/* * guile.c - interface to Guile core library * * Copyright (C) 2011-2013 Thien-Thi Nguyen * Copyright (C) 2001, 2002, 2003 Stefan Jahn * Copyright (C) 2002 Andreas Rottmann * Copyright (C) 2001 Raimund Jacob * * This is free software; you can redistribute it and/or modify it * under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 3, or (at your option) * any later version. * * This software is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU * General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this package. If not, see . */ #include "config.h" #include #include #include #include #include #include #if HAVE_UNISTD_H # include #endif #ifdef __MINGW32__ # include #endif #include #include "networking-headers.h" #include "action.h" #include "libserveez.h" #include "misc-macros.h" #include "gi.h" #include "guile-api.h" #include "guile-server.h" #include "guile.h" #include "unused.h" /* Port configuration items. */ #define PORTCFG_PORT "port" #define PORTCFG_PROTO "proto" #define PORTCFG_TCP "tcp" #define PORTCFG_UDP "udp" #define PORTCFG_ICMP "icmp" #define PORTCFG_RAW "raw" #define PORTCFG_PIPE "pipe" #define PORTCFG_IP "ipaddr" #define PORTCFG_DEVICE "device" #define PORTCFG_BACKLOG "backlog" #define PORTCFG_TYPE "type" /* Pipe definitions. */ #define PORTCFG_RECV "recv" #define PORTCFG_SEND "send" #define PORTCFG_NAME "name" #define PORTCFG_PERMS "permissions" #define PORTCFG_USER "user" #define PORTCFG_GROUP "group" #define PORTCFG_UID "uid" #define PORTCFG_GID "gid" /* Miscellaneous definitions. */ #define PORTCFG_SEND_BUFSIZE "send-buffer-size" #define PORTCFG_RECV_BUFSIZE "recv-buffer-size" #define PORTCFG_FREQ "connect-frequency" #define PORTCFG_ALLOW "allow" #define PORTCFG_DENY "deny" /* * Global error flag that indicating failure of one of the parsing * functions. */ int guile_global_error = 0; /* * Global variable containing the current load port in exceptions. * FIXME: Where should I aquire it? In each procedure? */ static SCM load_port_box; #define stashed_load_port() (SCM_CDR (load_port_box)) #define GUILE_PRECALL() guile_set_current_load_port() /* * What is an 'option-hash' ? * We build up that data structure from a scheme pairlist. The pairlist has * to be an alist which is a key => value mapping. We read that mapping and * construct a @code{svz_hash_t} from it. The values of this hash are * pointers to @code{guile_value_t} structures. The @code{guile_value_t} * structure contains a @code{defined} field which counts the number of * occurrences of the key. Use @code{optionhash_validate} to make sure it * is 1 for each key. The @code{use} field is to make sure that each key * was needed exactly once. Use @code{optionhash_validate} again to find * out which ones were not needed. */ /* * Used as value in option-hashes. */ typedef struct guile_value { SCM value; /* the scheme value itself, invalid when defined != 1 */ int defined; /* the number of definitions, 1 to be valid */ int use; /* how often was it looked up in the hash, 1 to be valid */ } guile_value_t; /* * Create a guile value structure with the given @var{value}. Initializes * the usage counter to zero. The define counter is set to 1. */ static guile_value_t * guile_value_create (SCM value) { guile_value_t *v = svz_malloc (sizeof (guile_value_t)); v->value = value; v->defined = 1; v->use = 0; return v; } /* * Create a fresh option-hash. */ svz_hash_t * optionhash_create (void) { return svz_hash_create (4, svz_free); } /* * Destroy the given option-hash @var{options}. */ void optionhash_destroy (svz_hash_t *options) { svz_hash_destroy (options); } /* * Save the current load port for later usage in the @code{guile_error} * function. */ static void guile_set_current_load_port (void) { SCM p = scm_current_load_port (); if (SCM_PORTP (p)) scm_set_cdr_x (load_port_box, p); } /* * Returns the current load port. This is either the "real" one or the one * saved by the procedure @code{guile_set_current_load_port}. If neither * is possible return @code{SCM_UNDEFINED}. */ static SCM guile_get_current_load_port (void) { SCM p = scm_current_load_port (); if (!SCM_FALSEP (p) && SCM_PORTP (p)) return p; p = stashed_load_port (); if (BOUNDP (p) && SCM_PORTP (p)) return p; return SCM_UNDEFINED; } /* * Report some error at the current scheme position. Prints to stderr * but lets the program continue. The format string @var{format} does not * need a trailing newline. */ void guile_error (char *format, ...) { va_list args; /* FIXME: Why is this port undefined in guile exceptions? */ SCM lp = guile_get_current_load_port (); int lp_valid_p = BOUNDP (lp) /* TODO: Investigate why ‘SCM_PORTP’ is (was) sufficient for Guile 1.8 but not 2.0 (which is succeptible to segv). TODO: Do all validation in ‘guile_get_current_load_port’. */ && SCM_OPINPORTP (lp); SCM filename = lp_valid_p ? SCM_FILENAME (lp) : SCM_BOOL_F; char file[1024]; /* guile counts lines from 0, we have to add one */ fprintf (stderr, "%s:%ld:%ld: ", (lp_valid_p && GI_GET_XREP_MAYBE (file, filename) ? file : "undefined"), lp_valid_p ? (long) SCM_LINUM (lp) + 1 : 0, lp_valid_p ? (long) SCM_COL (lp) : 0); va_start (args, format); vfprintf (stderr, format, args); va_end (args); fprintf (stderr, "\n"); } struct optionhash_validate_closure { int what; int errors; char *type; char *name; }; static void optionhash_validate_internal (void *k, void *v, void *closure) { char *key = k, *blurb; guile_value_t *value = v; struct optionhash_validate_closure *x = closure; switch (x->what) { case 1: /* Check definition counter. */ if (value->defined == 1) return; blurb = "Multiple definitions of"; break; case 0: /* Check usage counter. */ if (value->use != 0) return; blurb = "Unused variable"; break; default: abort (); /* PEBKAC */ } x->errors++; guile_error ("%s `%s' in %s `%s'", blurb, key, x->type, x->name); } /* * Validate the values of an option-hash. Returns the number of errors. * what = 0 : check if all 'use' fields are 1 * what = 1 : check if all 'defined' fields are 1 * type : what kind of thing the option-hash belongs to * name : current variable name (specifying the alist) */ int optionhash_validate (svz_hash_t *hash, int what, char *type, char *name) { struct optionhash_validate_closure x = { what, 0, type, name }; svz_hash_foreach (optionhash_validate_internal, hash, &x); return x.errors; } /* * Get a scheme value from an option-hash and increment its 'use' field. * Returns SCM_UNSPECIFIED when @var{key} was not found. */ SCM optionhash_get (svz_hash_t *hash, char *key) { guile_value_t *val = svz_hash_get (hash, key); if (NULL != val) { val->use++; return val->value; } return SCM_UNSPECIFIED; } /* * Traverse a scheme pairlist that is an associative list and build up * a hash from it. Emits error messages and returns NULL when it did * so. Hash keys are the key names. Hash values are pointers to * guile_value_t structures. If @var{dounpack} is set the pairlist's * car is used instead of the pairlist itself. You have to unpack when * no "." is in front of the pairlist definition (in scheme * code). Some please explain the "." to Stefan and Raimi... */ svz_hash_t * guile_to_optionhash (SCM pairlist, char *suffix, int dounpack) { svz_hash_t *hash = optionhash_create (); guile_value_t *old_value; guile_value_t *new_value; int err = 0; /* Unpack if requested, ignore if null already (null == not existent). */ if (dounpack && !SCM_NULLP (pairlist) && BOUNDP (pairlist)) pairlist = SCM_CAR (pairlist); for ( ; SCM_PAIRP (pairlist); pairlist = SCM_CDR (pairlist)) { SCM pair = SCM_CAR (pairlist); SCM key, val; char str[64]; /* The car must be another pair which contains key and value. */ if (!SCM_PAIRP (pair)) { guile_error ("Not a pair %s", suffix); err = 1; break; } key = SCM_CAR (pair); val = SCM_CDR (pair); if (! GI_GET_XREP_MAYBE (str, key)) { /* Unknown key type, must be string or symbol. */ guile_error ("Invalid key type (string expected) %s", suffix); err = 1; break; } /* Remember key and value. */ new_value = guile_value_create (val); if (NULL != (old_value = svz_hash_get (hash, str))) { /* Multiple definition, let caller croak about that error. */ new_value->defined += old_value->defined; svz_free_and_zero (old_value); } svz_hash_put (hash, str, (void *) new_value); } /* Pairlist must be ‘SCM_NULLP’ now or that was not a good pairlist. */ if (!err && !SCM_NULLP (pairlist)) { guile_error ("Invalid pairlist %s", suffix); err = 1; } if (err) { svz_hash_destroy (hash); return NULL; } return hash; } SCM_DEFINE (libserveez_features, "libserveez-features", 0, 0, 0, (void), doc: /*********** Return a list of symbols representing the features of the underlying libserveez. For details, @xref{Library features}. */) { #define FUNC_NAME s_libserveez_features SCM rv = SCM_EOL; size_t count; const char * const *ls = svz_library_features (&count); while (count--) rv = scm_cons (gi_symbol2scm (ls[count]), rv); return rv; #undef FUNC_NAME } /* * Parse an integer value from a scheme cell. Returns zero when successful. * Stores the integer value where @var{target} points to. Does not emit * error messages. */ int guile_to_integer (SCM cell, int *target) { #define FUNC_NAME __func__ int err = 0; char str[64], *endp; /* Usual guile exact number. */ if (gi_exactp (cell)) { *target = gi_scm2int (cell); } /* Try string (or even symbol) to integer conversion. */ else if (GI_GET_XREP_MAYBE (str, cell)) { errno = 0; *target = strtol (str, &endp, 10); if (*endp != '\0' || errno == ERANGE) err = 1; } /* No chance. */ else { err = 2; } return err; #undef FUNC_NAME } /* * Parse a boolean value from a scheme cell. We consider integers and #t/#f * as boolean boolean values. Represented as integers internally. Returns * zero when successful. Stores the boolean/integer where @var{target} points * to. Does not emit error messages. */ int guile_to_boolean (SCM cell, int *target) { #define FUNC_NAME __func__ int i; int err = 0; char str[8]; /* Usual guile boolean. */ if (SCM_BOOLP (cell)) { i = gi_nfalsep (cell); *target = (i == 0 ? 0 : 1); } /* Try with the integer converter. */ else if (guile_to_integer (cell, &i) == 0) { *target = (i == 0 ? 0 : 1); } /* Neither integer nor boolean, try text conversion. */ /* FIXME: Use symbols and ‘memq’. */ else if (GI_GET_XREP_MAYBE (str, cell)) { #define STR_IS_CI(k) (! strncasecmp (k, str, sizeof (k))) /* Note: We use ‘sizeof (k)’ instead of ‘sizeof (k) - 1’ to deliberately include the terminating '\0', thus preventing false matches, e.g., "yesssss". */ if (STR_IS_CI ("yes") || STR_IS_CI ("on") || STR_IS_CI ("true")) *target = 1; else if (STR_IS_CI ("no") || STR_IS_CI ("off") || STR_IS_CI ("false")) *target = 0; else err = 1; #undef STR_IS_CI } else { err = 2; } return err; #undef FUNC_NAME } /* * Convert the given guile list @var{list} into a hash. Return * @code{NULL} on failure. Error messages will be emitted if * necessary. */ svz_hash_t * guile_to_hash (SCM list, const char *func) { #define FUNC_NAME func int err = 0, i; svz_hash_t *hash; /* Is this valid guile list at all? */ if (!SCM_LISTP (list)) { err = -1; guile_error ("%s: Not a valid list for hash", func); return NULL; } /* Iterate the alist. */ hash = svz_hash_create (gi_scm2ulong (scm_length (list)), svz_free); for (i = 0; SCM_PAIRP (list); list = SCM_CDR (list), i++) { SCM k, v, pair = SCM_CAR (list); char str[2048], *keystr, *valstr; if (!SCM_PAIRP (pair)) { err = -1; guile_error ("%s: Element #%d of hash is not a pair", func, i); continue; } k = SCM_CAR (pair); v = SCM_CDR (pair); /* Obtain key character string. */ if (! GI_GET_XREP_MAYBE (str, k)) { err = -1; guile_error ("%s: Element #%d of hash has no valid key " "(string expected)", func, i); keystr = NULL; } else { keystr = svz_strdup (str); } /* Obtain value character string. */ if (! GI_GET_XREP_MAYBE (str, v)) { err = -1; guile_error ("%s: Element #%d of hash has no valid value " "(string expected)", func, i); valstr = NULL; } else { valstr = svz_strdup (str); } /* Add to hash if key and value look good. */ if (keystr != NULL && valstr != NULL) { svz_hash_put (hash, keystr, valstr); svz_free (keystr); } } /* Free the values, keys are freed by hash destructor. */ if (err) { svz_hash_destroy (hash); return NULL; } return hash; #undef FUNC_NAME } /* * Convert the given non-empty @var{list} into an array of duplicated strings. * Return @code{NULL} if it is not a valid non-empty list. Print an error * message if one of the list's elements is not a string. The additional * argument @var{func} should be the name of the caller. */ svz_array_t * guile_to_strarray (SCM list, const char *func) { #define FUNC_NAME func svz_array_t *array; int i; char str[2048]; /* Check if the given scheme cell is a valid list. */ if (!SCM_LISTP (list)) { guile_error ("%s: String array is not a valid list", func); return NULL; } /* Iterate over the list and build up the array of strings. */ array = svz_array_create (gi_scm2ulong (scm_length (list)), svz_free); for (i = 0; SCM_PAIRP (list); list = SCM_CDR (list), i++) { SCM head = SCM_CAR (list); if (! gi_stringp (head) || 0 > GI_GET_XREP (str, head)) { guile_error ("%s: String expected in position %d", func, i); guile_global_error = -1; continue; } svz_array_add (array, svz_strdup (str)); } /* Reject the empty array. */ if (! svz_array_size (array)) { svz_array_destroy (array); array = NULL; } return array; #undef FUNC_NAME } /* * Convert the given scheme cell @var{list} which needs to be a valid guile * list into an array of integers. The additional argument @var{func} is the * name of the caller. Return NULL on failure. */ svz_array_t * guile_to_intarray (SCM list, const char *func) { #define FUNC_NAME func svz_array_t *array; int i, n; /* Check if the given scheme cell is a valid associative list. */ if (!SCM_LISTP (list)) { guile_error ("%s: Integer array is not a valid list", func); return NULL; } /* Iterate over the list and build up the array of strings. */ array = svz_array_create (gi_scm2ulong (scm_length (list)), NULL); for (i = 0; SCM_PAIRP (list); list = SCM_CDR (list), i++) { if (guile_to_integer (SCM_CAR (list), &n) != 0) { guile_error ("%s: Integer expected in position %d", func, i); guile_global_error = -1; continue; } svz_array_add (array, SVZ_NUM2PTR (n)); } /* Check the size of the resulting integer array. */ if (svz_array_size (array) == 0) { svz_array_destroy (array); array = NULL; } return array; #undef FUNC_NAME } /* * Extract an integer value from an option hash. Returns zero if it worked. */ static int optionhash_extract_int (svz_hash_t *hash, char *key, /* the key to find */ int hasdef, /* is there a default ? */ int defvar, /* the default */ int *target, /* where to put it */ char *txt) /* appended to error */ { int err = 0; SCM hvalue = optionhash_get (hash, key); /* Is there such an integer in the option-hash? */ if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { /* Nothing in hash, try to use default. */ if (hasdef) *target = defvar; else { guile_error ("No default value for integer `%s' %s", key, txt); err = 1; } } /* Convert the integer value. */ else if (guile_to_integer (hvalue, target)) { guile_error ("Invalid integer value for `%s' %s", key, txt); err = 1; } return err; } /* * Extract a string value from an option hash. Returns zero if it worked. * The memory for the string is newly allocated, no matter where it came * from. */ int optionhash_extract_string (svz_hash_t *hash, char *key, /* the key to find */ int hasdef, /* if there is a default */ char *defvar, /* default */ char **target, /* where to put it */ char *txt) /* appended to error */ { SCM hvalue = optionhash_get (hash, key); int err = 0; char str[2048]; /* Is there such a string in the option-hash? */ if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { /* Nothing in hash, try to use default. */ if (hasdef) *target = svz_strdup (defvar); else { guile_error ("No default value for string `%s' %s", key, txt); err = 1; } } else { /* Try getting the character string. */ if (! GI_GET_XREP_MAYBE (str, hvalue)) { guile_error ("Invalid string value for `%s' %s", key, txt); err = 1; } else { *target = svz_strdup (str); } } return err; } /* Before callback for configuring a server. */ static int optionhash_cb_before (char *server, void *arg) { svz_hash_t *options = arg; if (0 == optionhash_validate (options, 1, "server", server)) return SVZ_ITEM_OK; return SVZ_ITEM_FAILED; } /* Integer callback for configuring a server. */ static int optionhash_cb_integer (char *server, void *arg, char *key, int *target, int hasdef, UNUSED int def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: You have to define an integer called `%s'", server, key); return SVZ_ITEM_FAILED; } if (guile_to_integer (hvalue, target)) { guile_error ("%s: Invalid integer value for `%s'", server, key); return SVZ_ITEM_FAILED; } return SVZ_ITEM_OK; } /* Boolean callback for configuring a server. */ static int optionhash_cb_boolean (char *server, void *arg, char *key, int *target, int hasdef, UNUSED int def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: You have to define a boolean called `%s'", server, key); return SVZ_ITEM_FAILED; } if (guile_to_boolean (hvalue, target)) { guile_error ("%s: Invalid boolean value for `%s'", server, key); return SVZ_ITEM_FAILED; } return SVZ_ITEM_OK; } /* Integer array callback for configuring a server. */ static int optionhash_cb_intarray (char *server, void *arg, char *key, svz_array_t **target, int hasdef, UNUSED svz_array_t *def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); /* Is that integer array defined in the option-hash? */ if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: You have to define a integer array called `%s'", server, key); return SVZ_ITEM_FAILED; } /* Yes, start parsing it. */ else { svz_array_t *array; if ((array = guile_to_intarray (hvalue, key)) == NULL) { guile_error ("%s: Failed to parse integer array `%s'", server, key); return SVZ_ITEM_FAILED; } *target = array; } return SVZ_ITEM_OK; } /* String callback for configuring a server. */ static int optionhash_cb_string (char *server, void *arg, char *key, char **target, int hasdef, UNUSED char *def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); char str[2048]; if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: You have to define a string called `%s'", server, key); return SVZ_ITEM_FAILED; } if (! GI_GET_XREP_MAYBE (str, hvalue)) { guile_error ("%s: Invalid string value for `%s'", server, key); return SVZ_ITEM_FAILED; } *target = svz_strdup (str); return SVZ_ITEM_OK; } /* String array callback for configuring a server. */ static int optionhash_cb_strarray (char *server, void *arg, char *key, svz_array_t **target, int hasdef, UNUSED svz_array_t *def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: You have to define a string array called `%s'", server, key); return SVZ_ITEM_FAILED; } else { svz_array_t *array; if ((array = guile_to_strarray (hvalue, key)) == NULL) { guile_error ("%s: Failed to parse string array `%s'", server, key); return SVZ_ITEM_FAILED; } *target = array; } return SVZ_ITEM_OK; } /* Hash callback for configuring a server. */ static int optionhash_cb_hash (char *server, void *arg, char *key, svz_hash_t **target, int hasdef, UNUSED svz_hash_t *def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: You have to define a hash called `%s'", server, key); return SVZ_ITEM_FAILED; } else { svz_hash_t *hash; if ((hash = guile_to_hash (hvalue, key)) == NULL) { guile_error ("%s: Failed to parse hash `%s'", server, key); return SVZ_ITEM_FAILED; } *target = hash; } return SVZ_ITEM_OK; } /* Port configuration callback for configuring a server. */ static int optionhash_cb_portcfg (char *server, void *arg, char *key, svz_portcfg_t **target, int hasdef, UNUSED svz_portcfg_t *def) { svz_hash_t *options = arg; SCM hvalue = optionhash_get (options, key); svz_portcfg_t *port; char str[2048]; /* Is the requested port configuration defined? */ if (SCM_EQ_P (hvalue, SCM_UNSPECIFIED)) { if (hasdef) return SVZ_ITEM_DEFAULT_ERRMSG; guile_error ("%s: Port configuration `%s' required", server, key); return SVZ_ITEM_FAILED; } /* Convert Scheme cell into string. */ if (! GI_GET_XREP_MAYBE (str, hvalue)) { guile_error ("%s: Invalid string value for port configuration `%s' " "(string expected)", server, key); return SVZ_ITEM_FAILED; } /* Check existence of this named port configuration. */ if ((port = svz_portcfg_get (str)) == NULL) { guile_error ("%s: No such port configuration: `%s'", server, str); return SVZ_ITEM_FAILED; } /* Duplicate this port configuration. */ *target = svz_portcfg_dup (port); return SVZ_ITEM_OK; } /* After callback for configuring a server. */ static int optionhash_cb_after (char *server, void *arg) { svz_hash_t *options = arg; if (0 == optionhash_validate (options, 0, "server", server)) return SVZ_ITEM_OK; return SVZ_ITEM_FAILED; } /* * Extract a full pipe from an option hash. Returns zero if it worked. */ static int optionhash_extract_pipe (svz_hash_t *hash, char *key, /* the key to find */ svz_pipe_t *pipe, /* where to put it */ char *txt) /* appended to error */ { int err = 0; err |= optionhash_validate (hash, 1, "pipe", key); err |= optionhash_extract_string (hash, PORTCFG_NAME, 0, NULL, &(pipe->name), txt); err |= optionhash_extract_string (hash, PORTCFG_USER, 1, NULL, &(pipe->user), txt); err |= optionhash_extract_string (hash, PORTCFG_GROUP, 1, NULL, &(pipe->group), txt); err |= optionhash_extract_int (hash, PORTCFG_UID, 1, -1, (int *) &(pipe->uid), txt); err |= optionhash_extract_int (hash, PORTCFG_GID, 1, -1, (int *) &(pipe->gid), txt); err |= optionhash_extract_int (hash, PORTCFG_PERMS, 1, -1, (int *) &(pipe->perm), txt); err |= optionhash_validate (hash, 0, "pipe", key); return err; } SCM_DEFINE (guile_config_instantiate, "instantiate-config-type!", 3, 1, 0, (SCM type, SCM name, SCM instance, SCM opts), doc: /*********** Instantiate a configurable type. The four arguments are: the name of the configurable @var{type}, the type @var{name} in the configurable type's domain, the @var{instance} name the newly instantiated type should get, and the configuration alist for the new instance. Emit error messages (to stderr). Return @code{#t} on success, @code{#f} in case of any error. */) { #define FUNC_NAME s_guile_config_instantiate int err = 0; char c_type[24], c_name[64], c_instance[64]; svz_hash_t *options = NULL; char action[ACTIONBUFSIZE]; char ebuf[ACTIONBUFSIZE]; /* Configure callbacks for the ‘svz_config_type_instantiate’ thing. */ svz_config_accessor_t accessor = { optionhash_cb_before, /* before */ optionhash_cb_integer, /* integers */ optionhash_cb_boolean, /* boolean */ optionhash_cb_intarray, /* integer arrays */ optionhash_cb_string, /* strings */ optionhash_cb_strarray, /* string arrays */ optionhash_cb_hash, /* hashes */ optionhash_cb_portcfg, /* port configurations */ optionhash_cb_after /* after */ }; if (! GI_GET_XREP_MAYBE (c_type, type)) { guile_error ("Invalid configurable type (string expected)"); FAIL (); } if (! GI_GET_XREP_MAYBE (c_name, name)) { guile_error ("Invalid type identifier (string expected)"); FAIL (); } if (! GI_GET_XREP_MAYBE (c_instance, instance)) { guile_error ("Invalid instance identifier (string expected)"); FAIL (); } DEFINING ("%s `%s'", c_type, c_instance); /* Extract options if any. */ if (!BOUNDP (opts)) options = optionhash_create (); else if (NULL == (options = guile_to_optionhash (opts, action, 0))) FAIL (); /* Message already emitted. */ err = svz_config_type_instantiate (c_type, c_name, c_instance, options, &accessor, ACTIONBUFSIZE, ebuf); if (err) { guile_error ("%s", ebuf); FAIL (); } out: optionhash_destroy (options); guile_global_error |= err; return err ? SCM_BOOL_F : SCM_BOOL_T; #undef FUNC_NAME } SCM_DEFINE (guile_define_server, "define-server!", 1, 1, 0, (SCM name, SCM args), doc: /*********** Define a server. @var{name} is a (unique) server name of the form @code{@var{type}-@var{something}}, where @var{type} is the shortname of a servertype. @var{args} is the optionhash that is special for the server. Emit error messages (to stderr). Return @code{#t} on success, @code{#f} in case of any error. */) { #define FUNC_NAME s_guile_define_server /* Note: This function could now as well be implemented in Scheme. [rotty] */ int err = 0; char servername[64], *servertype = NULL, *p = NULL; SCM retval; GUILE_PRECALL (); /* Check if the given server name is valid. */ if (! GI_GET_XREP_MAYBE (servername, name)) { guile_error ("%s: Invalid server name (string expected)", FUNC_NAME); FAIL (); } /* Separate server description. */ p = servertype = svz_strdup (servername); while (*p && *p != '-') p++; /* Extract server type and sanity check. */ if (*p == '-' && *(p + 1) != '\0') *p = '\0'; else { guile_error ("%s: Not a valid server name: `%s'", FUNC_NAME, servername); FAIL (); } /* Instantiate and configure this server. */ retval = guile_config_instantiate (gi_string2scm ("server"), gi_string2scm (servertype), name, args); out: svz_free (servertype); return err ? SCM_BOOL_F : retval; #undef FUNC_NAME } /* Validate a network port value. */ #define GUILE_VALIDATE_PORT(port, name, proto) do { \ if ((port) < 0 || (port) > 65535) { \ guile_error ("%s: %s port requires a short (0..65535)", proto, name); \ err = -1; } } while (0) SCM_DEFINE (guile_define_port, "define-port!", 2, 0, 0, (SCM name, SCM args), doc: /*********** Define a port configuration. @var{name} is a (unique) name for the port configuration. @var{args} is optionhash for various settings. Return @code{#t} on success, otherwise @code{#f}. Emit error messages (to stderr). */) { #define FUNC_NAME s_guile_define_port int err = 0; svz_portcfg_t *prev = NULL; svz_portcfg_t *cfg = svz_portcfg_create (); svz_hash_t *options = NULL; char portname[64], proto[16]; SCM protoname; char action[ACTIONBUFSIZE]; GUILE_PRECALL (); /* Check validity of first argument. */ if (! GI_GET_XREP_MAYBE (portname, name)) { guile_error ("%s: Invalid port configuration name (string expected)", FUNC_NAME); FAIL (); } DEFINING ("port `%s'", portname); if (NULL == (options = guile_to_optionhash (args, action, 0))) FAIL (); /* Message already emitted. */ /* Every key defined only once? */ if (0 != optionhash_validate (options, 1, "port", portname)) err = -1; /* Find out what protocol this portcfg will be about. */ protoname = optionhash_get (options, PORTCFG_PROTO); if (! GI_GET_XREP_MAYBE (proto, protoname)) { guile_error ("Port `%s' requires a `" PORTCFG_PROTO "' string field", portname); FAIL (); } /* Is that TCP? */ if (!strcmp (proto, PORTCFG_TCP)) { int port; cfg->proto = SVZ_PROTO_TCP; err |= optionhash_extract_int (options, PORTCFG_PORT, 0, 0, &port, action); GUILE_VALIDATE_PORT (port, "TCP", portname); SVZ_CFG_TCP (cfg, port) = port; err |= optionhash_extract_int (options, PORTCFG_BACKLOG, 1, 0, &SVZ_CFG_TCP (cfg, backlog), action); err |= optionhash_extract_string (options, PORTCFG_IP, 1, SVZ_PORTCFG_NOIP, &SVZ_CFG_TCP (cfg, ipaddr), action); err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL, &SVZ_CFG_TCP (cfg, device), action); } /* Maybe UDP? */ else if (!strcmp (proto, PORTCFG_UDP)) { int port; cfg->proto = SVZ_PROTO_UDP; err |= optionhash_extract_int (options, PORTCFG_PORT, 0, 0, &port, action); GUILE_VALIDATE_PORT (port, "UDP", portname); SVZ_CFG_UDP (cfg, port) = port; err |= optionhash_extract_string (options, PORTCFG_IP, 1, SVZ_PORTCFG_NOIP, &SVZ_CFG_UDP (cfg, ipaddr), action); err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL, &SVZ_CFG_UDP (cfg, device), action); } /* Maybe ICMP? */ else if (!strcmp (proto, PORTCFG_ICMP)) { int type; cfg->proto = SVZ_PROTO_ICMP; err |= optionhash_extract_string (options, PORTCFG_IP, 1, SVZ_PORTCFG_NOIP, &SVZ_CFG_ICMP (cfg, ipaddr), action); err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL, &SVZ_CFG_ICMP (cfg, device), action); err |= optionhash_extract_int (options, PORTCFG_TYPE, 1, SVZ_ICMP_SERVEEZ, &type, action); if (type & ~0xff) { guile_error ("ICMP type `%s' requires a byte (0..255) %s", PORTCFG_TYPE, action); err = -1; } SVZ_CFG_ICMP (cfg, type) = (uint8_t) (type & 0xff); } /* Maybe RAW? */ else if (!strcmp (proto, PORTCFG_RAW)) { cfg->proto = SVZ_PROTO_RAW; err |= optionhash_extract_string (options, PORTCFG_IP, 1, SVZ_PORTCFG_NOIP, &SVZ_CFG_RAW (cfg, ipaddr), action); err |= optionhash_extract_string (options, PORTCFG_DEVICE, 1, NULL, &SVZ_CFG_RAW (cfg, device), action); } /* Finally a PIPE? */ else if (!strcmp (proto, PORTCFG_PIPE)) { svz_hash_t *poptions; SCM p; char str[1024]; cfg->proto = SVZ_PROTO_PIPE; /* Handle receiving pipe. */ DEFINING ("pipe `%s' in port `%s'", PORTCFG_RECV, portname); /* Check if it is a plain string. */ p = optionhash_get (options, PORTCFG_RECV); if (GI_GET_XREP_MAYBE (str, p)) { svz_pipe_t *r = &SVZ_CFG_PIPE (cfg, recv); r->name = svz_strdup (str); r->gid = (gid_t) -1; r->uid = (uid_t) -1; r->perm = (mode_t) -1; } /* Create local optionhash for receiving pipe direction. */ else if (SCM_EQ_P (p, SCM_UNSPECIFIED)) { guile_error ("%s: You have to define a pipe called `%s'", portname, PORTCFG_RECV); err = -1; } else if ((poptions = guile_to_optionhash (p, action, 0)) == NULL) { err = -1; /* Message already emitted. */ } else { err |= optionhash_extract_pipe (poptions, PORTCFG_RECV, &SVZ_CFG_PIPE (cfg, recv), action); optionhash_destroy (poptions); } /* Try getting send pipe. */ DEFINING ("pipe `%s' in port `%s'", PORTCFG_SEND, portname); /* Check plain string. */ p = optionhash_get (options, PORTCFG_SEND); if (GI_GET_XREP_MAYBE (str, p)) { svz_pipe_t *s = &SVZ_CFG_PIPE (cfg, send); s->name = svz_strdup (str); s->gid = (gid_t) -1; s->uid = (uid_t) -1; s->perm = (mode_t) -1; } else if (SCM_EQ_P (p, SCM_UNSPECIFIED)) { guile_error ("%s: You have to define a pipe called `%s'", portname, PORTCFG_SEND); err = -1; } else if ((poptions = guile_to_optionhash (p, action, 0)) == NULL) { err = -1; /* Message already emitted. */ } else { err |= optionhash_extract_pipe (poptions, PORTCFG_SEND, &SVZ_CFG_PIPE (cfg, send), action); optionhash_destroy (poptions); } } else { guile_error ("Invalid `" PORTCFG_PROTO "' field `%s' in port `%s'", proto, portname); FAIL (); } /* Access the send and receive buffer sizes. */ err |= optionhash_extract_int (options, PORTCFG_SEND_BUFSIZE, 1, 0, &(cfg->send_buffer_size), action); err |= optionhash_extract_int (options, PORTCFG_RECV_BUFSIZE, 1, 0, &(cfg->recv_buffer_size), action); /* Acquire the connect frequency. */ if (cfg->proto & SVZ_PROTO_TCP) err |= optionhash_extract_int (options, PORTCFG_FREQ, 1, 0, &(cfg->connect_freq), action); /* Obtain the access lists "allow" and "deny". */ if (!(cfg->proto & SVZ_PROTO_PIPE)) { SCM list; cfg->deny = NULL; list = optionhash_get (options, PORTCFG_DENY); if (!SCM_EQ_P (list, SCM_UNSPECIFIED)) { if ((cfg->deny = guile_to_strarray (list, PORTCFG_DENY)) == NULL) { guile_error ("Failed to parse string array `" PORTCFG_DENY "' in port `%s'", portname); err = -1; } } cfg->allow = NULL; list = optionhash_get (options, PORTCFG_ALLOW); if (!SCM_EQ_P (list, SCM_UNSPECIFIED)) { if ((cfg->allow = guile_to_strarray (list, PORTCFG_ALLOW)) == NULL) { guile_error ("Failed to parse string array `" PORTCFG_ALLOW "' in port `%s'", portname); err = -1; } } } /* Check for unused keys in input. */ if (0 != optionhash_validate (options, 0, "port", portname)) FAIL (); /* Message already emitted. */ /* Now remember the name and add that port configuration. */ cfg->name = svz_strdup (portname); err |= svz_portcfg_mkaddr (cfg); if (err) FAIL (); if ((prev = svz_portcfg_get (portname)) != NULL) { /* We've overwritten something. Report and dispose. */ guile_error ("Duplicate definition of port `%s'", portname); err = -1; } else svz_portcfg_add (portname, cfg); out: if (err) svz_portcfg_destroy (cfg); optionhash_destroy (options); guile_global_error |= err; return err ? SCM_BOOL_F : SCM_BOOL_T; #undef FUNC_NAME } SCM_DEFINE (guile_bind_server, "bind-server!", 2, 0, 0, (SCM port, SCM server), doc: /*********** Do generic port to server(s) port binding. Both @var{port} and @var{server} must be either a string or symbol. See function @code{svz_server_bind}. */) { #define FUNC_NAME s_guile_bind_server char portname[64]; char servername[64]; svz_server_t *s; svz_portcfg_t *p; int err = 0; GUILE_PRECALL (); /* Check arguments. */ if (! STRING_OR_SYMBOL_P (port)) { guile_error ("%s: Port name must be string or symbol", FUNC_NAME); FAIL (); } if (! STRING_OR_SYMBOL_P (server)) { guile_error ("%s: Server name must be string or symbol", FUNC_NAME); FAIL (); } GI_GET_XREP (portname, port); GI_GET_XREP (servername, server); /* Check id there is such a port configuration. */ if ((p = svz_portcfg_get (portname)) == NULL) { guile_error ("%s: No such port: `%s'", FUNC_NAME, portname); err++; } /* Get one of the servers in the list. */ if ((s = svz_server_get (servername)) == NULL) { guile_error ("%s: No such server: `%s'", FUNC_NAME, servername); err++; } /* Bind a given server instance to a port configuration. */ if (s != NULL && p != NULL) { if (svz_server_bind (s, p) < 0) err++; } out: guile_global_error |= err; return err ? SCM_BOOL_F : SCM_BOOL_T; #undef FUNC_NAME } /* * Converts the given array of strings @var{array} into a guile list. */ SCM guile_strarray_to_guile (svz_array_t *array) { SCM list; size_t i; /* Check validity of the give string array. */ if (array == NULL) return SCM_UNDEFINED; /* Go through all the strings and add these to a guile list. */ for (list = SCM_EOL, i = 0; i < svz_array_size (array); i++) list = scm_cons (gi_string2scm ((char *) svz_array_get (array, i)), list); return scm_reverse (list); } /* * Converts the given array of integers @var{array} into a guile list. */ SCM guile_intarray_to_guile (svz_array_t *array) { SCM list; size_t i; /* Check validity of the give string array. */ if (array == NULL) return SCM_UNDEFINED; /* Go through all the strings and add these to a guile list. */ for (list = SCM_EOL, i = 0; i < svz_array_size (array); i++) list = scm_cons (gi_integer2scm ((long) svz_array_get (array, i)), list); return scm_reverse (list); } static void strhash_acons (void *k, void *v, void *closure) { SCM *alist = closure; *alist = scm_acons (gi_string2scm (k), gi_string2scm (v), *alist); } /* * Converts the given string hash @var{hash} into a guile alist. */ SCM guile_hash_to_guile (svz_hash_t *hash) { SCM alist = SCM_EOL; svz_hash_foreach (strhash_acons, hash, &alist); return alist; } static int access_interfaces_internal (const svz_interface_t *ifc, void *closure) { SCM *list = closure; char buf[64]; *list = scm_cons (gi_string2scm (SVZ_PP_ADDR (buf, ifc->addr)), *list); return 0; } SCM_DEFINE (guile_access_interfaces, "serveez-interfaces", 0, 1, 0, (SCM args), doc: /*********** Make the list of local interfaces accessible to Scheme. Return the local interfaces as a list of ip addresses in dotted decimal form. If @var{args} are specified, they are added as additional local interfaces. */) { #define FUNC_NAME s_guile_access_interfaces size_t n; SCM list = SCM_EOL; char *str, description[64]; struct sockaddr_in addr; svz_array_t *array; GUILE_PRECALL (); svz_foreach_interface (access_interfaces_internal, &list); /* Is there an argument given to the guile procedure? */ if (BOUNDP (args)) { if ((array = guile_to_strarray (args, FUNC_NAME)) != NULL) { svz_array_foreach (array, str, n) { if (svz_inet_aton (str, &addr) == -1) { guile_error ("%s: IP address in dotted decimals expected", FUNC_NAME); guile_global_error = -1; continue; } sprintf (description, "guile interface %zu", n); svz_interface_add (n, description, AF_INET, &addr.sin_addr.s_addr, 0); } svz_array_destroy (array); } } return scm_reverse_x (list, SCM_EOL); #undef FUNC_NAME } SCM_DEFINE (guile_access_loadpath, "serveez-loadpath", 0, 1, 0, (SCM args), doc: /*********** Make the search path for the Serveez core library accessible to Scheme. Return a list a each path as previously defined. If @var{args} is specified, override the current definition of this load path with it. The load path is used to tell Serveez where it can find additional server modules. */) { #define FUNC_NAME s_guile_access_loadpath SCM list; svz_array_t *paths = svz_dynload_path_get (); GUILE_PRECALL (); /* Create a guile list containing each search path. */ list = guile_strarray_to_guile (paths); svz_array_destroy (paths); /* Set the load path if argument is given. */ if (BOUNDP (args)) { if ((paths = guile_to_strarray (args, FUNC_NAME)) != NULL) svz_dynload_path_set (paths); } return list; #undef FUNC_NAME } /* * Create a checker procedure body which evaluates the boolean * expression @var{expression}. The argument for this procedure * is a character string which can be uses as @var{str} within * the expression. */ #define STRING_CHECKER_BODY(expression) \ char str[64]; \ \ GUILE_PRECALL (); \ return (GI_GET_XREP_MAYBE (str, arg) \ && (expression)) \ ? SCM_BOOL_T \ : SCM_BOOL_F SCM_DEFINE (guile_check_port, "serveez-port?", 1, 0, 0, (SCM arg), doc: /*********** Return @code{#t} if the given string @var{name} corresponds with a registered port configuration, otherwise @code{#f}. -args: (name) */) { #define FUNC_NAME s_guile_check_port STRING_CHECKER_BODY (svz_portcfg_get (str) != NULL); #undef FUNC_NAME } SCM_DEFINE (guile_check_server, "serveez-server?", 1, 0, 0, (SCM arg), doc: /*********** Check whether the given string @var{name} corresponds with an instantiated server name and return @code{#t} if so. -args: (name) */) { #define FUNC_NAME s_guile_check_server STRING_CHECKER_BODY (svz_server_get (str) != NULL); #undef FUNC_NAME } SCM_DEFINE (guile_check_stype, "serveez-servertype?", 1, 0, 0, (SCM arg), doc: /*********** Check whether the given string @var{name} is a valid server type prefix known in Serveez and return @code{#t} if so. Otherwise return @code{#f}. -args: (name) */) { #define FUNC_NAME s_guile_check_stype STRING_CHECKER_BODY (svz_servertype_get (str, 0) != NULL); #undef FUNC_NAME } static SCM parm_accessor (char const *who, int param, SCM arg) { SCM value; int n; GUILE_PRECALL (); value = gi_integer2scm (svz_runparm (-1, param)); if (BOUNDP (arg)) { if (guile_to_integer (arg, &n)) { guile_error ("%s: Invalid integer value", who); guile_global_error = -1; } else /* FIXME: Check return value. */ svz_runparm (param, n); } return value; } static SCM string_accessor (char const *who, char **x, SCM arg) { SCM value = gi_string2scm (*x); char str[2048]; GUILE_PRECALL (); if (BOUNDP (arg)) { if (! GI_GET_XREP_MAYBE (str, arg)) { guile_error ("%s: Invalid string value", who); guile_global_error = -1; } else { svz_free (*x); *x = svz_strdup (str); } } return value; } SCM_DEFINE (guile_access_verbosity, "serveez-verbosity", 0, 1, 0, (SCM level), doc: /*********** Return the verbosity level (an integer). Optional arg @var{level} means set it to that level, instead. This setting is overridden by the command-line @samp{-v} option. */) { return parm_accessor (s_guile_access_verbosity, SVZ_RUNPARM_VERBOSITY, level); } SCM_DEFINE (guile_access_maxsockets, "serveez-maxsockets", 0, 1, 0, (SCM max), doc: /*********** Return the maximum number of open sockets permitted (an integer). Optional arg @var{max} means set it to that number, instead. This setting is overridden by the command-line @samp{-m} option. */) { return parm_accessor (s_guile_access_maxsockets, SVZ_RUNPARM_MAX_SOCKETS, max); } #if ENABLE_CONTROL_PROTO extern char *control_protocol_password; #else static char *control_protocol_password; #endif SCM_DEFINE (guile_access_passwd, "serveez-passwd", 0, 1, 0, (SCM pw), doc: /*********** Return the control password (a string). Optional arg @var{pw} sets it to that, instead. This effectively does nothing if the control protocol is not enabled. */) { return string_accessor (s_guile_access_passwd, &control_protocol_password, pw); } /* * Exception handler for guile. It is called if the evaluation of the file * evaluator or a guile procedure call failed. */ static SCM guile_exception (UNUSED void *data, SCM tag, SCM args) { /* FIXME: current-load-port is not defined in this state. Why? */ char str[64]; SCM ep = scm_current_error_port (); GI_GET_XREP (str, tag); guile_error ("Exception due to `%s'", str); /* `tag' contains internal exception name */ scm_puts ("guile-error: ", ep); /* on quit/exit */ if (SCM_NULLP (args)) { scm_display (tag, ep); scm_puts ("\n", ep); return SCM_BOOL_F; } if (!SCM_FALSEP (SCM_CAR (args))) { scm_display (SCM_CAR (args), ep); scm_puts (": ", ep); } args = SCM_CDR (args); scm_display_error_message (SCM_CAR (args), SCM_CADR (args), ep); return SCM_BOOL_F; } /* * Initialize Guile. Make certain variables and procedures defined above * available to Guile. */ static void guile_init (void) { load_port_box = scm_permanent_object (scm_cons (SCM_BOOL_F, SCM_UNDEFINED)); /* The default module changed after Guile 1.3.4 from (guile) to (guile-user). Set it back explicitly, until the time when we can arrange to define the primitives in (serveez) proper. */ gi_eval_string ("(define-module (guile))"); #include "guile.x" /* define some variables */ gi_define ("serveez-version", gi_string2scm (PACKAGE_VERSION)); { #include "guile-boot.c" gi_eval_string (high); } #if ENABLE_GUILE_SERVER guile_server_init (); #endif /* ENABLE_GUILE_SERVER */ } /* Wrapper function for the file loader exception handler. */ static SCM guile_eval_file (void *data) { char *file = data; struct stat buf; int error; /* Parse configuration from standard input stream. */ #ifdef __MINGW32__ error = svz_fstat ((int) GetStdHandle (STD_INPUT_HANDLE), &buf); #else error = svz_fstat (fileno (stdin), &buf); #endif if (file == NULL || (error != -1 && !isatty (fileno (stdin)) && !S_ISCHR (buf.st_mode) && !S_ISBLK (buf.st_mode))) { SCM form, inp = scm_current_input_port (); while (!SCM_EOF_OBJECT_P (form = scm_read (inp))) gi_primitive_eval (form); return SCM_BOOL_T; } /* Load configuration from file. */ return gi_primitive_load (file); } /* * Get server settings from the file @var{cfgfile} and instantiate servers * as needed. Return non-zero on errors. */ int guile_load_config (char *cfgfile) { SCM ret; guile_global_error = 0; guile_init (); ret = scm_internal_catch (SCM_BOOL_T, guile_eval_file, cfgfile, guile_exception, NULL); if (SCM_FALSEP (ret)) guile_global_error = -1; /* Kick the garbage collection now since no Guile is involved anymore unless a Guile server is implemented. */ scm_gc (); return guile_global_error ? -1 : 0; }