From 342c17de79e7624affa866ee9eab9027453ae99e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 2 Aug 2012 16:33:25 -0400 Subject: Basis.getenv --- src/c/cgi.c | 6 ++++++ src/c/fastcgi.c | 7 +++++++ src/c/http.c | 5 +++++ src/c/urweb.c | 45 ++++++++++++++++++++++++++++++++++++++++++++- src/cjr_print.sml | 5 ++++- src/compiler.sig | 1 + src/compiler.sml | 7 +++++++ src/demo.sml | 1 + src/mono_opt.sml | 11 +++++++++++ src/monoize.sml | 3 +++ src/settings.sig | 4 ++++ src/settings.sml | 5 +++++ 12 files changed, 98 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/c/cgi.c b/src/c/cgi.c index 6d6e5252..d3ec32c7 100644 --- a/src/c/cgi.c +++ b/src/c/cgi.c @@ -1,6 +1,7 @@ #include "config.h" #include +#include #include #include #include @@ -39,6 +40,10 @@ static char *get_header(void *data, const char *h) { return NULL; } +static char *get_env(void *data, const char *name) { + return getenv(name); +} + static void on_success(uw_context ctx) { } static void on_failure(uw_context ctx) { @@ -102,6 +107,7 @@ int main(int argc, char *argv[]) { uw_set_on_success(""); uw_set_headers(ctx, get_header, NULL); + uw_set_env(ctx, get_env, NULL); uw_request_init(&uw_application, NULL, log_error, log_debug); body[body_pos] = 0; diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c index 5677af83..9e3c8d7e 100644 --- a/src/c/fastcgi.c +++ b/src/c/fastcgi.c @@ -229,6 +229,12 @@ static char *get_header(void *data, const char *h) { return search_nvps(hs->nvps, hs->uppercased); } +static char *get_env(void *data, const char *h) { + headers *hs = (headers *)data; + + return search_nvps(hs->nvps, h); +} + static int read_funny_len(unsigned char **buf, int *len) { if (*len <= 0) return -1; @@ -471,6 +477,7 @@ static void *worker(void *data) { query_string = ""; uw_set_headers(ctx, get_header, &hs); + uw_set_env(ctx, get_env, &hs); { request_result rr; diff --git a/src/c/http.c b/src/c/http.c index 9af86070..aa045d7a 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -40,6 +40,10 @@ static char *get_header(void *data, const char *h) { return NULL; } +static char *get_env(void *data, const char *name) { + return getenv(name); +} + static void on_success(uw_context ctx) { uw_write_header(ctx, "HTTP/1.1 200 OK\r\n"); } @@ -193,6 +197,7 @@ static void *worker(void *data) { } uw_set_headers(ctx, get_header, headers); + uw_set_env(ctx, get_env, NULL); printf("Serving URI %s....\n", path); rr = uw_request(rc, ctx, method, path, query_string, body, back - body, diff --git a/src/c/urweb.c b/src/c/urweb.c index 8d44088d..2eb1c9fe 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -420,6 +420,9 @@ struct uw_context { char *(*get_header)(void *, const char *); void *get_header_data; + char *(*get_env)(void *, const char *); + void *get_env_data; + uw_buffer outHeaders, page, heap, script; int allowed_to_return_indirectly, returning_indirectly; input *inputs, *subinputs, *cur_container; @@ -484,6 +487,9 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) { ctx->get_header = NULL; ctx->get_header_data = NULL; + ctx->get_env = NULL; + ctx->get_env_data = NULL; + uw_buffer_init(uw_headers_max, &ctx->outHeaders, 1); ctx->outHeaders.start[0] = 0; uw_buffer_init(uw_page_max, &ctx->page, 1); @@ -655,6 +661,11 @@ void uw_set_headers(uw_context ctx, char *(*get_header)(void *, const char *), v ctx->get_header_data = get_header_data; } +void uw_set_env(uw_context ctx, char *(*get_env)(void *, const char *), void *get_env_data) { + ctx->get_env = get_env; + ctx->get_env_data = get_env_data; +} + static void uw_set_error(uw_context ctx, const char *fmt, ...) { va_list ap; va_start(ap, fmt); @@ -3476,8 +3487,16 @@ uw_Basis_string uw_Basis_blessResponseHeader(uw_context ctx, uw_Basis_string s) uw_error(ctx, FATAL, "Disallowed response header %s", uw_Basis_htmlifyString(ctx, s)); } +static int envVar_format(const char *s) { + for (; *s; ++s) + if (!isalnum((int)*s) && *s != '_' && *s != '.') + return 0; + + return 1; +} + uw_Basis_string uw_Basis_checkResponseHeader(uw_context ctx, uw_Basis_string s) { - if (!mime_format(s)) + if (!envVar_format(s)) return NULL; if (ctx->app->check_responseHeader(s)) @@ -3486,6 +3505,26 @@ uw_Basis_string uw_Basis_checkResponseHeader(uw_context ctx, uw_Basis_string s) return NULL; } +uw_Basis_string uw_Basis_blessEnvVar(uw_context ctx, uw_Basis_string s) { + if (!envVar_format(s)) + uw_error(ctx, FATAL, "Environment variable \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s)); + + if (ctx->app->check_envVar(s)) + return s; + else + uw_error(ctx, FATAL, "Disallowed environment variable %s", uw_Basis_htmlifyString(ctx, s)); +} + +uw_Basis_string uw_Basis_checkEnvVar(uw_context ctx, uw_Basis_string s) { + if (!mime_format(s)) + return NULL; + + if (ctx->app->check_envVar(s)) + return s; + else + return NULL; +} + uw_Basis_string uw_Basis_getHeader(uw_context ctx, uw_Basis_string name) { return uw_Basis_requestHeader(ctx, name); } @@ -3510,6 +3549,10 @@ uw_unit uw_Basis_setHeader(uw_context ctx, uw_Basis_string name, uw_Basis_string return uw_unit_v; } +uw_Basis_string uw_Basis_getenv(uw_context ctx, uw_Basis_string name) { + return ctx->get_env(ctx->get_env_data, name); +} + uw_Basis_string uw_unnull(uw_Basis_string s) { return s ? s : ""; } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index c7be5526..c1198ccf 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3380,6 +3380,9 @@ fun p_file env (ds, ps) = makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()), newline, + + makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()), + newline, string "extern void uw_sign(const char *in, char *out);", newline, @@ -3537,7 +3540,7 @@ fun p_file env (ds, ps) = "uw_client_init", "uw_initializer", "uw_expunger", "uw_db_init", "uw_db_begin", "uw_db_commit", "uw_db_rollback", "uw_db_close", "uw_handle", - "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", + "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar", case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics", "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\""], string "};", diff --git a/src/compiler.sig b/src/compiler.sig index 2a900d41..f23728f0 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -54,6 +54,7 @@ signature COMPILER = sig filterMime : Settings.rule list, filterRequest : Settings.rule list, filterResponse : Settings.rule list, + filterEnv : Settings.rule list, protocol : string option, dbms : string option, sigFile : string option, diff --git a/src/compiler.sml b/src/compiler.sml index 10b2bd2f..a9720cf6 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -58,6 +58,7 @@ type job = { filterMime : Settings.rule list, filterRequest : Settings.rule list, filterResponse : Settings.rule list, + filterEnv : Settings.rule list, protocol : string option, dbms : string option, sigFile : string option, @@ -365,6 +366,7 @@ fun institutionalizeJob (job : job) = Settings.setMimeRules (#filterMime job); Settings.setRequestHeaderRules (#filterRequest job); Settings.setResponseHeaderRules (#filterResponse job); + Settings.setEnvVarRules (#filterEnv job); Option.app Settings.setProtocol (#protocol job); Option.app Settings.setDbms (#dbms job); Settings.setSafeGets (#safeGets job); @@ -439,6 +441,7 @@ fun parseUrp' accLibs fname = filterMime = [], filterRequest = [], filterResponse = [], + filterEnv = [], protocol = NONE, dbms = NONE, sigFile = NONE, @@ -557,6 +560,7 @@ fun parseUrp' accLibs fname = val mime = ref [] val request = ref [] val response = ref [] + val env = ref [] val libs = ref [] val protocol = ref NONE val dbms = ref NONE @@ -592,6 +596,7 @@ fun parseUrp' accLibs fname = filterMime = rev (!mime), filterRequest = rev (!request), filterResponse = rev (!response), + filterEnv = rev (!env), sources = sources, protocol = !protocol, dbms = !dbms, @@ -648,6 +653,7 @@ fun parseUrp' accLibs fname = filterMime = #filterMime old @ #filterMime new, filterRequest = #filterRequest old @ #filterRequest new, filterResponse = #filterResponse old @ #filterResponse new, + filterEnv = #filterEnv old @ #filterEnv new, sources = #sources new @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new)) (#sources old), @@ -690,6 +696,7 @@ fun parseUrp' accLibs fname = | "mime" => mime | "requestHeader" => request | "responseHeader" => response + | "env" => env | _ => (ErrorMsg.error "Bad filter kind"; url) diff --git a/src/demo.sml b/src/demo.sml index 747bbd2c..26dcfa95 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -117,6 +117,7 @@ fun make' {prefix, dirname, guided} = filterMime = #filterMime combined @ #filterMime urp, filterRequest = #filterRequest combined @ #filterRequest urp, filterResponse = #filterResponse combined @ #filterResponse urp, + filterEnv = #filterEnv combined @ #filterEnv urp, protocol = mergeWith #2 (#protocol combined, #protocol urp), dbms = mergeWith #2 (#dbms combined, #dbms urp), sigFile = mergeWith #2 (#sigFile combined, #sigFile urp), diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 70404c09..228c53e6 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -504,6 +504,17 @@ fun exp e = ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String s), loc), _)]) => + (if Settings.checkEnvVar s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'"); + se) + | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String s), loc), _)]) => + (if Settings.checkEnvVar s then + ESome ((TFfi ("Basis", "string"), loc), (se, loc)) + else + ENone (TFfi ("Basis", "string"), loc)) | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) => let diff --git a/src/monoize.sml b/src/monoize.sml index 7b1da97a..371e1d43 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -225,6 +225,9 @@ fun monoType env = | L.CFfi ("Basis", "css_property") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) => (L'.TFfi ("Basis", "string"), loc) diff --git a/src/settings.sig b/src/settings.sig index a9ad36a5..3e3f0985 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -120,6 +120,10 @@ signature SETTINGS = sig val getResponseHeaderRules : unit -> rule list val checkResponseHeader : string -> bool + val setEnvVarRules : rule list -> unit + val getEnvVarRules : unit -> rule list + val checkEnvVar : string -> bool + (* Web protocols that generated programs may speak *) type protocol = { name : string, (* Call it this on the command line *) diff --git a/src/settings.sml b/src/settings.sml index 6712925f..45e8640a 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -400,16 +400,19 @@ val url = ref ([] : rule list) val mime = ref ([] : rule list) val request = ref ([] : rule list) val response = ref ([] : rule list) +val env = ref ([] : rule list) fun setUrlRules ls = url := ls fun setMimeRules ls = mime := ls fun setRequestHeaderRules ls = request := ls fun setResponseHeaderRules ls = response := ls +fun setEnvVarRules ls = env := ls fun getUrlRules () = !url fun getMimeRules () = !mime fun getRequestHeaderRules () = !request fun getResponseHeaderRules () = !response +fun getEnvVarRules () = !env fun check f rules s = let @@ -437,10 +440,12 @@ fun check f rules s = val checkUrl = check (fn _ => true) url val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".") +val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".") val checkMime = check validMime mime val checkRequestHeader = check validMime request val checkResponseHeader = check validMime response +val checkEnvVar = check validEnv env type protocol = { -- cgit v1.2.3