1 /*
2 * guile.c - interface to Guile core library
3 *
4 * Copyright (C) 2011-2013 Thien-Thi Nguyen
5 * Copyright (C) 2001, 2002, 2003 Stefan Jahn <stefan@lkcc.org>
6 * Copyright (C) 2002 Andreas Rottmann <a.rottmann@gmx.at>
7 * Copyright (C) 2001 Raimund Jacob <raimi@lkcc.org>
8 *
9 * This is free software; you can redistribute it and/or modify it
10 * under the terms of the GNU General Public License as published by
11 * the Free Software Foundation; either version 3, or (at your option)
12 * any later version.
13 *
14 * This software is distributed in the hope that it will be useful,
15 * but WITHOUT ANY WARRANTY; without even the implied warranty of
16 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 * General Public License for more details.
18 *
19 * You should have received a copy of the GNU General Public License
20 * along with this package. If not, see <http://www.gnu.org/licenses/>.
21 */
22
23 #include "config.h"
24
25 #include <stdio.h>
26 #include <stdlib.h>
27 #include <stdarg.h>
28 #include <string.h>
29 #include <errno.h>
30 #include <sys/stat.h>
31
32 #if HAVE_UNISTD_H
33 # include <unistd.h>
34 #endif
35 #ifdef __MINGW32__
36 # include <io.h>
37 #endif
38
39 #include <libguile.h>
40 #include "networking-headers.h"
41 #include "action.h"
42 #include "libserveez.h"
43 #include "misc-macros.h"
44 #include "gi.h"
45 #include "guile-api.h"
46 #include "guile-server.h"
47 #include "guile.h"
48 #include "unused.h"
49
50 /* Port configuration items. */
51 #define PORTCFG_PORT "port"
52 #define PORTCFG_PROTO "proto"
53 #define PORTCFG_TCP "tcp"
54 #define PORTCFG_UDP "udp"
55 #define PORTCFG_ICMP "icmp"
56 #define PORTCFG_RAW "raw"
57 #define PORTCFG_PIPE "pipe"
58 #define PORTCFG_IP "ipaddr"
59 #define PORTCFG_DEVICE "device"
60 #define PORTCFG_BACKLOG "backlog"
61 #define PORTCFG_TYPE "type"
62
63 /* Pipe definitions. */
64 #define PORTCFG_RECV "recv"
65 #define PORTCFG_SEND "send"
66 #define PORTCFG_NAME "name"
67 #define PORTCFG_PERMS "permissions"
68 #define PORTCFG_USER "user"
69 #define PORTCFG_GROUP "group"
70 #define PORTCFG_UID "uid"
71 #define PORTCFG_GID "gid"
72
73 /* Miscellaneous definitions. */
74 #define PORTCFG_SEND_BUFSIZE "send-buffer-size"
75 #define PORTCFG_RECV_BUFSIZE "recv-buffer-size"
76 #define PORTCFG_FREQ "connect-frequency"
77 #define PORTCFG_ALLOW "allow"
78 #define PORTCFG_DENY "deny"
79
80 /*
81 * Global error flag that indicating failure of one of the parsing
82 * functions.
83 */
84 int guile_global_error = 0;
85
86 /*
87 * Global variable containing the current load port in exceptions.
88 * FIXME: Where should I aquire it? In each procedure?
89 */
90 static SCM load_port_box;
91 #define stashed_load_port() (SCM_CDR (load_port_box))
92 #define GUILE_PRECALL() guile_set_current_load_port()
93
94 /*
95 * What is an 'option-hash' ?
96 * We build up that data structure from a scheme pairlist. The pairlist has
97 * to be an alist which is a key => value mapping. We read that mapping and
98 * construct a @code{svz_hash_t} from it. The values of this hash are
99 * pointers to @code{guile_value_t} structures. The @code{guile_value_t}
100 * structure contains a @code{defined} field which counts the number of
101 * occurrences of the key. Use @code{optionhash_validate} to make sure it
102 * is 1 for each key. The @code{use} field is to make sure that each key
103 * was needed exactly once. Use @code{optionhash_validate} again to find
104 * out which ones were not needed.
105 */
106
107 /*
108 * Used as value in option-hashes.
109 */
110 typedef struct guile_value
111 {
112 SCM value; /* the scheme value itself, invalid when defined != 1 */
113 int defined; /* the number of definitions, 1 to be valid */
114 int use; /* how often was it looked up in the hash, 1 to be valid */
115 }
116 guile_value_t;
117
118 /*
119 * Create a guile value structure with the given @var{value}. Initializes
120 * the usage counter to zero. The define counter is set to 1.
121 */
122 static guile_value_t *
guile_value_create(SCM value)123 guile_value_create (SCM value)
124 {
125 guile_value_t *v = svz_malloc (sizeof (guile_value_t));
126 v->value = value;
127 v->defined = 1;
128 v->use = 0;
129 return v;
130 }
131
132 /*
133 * Create a fresh option-hash.
134 */
135 svz_hash_t *
optionhash_create(void)136 optionhash_create (void)
137 {
138 return svz_hash_create (4, svz_free);
139 }
140
141 /*
142 * Destroy the given option-hash @var{options}.
143 */
144 void
optionhash_destroy(svz_hash_t * options)145 optionhash_destroy (svz_hash_t *options)
146 {
147 svz_hash_destroy (options);
148 }
149
150 /*
151 * Save the current load port for later usage in the @code{guile_error}
152 * function.
153 */
154 static void
guile_set_current_load_port(void)155 guile_set_current_load_port (void)
156 {
157 SCM p = scm_current_load_port ();
158 if (SCM_PORTP (p))
159 scm_set_cdr_x (load_port_box, p);
160 }
161
162 /*
163 * Returns the current load port. This is either the "real" one or the one
164 * saved by the procedure @code{guile_set_current_load_port}. If neither
165 * is possible return @code{SCM_UNDEFINED}.
166 */
167 static SCM
guile_get_current_load_port(void)168 guile_get_current_load_port (void)
169 {
170 SCM p = scm_current_load_port ();
171 if (!SCM_FALSEP (p) && SCM_PORTP (p))
172 return p;
173 p = stashed_load_port ();
174 if (BOUNDP (p) && SCM_PORTP (p))
175 return p;
176 return SCM_UNDEFINED;
177 }
178
179 /*
180 * Report some error at the current scheme position. Prints to stderr
181 * but lets the program continue. The format string @var{format} does not
182 * need a trailing newline.
183 */
184 void
guile_error(char * format,...)185 guile_error (char *format, ...)
186 {
187 va_list args;
188 /* FIXME: Why is this port undefined in guile exceptions? */
189 SCM lp = guile_get_current_load_port ();
190 int lp_valid_p = BOUNDP (lp)
191 /* TODO: Investigate why ‘SCM_PORTP’ is (was) sufficient for
192 Guile 1.8 but not 2.0 (which is succeptible to segv).
193 TODO: Do all validation in ‘guile_get_current_load_port’. */
194 && SCM_OPINPORTP (lp);
195 SCM filename = lp_valid_p ? SCM_FILENAME (lp) : SCM_BOOL_F;
196 char file[1024];
197
198 /* guile counts lines from 0, we have to add one */
199 fprintf (stderr, "%s:%ld:%ld: ",
200 (lp_valid_p && GI_GET_XREP_MAYBE (file, filename)
201 ? file
202 : "undefined"),
203 lp_valid_p ? (long) SCM_LINUM (lp) + 1 : 0,
204 lp_valid_p ? (long) SCM_COL (lp) : 0);
205
206 va_start (args, format);
207 vfprintf (stderr, format, args);
208 va_end (args);
209 fprintf (stderr, "\n");
210 }
211
212 struct optionhash_validate_closure
213 {
214 int what;
215 int errors;
216 char *type;
217 char *name;
218 };
219
220 static void
optionhash_validate_internal(void * k,void * v,void * closure)221 optionhash_validate_internal (void *k, void *v, void *closure)
222 {
223 char *key = k, *blurb;
224 guile_value_t *value = v;
225 struct optionhash_validate_closure *x = closure;
226
227 switch (x->what)
228 {
229 case 1:
230 /* Check definition counter. */
231 if (value->defined == 1)
232 return;
233 blurb = "Multiple definitions of";
234 break;
235
236 case 0:
237 /* Check usage counter. */
238 if (value->use != 0)
239 return;
240 blurb = "Unused variable";
241 break;
242
243 default:
244 abort (); /* PEBKAC */
245 }
246
247 x->errors++;
248 guile_error ("%s `%s' in %s `%s'", blurb, key, x->type, x->name);
249 }
250
251 /*
252 * Validate the values of an option-hash. Returns the number of errors.
253 * what = 0 : check if all 'use' fields are 1
254 * what = 1 : check if all 'defined' fields are 1
255 * type : what kind of thing the option-hash belongs to
256 * name : current variable name (specifying the alist)
257 */
258 int
optionhash_validate(svz_hash_t * hash,int what,char * type,char * name)259 optionhash_validate (svz_hash_t *hash, int what, char *type, char *name)
260 {
261 struct optionhash_validate_closure x = { what, 0, type, name };
262
263 svz_hash_foreach (optionhash_validate_internal, hash, &x);
264 return x.errors;
265 }
266
267 /*
268 * Get a scheme value from an option-hash and increment its 'use' field.
269 * Returns SCM_UNSPECIFIED when @var{key} was not found.
270 */
271 SCM
optionhash_get(svz_hash_t * hash,char * key)272 optionhash_get (svz_hash_t *hash, char *key)
273 {
274 guile_value_t *val = svz_hash_get (hash, key);
275
276 if (NULL != val)
277 {
278 val->use++;
279 return val->value;
280 }
281 return SCM_UNSPECIFIED;
282 }
283
284 /*
285 * Traverse a scheme pairlist that is an associative list and build up
286 * a hash from it. Emits error messages and returns NULL when it did
287 * so. Hash keys are the key names. Hash values are pointers to
288 * guile_value_t structures. If @var{dounpack} is set the pairlist's
289 * car is used instead of the pairlist itself. You have to unpack when
290 * no "." is in front of the pairlist definition (in scheme
291 * code). Some please explain the "." to Stefan and Raimi...
292 */
293 svz_hash_t *
guile_to_optionhash(SCM pairlist,char * suffix,int dounpack)294 guile_to_optionhash (SCM pairlist, char *suffix, int dounpack)
295 {
296 svz_hash_t *hash = optionhash_create ();
297 guile_value_t *old_value;
298 guile_value_t *new_value;
299 int err = 0;
300
301 /* Unpack if requested, ignore if null already (null == not existent). */
302 if (dounpack && !SCM_NULLP (pairlist) && BOUNDP (pairlist))
303 pairlist = SCM_CAR (pairlist);
304
305 for ( ; SCM_PAIRP (pairlist); pairlist = SCM_CDR (pairlist))
306 {
307 SCM pair = SCM_CAR (pairlist);
308 SCM key, val;
309 char str[64];
310
311 /* The car must be another pair which contains key and value. */
312 if (!SCM_PAIRP (pair))
313 {
314 guile_error ("Not a pair %s", suffix);
315 err = 1;
316 break;
317 }
318 key = SCM_CAR (pair);
319 val = SCM_CDR (pair);
320
321 if (! GI_GET_XREP_MAYBE (str, key))
322 {
323 /* Unknown key type, must be string or symbol. */
324 guile_error ("Invalid key type (string expected) %s", suffix);
325 err = 1;
326 break;
327 }
328
329 /* Remember key and value. */
330 new_value = guile_value_create (val);
331 if (NULL != (old_value = svz_hash_get (hash, str)))
332 {
333 /* Multiple definition, let caller croak about that error. */
334 new_value->defined += old_value->defined;
335 svz_free_and_zero (old_value);
336 }
337 svz_hash_put (hash, str, (void *) new_value);
338 }
339
340 /* Pairlist must be ‘SCM_NULLP’ now or that was not a good pairlist. */
341 if (!err && !SCM_NULLP (pairlist))
342 {
343 guile_error ("Invalid pairlist %s", suffix);
344 err = 1;
345 }
346
347 if (err)
348 {
349 svz_hash_destroy (hash);
350 return NULL;
351 }
352
353 return hash;
354 }
355
356 SCM_DEFINE
357 (libserveez_features,
358 "libserveez-features", 0, 0, 0,
359 (void),
360 doc: /***********
361 Return a list of symbols representing the features of the underlying
362 libserveez. For details, @xref{Library features}. */)
363 {
364 #define FUNC_NAME s_libserveez_features
365 SCM rv = SCM_EOL;
366 size_t count;
367 const char * const *ls = svz_library_features (&count);
368
369 while (count--)
370 rv = scm_cons (gi_symbol2scm (ls[count]), rv);
371
372 return rv;
373 #undef FUNC_NAME
374 }
375
376 /*
377 * Parse an integer value from a scheme cell. Returns zero when successful.
378 * Stores the integer value where @var{target} points to. Does not emit
379 * error messages.
380 */
381 int
guile_to_integer(SCM cell,int * target)382 guile_to_integer (SCM cell, int *target)
383 {
384 #define FUNC_NAME __func__
385 int err = 0;
386 char str[64], *endp;
387
388 /* Usual guile exact number. */
389 if (gi_exactp (cell))
390 {
391 *target = gi_scm2int (cell);
392 }
393 /* Try string (or even symbol) to integer conversion. */
394 else if (GI_GET_XREP_MAYBE (str, cell))
395 {
396 errno = 0;
397 *target = strtol (str, &endp, 10);
398 if (*endp != '\0' || errno == ERANGE)
399 err = 1;
400 }
401 /* No chance. */
402 else
403 {
404 err = 2;
405 }
406 return err;
407 #undef FUNC_NAME
408 }
409
410 /*
411 * Parse a boolean value from a scheme cell. We consider integers and #t/#f
412 * as boolean boolean values. Represented as integers internally. Returns
413 * zero when successful. Stores the boolean/integer where @var{target} points
414 * to. Does not emit error messages.
415 */
416 int
guile_to_boolean(SCM cell,int * target)417 guile_to_boolean (SCM cell, int *target)
418 {
419 #define FUNC_NAME __func__
420 int i;
421 int err = 0;
422 char str[8];
423
424 /* Usual guile boolean. */
425 if (SCM_BOOLP (cell))
426 {
427 i = gi_nfalsep (cell);
428 *target = (i == 0 ? 0 : 1);
429 }
430 /* Try with the integer converter. */
431 else if (guile_to_integer (cell, &i) == 0)
432 {
433 *target = (i == 0 ? 0 : 1);
434 }
435 /* Neither integer nor boolean, try text conversion. */
436 /* FIXME: Use symbols and ‘memq’. */
437 else if (GI_GET_XREP_MAYBE (str, cell))
438 {
439 #define STR_IS_CI(k) (! strncasecmp (k, str, sizeof (k)))
440 /* Note: We use ‘sizeof (k)’ instead of ‘sizeof (k) - 1’
441 to deliberately include the terminating '\0', thus
442 preventing false matches, e.g., "yesssss". */
443
444 if (STR_IS_CI ("yes")
445 || STR_IS_CI ("on")
446 || STR_IS_CI ("true"))
447 *target = 1;
448 else if (STR_IS_CI ("no")
449 || STR_IS_CI ("off")
450 || STR_IS_CI ("false"))
451 *target = 0;
452 else
453 err = 1;
454 #undef STR_IS_CI
455 }
456 else
457 {
458 err = 2;
459 }
460 return err;
461 #undef FUNC_NAME
462 }
463
464 /*
465 * Convert the given guile list @var{list} into a hash. Return
466 * @code{NULL} on failure. Error messages will be emitted if
467 * necessary.
468 */
469 svz_hash_t *
guile_to_hash(SCM list,const char * func)470 guile_to_hash (SCM list, const char *func)
471 {
472 #define FUNC_NAME func
473 int err = 0, i;
474 svz_hash_t *hash;
475
476 /* Is this valid guile list at all? */
477 if (!SCM_LISTP (list))
478 {
479 err = -1;
480 guile_error ("%s: Not a valid list for hash", func);
481 return NULL;
482 }
483
484 /* Iterate the alist. */
485 hash = svz_hash_create (gi_scm2ulong (scm_length (list)),
486 svz_free);
487 for (i = 0; SCM_PAIRP (list); list = SCM_CDR (list), i++)
488 {
489 SCM k, v, pair = SCM_CAR (list);
490 char str[2048], *keystr, *valstr;
491
492 if (!SCM_PAIRP (pair))
493 {
494 err = -1;
495 guile_error ("%s: Element #%d of hash is not a pair", func, i);
496 continue;
497 }
498 k = SCM_CAR (pair);
499 v = SCM_CDR (pair);
500
501 /* Obtain key character string. */
502 if (! GI_GET_XREP_MAYBE (str, k))
503 {
504 err = -1;
505 guile_error ("%s: Element #%d of hash has no valid key "
506 "(string expected)", func, i);
507 keystr = NULL;
508 }
509 else
510 {
511 keystr = svz_strdup (str);
512 }
513
514 /* Obtain value character string. */
515 if (! GI_GET_XREP_MAYBE (str, v))
516 {
517 err = -1;
518 guile_error ("%s: Element #%d of hash has no valid value "
519 "(string expected)", func, i);
520 valstr = NULL;
521 }
522 else
523 {
524 valstr = svz_strdup (str);
525 }
526
527 /* Add to hash if key and value look good. */
528 if (keystr != NULL && valstr != NULL)
529 {
530 svz_hash_put (hash, keystr, valstr);
531 svz_free (keystr);
532 }
533 }
534
535 /* Free the values, keys are freed by hash destructor. */
536 if (err)
537 {
538 svz_hash_destroy (hash);
539 return NULL;
540 }
541 return hash;
542 #undef FUNC_NAME
543 }
544
545 /*
546 * Convert the given non-empty @var{list} into an array of duplicated strings.
547 * Return @code{NULL} if it is not a valid non-empty list. Print an error
548 * message if one of the list's elements is not a string. The additional
549 * argument @var{func} should be the name of the caller.
550 */
551 svz_array_t *
guile_to_strarray(SCM list,const char * func)552 guile_to_strarray (SCM list, const char *func)
553 {
554 #define FUNC_NAME func
555 svz_array_t *array;
556 int i;
557 char str[2048];
558
559 /* Check if the given scheme cell is a valid list. */
560 if (!SCM_LISTP (list))
561 {
562 guile_error ("%s: String array is not a valid list", func);
563 return NULL;
564 }
565
566 /* Iterate over the list and build up the array of strings. */
567 array = svz_array_create (gi_scm2ulong (scm_length (list)),
568 svz_free);
569 for (i = 0; SCM_PAIRP (list); list = SCM_CDR (list), i++)
570 {
571 SCM head = SCM_CAR (list);
572
573 if (! gi_stringp (head)
574 || 0 > GI_GET_XREP (str, head))
575 {
576 guile_error ("%s: String expected in position %d", func, i);
577 guile_global_error = -1;
578 continue;
579 }
580 svz_array_add (array, svz_strdup (str));
581 }
582
583 /* Reject the empty array. */
584 if (! svz_array_size (array))
585 {
586 svz_array_destroy (array);
587 array = NULL;
588 }
589 return array;
590 #undef FUNC_NAME
591 }
592
593 /*
594 * Convert the given scheme cell @var{list} which needs to be a valid guile
595 * list into an array of integers. The additional argument @var{func} is the
596 * name of the caller. Return NULL on failure.
597 */
598 svz_array_t *
guile_to_intarray(SCM list,const char * func)599 guile_to_intarray (SCM list, const char *func)
600 {
601 #define FUNC_NAME func
602 svz_array_t *array;
603 int i, n;
604
605 /* Check if the given scheme cell is a valid associative list. */
606 if (!SCM_LISTP (list))
607 {
608 guile_error ("%s: Integer array is not a valid list", func);
609 return NULL;
610 }
611
612 /* Iterate over the list and build up the array of strings. */
613 array = svz_array_create (gi_scm2ulong (scm_length (list)), NULL);
614 for (i = 0; SCM_PAIRP (list); list = SCM_CDR (list), i++)
615 {
616 if (guile_to_integer (SCM_CAR (list), &n) != 0)
617 {
618 guile_error ("%s: Integer expected in position %d", func, i);
619 guile_global_error = -1;
620 continue;
621 }
622 svz_array_add (array, SVZ_NUM2PTR (n));
623 }
624
625 /* Check the size of the resulting integer array. */
626 if (svz_array_size (array) == 0)
627 {
628 svz_array_destroy (array);
629 array = NULL;
630 }
631 return array;
632 #undef FUNC_NAME
633 }
634
635 /*
636 * Extract an integer value from an option hash. Returns zero if it worked.
637 */
638 static int
optionhash_extract_int(svz_hash_t * hash,char * key,int hasdef,int defvar,int * target,char * txt)639 optionhash_extract_int (svz_hash_t *hash,
640 char *key, /* the key to find */
641 int hasdef, /* is there a default ? */
642 int defvar, /* the default */
643 int *target, /* where to put it */
644 char *txt) /* appended to error */
645 {
646 int err = 0;
647 SCM hvalue = optionhash_get (hash, key);
648
649 /* Is there such an integer in the option-hash? */
650 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
651 {
652 /* Nothing in hash, try to use default. */
653 if (hasdef)
654 *target = defvar;
655 else
656 {
657 guile_error ("No default value for integer `%s' %s", key, txt);
658 err = 1;
659 }
660 }
661 /* Convert the integer value. */
662 else if (guile_to_integer (hvalue, target))
663 {
664 guile_error ("Invalid integer value for `%s' %s", key, txt);
665 err = 1;
666 }
667 return err;
668 }
669
670 /*
671 * Extract a string value from an option hash. Returns zero if it worked.
672 * The memory for the string is newly allocated, no matter where it came
673 * from.
674 */
675 int
optionhash_extract_string(svz_hash_t * hash,char * key,int hasdef,char * defvar,char ** target,char * txt)676 optionhash_extract_string (svz_hash_t *hash,
677 char *key, /* the key to find */
678 int hasdef, /* if there is a default */
679 char *defvar, /* default */
680 char **target, /* where to put it */
681 char *txt) /* appended to error */
682 {
683 SCM hvalue = optionhash_get (hash, key);
684 int err = 0;
685 char str[2048];
686
687 /* Is there such a string in the option-hash? */
688 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
689 {
690 /* Nothing in hash, try to use default. */
691 if (hasdef)
692 *target = svz_strdup (defvar);
693 else
694 {
695 guile_error ("No default value for string `%s' %s", key, txt);
696 err = 1;
697 }
698 }
699 else
700 {
701 /* Try getting the character string. */
702 if (! GI_GET_XREP_MAYBE (str, hvalue))
703 {
704 guile_error ("Invalid string value for `%s' %s", key, txt);
705 err = 1;
706 }
707 else
708 {
709 *target = svz_strdup (str);
710 }
711 }
712 return err;
713 }
714
715 /* Before callback for configuring a server. */
716 static int
optionhash_cb_before(char * server,void * arg)717 optionhash_cb_before (char *server, void *arg)
718 {
719 svz_hash_t *options = arg;
720 if (0 == optionhash_validate (options, 1, "server", server))
721 return SVZ_ITEM_OK;
722 return SVZ_ITEM_FAILED;
723 }
724
725 /* Integer callback for configuring a server. */
726 static int
optionhash_cb_integer(char * server,void * arg,char * key,int * target,int hasdef,UNUSED int def)727 optionhash_cb_integer (char *server, void *arg, char *key, int *target,
728 int hasdef, UNUSED int def)
729 {
730 svz_hash_t *options = arg;
731 SCM hvalue = optionhash_get (options, key);
732
733 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
734 {
735 if (hasdef)
736 return SVZ_ITEM_DEFAULT_ERRMSG;
737
738 guile_error ("%s: You have to define an integer called `%s'",
739 server, key);
740 return SVZ_ITEM_FAILED;
741 }
742
743 if (guile_to_integer (hvalue, target))
744 {
745 guile_error ("%s: Invalid integer value for `%s'", server, key);
746 return SVZ_ITEM_FAILED;
747 }
748
749 return SVZ_ITEM_OK;
750 }
751
752 /* Boolean callback for configuring a server. */
753 static int
optionhash_cb_boolean(char * server,void * arg,char * key,int * target,int hasdef,UNUSED int def)754 optionhash_cb_boolean (char *server, void *arg, char *key, int *target,
755 int hasdef, UNUSED int def)
756 {
757 svz_hash_t *options = arg;
758 SCM hvalue = optionhash_get (options, key);
759
760 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
761 {
762 if (hasdef)
763 return SVZ_ITEM_DEFAULT_ERRMSG;
764
765 guile_error ("%s: You have to define a boolean called `%s'",
766 server, key);
767 return SVZ_ITEM_FAILED;
768 }
769
770 if (guile_to_boolean (hvalue, target))
771 {
772 guile_error ("%s: Invalid boolean value for `%s'", server, key);
773 return SVZ_ITEM_FAILED;
774 }
775
776 return SVZ_ITEM_OK;
777 }
778
779 /* Integer array callback for configuring a server. */
780 static int
optionhash_cb_intarray(char * server,void * arg,char * key,svz_array_t ** target,int hasdef,UNUSED svz_array_t * def)781 optionhash_cb_intarray (char *server, void *arg, char *key,
782 svz_array_t **target, int hasdef,
783 UNUSED svz_array_t *def)
784 {
785 svz_hash_t *options = arg;
786 SCM hvalue = optionhash_get (options, key);
787
788 /* Is that integer array defined in the option-hash? */
789 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
790 {
791 if (hasdef)
792 return SVZ_ITEM_DEFAULT_ERRMSG;
793
794 guile_error ("%s: You have to define a integer array called `%s'",
795 server, key);
796 return SVZ_ITEM_FAILED;
797 }
798 /* Yes, start parsing it. */
799 else
800 {
801 svz_array_t *array;
802
803 if ((array = guile_to_intarray (hvalue, key)) == NULL)
804 {
805 guile_error ("%s: Failed to parse integer array `%s'", server, key);
806 return SVZ_ITEM_FAILED;
807 }
808 *target = array;
809 }
810 return SVZ_ITEM_OK;
811 }
812
813 /* String callback for configuring a server. */
814 static int
optionhash_cb_string(char * server,void * arg,char * key,char ** target,int hasdef,UNUSED char * def)815 optionhash_cb_string (char *server, void *arg, char *key,
816 char **target, int hasdef, UNUSED char *def)
817 {
818 svz_hash_t *options = arg;
819 SCM hvalue = optionhash_get (options, key);
820 char str[2048];
821
822 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
823 {
824 if (hasdef)
825 return SVZ_ITEM_DEFAULT_ERRMSG;
826
827 guile_error ("%s: You have to define a string called `%s'",
828 server, key);
829 return SVZ_ITEM_FAILED;
830 }
831
832 if (! GI_GET_XREP_MAYBE (str, hvalue))
833 {
834 guile_error ("%s: Invalid string value for `%s'", server, key);
835 return SVZ_ITEM_FAILED;
836 }
837
838 *target = svz_strdup (str);
839 return SVZ_ITEM_OK;
840 }
841
842 /* String array callback for configuring a server. */
843 static int
optionhash_cb_strarray(char * server,void * arg,char * key,svz_array_t ** target,int hasdef,UNUSED svz_array_t * def)844 optionhash_cb_strarray (char *server, void *arg, char *key,
845 svz_array_t **target, int hasdef,
846 UNUSED svz_array_t *def)
847 {
848 svz_hash_t *options = arg;
849 SCM hvalue = optionhash_get (options, key);
850
851 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
852 {
853 if (hasdef)
854 return SVZ_ITEM_DEFAULT_ERRMSG;
855
856 guile_error ("%s: You have to define a string array called `%s'",
857 server, key);
858 return SVZ_ITEM_FAILED;
859 }
860 else
861 {
862 svz_array_t *array;
863
864 if ((array = guile_to_strarray (hvalue, key)) == NULL)
865 {
866 guile_error ("%s: Failed to parse string array `%s'", server, key);
867 return SVZ_ITEM_FAILED;
868 }
869 *target = array;
870 }
871 return SVZ_ITEM_OK;
872 }
873
874 /* Hash callback for configuring a server. */
875 static int
optionhash_cb_hash(char * server,void * arg,char * key,svz_hash_t ** target,int hasdef,UNUSED svz_hash_t * def)876 optionhash_cb_hash (char *server, void *arg, char *key,
877 svz_hash_t **target, int hasdef,
878 UNUSED svz_hash_t *def)
879 {
880 svz_hash_t *options = arg;
881 SCM hvalue = optionhash_get (options, key);
882
883 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
884 {
885 if (hasdef)
886 return SVZ_ITEM_DEFAULT_ERRMSG;
887
888 guile_error ("%s: You have to define a hash called `%s'",
889 server, key);
890 return SVZ_ITEM_FAILED;
891 }
892 else
893 {
894 svz_hash_t *hash;
895
896 if ((hash = guile_to_hash (hvalue, key)) == NULL)
897 {
898 guile_error ("%s: Failed to parse hash `%s'", server, key);
899 return SVZ_ITEM_FAILED;
900 }
901 *target = hash;
902 }
903 return SVZ_ITEM_OK;
904 }
905
906 /* Port configuration callback for configuring a server. */
907 static int
optionhash_cb_portcfg(char * server,void * arg,char * key,svz_portcfg_t ** target,int hasdef,UNUSED svz_portcfg_t * def)908 optionhash_cb_portcfg (char *server, void *arg, char *key,
909 svz_portcfg_t **target, int hasdef,
910 UNUSED svz_portcfg_t *def)
911 {
912 svz_hash_t *options = arg;
913 SCM hvalue = optionhash_get (options, key);
914 svz_portcfg_t *port;
915 char str[2048];
916
917 /* Is the requested port configuration defined? */
918 if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED))
919 {
920 if (hasdef)
921 return SVZ_ITEM_DEFAULT_ERRMSG;
922
923 guile_error ("%s: Port configuration `%s' required", server, key);
924 return SVZ_ITEM_FAILED;
925 }
926
927 /* Convert Scheme cell into string. */
928 if (! GI_GET_XREP_MAYBE (str, hvalue))
929 {
930 guile_error ("%s: Invalid string value for port configuration `%s' "
931 "(string expected)", server, key);
932 return SVZ_ITEM_FAILED;
933 }
934
935 /* Check existence of this named port configuration. */
936 if ((port = svz_portcfg_get (str)) == NULL)
937 {
938 guile_error ("%s: No such port configuration: `%s'", server, str);
939 return SVZ_ITEM_FAILED;
940 }
941
942 /* Duplicate this port configuration. */
943 *target = svz_portcfg_dup (port);
944 return SVZ_ITEM_OK;
945 }
946
947 /* After callback for configuring a server. */
948 static int
optionhash_cb_after(char * server,void * arg)949 optionhash_cb_after (char *server, void *arg)
950 {
951 svz_hash_t *options = arg;
952 if (0 == optionhash_validate (options, 0, "server", server))
953 return SVZ_ITEM_OK;
954 return SVZ_ITEM_FAILED;
955 }
956
957 /*
958 * Extract a full pipe from an option hash. Returns zero if it worked.
959 */
960 static int
optionhash_extract_pipe(svz_hash_t * hash,char * key,svz_pipe_t * pipe,char * txt)961 optionhash_extract_pipe (svz_hash_t *hash,
962 char *key, /* the key to find */
963 svz_pipe_t *pipe, /* where to put it */
964 char *txt) /* appended to error */
965 {
966 int err = 0;
967
968 err |= optionhash_validate (hash, 1, "pipe", key);
969 err |= optionhash_extract_string (hash, PORTCFG_NAME, 0, NULL,
970 &(pipe->name), txt);
971 err |= optionhash_extract_string (hash, PORTCFG_USER, 1, NULL,
972 &(pipe->user), txt);
973 err |= optionhash_extract_string (hash, PORTCFG_GROUP, 1, NULL,
974 &(pipe->group), txt);
975 err |= optionhash_extract_int (hash, PORTCFG_UID, 1, -1,
976 (int *) &(pipe->uid), txt);
977 err |= optionhash_extract_int (hash, PORTCFG_GID, 1, -1,
978 (int *) &(pipe->gid), txt);
979 err |= optionhash_extract_int (hash, PORTCFG_PERMS, 1, -1,
980 (int *) &(pipe->perm), txt);
981 err |= optionhash_validate (hash, 0, "pipe", key);
982 return err;
983 }
984
985 SCM_DEFINE
986 (guile_config_instantiate,
987 "instantiate-config-type!", 3, 1, 0,
988 (SCM type, SCM name, SCM instance, SCM opts),
989 doc: /***********
990 Instantiate a configurable type. The four arguments are: the name of
991 the configurable @var{type}, the type @var{name} in the configurable
992 type's domain, the @var{instance} name the newly instantiated type
993 should get, and the configuration alist for the new instance.
994 Emit error messages (to stderr). Return @code{#t} on success,
995 @code{#f} in case of any error. */)
996 {
997 #define FUNC_NAME s_guile_config_instantiate
998 int err = 0;
999 char c_type[24], c_name[64], c_instance[64];
1000 svz_hash_t *options = NULL;
1001 char action[ACTIONBUFSIZE];
1002 char ebuf[ACTIONBUFSIZE];
1003
1004 /* Configure callbacks for the ‘svz_config_type_instantiate’ thing. */
1005 svz_config_accessor_t accessor = {
1006 optionhash_cb_before, /* before */
1007 optionhash_cb_integer, /* integers */
1008 optionhash_cb_boolean, /* boolean */
1009 optionhash_cb_intarray, /* integer arrays */
1010 optionhash_cb_string, /* strings */
1011 optionhash_cb_strarray, /* string arrays */
1012 optionhash_cb_hash, /* hashes */
1013 optionhash_cb_portcfg, /* port configurations */
1014 optionhash_cb_after /* after */
1015 };
1016
1017 if (! GI_GET_XREP_MAYBE (c_type, type))
1018 {
1019 guile_error ("Invalid configurable type (string expected)");
1020 FAIL ();
1021 }
1022 if (! GI_GET_XREP_MAYBE (c_name, name))
1023 {
1024 guile_error ("Invalid type identifier (string expected)");
1025 FAIL ();
1026 }
1027 if (! GI_GET_XREP_MAYBE (c_instance, instance))
1028 {
1029 guile_error ("Invalid instance identifier (string expected)");
1030 FAIL ();
1031 }
1032
1033 DEFINING ("%s `%s'", c_type, c_instance);
1034
1035 /* Extract options if any. */
1036 if (!BOUNDP (opts))
1037 options = optionhash_create ();
1038 else if (NULL == (options = guile_to_optionhash (opts, action, 0)))
1039 FAIL (); /* Message already emitted. */
1040
1041 err = svz_config_type_instantiate (c_type, c_name, c_instance,
1042 options, &accessor,
1043 ACTIONBUFSIZE, ebuf);
1044 if (err)
1045 {
1046 guile_error ("%s", ebuf);
1047 FAIL ();
1048 }
1049
1050 out:
1051 optionhash_destroy (options);
1052
1053 guile_global_error |= err;
1054 return err ? SCM_BOOL_F : SCM_BOOL_T;
1055 #undef FUNC_NAME
1056 }
1057
1058 SCM_DEFINE
1059 (guile_define_server,
1060 "define-server!", 1, 1, 0,
1061 (SCM name, SCM args),
1062 doc: /***********
1063 Define a server. @var{name} is a (unique) server name of the form
1064 @code{@var{type}-@var{something}}, where @var{type} is the shortname of a
1065 servertype. @var{args} is the optionhash that is special for the server.
1066 Emit error messages (to stderr). Return @code{#t} on success, @code{#f}
1067 in case of any error. */)
1068 {
1069 #define FUNC_NAME s_guile_define_server
1070 /* Note: This function could now as well be implemented in Scheme.
1071 [rotty] */
1072 int err = 0;
1073 char servername[64], *servertype = NULL, *p = NULL;
1074 SCM retval;
1075
1076 GUILE_PRECALL ();
1077
1078 /* Check if the given server name is valid. */
1079 if (! GI_GET_XREP_MAYBE (servername, name))
1080 {
1081 guile_error ("%s: Invalid server name (string expected)", FUNC_NAME);
1082 FAIL ();
1083 }
1084
1085 /* Separate server description. */
1086 p = servertype = svz_strdup (servername);
1087 while (*p && *p != '-')
1088 p++;
1089
1090 /* Extract server type and sanity check. */
1091 if (*p == '-' && *(p + 1) != '\0')
1092 *p = '\0';
1093 else
1094 {
1095 guile_error ("%s: Not a valid server name: `%s'", FUNC_NAME, servername);
1096 FAIL ();
1097 }
1098
1099 /* Instantiate and configure this server. */
1100 retval = guile_config_instantiate (gi_string2scm ("server"),
1101 gi_string2scm (servertype),
1102 name, args);
1103 out:
1104 svz_free (servertype);
1105
1106 return err ? SCM_BOOL_F : retval;
1107 #undef FUNC_NAME
1108 }
1109
1110 /* Validate a network port value. */
1111 #define GUILE_VALIDATE_PORT(port, name, proto) do { \
1112 if ((port) < 0 || (port) > 65535) { \
1113 guile_error ("%s: %s port requires a short (0..65535)", proto, name); \
1114 err = -1; } } while (0)
1115
1116 SCM_DEFINE
1117 (guile_define_port,
1118 "define-port!", 2, 0, 0,
1119 (SCM name, SCM args),
1120 doc: /***********
1121 Define a port configuration. @var{name} is a (unique) name for the
1122 port configuration. @var{args} is optionhash for various settings.
1123 Return @code{#t} on success, otherwise @code{#f}.
1124 Emit error messages (to stderr). */)
1125 {
1126 #define FUNC_NAME s_guile_define_port
1127 int err = 0;
1128 svz_portcfg_t *prev = NULL;
1129 svz_portcfg_t *cfg = svz_portcfg_create ();
1130 svz_hash_t *options = NULL;
1131 char portname[64], proto[16];
1132 SCM protoname;
1133 char action[ACTIONBUFSIZE];
1134
1135 GUILE_PRECALL ();
1136
1137 /* Check validity of first argument. */
1138 if (! GI_GET_XREP_MAYBE (portname, name))
1139 {
1140 guile_error ("%s: Invalid port configuration name (string expected)",
1141 FUNC_NAME);
1142 FAIL ();
1143 }
1144
1145 DEFINING ("port `%s'", portname);
1146
1147 if (NULL == (options = guile_to_optionhash (args, action, 0)))
1148 FAIL (); /* Message already emitted. */
1149
1150 /* Every key defined only once? */
1151 if (0 != optionhash_validate (options, 1, "port", portname))
1152 err = -1;
1153
1154 /* Find out what protocol this portcfg will be about. */
1155 protoname = optionhash_get (options, PORTCFG_PROTO);
1156 if (! GI_GET_XREP_MAYBE (proto, protoname))
1157 {
1158 guile_error ("Port `%s' requires a `" PORTCFG_PROTO "' string field",
1159 portname);
1160 FAIL ();
1161 }
1162
1163 /* Is that TCP? */
1164 if (!strcmp (proto, PORTCFG_TCP))
1165 {
1166 int port;
1167 cfg->proto = SVZ_PROTO_TCP;
1168 err |= optionhash_extract_int (options, PORTCFG_PORT, 0, 0,
1169 &port, action);
1170 GUILE_VALIDATE_PORT (port, "TCP", portname);
1171 SVZ_CFG_TCP (cfg, port) = port;
1172 err |= optionhash_extract_int (options, PORTCFG_BACKLOG, 1, 0,
1173 &SVZ_CFG_TCP (cfg, backlog), action);
1174 err |= optionhash_extract_string (options, PORTCFG_IP, 1,
1175 SVZ_PORTCFG_NOIP,
1176 &SVZ_CFG_TCP (cfg, ipaddr), action);
1177 err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL,
1178 &SVZ_CFG_TCP (cfg, device), action);
1179 }
1180 /* Maybe UDP? */
1181 else if (!strcmp (proto, PORTCFG_UDP))
1182 {
1183 int port;
1184 cfg->proto = SVZ_PROTO_UDP;
1185 err |= optionhash_extract_int (options, PORTCFG_PORT,
1186 0, 0, &port, action);
1187 GUILE_VALIDATE_PORT (port, "UDP", portname);
1188 SVZ_CFG_UDP (cfg, port) = port;
1189 err |= optionhash_extract_string (options, PORTCFG_IP, 1,
1190 SVZ_PORTCFG_NOIP,
1191 &SVZ_CFG_UDP (cfg, ipaddr), action);
1192 err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL,
1193 &SVZ_CFG_UDP (cfg, device), action);
1194 }
1195 /* Maybe ICMP? */
1196 else if (!strcmp (proto, PORTCFG_ICMP))
1197 {
1198 int type;
1199 cfg->proto = SVZ_PROTO_ICMP;
1200 err |= optionhash_extract_string (options, PORTCFG_IP, 1,
1201 SVZ_PORTCFG_NOIP,
1202 &SVZ_CFG_ICMP (cfg, ipaddr), action);
1203 err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL,
1204 &SVZ_CFG_ICMP (cfg, device), action);
1205 err |= optionhash_extract_int (options, PORTCFG_TYPE, 1,
1206 SVZ_ICMP_SERVEEZ, &type, action);
1207 if (type & ~0xff)
1208 {
1209 guile_error ("ICMP type `%s' requires a byte (0..255) %s",
1210 PORTCFG_TYPE, action);
1211 err = -1;
1212 }
1213 SVZ_CFG_ICMP (cfg, type) = (uint8_t) (type & 0xff);
1214 }
1215 /* Maybe RAW? */
1216 else if (!strcmp (proto, PORTCFG_RAW))
1217 {
1218 cfg->proto = SVZ_PROTO_RAW;
1219 err |= optionhash_extract_string (options, PORTCFG_IP, 1,
1220 SVZ_PORTCFG_NOIP,
1221 &SVZ_CFG_RAW (cfg, ipaddr), action);
1222 err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL,
1223 &SVZ_CFG_RAW (cfg, device), action);
1224 }
1225 /* Finally a PIPE? */
1226 else if (!strcmp (proto, PORTCFG_PIPE))
1227 {
1228 svz_hash_t *poptions;
1229 SCM p;
1230 char str[1024];
1231 cfg->proto = SVZ_PROTO_PIPE;
1232
1233 /* Handle receiving pipe. */
1234 DEFINING ("pipe `%s' in port `%s'", PORTCFG_RECV, portname);
1235
1236 /* Check if it is a plain string. */
1237 p = optionhash_get (options, PORTCFG_RECV);
1238 if (GI_GET_XREP_MAYBE (str, p))
1239 {
1240 svz_pipe_t *r = &SVZ_CFG_PIPE (cfg, recv);
1241
1242 r->name = svz_strdup (str);
1243 r->gid = (gid_t) -1;
1244 r->uid = (uid_t) -1;
1245 r->perm = (mode_t) -1;
1246 }
1247 /* Create local optionhash for receiving pipe direction. */
1248 else if (SCM_EQ_P (p, SCM_UNSPECIFIED))
1249 {
1250 guile_error ("%s: You have to define a pipe called `%s'",
1251 portname, PORTCFG_RECV);
1252 err = -1;
1253 }
1254 else if ((poptions = guile_to_optionhash (p, action, 0)) == NULL)
1255 {
1256 err = -1; /* Message already emitted. */
1257 }
1258 else
1259 {
1260 err |= optionhash_extract_pipe (poptions, PORTCFG_RECV,
1261 &SVZ_CFG_PIPE (cfg, recv), action);
1262 optionhash_destroy (poptions);
1263 }
1264
1265 /* Try getting send pipe. */
1266 DEFINING ("pipe `%s' in port `%s'", PORTCFG_SEND, portname);
1267
1268 /* Check plain string. */
1269 p = optionhash_get (options, PORTCFG_SEND);
1270 if (GI_GET_XREP_MAYBE (str, p))
1271 {
1272 svz_pipe_t *s = &SVZ_CFG_PIPE (cfg, send);
1273
1274 s->name = svz_strdup (str);
1275 s->gid = (gid_t) -1;
1276 s->uid = (uid_t) -1;
1277 s->perm = (mode_t) -1;
1278 }
1279 else if (SCM_EQ_P (p, SCM_UNSPECIFIED))
1280 {
1281 guile_error ("%s: You have to define a pipe called `%s'",
1282 portname, PORTCFG_SEND);
1283 err = -1;
1284 }
1285 else if ((poptions = guile_to_optionhash (p, action, 0)) == NULL)
1286 {
1287 err = -1; /* Message already emitted. */
1288 }
1289 else
1290 {
1291 err |= optionhash_extract_pipe (poptions, PORTCFG_SEND,
1292 &SVZ_CFG_PIPE (cfg, send), action);
1293 optionhash_destroy (poptions);
1294 }
1295 }
1296 else
1297 {
1298 guile_error ("Invalid `" PORTCFG_PROTO "' field `%s' in port `%s'",
1299 proto, portname);
1300 FAIL ();
1301 }
1302
1303 /* Access the send and receive buffer sizes. */
1304 err |= optionhash_extract_int (options, PORTCFG_SEND_BUFSIZE, 1, 0,
1305 &(cfg->send_buffer_size), action);
1306 err |= optionhash_extract_int (options, PORTCFG_RECV_BUFSIZE, 1, 0,
1307 &(cfg->recv_buffer_size), action);
1308
1309 /* Acquire the connect frequency. */
1310 if (cfg->proto & SVZ_PROTO_TCP)
1311 err |= optionhash_extract_int (options, PORTCFG_FREQ, 1, 0,
1312 &(cfg->connect_freq), action);
1313
1314 /* Obtain the access lists "allow" and "deny". */
1315 if (!(cfg->proto & SVZ_PROTO_PIPE))
1316 {
1317 SCM list;
1318
1319 cfg->deny = NULL;
1320 list = optionhash_get (options, PORTCFG_DENY);
1321 if (!SCM_EQ_P (list, SCM_UNSPECIFIED))
1322 {
1323 if ((cfg->deny = guile_to_strarray (list, PORTCFG_DENY)) == NULL)
1324 {
1325 guile_error ("Failed to parse string array `" PORTCFG_DENY
1326 "' in port `%s'", portname);
1327 err = -1;
1328 }
1329 }
1330 cfg->allow = NULL;
1331 list = optionhash_get (options, PORTCFG_ALLOW);
1332 if (!SCM_EQ_P (list, SCM_UNSPECIFIED))
1333 {
1334 if ((cfg->allow = guile_to_strarray (list, PORTCFG_ALLOW)) == NULL)
1335 {
1336 guile_error ("Failed to parse string array `" PORTCFG_ALLOW
1337 "' in port `%s'", portname);
1338 err = -1;
1339 }
1340 }
1341 }
1342
1343 /* Check for unused keys in input. */
1344 if (0 != optionhash_validate (options, 0, "port", portname))
1345 FAIL (); /* Message already emitted. */
1346
1347 /* Now remember the name and add that port configuration. */
1348 cfg->name = svz_strdup (portname);
1349 err |= svz_portcfg_mkaddr (cfg);
1350
1351 if (err)
1352 FAIL ();
1353
1354 if ((prev = svz_portcfg_get (portname)) != NULL)
1355 {
1356 /* We've overwritten something. Report and dispose. */
1357 guile_error ("Duplicate definition of port `%s'", portname);
1358 err = -1;
1359 }
1360 else
1361 svz_portcfg_add (portname, cfg);
1362
1363 out:
1364 if (err)
1365 svz_portcfg_destroy (cfg);
1366 optionhash_destroy (options);
1367 guile_global_error |= err;
1368 return err ? SCM_BOOL_F : SCM_BOOL_T;
1369 #undef FUNC_NAME
1370 }
1371
1372
1373 SCM_DEFINE
1374 (guile_bind_server,
1375 "bind-server!", 2, 0, 0,
1376 (SCM port, SCM server),
1377 doc: /***********
1378 Do generic port to server(s) port binding.
1379 Both @var{port} and @var{server} must be either a string or symbol.
1380 See function @code{svz_server_bind}. */)
1381 {
1382 #define FUNC_NAME s_guile_bind_server
1383 char portname[64];
1384 char servername[64];
1385 svz_server_t *s;
1386 svz_portcfg_t *p;
1387 int err = 0;
1388
1389 GUILE_PRECALL ();
1390
1391 /* Check arguments. */
1392 if (! STRING_OR_SYMBOL_P (port))
1393 {
1394 guile_error ("%s: Port name must be string or symbol", FUNC_NAME);
1395 FAIL ();
1396 }
1397 if (! STRING_OR_SYMBOL_P (server))
1398 {
1399 guile_error ("%s: Server name must be string or symbol", FUNC_NAME);
1400 FAIL ();
1401 }
1402
1403 GI_GET_XREP (portname, port);
1404 GI_GET_XREP (servername, server);
1405
1406 /* Check id there is such a port configuration. */
1407 if ((p = svz_portcfg_get (portname)) == NULL)
1408 {
1409 guile_error ("%s: No such port: `%s'", FUNC_NAME, portname);
1410 err++;
1411 }
1412
1413 /* Get one of the servers in the list. */
1414 if ((s = svz_server_get (servername)) == NULL)
1415 {
1416 guile_error ("%s: No such server: `%s'", FUNC_NAME, servername);
1417 err++;
1418 }
1419
1420 /* Bind a given server instance to a port configuration. */
1421 if (s != NULL && p != NULL)
1422 {
1423 if (svz_server_bind (s, p) < 0)
1424 err++;
1425 }
1426
1427 out:
1428 guile_global_error |= err;
1429 return err ? SCM_BOOL_F : SCM_BOOL_T;
1430 #undef FUNC_NAME
1431 }
1432
1433 /*
1434 * Converts the given array of strings @var{array} into a guile list.
1435 */
1436 SCM
guile_strarray_to_guile(svz_array_t * array)1437 guile_strarray_to_guile (svz_array_t *array)
1438 {
1439 SCM list;
1440 size_t i;
1441
1442 /* Check validity of the give string array. */
1443 if (array == NULL)
1444 return SCM_UNDEFINED;
1445
1446 /* Go through all the strings and add these to a guile list. */
1447 for (list = SCM_EOL, i = 0; i < svz_array_size (array); i++)
1448 list = scm_cons (gi_string2scm ((char *) svz_array_get (array, i)),
1449 list);
1450 return scm_reverse (list);
1451 }
1452
1453 /*
1454 * Converts the given array of integers @var{array} into a guile list.
1455 */
1456 SCM
guile_intarray_to_guile(svz_array_t * array)1457 guile_intarray_to_guile (svz_array_t *array)
1458 {
1459 SCM list;
1460 size_t i;
1461
1462 /* Check validity of the give string array. */
1463 if (array == NULL)
1464 return SCM_UNDEFINED;
1465
1466 /* Go through all the strings and add these to a guile list. */
1467 for (list = SCM_EOL, i = 0; i < svz_array_size (array); i++)
1468 list = scm_cons (gi_integer2scm ((long) svz_array_get (array, i)), list);
1469 return scm_reverse (list);
1470 }
1471
1472 static void
strhash_acons(void * k,void * v,void * closure)1473 strhash_acons (void *k, void *v, void *closure)
1474 {
1475 SCM *alist = closure;
1476
1477 *alist = scm_acons (gi_string2scm (k),
1478 gi_string2scm (v),
1479 *alist);
1480 }
1481
1482 /*
1483 * Converts the given string hash @var{hash} into a guile alist.
1484 */
1485 SCM
guile_hash_to_guile(svz_hash_t * hash)1486 guile_hash_to_guile (svz_hash_t *hash)
1487 {
1488 SCM alist = SCM_EOL;
1489
1490 svz_hash_foreach (strhash_acons, hash, &alist);
1491 return alist;
1492 }
1493
1494 static int
access_interfaces_internal(const svz_interface_t * ifc,void * closure)1495 access_interfaces_internal (const svz_interface_t *ifc, void *closure)
1496 {
1497 SCM *list = closure;
1498 char buf[64];
1499
1500 *list = scm_cons (gi_string2scm (SVZ_PP_ADDR (buf, ifc->addr)), *list);
1501 return 0;
1502 }
1503
1504 SCM_DEFINE
1505 (guile_access_interfaces,
1506 "serveez-interfaces", 0, 1, 0,
1507 (SCM args),
1508 doc: /***********
1509 Make the list of local interfaces accessible to Scheme. Return the
1510 local interfaces as a list of ip addresses in dotted decimal form. If
1511 @var{args} are specified, they are added as additional local interfaces. */)
1512 {
1513 #define FUNC_NAME s_guile_access_interfaces
1514 size_t n;
1515 SCM list = SCM_EOL;
1516 char *str, description[64];
1517 struct sockaddr_in addr;
1518 svz_array_t *array;
1519
1520 GUILE_PRECALL ();
1521
1522 svz_foreach_interface (access_interfaces_internal, &list);
1523
1524 /* Is there an argument given to the guile procedure? */
1525 if (BOUNDP (args))
1526 {
1527 if ((array = guile_to_strarray (args, FUNC_NAME)) != NULL)
1528 {
svz_array_foreach(array,str,n)1529 svz_array_foreach (array, str, n)
1530 {
1531 if (svz_inet_aton (str, &addr) == -1)
1532 {
1533 guile_error ("%s: IP address in dotted decimals expected",
1534 FUNC_NAME);
1535 guile_global_error = -1;
1536 continue;
1537 }
1538 sprintf (description, "guile interface %zu", n);
1539 svz_interface_add (n, description, AF_INET,
1540 &addr.sin_addr.s_addr, 0);
1541 }
1542 svz_array_destroy (array);
1543 }
1544 }
1545
1546 return scm_reverse_x (list, SCM_EOL);
1547 #undef FUNC_NAME
1548 }
1549
1550 SCM_DEFINE
1551 (guile_access_loadpath,
1552 "serveez-loadpath", 0, 1, 0,
1553 (SCM args),
1554 doc: /***********
1555 Make the search path for the Serveez core library accessible to Scheme.
1556 Return a list a each path as previously defined. If @var{args} is specified,
1557 override the current definition of this load path with it.
1558 The load path is used to tell Serveez where
1559 it can find additional server modules. */)
1560 {
1561 #define FUNC_NAME s_guile_access_loadpath
1562 SCM list;
1563 svz_array_t *paths = svz_dynload_path_get ();
1564
1565 GUILE_PRECALL ();
1566
1567 /* Create a guile list containing each search path. */
1568 list = guile_strarray_to_guile (paths);
1569 svz_array_destroy (paths);
1570
1571 /* Set the load path if argument is given. */
1572 if (BOUNDP (args))
1573 {
1574 if ((paths = guile_to_strarray (args, FUNC_NAME)) != NULL)
1575 svz_dynload_path_set (paths);
1576 }
1577 return list;
1578 #undef FUNC_NAME
1579 }
1580
1581 /*
1582 * Create a checker procedure body which evaluates the boolean
1583 * expression @var{expression}. The argument for this procedure
1584 * is a character string which can be uses as @var{str} within
1585 * the expression.
1586 */
1587 #define STRING_CHECKER_BODY(expression) \
1588 char str[64]; \
1589 \
1590 GUILE_PRECALL (); \
1591 return (GI_GET_XREP_MAYBE (str, arg) \
1592 && (expression)) \
1593 ? SCM_BOOL_T \
1594 : SCM_BOOL_F
1595
1596 SCM_DEFINE
1597 (guile_check_port,
1598 "serveez-port?", 1, 0, 0,
1599 (SCM arg),
1600 doc: /***********
1601 Return @code{#t} if the given string @var{name} corresponds with a
1602 registered port configuration, otherwise @code{#f}.
1603
1604 -args: (name) */)
1605 {
1606 #define FUNC_NAME s_guile_check_port
1607 STRING_CHECKER_BODY (svz_portcfg_get (str) != NULL);
1608 #undef FUNC_NAME
1609 }
1610
1611 SCM_DEFINE
1612 (guile_check_server,
1613 "serveez-server?", 1, 0, 0,
1614 (SCM arg),
1615 doc: /***********
1616 Check whether the given string @var{name} corresponds with an
1617 instantiated server name and return @code{#t} if so.
1618
1619 -args: (name) */)
1620 {
1621 #define FUNC_NAME s_guile_check_server
1622 STRING_CHECKER_BODY (svz_server_get (str) != NULL);
1623 #undef FUNC_NAME
1624 }
1625
1626 SCM_DEFINE
1627 (guile_check_stype,
1628 "serveez-servertype?", 1, 0, 0,
1629 (SCM arg),
1630 doc: /***********
1631 Check whether the given string @var{name} is a valid
1632 server type prefix known in Serveez and return @code{#t} if so.
1633 Otherwise return @code{#f}.
1634
1635 -args: (name) */)
1636 {
1637 #define FUNC_NAME s_guile_check_stype
1638 STRING_CHECKER_BODY (svz_servertype_get (str, 0) != NULL);
1639 #undef FUNC_NAME
1640 }
1641
1642 static SCM
parm_accessor(char const * who,int param,SCM arg)1643 parm_accessor (char const *who, int param, SCM arg)
1644 {
1645 SCM value;
1646 int n;
1647
1648 GUILE_PRECALL ();
1649 value = gi_integer2scm (svz_runparm (-1, param));
1650 if (BOUNDP (arg))
1651 {
1652 if (guile_to_integer (arg, &n))
1653 {
1654 guile_error ("%s: Invalid integer value", who);
1655 guile_global_error = -1;
1656 }
1657 else
1658 /* FIXME: Check return value. */
1659 svz_runparm (param, n);
1660 }
1661 return value;
1662 }
1663
1664 static SCM
string_accessor(char const * who,char ** x,SCM arg)1665 string_accessor (char const *who, char **x, SCM arg)
1666 {
1667 SCM value = gi_string2scm (*x);
1668 char str[2048];
1669
1670 GUILE_PRECALL ();
1671
1672 if (BOUNDP (arg))
1673 {
1674 if (! GI_GET_XREP_MAYBE (str, arg))
1675 {
1676 guile_error ("%s: Invalid string value", who);
1677 guile_global_error = -1;
1678 }
1679 else
1680 {
1681 svz_free (*x);
1682 *x = svz_strdup (str);
1683 }
1684 }
1685 return value;
1686 }
1687
1688 SCM_DEFINE
1689 (guile_access_verbosity,
1690 "serveez-verbosity", 0, 1, 0,
1691 (SCM level),
1692 doc: /***********
1693 Return the verbosity level (an integer). Optional
1694 arg @var{level} means set it to that level, instead. This
1695 setting is overridden by the command-line @samp{-v} option. */)
1696 {
1697 return parm_accessor (s_guile_access_verbosity,
1698 SVZ_RUNPARM_VERBOSITY,
1699 level);
1700 }
1701
1702 SCM_DEFINE
1703 (guile_access_maxsockets,
1704 "serveez-maxsockets", 0, 1, 0,
1705 (SCM max),
1706 doc: /***********
1707 Return the maximum number of open sockets permitted (an integer).
1708 Optional arg @var{max} means set it to that number, instead.
1709 This setting is overridden by the command-line @samp{-m} option. */)
1710 {
1711 return parm_accessor (s_guile_access_maxsockets,
1712 SVZ_RUNPARM_MAX_SOCKETS,
1713 max);
1714 }
1715
1716 #if ENABLE_CONTROL_PROTO
1717 extern char *control_protocol_password;
1718 #else
1719 static char *control_protocol_password;
1720 #endif
1721
1722 SCM_DEFINE
1723 (guile_access_passwd,
1724 "serveez-passwd", 0, 1, 0,
1725 (SCM pw),
1726 doc: /***********
1727 Return the control password (a string).
1728 Optional arg @var{pw} sets it to that, instead. This effectively
1729 does nothing if the control protocol is not enabled. */)
1730 {
1731 return string_accessor
1732 (s_guile_access_passwd, &control_protocol_password, pw);
1733 }
1734
1735 /*
1736 * Exception handler for guile. It is called if the evaluation of the file
1737 * evaluator or a guile procedure call failed.
1738 */
1739 static SCM
guile_exception(UNUSED void * data,SCM tag,SCM args)1740 guile_exception (UNUSED void *data, SCM tag, SCM args)
1741 {
1742 /* FIXME: current-load-port is not defined in this state. Why? */
1743 char str[64];
1744 SCM ep = scm_current_error_port ();
1745
1746 GI_GET_XREP (str, tag);
1747 guile_error ("Exception due to `%s'", str);
1748
1749 /* `tag' contains internal exception name */
1750 scm_puts ("guile-error: ", ep);
1751
1752 /* on quit/exit */
1753 if (SCM_NULLP (args))
1754 {
1755 scm_display (tag, ep);
1756 scm_puts ("\n", ep);
1757 return SCM_BOOL_F;
1758 }
1759
1760 if (!SCM_FALSEP (SCM_CAR (args)))
1761 {
1762 scm_display (SCM_CAR (args), ep);
1763 scm_puts (": ", ep);
1764 }
1765 args = SCM_CDR (args);
1766 scm_display_error_message (SCM_CAR (args), SCM_CADR (args), ep);
1767 return SCM_BOOL_F;
1768 }
1769
1770 /*
1771 * Initialize Guile. Make certain variables and procedures defined above
1772 * available to Guile.
1773 */
1774 static void
guile_init(void)1775 guile_init (void)
1776 {
1777 load_port_box = scm_permanent_object
1778 (scm_cons (SCM_BOOL_F, SCM_UNDEFINED));
1779
1780 /* The default module changed after Guile 1.3.4 from (guile) to
1781 (guile-user). Set it back explicitly, until the time when we
1782 can arrange to define the primitives in (serveez) proper. */
1783 gi_eval_string ("(define-module (guile))");
1784
1785 #include "guile.x"
1786
1787 /* define some variables */
1788 gi_define ("serveez-version", gi_string2scm (PACKAGE_VERSION));
1789
1790 {
1791 #include "guile-boot.c"
1792
1793 gi_eval_string (high);
1794 }
1795
1796 #if ENABLE_GUILE_SERVER
1797 guile_server_init ();
1798 #endif /* ENABLE_GUILE_SERVER */
1799 }
1800
1801 /* Wrapper function for the file loader exception handler. */
1802 static SCM
guile_eval_file(void * data)1803 guile_eval_file (void *data)
1804 {
1805 char *file = data;
1806 struct stat buf;
1807 int error;
1808
1809 /* Parse configuration from standard input stream. */
1810 #ifdef __MINGW32__
1811 error = svz_fstat ((int) GetStdHandle (STD_INPUT_HANDLE), &buf);
1812 #else
1813 error = svz_fstat (fileno (stdin), &buf);
1814 #endif
1815 if (file == NULL || (error != -1 && !isatty (fileno (stdin)) &&
1816 !S_ISCHR (buf.st_mode) && !S_ISBLK (buf.st_mode)))
1817 {
1818 SCM form, inp = scm_current_input_port ();
1819
1820 while (!SCM_EOF_OBJECT_P (form = scm_read (inp)))
1821 gi_primitive_eval (form);
1822 return SCM_BOOL_T;
1823 }
1824
1825 /* Load configuration from file. */
1826 return gi_primitive_load (file);
1827 }
1828
1829 /*
1830 * Get server settings from the file @var{cfgfile} and instantiate servers
1831 * as needed. Return non-zero on errors.
1832 */
1833 int
guile_load_config(char * cfgfile)1834 guile_load_config (char *cfgfile)
1835 {
1836 SCM ret;
1837 guile_global_error = 0;
1838 guile_init ();
1839
1840 ret = scm_internal_catch (SCM_BOOL_T,
1841 guile_eval_file, cfgfile,
1842 guile_exception, NULL);
1843
1844 if (SCM_FALSEP (ret))
1845 guile_global_error = -1;
1846
1847 /* Kick the garbage collection now since no Guile is involved anymore
1848 unless a Guile server is implemented. */
1849 scm_gc ();
1850
1851 return guile_global_error ? -1 : 0;
1852 }
1853