# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1343939605 14400
# Node ID 3d922a28370bc3543011ee0f55ad7000d4b6e6f0
# Parent  10a2cb93d175ae8abbda0fc602dad670c7a213db
Basis.getenv

diff -r 10a2cb93d175 -r 3d922a28370b doc/manual.tex
--- a/doc/manual.tex	Sun Jul 29 12:54:17 2012 -0400
+++ b/doc/manual.tex	Thu Aug 02 16:33:25 2012 -0400
@@ -135,7 +135,7 @@
 
 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|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{[allow|deny] [url|mime|requestHeader|responseHeader|env] PATTERN} registers a rule governing which URLs, MIME types, HTTP request headers, HTTP response headers, or environment variable names 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.
@@ -1469,7 +1469,7 @@
   \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.
+It is also possible to get HTTP request headers and environment variables, and set HTTP response headers, using abstract types similar to the one for URLs.
 
 $$\begin{array}{l}
   \mt{type} \; \mt{requestHeader} \\
@@ -1477,6 +1477,11 @@
   \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{envVar} \\
+  \mt{val} \; \mt{blessEnvVar} : \mt{string} \to \mt{envVar} \\
+  \mt{val} \; \mt{checkEnvVar} : \mt{string} \to \mt{option} \; \mt{envVar} \\
+  \mt{val} \; \mt{getenv} : \mt{envVar} \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} \\
diff -r 10a2cb93d175 -r 3d922a28370b include/urweb/types.h
--- a/include/urweb/types.h	Sun Jul 29 12:54:17 2012 -0400
+++ b/include/urweb/types.h	Thu Aug 02 16:33:25 2012 -0400
@@ -97,6 +97,7 @@
   int (*check_mime)(const char *);
   int (*check_requestHeader)(const char *);
   int (*check_responseHeader)(const char *);
+  int (*check_envVar)(const char *);
 
   void (*on_error)(uw_context, char *);
 
diff -r 10a2cb93d175 -r 3d922a28370b include/urweb/urweb.h
--- a/include/urweb/urweb.h	Sun Jul 29 12:54:17 2012 -0400
+++ b/include/urweb/urweb.h	Thu Aug 02 16:33:25 2012 -0400
@@ -35,6 +35,7 @@
 failure_kind uw_begin_init(uw_context);
 void uw_set_on_success(char *);
 void uw_set_headers(uw_context, char *(*get_header)(void *, const char *), void *get_header_data);
+void uw_set_env(uw_context, char *(*get_env)(void *, const char *), void *get_env_data);
 failure_kind uw_begin(uw_context, char *path);
 failure_kind uw_begin_onError(uw_context, char *msg);
 void uw_login(uw_context);
