/* Copyright (C) 2002 Dale P. Smith This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA */ #include #include #include #include #include #include #include #include /* #include "fakeout.h" */ #include #define APACHE_REGEXP 1 #define HANDLERS 0 #define GBRL 1 #define CHILD 1 #define CONFIG 1 #define USE_STRPORT 1 #define MAIN_INIT HTTPD_ROOT "/mod_guile/main_init.scm" #if CHILD #define CHILD_INIT HTTPD_ROOT "/mod_guile/child_init.scm" #define CHILD_EXIT HTTPD_ROOT "/mod_guile/child_exit.scm" #endif #if 1 #define TRACE(x) #else #define TRACE(x) x #endif long tc_request_rec; long tc_server_rec; long tc_conn_rec; long tc_table; /* Do Smobs */ void create_request_rec_type(void) { tc_request_rec = scm_make_smob_type("request-rec", 0); } SCM new_request_rec(request_rec *r) { if (!r) return SCM_BOOL_F; SCM_RETURN_NEWSMOB(tc_request_rec, r); } void create_server_rec_type(void) { tc_server_rec = scm_make_smob_type("server-rec", 0); } SCM new_server_rec(server_rec *s) { if (!s) return SCM_BOOL_F; SCM_RETURN_NEWSMOB(tc_server_rec, s); } void create_conn_rec_type(void) { tc_conn_rec = scm_make_smob_type("conn-rec", 0); } SCM new_conn_rec(conn_rec *c) { if (!c) return SCM_BOOL_F; SCM_RETURN_NEWSMOB(tc_conn_rec, c); } void create_table_type(void) { long tc; tc = scm_make_smob_type("table", 0); #if 0 scm_set_smob_apply(tc, table_apply, 0, 0, 0); #endif tc_table = tc; } SCM new_table(table *t) { if (!t) return SCM_BOOL_F; SCM_RETURN_NEWSMOB(tc_table, t); } #define TYPE_GET(TYPE, GETTER, C_NAME, S_NAME) \ SCM_SNARF_HERE (\ static const char s_##TYPE##_get_##C_NAME [] = S_NAME; \ static SCM TYPE##_get_##C_NAME (SCM obj) \ { \ TYPE *o; \ SCM_ASSERT(SCM_SMOB_PREDICATE(tc_##TYPE, obj), obj, SCM_ARG1, s_##TYPE##_get_##C_NAME);\ o = (TYPE *) SCM_SMOB_DATA(obj); \ return GETTER; \ }\ )SCM_SNARF_INIT (\ scm_c_define_gsubr(s_##TYPE##_get_##C_NAME, 1, 0, 0, TYPE##_get_##C_NAME);\ scm_c_export(s_##TYPE##_get_##C_NAME , NULL); \ ) #define TYPE_SET(TYPE, SETTER, PRED, C_NAME, S_NAME) \ SCM_SNARF_HERE (\ static const char s_##TYPE##_set_##C_NAME [] = S_NAME; \ static SCM TYPE##_set_##C_NAME(SCM obj, SCM val) \ { \ TYPE *o; \ SCM_ASSERT(SCM_SMOB_PREDICATE(tc_##TYPE, obj), obj, SCM_ARG1, s_##TYPE##_set_##C_NAME);\ SCM_ASSERT(PRED(val), val, SCM_ARG2, s_##TYPE##_set_##C_NAME); \ o = (TYPE *) SCM_SMOB_DATA(obj); \ o->C_NAME = SETTER; \ return SCM_UNSPECIFIED; \ }\ )SCM_SNARF_INIT (\ scm_c_define_gsubr(s_##TYPE##_set_##C_NAME, 2, 0, 0, TYPE##_set_##C_NAME);\ scm_c_export(s_##TYPE##_set_##C_NAME , NULL); \ ) static char * mgap_pstrndup(pool *p, char const *s, int n) { char *d; SCM_DEFER_INTS; d = ap_pstrndup(p, s, n); SCM_ALLOW_INTS; return d; } #define GET_INT(TYPE, C_NAME, S_NAME) \ TYPE_GET(TYPE, SCM_MAKINUM(o->C_NAME), C_NAME, S_NAME) #define GET_STRING(TYPE, C_NAME, S_NAME) \ TYPE_GET(TYPE, scm_makfrom0str(o->C_NAME), C_NAME, S_NAME) #define SET_INT(TYPE, C_NAME, S_NAME) \ TYPE_SET(TYPE, SCM_INUM(val), SCM_INUMP, C_NAME, S_NAME) #define SET_STRING(TYPE, C_NAME, S_NAME) \ TYPE_SET(TYPE, mgap_pstrndup(o->pool, SCM_STRING_CHARS(val), SCM_STRING_LENGTH(val)), SCM_STRINGP, C_NAME, S_NAME) #define GET_TABLE(TYPE, C_NAME, S_NAME) \ TYPE_GET(TYPE, new_table(o->C_NAME), C_NAME, S_NAME) #define GET_RR(TYPE, C_NAME, S_NAME) \ TYPE_GET(TYPE, new_request_rec(o->C_NAME), C_NAME, S_NAME) #define GET_SERVER(TYPE, C_NAME, S_NAME) \ TYPE_GET(TYPE, new_server_rec(o->C_NAME), C_NAME, S_NAME) #define GET_CONN(TYPE, C_NAME, S_NAME) \ TYPE_GET(TYPE, new_conn_rec(o->C_NAME), C_NAME, S_NAME) /* tables */ #if 0 int tp_subr(void *data, char const *key, char const *val) { SCM port = (SCM) data; scm_puts("Key: [", port); scm_puts(key, port); scm_puts("]\tVal: [", port); scm_puts(val, port); scm_puts("]\n", port); return 1; } int table_print(SCM tab, SCM port, scm_print_state *pstate) { ap_table_do(tp_subr, (void *)port, (table *) SCM_SMOB_DATA(tab), NULL); return 1; } #endif /* request rec access routines */ GET_CONN (request_rec, connection, "request-rec:connection") /*ro*/ GET_SERVER (request_rec, server, "request-rec:server") /*ro*/ GET_RR (request_rec, next, "request-rec:next") /*ro*/ GET_RR (request_rec, prev, "request-rec:prev") /*ro*/ GET_RR (request_rec, main, "request-rec:main") /*ro*/ GET_STRING (request_rec, the_request, "request-rec:the-request") /*ro*/ /* assbackwards */ GET_INT (request_rec, header_only, "request-rec:header-only") /*ro*/ /* protocol */ /*ro*/ /* proto_num */ /*ro*/ /* hostname */ /*ro*/ /* request_time */ /*ro*/ GET_STRING (request_rec, status_line, "request-rec:status-line") /*ro*/ GET_INT (request_rec, status, "request-rec:status") GET_STRING (request_rec, method, "request-rec:method") /*ro*/ GET_INT (request_rec, method_number, "request-rec:method-number") /*ro*/ GET_INT (request_rec, allowed, "request-rec:allowed") /*ro*/ /* sent_body */ /* bytes_sent */ /* mtime */ /* boundary */ /* range */ /* clength */ /* remaining */ /* read_length */ /* read_body */ /* read_chunked */ GET_TABLE (request_rec, headers_in, "request-rec:headers-in") GET_TABLE (request_rec, headers_out, "request-rec:headers-out") GET_TABLE (request_rec, err_headers_out, "request-rec:err-headers-out") GET_TABLE (request_rec, subprocess_env, "request-rec:subprocess-env") GET_TABLE (request_rec, notes, "request-rec:notes") SET_STRING (request_rec, content_type, "request-rec:set-content-type!") GET_STRING (request_rec, content_type, "request-rec:content-type") GET_STRING (request_rec, handler, "request-rec:handler") GET_STRING (request_rec, content_encoding, "request-rec:content-encoding") GET_STRING (request_rec, content_language, "request-rec:content-language") /* vlist_validator */ /* no_cache */ /* no_local_copy */ GET_STRING (request_rec, unparsed_uri, "request-rec:unparsed-uri") /*ro*/ GET_STRING (request_rec, uri, "request-rec:uri") /*ro*/ SET_STRING (request_rec, filename, "request-rec:set-filename!") GET_STRING (request_rec, filename, "request-rec:filename") /*ro*/ GET_STRING (request_rec, path_info, "request-rec:path-info") /*ro*/ GET_STRING (request_rec, args, "request-rec:args") /*ro*/ /* server_rec access routines */ GET_STRING (server_rec, defn_name, "server-rec:defn-name") GET_INT (server_rec, defn_line_number, "server-rec:defn-line-number") GET_STRING (server_rec, srm_confname, "server-rec:srm-confname") GET_STRING (server_rec, access_confname, "server-rec:access-confname") GET_STRING (server_rec, server_admin, "server-rec:server-admin") GET_STRING (server_rec, server_hostname, "server-rec:server-hostname") GET_INT (server_rec, port, "server-rec:port") GET_STRING (server_rec, error_fname, "server-rec:error-fname") GET_INT (server_rec, loglevel, "server-rec:loglevel") GET_INT (server_rec, is_virtual, "server-rec:is_virtual") GET_INT (server_rec, timeout, "server-rec:timeout") GET_INT (server_rec, keep_alive_timeout, "server-rec:keep-alive-timeout") GET_INT (server_rec, keep_alive_max, "server-rec:keep-alive-max") GET_INT (server_rec, keep_alive, "server-rec:keep-alive") GET_INT (server_rec, send_buffer_size, "server-rec:send_buffer_size") GET_STRING (server_rec, path, "server-rec:path") GET_INT (server_rec, limit_req_line, "server-rec:limit-req-line") GET_INT (server_rec, limit_req_fieldsize, "server-rec:limit-req-fieldsize") GET_INT (server_rec, limit_req_fields, "server-rec:limit-req-fields") /* conn_rec access routines */ GET_SERVER (conn_rec, server, "conn-rec:server") GET_SERVER (conn_rec, base_server, "conn-rec:base-server") GET_INT (conn_rec, child_num, "conn-rec:child-num") GET_STRING (conn_rec, remote_ip, "conn-rec:remote-ip") GET_STRING (conn_rec, remote_host, "conn-rec:remote-host") GET_STRING (conn_rec, remote_logname, "conn-rec:remote-logname") GET_STRING (conn_rec, user, "conn-rec:user") GET_STRING (conn_rec, ap_auth_type, "conn-rec:ap-auth-type") GET_INT (conn_rec, keepalives, "conn-rec:keepalives") GET_STRING (conn_rec, local_ip, "conn-rec:local-ip") GET_STRING (conn_rec, local_host, "conn-rec:local-host") /* need to define some method_numbers */ SCM_VARIABLE_INIT(s_m_get, "M_GET", SCM_MAKINUM(M_GET)); SCM_VARIABLE_INIT(s_m_put, "M_PUT", SCM_MAKINUM(M_PUT)); SCM_VARIABLE_INIT(s_m_post, "M_POST", SCM_MAKINUM(M_POST)); SCM_VARIABLE_INIT(s_m_delete, "M_DELETE", SCM_MAKINUM(M_DELETE)); SCM_VARIABLE_INIT(s_m_connect, "M_CONNECT", SCM_MAKINUM(M_CONNECT)); SCM_VARIABLE_INIT(s_m_options, "M_OPTIONS", SCM_MAKINUM(M_OPTIONS)); #if 0 SCM_VARIABLE_INIT(s_m_trace, "M_TRACE", SCM_MAKINUM(M_TRACE)); SCM_VARIABLE_INIT(s_m_patch, "M_PATCH", SCM_MAKINUM(M_PATCH)); SCM_VARIABLE_INIT(s_m_propfind, "M_PROPFIND", SCM_MAKINUM(M_PROPFIND)); SCM_VARIABLE_INIT(s_m_proppatch, "M_PROPPATCH", SCM_MAKINUM(M_PROPPATCH)); SCM_VARIABLE_INIT(s_m_mkcol, "M_MKCOL", SCM_MAKINUM(M_MKCOL)); SCM_VARIABLE_INIT(s_m_copy, "M_COPY", SCM_MAKINUM(M_COPY)); SCM_VARIABLE_INIT(s_m_move, "M_MOVE", SCM_MAKINUM(M_MOVE)); SCM_VARIABLE_INIT(s_m_lock, "M_LOCK", SCM_MAKINUM(M_LOCK)); SCM_VARIABLE_INIT(s_m_unlock, "M_UNLOCK", SCM_MAKINUM(M_UNLOCK)); SCM_VARIABLE_INIT(s_m_invalid, "M_INVALID", SCM_MAKINUM(M_INVALID)); #endif /* More table stuff */ SCM_PROC(s_table_set, "table:set!", 3, 0, 0, table_set); SCM table_set (SCM obj, SCM key, SCM val) { table *t; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_table, obj), obj, SCM_ARG1, s_table_set); SCM_ASSERT(SCM_STRINGP(key), key, SCM_ARG2, s_table_set); SCM_ASSERT(SCM_STRINGP(val), val, SCM_ARG3, s_table_set); t = (table *) SCM_SMOB_DATA(obj); SCM_DEFER_INTS; SCM_STRING_COERCE_0TERMINATION_X(key); SCM_STRING_COERCE_0TERMINATION_X(val); ap_table_set(t, SCM_STRING_CHARS(key), SCM_STRING_CHARS(val)); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } SCM_PROC(s_table_add, "table:add!", 3, 0, 0, table_add); SCM table_add (SCM obj, SCM key, SCM val) { table *t; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_table, obj), obj, SCM_ARG1, s_table_add); SCM_ASSERT(SCM_STRINGP(key), key, SCM_ARG2, s_table_add); SCM_ASSERT(SCM_STRINGP(val), val, SCM_ARG3, s_table_add); t = (table *) SCM_SMOB_DATA(obj); SCM_DEFER_INTS; SCM_STRING_COERCE_0TERMINATION_X(key); SCM_STRING_COERCE_0TERMINATION_X(val); ap_table_add(t, SCM_STRING_CHARS(key), SCM_STRING_CHARS(val)); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } SCM_PROC(s_table_merge, "table:merge!", 3, 0, 0, table_merge); SCM table_merge (SCM obj, SCM key, SCM val) { table *t; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_table, obj), obj, SCM_ARG1, s_table_merge); SCM_ASSERT(SCM_STRINGP(key), key, SCM_ARG2, s_table_merge); SCM_ASSERT(SCM_STRINGP(val), val, SCM_ARG3, s_table_merge); t = (table *) SCM_SMOB_DATA(obj); SCM_DEFER_INTS; SCM_STRING_COERCE_0TERMINATION_X(key); SCM_STRING_COERCE_0TERMINATION_X(val); ap_table_merge(t, SCM_STRING_CHARS(key), SCM_STRING_CHARS(val)); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } SCM_PROC(s_table_get, "table:get", 2, 0, 0, table_get); SCM table_get (SCM obj, SCM key) { table *t; char const *r; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_table, obj), obj, SCM_ARG1, s_table_get); SCM_ASSERT(SCM_STRINGP(key), key, SCM_ARG2, s_table_get); t = (table *) SCM_SMOB_DATA(obj); SCM_DEFER_INTS; SCM_STRING_COERCE_0TERMINATION_X(key); r = ap_table_get(t, SCM_STRING_CHARS(key)); SCM_ALLOW_INTS; return scm_makfrom0str(r); } SCM_PROC(s_table_clear, "table:clear!", 1, 0, 0, table_clear); SCM table_clear(SCM obj) { table *t; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_table, obj), obj, SCM_ARG1, s_table_clear); t = (table *) SCM_SMOB_DATA(obj); SCM_DEFER_INTS; ap_clear_table(t); SCM_ALLOW_INTS; return SCM_UNSPECIFIED; } SCM_PROC(s_table_do, "table:do", 2, 1, 0, table_do); static int do_subr(void *data, char const *key, char const *val) { SCM ret; ret = scm_call_2((SCM)data, scm_makfrom0str(key), scm_makfrom0str(val)); return ret != SCM_BOOL_F; } SCM table_do(SCM tab, SCM proc, SCM key) { table * t; SCM arity; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_table, tab), tab, SCM_ARG1, s_table_do); SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)), proc, SCM_ARG2, s_table_do); if (SCM_INUM(SCM_CAR(arity)) != 2 || (SCM_FALSEP(SCM_CADDR(arity)) && (SCM_INUM(SCM_CAR(arity)) + SCM_INUM(SCM_CADR(arity)) < 2))) scm_wrong_type_arg(s_table_do, 2, proc); t = (table *) SCM_SMOB_DATA(tab); if (SCM_UNBNDP(key)) ap_table_do(do_subr, (void *)proc, t, NULL); else { SCM_ASSERT(SCM_STRINGP(key), key, SCM_ARG3, s_table_do); SCM_DEFER_INTS; SCM_STRING_COERCE_0TERMINATION_X(key); ap_table_do(do_subr, (void *)proc, t, ap_pstrdup(ap_table_elts(t)->pool, SCM_STRING_CHARS(key)), NULL); SCM_ALLOW_INTS; } return SCM_UNSPECIFIED; } SCM_PROC(s_table_p, "table?", 1, 0, 0, table_p); SCM table_p(SCM tab) { return SCM_BOOL(SCM_SMOB_PREDICATE(tc_table, tab)); } /* Utilities */ /* Turns magic html characters into &xxx; forms. If there are no special characters, just return the input. I'd like to generalize this somehow. The basic engine can be used for several kinds of escaping. brl does this, but I want to do it in C. Why? I want this to be *fast*. Faster than perl or php. */ SCM_PROC(s_scm_escape_html, "escape-html", 1, 0, 0, scm_escape_html); SCM scm_escape_html(SCM str) { char const *src; char *dst; int i, count; SCM newstr; SCM_ASSERT(SCM_STRINGP(str), str, SCM_ARG1, s_scm_escape_html); src = SCM_STRING_CHARS(str); count = 0; for (i = SCM_STRING_LENGTH(str); i--;) { switch (*src++) { case '<': case '>': count += 3; break; case '&': count += 4; break; case '"': count += 5; break; } } if (!count) return str; newstr = scm_allocate_string(count + SCM_STRING_LENGTH(str)); dst = SCM_STRING_CHARS(newstr); src = SCM_STRING_CHARS(str); for (i = SCM_STRING_LENGTH(str); i--; ++src) { switch (*src) { case '<': memcpy(dst, "<", 4); dst += 4; break; case '>': memcpy(dst, ">", 4); dst += 4; break; case '&': memcpy(dst, "&", 5); dst += 5; break; case '"': memcpy(dst, """, 6); dst += 6; break; default: *dst++ = *src; } } return newstr; } SCM mg_c_url_decode(char const *src, int len) { SCM newstr; int plus, i, count; char const *s; char *d; plus = 0; s = src; for (count = i = len; i--;) { if ((*s == '%') && isxdigit(s[1]) && isxdigit(s[2])) { count -= 2; s += 2; } else if (*s == '+') plus++; ++s; } if (!plus && (len == count)) return scm_mem2string(src, len); newstr = scm_allocate_string(count); d = SCM_STRING_CHARS(newstr); s = src; for (i = len; i--; ++s) { #define hexdigit(x) (isdigit(x) ? (x - '0') : ((tolower(x) - 'a') + 10)) if ((*s == '%') && isxdigit(s[1]) && isxdigit(s[2])) { *d++ = ((hexdigit(s[1]) << 4) | hexdigit(s[2])); i -= 2; s += 2; } else if (*s == '+') *d++ = ' '; else *d++ = *s; } return newstr; } /* return a new string with all the url encoding decoded. */ SCM_PROC(s_mg_url_decode, "url-decode", 1, 0, 0, mg_url_decode); SCM mg_url_decode(SCM str) { SCM_ASSERT(SCM_STRINGP(str), str, SCM_ARG1, s_mg_url_decode); return mg_c_url_decode(SCM_STRING_CHARS(str), SCM_STRING_LENGTH(str)); } /* Return a list of (name value) pairs that are url escaped. */ SCM_PROC(s_mg_parse_form_data, "parse-form-data", 1, 0, 0, mg_parse_form_data); SCM mg_parse_form_data(SCM str) { SCM lst; int len; char *src, *ks, *ke, *vs, *ve; SCM_ASSERT(SCM_STRINGP(str), str, SCM_ARG1, s_mg_parse_form_data); src = SCM_STRING_CHARS(str); len = SCM_STRING_LENGTH(str); lst = SCM_EOL; while (len > 0) { /* find end of key */ ks = src; while (len && *src != '=') { ++src; --len; } if (!len) break; ke = src++; --len; /* find end of value */ vs = src; while (len && *src != '&') { ++src; --len; } /* Last key=value pair has no terminating '&' */ /* if (!len) break; */ ve = src++; --len; /* add key, val to list */ lst = scm_cons(scm_cons(mg_c_url_decode(ks, ke-ks), mg_c_url_decode(vs, ve-vs)), lst); } return scm_return_first(lst); } static const char basis_64[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; SCM_PROC(s_mg_uuencode, "uuencode", 1, 0, 0, mg_uuencode); static SCM mg_uuencode(SCM str) { int i, len; char *p, *string; SCM encoded; SCM_ASSERT(SCM_STRINGP(str), str, SCM_ARG1, s_mg_uuencode); string = SCM_STRING_CHARS(str); len = SCM_STRING_LENGTH(str); encoded = scm_allocate_string((len+2) / 3 * 4); p = SCM_STRING_CHARS(encoded); for (i = 0; i < len; i += 3) { *p++ = basis_64[string[i] >> 2]; *p++ = basis_64[((string[i] & 0x3) << 4) | ((int) (string[i + 1] & 0xF0) >> 4)]; *p++ = basis_64[((string[i + 1] & 0xF) << 2) | ((int) (string[i + 2] & 0xC0) >> 6)]; *p++ = basis_64[string[i + 2] & 0x3F]; } *p-- = '\0'; *p-- = '='; *p-- = '='; return encoded; } SCM_PROC(s_mg_read_post_data, "read-post-data", 1, 0, 0, mg_read_post_data); SCM mg_read_post_data(SCM request) { request_rec *r; int total_read_bytes=0, read_bytes; int length; char *content_length; char *buffer; SCM newstr; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_request_rec, request), request, SCM_ARG1, s_mg_read_post_data); r = (request_rec *) SCM_SMOB_DATA(request); SCM_DEFER_INTS; content_length = (char *) ap_table_get(r->headers_in, "Content-Length"); length = (content_length ? atoi(content_length) : 0); if (ap_setup_client_block(r, REQUEST_CHUNKED_ERROR) != OK) { /* What if we get an error here? I'm returning a zero lenth string... */ SCM_ALLOW_INTS; return scm_allocate_string(0); } newstr = scm_allocate_string(length); buffer = SCM_STRING_CHARS(newstr); while (total_read_bytes < length) { ap_hard_timeout("Read POST information", r); /* start timeout timer */ read_bytes = ap_get_client_block(r, buffer+total_read_bytes, length-total_read_bytes); ap_reset_timeout(r); if (read_bytes <= 0) { break; } total_read_bytes += read_bytes; } SCM_ALLOW_INTS; return newstr; } #if APACHE_REGEXP /* This regex code is pretty much just lifted out of libguile/regex-posix.c. The arg verification macros have been converted to non-guile-internals style. Apache provides it's own regexp code that is statically linked into the executable. The function calls are the same, but the data structures are different. This code is compiled to use the Apache data structures instead of the libc structures. */ #include long tc_mg_regex; static size_t mg_regex_free (SCM obj) { regfree((regex_t *) SCM_CELL_WORD_1(obj)); free((regex_t *) SCM_CELL_WORD_1(obj)); return sizeof(regex_t); } SCM_SYMBOL (scm_regexp_error_key, "regular-expression-syntax"); static char * mg_scm_regexp_error_msg(int regerrno, regex_t *rx) { SCM errmsg; int l; /* FIXME: must we wrap any external calls in SCM_DEFER_INTS...SCM_ALLOW_INTS? Or are these only necessary when a SCM object may be left in an undetermined state (half-formed)? If the latter then I believe we may do without the critical section code. -twp */ /* We could simply make errmsg a char pointer, and allocate space with malloc. But since we are about to pass the pointer to scm_error, which never returns, we would never have the opportunity to free it. Creating it as a SCM object means that the system will GC it at some point. */ errmsg = scm_make_string(SCM_MAKINUM (80), SCM_UNDEFINED); SCM_DEFER_INTS; l = regerror(regerrno, rx, SCM_STRING_CHARS(errmsg), 80); if (l > 80) { errmsg = scm_make_string(SCM_MAKINUM (l), SCM_UNDEFINED); regerror(regerrno, rx, SCM_STRING_CHARS(errmsg), l); } SCM_ALLOW_INTS; return SCM_STRING_CHARS(errmsg); } SCM_PROC(s_scm_regexp_p, "regexp?", 1, 0, 0, mg_scm_regexp_p); SCM mg_scm_regexp_p(SCM obj) { return SCM_BOOL(SCM_SMOB_PREDICATE(tc_mg_regex, obj)); } SCM_PROC(s_scm_make_regexp, "make-regexp", 1, 0, 1, mg_scm_make_regexp); SCM mg_scm_make_regexp(SCM pat, SCM flags) { SCM flag; regex_t *rx; int status, cflags; SCM_ASSERT(SCM_STRINGP(pat), pat, SCM_ARG1, s_scm_make_regexp); if (scm_ilength (flags) < 0) scm_misc_error(s_scm_make_regexp, "Rest arguments do not form a proper list.", SCM_EOL); SCM_STRING_COERCE_0TERMINATION_X (pat); /* Examine list of regexp flags. If REG_BASIC is supplied, then turn off REG_EXTENDED flag (on by default). */ cflags = REG_EXTENDED; flag = flags; while (!SCM_NULLP(flag)) { if (SCM_INUM(SCM_CAR(flag)) == REG_BASIC) cflags &= ~REG_EXTENDED; else cflags |= SCM_INUM (SCM_CAR (flag)); flag = SCM_CDR (flag); } rx = (regex_t *) scm_must_malloc(sizeof(regex_t), s_scm_make_regexp); status = regcomp(rx, SCM_STRING_CHARS(pat), /* Make sure they're not passing REG_NOSUB; regexp-exec assumes we're getting match data. */ cflags & ~REG_NOSUB); if (status != 0) { scm_error(scm_regexp_error_key, s_scm_make_regexp, mg_scm_regexp_error_msg (status, rx), SCM_BOOL_F, SCM_BOOL_F); /* never returns */ } SCM_RETURN_NEWSMOB(tc_mg_regex, rx); } SCM_PROC(s_scm_regexp_exec, "regexp-exec", 2, 2, 0, mg_scm_regexp_exec); SCM mg_scm_regexp_exec(SCM rx, SCM str, SCM start, SCM flags) { int status, nmatches, offset; regmatch_t *matches; SCM mvec = SCM_BOOL_F; SCM_ASSERT(SCM_SMOB_PREDICATE(tc_mg_regex, rx), rx, SCM_ARG1, s_scm_regexp_exec); SCM_ASSERT(SCM_STRINGP(str), str, SCM_ARG2, s_scm_regexp_exec); if (SCM_UNBNDP(start)) { start = SCM_MAKINUM(0); offset = 0; } else { SCM_ASSERT(SCM_INUMP(start), start, SCM_ARG3, s_scm_regexp_exec); offset = SCM_INUM(start); } if (!(offset >= 0 && offset <= SCM_STRING_LENGTH (str))) scm_out_of_range_pos(s_scm_regexp_exec, start, SCM_MAKINUM(3)); if (SCM_UNBNDP (flags)) flags = SCM_INUM0; SCM_ASSERT(SCM_INUMP(flags), flags, SCM_ARG4, s_scm_regexp_exec); SCM_STRING_COERCE_0TERMINATION_X (str); /* re_nsub doesn't account for the `subexpression' representing the whole regexp, so add 1 to nmatches. */ nmatches = ((regex_t *) SCM_CELL_WORD_1(rx))->re_nsub + 1; SCM_DEFER_INTS; matches = (regmatch_t *) scm_must_malloc(sizeof(regmatch_t) * nmatches, s_scm_regexp_exec); status = regexec(((regex_t *) SCM_CELL_WORD_1(rx)), SCM_STRING_CHARS(str) + offset, nmatches, matches, SCM_INUM(flags)); if (!status) { int i; /* The match vector must include a cell for the string that was matched, so add 1. */ mvec = scm_c_make_vector (nmatches + 1, SCM_UNSPECIFIED); SCM_VELTS(mvec)[0] = str; for (i = 0; i < nmatches; ++i) if (matches[i].rm_so == -1) SCM_VELTS(mvec)[i+1] = scm_cons (SCM_MAKINUM (-1), SCM_MAKINUM (-1)); else SCM_VELTS(mvec)[i+1] = scm_cons (scm_long2num (matches[i].rm_so + offset), scm_long2num (matches[i].rm_eo + offset)); } scm_must_free ((char *) matches); SCM_ALLOW_INTS; if (status != 0 && status != REG_NOMATCH) scm_error (scm_regexp_error_key, s_scm_regexp_exec, mg_scm_regexp_error_msg(status, (regex_t *) SCM_CELL_WORD_1(rx)), SCM_BOOL_F, SCM_BOOL_F); return mvec; } void mg_scm_init_regex_posix() { tc_mg_regex = scm_make_smob_type ("regexp", sizeof(regex_t)); scm_set_smob_free(tc_mg_regex, mg_regex_free); /* Compilation flags. */ scm_c_define("regexp/basic", scm_long2num (REG_BASIC)); scm_c_define("regexp/extended", scm_long2num (REG_EXTENDED)); scm_c_define("regexp/icase", scm_long2num (REG_ICASE)); scm_c_define("regexp/newline", scm_long2num (REG_NEWLINE)); /* Execution flags. */ scm_c_define("regexp/notbol", scm_long2num (REG_NOTBOL)); scm_c_define("regexp/noteol", scm_long2num (REG_NOTEOL)); scm_add_feature("regex"); } #endif #if CONFIG /* configuration */ typedef struct { char *main_init; #if CHILD char *child_init; char *child_exit; #endif } mg_config; module guile_module; #endif void plain_cleanup(void *data) { #if 0 fprintf(stderr, "plain_cleanup pid: %d, %p\n", getpid(), data); #endif } #if CONFIG void * mg_server_config(pool *p, server_rec *s) { mg_config *new = 0; TRACE(fprintf(stderr, "1: [%d] server config pool: %p, server_rec: %p\n", getpid(), p, s)); new = (mg_config *) ap_palloc(p, sizeof(mg_config)); TRACE(fprintf(stderr, "1: [%d] server config mg_config: %p\n", getpid(), new)); new->main_init = MAIN_INIT; #if CHILD new->child_init = CHILD_INIT; new->child_exit = CHILD_EXIT; #endif return new; } const char * mg_set_init(cmd_parms *cmd, void *dummy, char *arg) { mg_config * mgc = ap_get_module_config(cmd->server->module_config, &guile_module); #if 0 fprintf(stderr, "set init info: %p\n", cmd->info); fprintf(stderr, "set init override: %d\n", cmd->override); fprintf(stderr, "set init config_file: [%s]\n", cmd->config_file); fprintf(stderr, "set init pool: %p\n", cmd->pool); fprintf(stderr, "set init temp_pool: %p\n", cmd->temp_pool); fprintf(stderr, "set init server: %p\n", cmd->server); fprintf(stderr, "set init path: [%s]\n", cmd->path); fprintf(stderr, "set init cmd: %p\n", cmd->cmd); fprintf(stderr, "set init end_token: [%s]\n", cmd->end_token); #endif if (!strcmp(cmd->info, "main")) mgc->main_init = arg; #if CHILD else if (!strcmp(cmd->info, "child")) mgc->child_init = arg; else if (!strcmp(cmd->info, "exit")) mgc->child_exit = arg; #endif else return "unknown config!"; return NULL; } #else #define mg_server_config NULL #endif SCM_SYMBOL(header_only_key, "header-only"); SCM mg_lazy_handler(void *data, SCM tag, SCM throw_args) { SCM eport = scm_current_error_port(); /* header only tag. Just return */ if (SCM_EQ_P(header_only_key, tag)) scm_ithrow(tag, throw_args, 1); /* Error report */ scm_putc('[', eport); scm_puts(ap_get_time(), eport); scm_puts("] mod_guile:", eport); if (!SCM_DEVAL_P) scm_puts(" (enable debugging evaluator for backtrace output)", eport); scm_putc('\n', eport); scm_handle_by_message_noexit(data, tag, throw_args); scm_force_output(eport); scm_ithrow(tag, throw_args, 1); return SCM_UNSPECIFIED; /* never returns */ } SCM mg_empty_handler(void *data, SCM tag, SCM args) { /* header only tag. Just return */ if (SCM_EQ_P(header_only_key, tag)) return SCM_UNSPECIFIED; /* This (non SCM_UNSPECIFIED) return causes the handler to return an error back to apache */ return SCM_BOOL_F; } static SCM mg_lazy_eval_file(char *file) { return scm_internal_lazy_catch(SCM_BOOL_T, (scm_t_catch_body) scm_c_primitive_load, file, (scm_t_catch_handler) mg_lazy_handler, file); } static SCM mg_eval_file(char *file) { return scm_internal_catch(SCM_BOOL_T, (scm_t_catch_body) mg_lazy_eval_file, file, (scm_t_catch_handler) mg_empty_handler, file); } #if !USE_STRPORT /* Apache port */ int ap_port_fill_input(SCM port) { return EOF; } void ap_port_write(SCM port, const void *data, size_t size) { request_rec *r = (request_rec *) SCM_STREAM(port); if (!r->sent_bodyct) { SCM_DEFER_INTS; ap_send_http_header(r); SCM_ALLOW_INTS; } /* We should throw an error here to quit sending stuff, as it is now, we continue to process scheme code, we just throw away any output that is generated. */ if (r->header_only) scm_ithrow(header_only_key, SCM_EOL, 1); SCM_DEFER_INTS; ap_rwrite(data, size, r); SCM_ALLOW_INTS; } void ap_port_flush(SCM port) { SCM_DEFER_INTS; ap_rflush((request_rec *) SCM_STREAM(port)); SCM_ALLOW_INTS; } long ap_port_type; void make_apache_port() { ap_port_type = scm_make_port_type("Apache", ap_port_fill_input, ap_port_write); scm_set_port_flush(ap_port_type, ap_port_flush); } /* Returns a new port based on a request_rec structure. I'm not really sure if this is the right way to go, or should be dig in to to the request_rec and record the BUFF pointer and make calls that use it? */ SCM new_apache_port(request_rec *r) { SCM port; scm_t_port *pt; SCM_NEWCELL(port); SCM_DEFER_INTS; pt = scm_add_to_port_table(port); scm_port_non_buffer(pt); SCM_SETPTAB_ENTRY(port, pt); SCM_SET_CELL_TYPE(port, ap_port_type | SCM_OPN | SCM_WRTNG); SCM_SETSTREAM(port, r); SCM_ALLOW_INTS; return port; } #endif #if HANDLERS /* Hooks */ SCM_SYMBOL(return_key, "return"); SCM_PROC(s_hook_return, "return", 1, 0, 0, hook_return); /* Use "return" from scheme to return from a handler. Handlers are run from hooks. */ SCM hook_return(SCM arg) { return scm_ithrow(return_key, arg, 1); } #define SCM_HOOK(C_NAME, S_NAME, ARITY)\ SCM_SNARF_HERE(\ static SCM C_NAME\ )SCM_SNARF_INIT(\ C_NAME = scm_create_hook(S_NAME, ARITY);\ scm_c_export(S_NAME , NULL) \ ) SCM_HOOK(post_read_request_hook, "post-read-request-hook", 1); SCM_HOOK(translate_name_hook, "translate-name-hook", 1); SCM_HOOK(header_parse_hook, "header-parse-hook", 1); SCM_HOOK(check_access_hook, "check-access-hook", 1); SCM_HOOK(check_user_id_hook, "check-user-id-hook", 1); SCM_HOOK(check_auth_hook, "check-auth-hook", 1); SCM_HOOK(find_types_hook, "find-types-hook", 1); SCM_HOOK(run_fixups_hook, "run-fixups-hook", 1); SCM_HOOK(log_transaction_hook, "log-transaction-hook", 1); // handler_hook = scm_create_hook("handler-hook", 1); SCM_VCELL_INIT(s_mg_ok, "OK", OK); SCM_VCELL_INIT(s_mg_done, "DONE", DONE); SCM_VCELL_INIT(s_mg_declined, "DECLINED", DECLINED); struct hook_request { SCM proc; SCM request; }; SCM hook_body(void *data) { struct hook_request *hr = (struct hook_request *) data; TRACE(fprintf(stderr, "[%d] hook body\n", getpid())); return scm_call_1(hr->proc, hr->request); } SCM hook_handler(void *data, SCM tag, SCM throw_args) { TRACE(fprintf(stderr, "[%d] hook handler\n", getpid())); return throw_args; } int run_hooks(SCM hook, SCM request, int run_all) { SCM procs; struct hook_request hr; SCM ret; int result; TRACE(fprintf(stderr, "[%d] running hook\n", getpid())); procs = SCM_HOOK_PROCEDURES(hook); hr.request = request; while (SCM_NIMP(procs)) { hr.proc = SCM_CAR(procs); ret = scm_internal_catch(return_key, hook_body, &hr, hook_handler, NULL); result = SCM_INUMP(ret) ? SCM_INUM(ret) : DECLINED; if (result != DECLINED && (!run_all || result != OK)) return result; procs = SCM_CDR(procs); } return run_all ? OK : DECLINED; } int mg_translate_name(request_rec *r) { return run_hooks(translate_name_hook, new_request_rec(r), 0); } int mg_check_access(request_rec *r) { return run_hooks(check_access_hook, new_request_rec(r), 1); } int mg_find_types(request_rec *r) { return run_hooks(find_types_hook, new_request_rec(r), 0); } int mg_run_fixups(request_rec *r) { return run_hooks(run_fixups_hook, new_request_rec(r), 1); } int mg_log_transaction(request_rec *r) { return run_hooks(log_transaction_hook, new_request_rec(r), 1); } int mg_header_parse(request_rec *r) { return run_hooks(header_parse_hook, new_request_rec(r), 1); } int mg_post_read_request(request_rec *r) { return run_hooks(post_read_request_hook, new_request_rec(r), 1); } int mg_check_user_id(request_rec *r) { // fprintf(stderr, "check_user_id\n"); return run_hooks(check_user_id_hook, new_request_rec(r), 0); } int mg_check_auth(request_rec *r) { return run_hooks(check_auth_hook, new_request_rec(r), 0); } #else #define mg_check_auth NULL #define mg_find_types NULL #define mg_run_fixups NULL #define mg_header_parse NULL #define mg_check_access NULL #define mg_check_user_id NULL #define mg_translate_name NULL #define mg_log_transaction NULL #define mg_post_read_request NULL #endif /* HOOKS */ /* scm_c_lookup() throws an exception when name is undefined. */ SCM mg_c_lookup_noexception (const char *name) { return scm_sym2var (scm_str2symbol (name), scm_current_module_lookup_closure (), SCM_BOOL_F); } /* * Init the mod_guile module. * * Init guile, load any config files, init ports etc. */ void mg_init(server_rec *s, pool *p) { SCM code; TRACE(fprintf(stderr, "2: [%d] main init s:%p pool :%p &s: %p\n", getpid(),s, p, &s)); /* start guile */ scm_init_guile(); #if !USE_STRPORT make_apache_port(); #endif create_request_rec_type(); create_server_rec_type(); create_conn_rec_type(); create_table_type(); #if APACHE_REGEXP mg_scm_init_regex_posix(); #endif scm_load_goops(); #ifndef SCM_MAGIC_SNARF_INITS #include "mod_guile.x" #endif #if 1 /* wacky! */ #define MAKE_GETTER_SETTER(GETTER, SETTER) \ scm_c_define(GETTER,\ scm_make_procedure_with_setter(SCM_VARIABLE_REF(scm_c_lookup(GETTER)),\ SCM_VARIABLE_REF(scm_c_lookup(SETTER)))) MAKE_GETTER_SETTER("request-rec:content-type", "request-rec:set-content-type!"); MAKE_GETTER_SETTER("request-rec:filename", "request-rec:set-filename!"); #endif ap_add_version_component("mod_guile/0.1"); { SCM ver = scm_version(); char buff[100]; strcpy(buff, "Guile/"); strcat(buff, SCM_STRING_CHARS(ver)); ap_add_version_component(buff); } /* Maybe we could make these options? */ SCM_DEVAL_P = 1; SCM_BACKTRACE_P = 1; SCM_RECORD_POSITIONS_P = 1; SCM_RESET_DEBUG_MODE; TRACE(fprintf(stderr, "[%d] before init\n", getpid())); /* Load global init file */ #if CONFIG { mg_config *mgc = ap_get_module_config(s->module_config, &guile_module); mg_eval_file(mgc->main_init); } #else mg_eval_file(MAIN_INIT); #endif } #if CHILD void mg_child_init(server_rec *s, pool *p) { mg_config *mgc = ap_get_module_config(s->module_config, &guile_module); TRACE(fprintf(stderr, "[%d] child init s:%p p:%p\n", getpid(), s, p)); /* Load per-server init file. Open database connections etc. */ mg_eval_file(mgc->child_init); } void mg_child_exit(server_rec *s, pool *p) { mg_config *mgc = ap_get_module_config(s->module_config, &guile_module); TRACE(fprintf(stderr, "[%d] child exit s:%p p:%p\n", getpid(), s, p)); /* load per-server deinit file. Close database connections etc. */ mg_eval_file(mgc->child_exit); /* from scm_boot_guile_1 */ scm_restore_signals(); SCM_ASYNC_TICK; } #else #define mg_child_init NULL #define mg_child_exit NULL #endif int mg_scm_handler(request_rec *r) { SCM code; TRACE(fprintf(stderr, "\n[%d] scm handler request: %p, pool: %p, &r: %p\n", getpid(), r, r->pool, &r)); ap_register_cleanup(r->pool, r, plain_cleanup, ap_null_cleanup); if (r->finfo.st_mode == 0) return DECLINED; r->content_type = "text/html"; // if (!r->header_only) { SCM port, req, ret; #if USE_STRPORT SCM str; #endif /* Is this really necessary? It doesn't add to the environment, just the "subprocess_env" table. */ ap_add_common_vars(r); ap_add_cgi_vars(r); #if USE_STRPORT port = scm_open_output_string(); #else port = new_apache_port(r); #endif // Probably a better way to do this... scm_c_define("Request", new_request_rec(r)); scm_set_current_output_port(port); TRACE(fprintf(stderr, "[%d] evaluating filename [%s]\n", getpid(), r->filename)); ret = mg_eval_file(r->filename); #if USE_STRPORT str = scm_get_output_string(port); #else scm_close_port(port); #endif // fprintf(stderr, "ret is %x\n", ret); #if 1 if (ret != SCM_UNSPECIFIED) { TRACE(fprintf(stderr, "[%d] scm handler request: %p, pool: %p ERROR\n", getpid(), r, r->pool)); return SERVER_ERROR; } #endif #if USE_STRPORT ap_send_http_header(r); ap_rwrite(SCM_STRING_CHARS(str), SCM_STRING_LENGTH(str), r); ap_rflush(r); scm_close_port(port); #endif } TRACE(fprintf(stderr, "[%d] scm handler request: %p, pool: %p DONE\n", getpid(), r, r->pool)); return OK; } #if GBRL int mg_gbrl_handler(request_rec *r) { SCM code; TRACE(fprintf(stderr, "\n[%d] gbrl handler r:%p\n", getpid(), r)); if (r->finfo.st_mode == 0) return DECLINED; /* scm_c_lookup() throws an exception when undefined. */ code = mg_c_lookup_noexception("handle-request"); if (SCM_FALSEP(code)) { ap_log_rerror(APLOG_MARK, APLOG_ERR|APLOG_NOERRNO, r, "handle-request is not defined\n"); return SERVER_ERROR; } code = SCM_VARIABLE_REF(code); r->content_type = "text/html"; // if (!r->header_only) { #if USE_STRPORT SCM str; SCM port = scm_open_output_string(); #else SCM port = new_apache_port(r); #endif scm_set_current_output_port(port); scm_call_2(code, scm_makfrom0str(r->filename), scm_ulong2num(r->finfo.st_mtime)); #if USE_STRPORT str = scm_get_output_string(port); ap_send_http_header(r); ap_rwrite(SCM_STRING_CHARS(str), SCM_STRING_LENGTH(str), r); ap_rflush(r); #endif scm_close_port(port); } return OK; } #endif #if CONFIG command_rec mg_commands[] = { { "GuileInit", mg_set_init, "main" , OR_ALL, TAKE1, "Module init script, default: " MAIN_INIT }, #if CHILD { "GuileChildInit", mg_set_init, "child", OR_ALL, TAKE1, "Module Child init script, default: " CHILD_INIT }, { "GuileChildExit", mg_set_init, "exit", OR_ALL, TAKE1, "Module Child exit script, default: " CHILD_EXIT }, #endif { NULL } }; #else #define mg_commands NULL #endif static const handler_rec mg_handlers[] = { #if GBRL { "application/x-httpd-gbrl", mg_gbrl_handler }, #endif { "application/x-httpd-scm", mg_scm_handler }, { NULL } }; #ifdef EAPI static void mg_add_module(module *m) { fprintf(stderr, "[%d] add module(%p) \"%s\"\n", getpid(), m, m->name); } static void mg_remove_module(module *m) { fprintf(stderr, "[%d] remove module(%p) \"%s\"\n", getpid(), m, m->name); } static char * mg_rewrite_command(cmd_parms *c, void *data, const char *str) { fprintf(stderr, "[%d] rewrite_command(%p, %p, \"%s\"\n", getpid(), c, data, str); return NULL; } static void mg_new_connection(conn_rec *c) { fprintf(stderr, "[%d] new connection(%p)\n", getpid(), c); } static void mg_close_connection(conn_rec *c) { fprintf(stderr, "[%d] close connection(%p)\n", getpid(), c); } #endif module guile_module = { STANDARD_MODULE_STUFF, mg_init, /* module initializer */ NULL, /* create per-dir config structures */ NULL, /* merge per-dir config structures */ mg_server_config, /* create per-server config structures */ NULL, /* merge per-server config structures */ mg_commands, /* table of config file commands */ mg_handlers, /* [#8] MIME-typed-dispatched handlers */ mg_translate_name, /* [#1] URI to filename translation */ mg_check_user_id, /* [#4] validate user id from request */ mg_check_auth, /* [#5] check if user_id is ok _here_ */ mg_check_access, /* [#3] check access by host address */ mg_find_types, /* [#6] determine MIME type */ mg_run_fixups, /* [#7] pre-run fixups */ mg_log_transaction, /* [#9] log a transaction */ mg_header_parse, /* [#2] header parser */ mg_child_init, /* child_init */ mg_child_exit, /* child exit */ mg_post_read_request, /* [#0] post read_request */ #ifdef EAPI mg_add_module, /* EAPI: add_module */ mg_remove_module, /* EAPI: remove_module */ NULL, /* EAPI: rewrite_command */ mg_new_connection, /* EAPI: new_connection */ mg_close_connection, /* EAPI: close_connection */ #endif }; /* Local Variables: c-file-style: "gnu" End: */ /* end of mod-guile.c */