getHeader and setHeader

15 files changed, 191 insertions, 7 deletions

diff --git a/doc/manual.tex b/doc/manual.tex
index 07c80b69..755cc735 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -136,7 +136,7 @@ For each entry \texttt{M} in the module list, the file \texttt{M.urs} is include
 
 Here is the complete list of directive forms.  ``FFI'' stands for ``foreign function interface,'' Ur's facility for interaction between Ur programs and C and JavaScript libraries.
 \begin{itemize}
-\item \texttt{[allow|deny] [url|mime] PATTERN} registers a rule governing which URLs or MIME types are allowed in this application.  The first such rule to match a URL or MIME type determines the verdict.  If \texttt{PATTERN} ends in \texttt{*}, it is interpreted as a prefix rule.  Otherwise, a string must match it exactly.
+\item \texttt{[allow|deny] [url|mime|requestHeader|responseHeader] PATTERN} registers a rule governing which URLs, MIME types, HTTP request headers, or HTTP response headers are allowed to appear explicitly in this application.  The first such rule to match a name determines the verdict.  If \texttt{PATTERN} ends in \texttt{*}, it is interpreted as a prefix rule.  Otherwise, a string must match it exactly.
 \item \texttt{alwaysInline PATH} requests that every call to the referenced function be inlined.  Section \ref{structure} explains how functions are assigned path strings.
 \item \texttt{benignEffectful Module.ident} registers an FFI function or transaction as having side effects.  The optimizer avoids removing, moving, or duplicating calls to such functions.  Every effectful FFI function must be registered, or the optimizer may make invalid transformations.  This version of the \texttt{effectful} directive registers that this function only has side effects that remain local to a single page generation.
 \item \texttt{clientOnly Module.ident} registers an FFI function or transaction that may only be run in client browsers.
@@ -1406,6 +1406,20 @@ $$\begin{array}{l}
   \mt{val} \; \mt{fileData} : \mt{file} \to \mt{blob}
 \end{array}$$
 
+It is also possible to get HTTP request headers and set HTTP response headers, using abstract types similar to the one for URLs.
+
+$$\begin{array}{l}
+  \mt{type} \; \mt{requestHeader} \\
+  \mt{val} \; \mt{blessRequestHeader} : \mt{string} \to \mt{requestHeader} \\
+  \mt{val} \; \mt{checkRequestHeader} : \mt{string} \to \mt{option} \; \mt{requestHeader} \\
+  \mt{val} \; \mt{getHeader} : \mt{requestHeader} \to \mt{transaction} \; (\mt{option} \; \mt{string}) \\
+  \\
+  \mt{type} \; \mt{responseHeader} \\
+  \mt{val} \; \mt{blessResponseHeader} : \mt{string} \to \mt{responseHeader} \\
+  \mt{val} \; \mt{checkResponseHeader} : \mt{string} \to \mt{option} \; \mt{responseHeader} \\
+  \mt{val} \; \mt{setHeader} : \mt{responseHeader} \to \mt{string} \to \mt{transaction} \; \mt{unit}
+\end{array}$$
+
 A blob can be extracted from a file and returned as the page result.  There are bless and check functions for MIME types analogous to those for URLs.
 $$\begin{array}{l}
   \mt{type} \; \mt{mimeType} \\
diff --git a/include/types.h b/include/types.h
index 1e479398..91089ef3 100644
--- a/include/types.h
+++ b/include/types.h
@@ -90,6 +90,8 @@ typedef struct {
   uw_Basis_string (*cookie_sig)(uw_context);
   int (*check_url)(const char *);
   int (*check_mime)(const char *);
+  int (*check_requestHeader)(const char *);
+  int (*check_responseHeader)(const char *);
 
   void (*on_error)(uw_context, char *);
 
diff --git a/include/urweb.h b/include/urweb.h
index 019761f7..4c1489c9 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -217,9 +217,16 @@ uw_Basis_client uw_Basis_self(uw_context);
 
 uw_Basis_string uw_Basis_bless(uw_context, uw_Basis_string);
 uw_Basis_string uw_Basis_blessMime(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_blessRequestHeader(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_blessResponseHeader(uw_context, uw_Basis_string);
 
 uw_Basis_string uw_Basis_checkUrl(uw_context, uw_Basis_string);
 uw_Basis_string uw_Basis_checkMime(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_checkRequestHeader(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_checkResponseHeader(uw_context, uw_Basis_string);
+
+uw_Basis_string uw_Basis_getHeader(uw_context, uw_Basis_string name);
+uw_unit uw_Basis_setHeader(uw_context, uw_Basis_string name, uw_Basis_string value);
 
 uw_Basis_string uw_unnull(uw_Basis_string);
 uw_Basis_string uw_Basis_makeSigString(uw_context, uw_Basis_string);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 09fd1a1d..bb671388 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -163,6 +163,16 @@ val setCookie : t ::: Type -> http_cookie t -> {Value : t,
                                                 Secure : bool} -> transaction unit
 val clearCookie : t ::: Type -> http_cookie t -> transaction unit
 
+type requestHeader
+val blessRequestHeader : string -> requestHeader
+val checkRequestHeader : string -> option requestHeader
+val getHeader : requestHeader -> transaction (option string)
+
+type responseHeader
+val blessResponseHeader : string -> responseHeader
+val checkResponseHeader : string -> option responseHeader
+val setHeader : responseHeader -> string -> transaction unit
+
 
 (** JavaScript-y gadgets *)
 
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 = {
diff --git a/tests/headers.ur b/tests/headers.ur
new file mode 100644
index 00000000..afb1565f
--- /dev/null
+++ b/tests/headers.ur
@@ -0,0 +1,11 @@
+fun action () =
+  setHeader (blessResponseHeader "Location") "http://www.google.com/";
+  return <xml/>
+
+fun main () =
+  ag <- getHeader (blessRequestHeader "User-Agent");
+  return <xml><body>
+    User agent: {[ag]}
+
+    <form> <submit action={action}/> </form>
+  </body></xml>
diff --git a/tests/headers.urp b/tests/headers.urp
new file mode 100644
index 00000000..c5fdfc99
--- /dev/null
+++ b/tests/headers.urp
@@ -0,0 +1,5 @@
+rewrite url Headers/*
+allow requestHeader User-Agent
+allow responseHeader Location
+
+headers
diff --git a/tests/headers.urs b/tests/headers.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/headers.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page