@@ -220,14 +221,17 @@
 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_blessEnvVar(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_checkEnvVar(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_Basis_getenv(uw_context, uw_Basis_string name);
 
 uw_Basis_string uw_unnull(uw_Basis_string);
 uw_Basis_string uw_Basis_makeSigString(uw_context, uw_Basis_string);
diff -r 10a2cb93d175 -r 3d922a28370b lib/ur/basis.urs
--- a/lib/ur/basis.urs	Sun Jul 29 12:54:17 2012 -0400
+++ b/lib/ur/basis.urs	Thu Aug 02 16:33:25 2012 -0400
@@ -191,6 +191,11 @@
 val checkResponseHeader : string -> option responseHeader
 val setHeader : responseHeader -> string -> transaction unit
 
+type envVar
+val blessEnvVar : string -> envVar
+val checkEnvVar : string -> option envVar
+val getenv : envVar -> transaction (option string)
+
 
 (** JavaScript-y gadgets *)
 
diff -r 10a2cb93d175 -r 3d922a28370b src/c/cgi.c
--- a/src/c/cgi.c	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/c/cgi.c	Thu Aug 02 16:33:25 2012 -0400
@@ -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 @@
     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 @@
 
   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 -r 10a2cb93d175 -r 3d922a28370b src/c/fastcgi.c
--- a/src/c/fastcgi.c	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/c/fastcgi.c	Thu Aug 02 16:33:25 2012 -0400
@@ -229,6 +229,12 @@
   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 @@
       query_string = "";
 
     uw_set_headers(ctx, get_header, &hs);
+    uw_set_env(ctx, get_env, &hs);
 
     {
       request_result rr;
diff -r 10a2cb93d175 -r 3d922a28370b src/c/http.c
--- a/src/c/http.c	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/c/http.c	Thu Aug 02 16:33:25 2012 -0400
@@ -40,6 +40,10 @@
   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 @@
         }
 
         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 -r 10a2cb93d175 -r 3d922a28370b src/c/urweb.c
--- a/src/c/urweb.c	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/c/urweb.c	Thu Aug 02 16:33:25 2012 -0400
@@ -420,6 +420,9 @@
   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 @@
   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 @@
   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_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 @@
     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 @@
   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 -r 10a2cb93d175 -r 3d922a28370b src/cjr_print.sml
--- a/src/cjr_print.sml	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/cjr_print.sml	Thu Aug 02 16:33:25 2012 -0400
@@ -3380,6 +3380,9 @@
 
              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 @@
                          "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 -r 10a2cb93d175 -r 3d922a28370b src/compiler.sig
--- a/src/compiler.sig	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/compiler.sig	Thu Aug 02 16:33:25 2012 -0400
@@ -54,6 +54,7 @@
          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 -r 10a2cb93d175 -r 3d922a28370b src/compiler.sml
--- a/src/compiler.sml	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/compiler.sml	Thu Aug 02 16:33:25 2012 -0400
@@ -58,6 +58,7 @@
      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 @@
      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 @@
                         filterMime = [],
                         filterRequest = [],
                         filterResponse = [],
+                        filterEnv = [],
                         protocol = NONE,
                         dbms = NONE,
                         sigFile = NONE,
@@ -557,6 +560,7 @@
                      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 @@
                                  filterMime = rev (!mime),
                                  filterRequest = rev (!request),
                                  filterResponse = rev (!response),
+                                 filterEnv = rev (!env),
                                  sources = sources,
                                  protocol = !protocol,
                                  dbms = !dbms,
@@ -648,6 +653,7 @@
                                  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 @@
                            | "mime" => mime
                            | "requestHeader" => request
                            | "responseHeader" => response
+                           | "env" => env
                            | _ => (ErrorMsg.error "Bad filter kind";
                                    url)
 
diff -r 10a2cb93d175 -r 3d922a28370b src/demo.sml
--- a/src/demo.sml	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/demo.sml	Thu Aug 02 16:33:25 2012 -0400
@@ -117,6 +117,7 @@
             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 -r 10a2cb93d175 -r 3d922a28370b src/mono_opt.sml
--- a/src/mono_opt.sml	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/mono_opt.sml	Thu Aug 02 16:33:25 2012 -0400
@@ -504,6 +504,17 @@
              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 -r 10a2cb93d175 -r 3d922a28370b src/monoize.sml
--- a/src/monoize.sml	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/monoize.sml	Thu Aug 02 16:33:25 2012 -0400
@@ -225,6 +225,9 @@
                   | 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 -r 10a2cb93d175 -r 3d922a28370b src/settings.sig
--- a/src/settings.sig	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/settings.sig	Thu Aug 02 16:33:25 2012 -0400
@@ -120,6 +120,10 @@
     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 -r 10a2cb93d175 -r 3d922a28370b src/settings.sml
--- a/src/settings.sml	Sun Jul 29 12:54:17 2012 -0400
+++ b/src/settings.sml	Thu Aug 02 16:33:25 2012 -0400
@@ -400,16 +400,19 @@
 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 @@
 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 = {
diff -r 10a2cb93d175 -r 3d922a28370b tests/env.ur
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/env.ur	Thu Aug 02 16:33:25 2012 -0400
@@ -0,0 +1,21 @@
+fun handler r =
+  vo <- getenv (blessEnvVar r.Nam);
+  return <xml><body>
+  {case vo of
+       None => <xml>Not set</xml>
+     | Some v => <xml>Set to: {[v]}</xml>}
+</body></xml>
+
+fun main () : transaction page =
+  term <- getenv (blessEnvVar "TERM");
+  return <xml><body>
+    TERM = {case term of
+                None => <xml>Nada</xml>
+              | Some v => txt v}
+                 
+    <form>
+      What would you like to know?
+      <textbox{#Nam}/>
+      <submit action={handler}/>
+    </form>
+  </body></xml>
diff -r 10a2cb93d175 -r 3d922a28370b tests/env.urp
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/env.urp	Thu Aug 02 16:33:25 2012 -0400
@@ -0,0 +1,6 @@
+rewrite url Env/*
+allow env TERM
+allow env DESKTOP_*
+allow env SCRIPT_NAME
+
+env
diff -r 10a2cb93d175 -r 3d922a28370b tests/env.urs
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/tests/env.urs	Thu Aug 02 16:33:25 2012 -0400
@@ -0,0 +1,1 @@
+val main : unit -> transaction page