summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2012-08-02 16:33:25 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2012-08-02 16:33:25 -0400
commitfdc6c1310be60fbeb597400618473861f78676de (patch)
tree201d14d77f7f944545809bff02ae45fc826bb7e7 /src
parent722b0c632007ac6ea178b05695974e447b4288a3 (diff)
Basis.getenv
Diffstat (limited to 'src')
-rw-r--r--src/c/cgi.c6
-rw-r--r--src/c/fastcgi.c7
-rw-r--r--src/c/http.c5
-rw-r--r--src/c/urweb.c45
-rw-r--r--src/cjr_print.sml5
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml7
-rw-r--r--src/demo.sml1
-rw-r--r--src/mono_opt.sml11
-rw-r--r--src/monoize.sml3
-rw-r--r--src/settings.sig4
-rw-r--r--src/settings.sml5
12 files changed, 98 insertions, 2 deletions
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 <stdio.h>
+#include <stdlib.h>
#include <ctype.h>
#include <string.h>
#include <stdlib.h>
@@ -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 = {