summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2011-05-29 14:29:26 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2011-05-29 14:29:26 -0400
commit0932f8d0a699d270069816bbf1a367df68c2aeb5 (patch)
tree02dc2d6caca935269cf3c6f523ad087c80d9c778 /src
parentac03a2629057969e5aaf707c3af3123b74617af3 (diff)
getHeader and setHeader
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c66
-rw-r--r--src/cjr_print.sml8
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml14
-rw-r--r--src/demo.sml2
-rw-r--r--src/mono_opt.sml27
-rw-r--r--src/settings.sig8
-rw-r--r--src/settings.sml19
8 files changed, 140 insertions, 6 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index d440ed47..1edf47e0 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3346,7 +3346,7 @@ uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) {
return NULL;
}
-int mime_format(const char *s) {
+static int mime_format(const char *s) {
for (; *s; ++s)
if (!isalnum((int)*s) && *s != '/' && *s != '-' && *s != '.')
return 0;
@@ -3374,6 +3374,70 @@ uw_Basis_string uw_Basis_checkMime(uw_context ctx, uw_Basis_string s) {
return NULL;
}
+uw_Basis_string uw_Basis_blessRequestHeader(uw_context ctx, uw_Basis_string s) {
+ if (!mime_format(s))
+ uw_error(ctx, FATAL, "Request header \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
+
+ if (ctx->app->check_requestHeader(s))
+ return s;
+ else
+ uw_error(ctx, FATAL, "Disallowed request header %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkRequestHeader(uw_context ctx, uw_Basis_string s) {
+ if (!mime_format(s))
+ return NULL;
+
+ if (ctx->app->check_requestHeader(s))
+ return s;
+ else
+ return NULL;
+}
+
+uw_Basis_string uw_Basis_blessResponseHeader(uw_context ctx, uw_Basis_string s) {
+ if (!mime_format(s))
+ uw_error(ctx, FATAL, "Response header \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
+
+ if (ctx->app->check_responseHeader(s))
+ return s;
+ else
+ uw_error(ctx, FATAL, "Disallowed response header %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkResponseHeader(uw_context ctx, uw_Basis_string s) {
+ if (!mime_format(s))
+ return NULL;
+
+ if (ctx->app->check_responseHeader(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);
+}
+
+static int mime_value_format(const char *s) {
+ for (; *s; ++s)
+ if (*s == '\r' || *s == '\n')
+ return 0;
+
+ return 1;
+}
+
+uw_unit uw_Basis_setHeader(uw_context ctx, uw_Basis_string name, uw_Basis_string value) {
+ if (!mime_value_format(value))
+ uw_error(ctx, FATAL, "Invalid value for HTTP response header");
+
+ uw_write_header(ctx, name);
+ uw_write_header(ctx, ": ");
+ uw_write_header(ctx, value);
+ uw_write_header(ctx, "\r\n");
+
+ return uw_unit_v;
+}
+
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 009f8e45..f2455636 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2986,6 +2986,12 @@ fun p_file env (ds, ps) =
makeChecker ("uw_check_mime", Settings.getMimeRules ()),
newline,
+
+ makeChecker ("uw_check_requestHeader", Settings.getRequestHeaderRules ()),
+ newline,
+
+ makeChecker ("uw_check_responseHeader", Settings.getResponseHeaderRules ()),
+ newline,
string "extern void uw_sign(const char *in, char *out);",
newline,
@@ -3122,7 +3128,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_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader",
case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics"],
string "};",
newline]
diff --git a/src/compiler.sig b/src/compiler.sig
index a56a679a..587b3a94 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -51,6 +51,8 @@ signature COMPILER = sig
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
filterMime : Settings.rule list,
+ filterRequest : Settings.rule list,
+ filterResponse : Settings.rule list,
protocol : string option,
dbms : string option,
sigFile : string option,
diff --git a/src/compiler.sml b/src/compiler.sml
index 75e7b129..6d9c8166 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -55,6 +55,8 @@ type job = {
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
filterMime : Settings.rule list,
+ filterRequest : Settings.rule list,
+ filterResponse : Settings.rule list,
protocol : string option,
dbms : string option,
sigFile : string option,
@@ -335,6 +337,8 @@ fun institutionalizeJob (job : job) =
Settings.setRewriteRules (#rewrites job);
Settings.setUrlRules (#filterUrl job);
Settings.setMimeRules (#filterMime job);
+ Settings.setRequestHeaderRules (#filterRequest job);
+ Settings.setResponseHeaderRules (#filterResponse job);
Option.app Settings.setProtocol (#protocol job);
Option.app Settings.setDbms (#dbms job);
Settings.setSafeGets (#safeGets job);
@@ -384,6 +388,8 @@ fun parseUrp' accLibs fname =
from = capitalize (OS.Path.file fname) ^ "/", to = ""}],
filterUrl = [],
filterMime = [],
+ filterRequest = [],
+ filterResponse = [],
protocol = NONE,
dbms = NONE,
sigFile = NONE,
@@ -497,6 +503,8 @@ fun parseUrp' accLibs fname =
val rewrites = ref []
val url = ref []
val mime = ref []
+ val request = ref []
+ val response = ref []
val libs = ref []
val protocol = ref NONE
val dbms = ref NONE
@@ -529,6 +537,8 @@ fun parseUrp' accLibs fname =
rewrites = rev (!rewrites),
filterUrl = rev (!url),
filterMime = rev (!mime),
+ filterRequest = rev (!request),
+ filterResponse = rev (!response),
sources = sources,
protocol = !protocol,
dbms = !dbms,
@@ -573,6 +583,8 @@ fun parseUrp' accLibs fname =
rewrites = #rewrites old @ #rewrites new,
filterUrl = #filterUrl old @ #filterUrl new,
filterMime = #filterMime old @ #filterMime new,
+ filterRequest = #filterRequest old @ #filterRequest new,
+ filterResponse = #filterResponse old @ #filterResponse new,
sources = #sources new
@ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
(#sources old),
@@ -613,6 +625,8 @@ fun parseUrp' accLibs fname =
case s of
"url" => url
| "mime" => mime
+ | "requestHeader" => request
+ | "responseHeader" => response
| _ => (ErrorMsg.error "Bad filter kind";
url)
diff --git a/src/demo.sml b/src/demo.sml
index 4ebdbcbc..b9976a0c 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -114,6 +114,8 @@ fun make' {prefix, dirname, guided} =
rewrites = #rewrites combined @ #rewrites urp,
filterUrl = #filterUrl combined @ #filterUrl urp,
filterMime = #filterMime combined @ #filterMime urp,
+ filterRequest = #filterRequest combined @ #filterRequest urp,
+ filterResponse = #filterResponse combined @ #filterResponse 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 34c13e82..ffadeec4 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -435,6 +435,33 @@ fun exp e =
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
se)
+ | EFfiApp ("Basis", "checkMime", [(se as EPrim (Prim.String s), loc)]) =>
+ (if Settings.checkMime s then
+ ESome ((TFfi ("Basis", "string"), loc), (se, loc))
+ else
+ ENone (TFfi ("Basis", "string"), loc))
+ | EFfiApp ("Basis", "blessRequestHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ (if Settings.checkRequestHeader s then
+ ()
+ else
+ ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'");
+ se)
+ | EFfiApp ("Basis", "checkRequestHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ (if Settings.checkRequestHeader s then
+ ESome ((TFfi ("Basis", "string"), loc), (se, loc))
+ else
+ ENone (TFfi ("Basis", "string"), loc))
+ | EFfiApp ("Basis", "blessResponseHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ (if Settings.checkResponseHeader s then
+ ()
+ else
+ ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'");
+ se)
+ | EFfiApp ("Basis", "checkResponseHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ (if Settings.checkResponseHeader 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/settings.sig b/src/settings.sig
index 279325c3..d5383bca 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -96,6 +96,14 @@ signature SETTINGS = sig
val getMimeRules : unit -> rule list
val checkMime : string -> bool
+ val setRequestHeaderRules : rule list -> unit
+ val getRequestHeaderRules : unit -> rule list
+ val checkRequestHeader : string -> bool
+
+ val setResponseHeaderRules : rule list -> unit
+ val getResponseHeaderRules : unit -> rule list
+ val checkResponseHeader : 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 541ff1b4..c60f5d60 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -140,7 +140,9 @@ val benignBase = basis ["get_cookie",
"debug",
"naughtyDebug",
"rand",
- "now"]
+ "now",
+ "getHeader",
+ "setHeader"]
val benign = ref benignBase
fun setBenignEffectful ls = benign := S.addList (benignBase, ls)
@@ -293,12 +295,18 @@ fun rewrite pk s =
val url = ref ([] : rule list)
val mime = ref ([] : rule list)
+val request = ref ([] : rule list)
+val response = ref ([] : rule list)
fun setUrlRules ls = url := ls
fun setMimeRules ls = mime := ls
+fun setRequestHeaderRules ls = request := ls
+fun setResponseHeaderRules ls = response := ls
fun getUrlRules () = !url
fun getMimeRules () = !mime
+fun getRequestHeaderRules () = !request
+fun getResponseHeaderRules () = !response
fun check f rules s =
let
@@ -324,9 +332,12 @@ fun check f rules s =
end
val checkUrl = check (fn _ => true) url
-val checkMime = check
- (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"."))
- mime
+
+val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #".")
+
+val checkMime = check validMime mime
+val checkRequestHeader = check validMime request
+val checkResponseHeader = check validMime response
type protocol = {