Merge branch 'upstream' into dfsg_clean20160515+dfsg

37 files changed, 366 insertions, 64 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 701e9c03..bec77354 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -1,4 +1,20 @@
 ========
+20160515
+========
+
+- Support for HTML <meta> tags
+- Resource-integrity attributes for HTML <link>
+- Bug fixes and optimization improvements
+
+========
+20160306
+========
+
+- Allow '\r' in string and character literals
+- New standard library functions: List.span and List.groupBy
+- Bug fixes
+
+========
 20160213
 ========
 
diff --git a/configure.ac b/configure.ac
index 351d1129..2a09d3b5 100644
--- a/configure.ac
+++ b/configure.ac
@@ -1,4 +1,4 @@
-AC_INIT([urweb], [20160213])
+AC_INIT([urweb], [20160515])
 WORKING_VERSION=0
 AC_USE_SYSTEM_EXTENSIONS
 
diff --git a/doc/manual.tex b/doc/manual.tex
index 0a2d6faa..76f69330 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -139,7 +139,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|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{[allow|deny] [url|mime|requestHeader|responseHeader|env|meta] PATTERN} registers a rule governing which URLs, MIME types, HTTP request headers, HTTP response headers, environment variable names, or HTML \texttt{<meta>} 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.
@@ -1539,6 +1539,7 @@ $$\begin{array}{l}
   \mt{val} \; \mt{returnBlob} : \mt{t} ::: \mt{Type} \to \mt{blob} \to \mt{mimeType} \to \mt{transaction} \; \mt{t}
 \end{array}$$
 
+
 \subsection{SQL}
 
 Everything about SQL database access is restricted to server-side code.
@@ -2081,6 +2082,14 @@ $$\begin{array}{l}
   \mt{val} \; \mt{error} : \mt{t} ::: \mt{Type} \to \mt{xbody} \to \mt{t}
 \end{array}$$
 
+There is limited support for the HTML \texttt{<meta>} tag, with the following type used to control which names are allowed.
+$$\begin{array}{l}
+  \mt{type} \; \mt{meta} \\
+  \mt{val} \; \mt{blessMeta} : \mt{string} \to \mt{meta} \\
+  \mt{val} \; \mt{checkMeta} : \mt{string} \to \mt{option} \; \mt{meta}
+\end{array}$$
+Configure the policy for meta names with the \texttt{allow} and \texttt{deny} \texttt{.urp} directives.
+
 
 \subsection{Client-Side Programming}
 
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index 77e4c611..47086791 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -96,6 +96,7 @@ typedef struct {
   int (*check_requestHeader)(const char *);
   int (*check_responseHeader)(const char *);
   int (*check_envVar)(const char *);
+  int (*check_meta)(const char *);
 
   void (*on_error)(struct uw_context *, char *);
 
@@ -127,6 +128,7 @@ typedef struct {
 typedef struct uw_Sqlcache_Value {
   char *result;
   char *output;
+  char *scriptOutput;
   unsigned long timeValid;
 } uw_Sqlcache_Value;
 
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index 916fbbf9..5b6c6221 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -81,6 +81,7 @@ void uw_write(struct uw_context *, const char*);
 // For caching.
 void uw_recordingStart(struct uw_context *);
 char *uw_recordingRead(struct uw_context *);
+char *uw_recordingReadScript(struct uw_context *);
 
 uw_Basis_source uw_Basis_new_client_source(struct uw_context *, uw_Basis_string);
 uw_unit uw_Basis_set_client_source(struct uw_context *, uw_Basis_source, uw_Basis_string);
@@ -222,6 +223,8 @@ void uw_clear_headers(struct uw_context *);
 int uw_has_contentLength(struct uw_context *);
 void uw_Basis_clear_page(struct uw_context *);
 
+void uw_write_script(struct uw_context *, uw_Basis_string);
+
 uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c);
 uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure);
 uw_unit uw_Basis_clear_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c);
@@ -236,12 +239,14 @@ uw_Basis_string uw_Basis_blessMime(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_blessRequestHeader(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_blessResponseHeader(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_blessEnvVar(struct uw_context *, uw_Basis_string);
+uw_Basis_string uw_Basis_blessMeta(struct uw_context *, uw_Basis_string);
 
 uw_Basis_string uw_Basis_checkUrl(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_checkMime(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_checkRequestHeader(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_checkResponseHeader(struct uw_context *, uw_Basis_string);
 uw_Basis_string uw_Basis_checkEnvVar(struct uw_context *, uw_Basis_string);
+uw_Basis_string uw_Basis_checkMeta(struct uw_context *, uw_Basis_string);
 
 uw_Basis_string uw_Basis_getHeader(struct uw_context *, uw_Basis_string name);
 uw_unit uw_Basis_setHeader(struct uw_context *, uw_Basis_string name, uw_Basis_string value);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index a4872c32..883cc5b1 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -208,6 +208,10 @@ val blessEnvVar : string -> envVar
 val checkEnvVar : string -> option envVar
 val getenv : envVar -> transaction (option string)
 
+type meta
+val blessMeta : string -> meta
+val checkMeta : string -> option meta
+
 
 (** JavaScript-y gadgets *)
 
@@ -813,7 +817,8 @@ val data_attrs : data_attr -> data_attr -> data_attr
 
 val head : unit -> tag [Data = data_attr] html head [] []
 val title : unit -> tag [Data = data_attr] head [] [] []
-val link : unit -> tag [Data = data_attr, Id = id, Rel = string, Typ = string, Href = url, Media = string] head [] [] []
+val link : unit -> tag [Data = data_attr, Id = id, Rel = string, Typ = string, Href = url, Media = string, Integrity = string, Crossorigin = string] head [] [] []
+val meta : unit -> tag [Nam = meta, Content = string, Id = id] head [] [] []
 
 datatype mouseButton = Left | Right | Middle
 
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index 11895884..50764e46 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -434,6 +434,31 @@ fun drop [a] (n : int) (xs : list a) : list a =
 
 fun splitAt [a] (n : int) (xs : list a) : list a * list a =
     (take n xs, drop n xs)
+    
+fun span [a] (f : a -> bool) (ls : list a) : list a * list a  = 
+    let
+        fun span' ls acc =
+            case ls of
+                []      =>  (rev acc, [])
+              | x :: xs =>  if f x then span' xs (x :: acc) else (rev acc, ls)
+    in
+        span' ls []
+    end
+    
+fun groupBy [a] (f : a -> a -> bool) (ls : list a) : list (list a) = 
+    let
+        fun groupBy' ls acc =
+            case ls of
+                [] => rev ([] :: acc)
+              | x :: xs => 
+                let
+                    val (ys, zs) = span (f x) xs
+                in 
+                    groupBy' zs ((x :: ys) :: acc)
+                end
+    in
+        groupBy' ls []
+    end
 
 fun mapXiM [m ::: Type -> Type] (_ : monad m) [a] [ctx ::: {Unit}] (f : int -> a -> m (xml ctx [] [])) : t a -> m (xml ctx [] []) =
     let
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index 55068935..432d8c1a 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -105,3 +105,9 @@ val recToList : a ::: Type -> r ::: {Unit} -> folder r -> $(mapU a r) -> t a
 val drop : t ::: Type -> int -> list t -> list t
 val take : t ::: Type -> int -> list t -> list t
 val splitAt : t ::: Type -> int -> list t -> list t * list t
+
+(** Longest prefix of elements that satisfy a predicate, returned along with the remaining suffix *)
+val span : a ::: Type -> (a -> bool) -> t a -> t a * t a
+
+(** Group a list into maximal adjacent segments where all elements compare as equal, according to the provided predicate. *)
+val groupBy : a ::: Type -> (a -> a -> bool) -> t a -> t (t a)
diff --git a/src/c/request.c b/src/c/request.c
index d621aea7..cad84cb2 100644
--- a/src/c/request.c
+++ b/src/c/request.c
@@ -39,7 +39,12 @@ uw_context uw_request_new_context(int id, uw_app *app, uw_loggers *ls) {
   uw_logger log_error = ls->log_error;
   uw_context ctx = uw_init(id, ls);
   int retries_left = MAX_RETRIES;
-  uw_set_app(ctx, app);
+
+  if (uw_set_app(ctx, app)) {
+    log_error(logger_data, "Unable to initialize request context.  Most likely the limit on number of form inputs has been exceeded.\n");
+    uw_free(ctx);
+    return NULL;
+  }
 
   while (1) {
     failure_kind fk = uw_begin_init(ctx);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index c057688c..c23366fb 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -505,7 +505,7 @@ struct uw_context {
 
   // Sqlcache.
   int numRecording, recordingCapacity;
-  int *recordingOffsets;
+  int *recordingOffsets, *scriptRecordingOffsets;
   uw_Sqlcache_Update *cacheUpdate;
   uw_Sqlcache_Update *cacheUpdateTail;
   uw_Sqlcache_Unlock *cacheUnlock;
@@ -597,6 +597,7 @@ uw_context uw_init(int id, uw_loggers *lg) {
   ctx->numRecording = 0;
   ctx->recordingCapacity = 0;
   ctx->recordingOffsets = malloc(0);
+  ctx->scriptRecordingOffsets = malloc(0);
   ctx->cacheUpdate = NULL;
   ctx->cacheUpdateTail = NULL;
 
@@ -670,6 +671,7 @@ void uw_free(uw_context ctx) {
   free(ctx->output_buffer);
 
   free(ctx->recordingOffsets);
+  free(ctx->scriptRecordingOffsets);
 
   free(ctx);
 }
@@ -1568,6 +1570,10 @@ uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
       strcpy(s2, "\\074");
       s2 += 4;
       break;
+    case '&':
+      strcpy(s2, "\\046");
+      s2 += 4;
+      break;
     default:
       if (isprint((int)c) || c >= 128)
         *s2++ = c;
@@ -1609,6 +1615,10 @@ uw_Basis_string uw_Basis_jsifyChar(uw_context ctx, uw_Basis_char c1) {
     strcpy(s2, "\\074");
     s2 += 4;
     break;
+  case '&':
+    strcpy(s2, "\\046");
+    s2 += 4;
+    break;
   default:
     if (isprint((int)c) || c >= 128)
       *s2++ = c;
@@ -1647,6 +1657,10 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
       strcpy(s2, "\\074");
       s2 += 4;
       break;
+    case '&':
+      strcpy(s2, "\\046");
+      s2 += 4;
+      break;
     default:
       if (isprint((int)c) || c >= 128)
         *s2++ = c;
@@ -1745,13 +1759,20 @@ void uw_recordingStart(uw_context ctx) {
   if (ctx->numRecording == ctx->recordingCapacity) {
     ++ctx->recordingCapacity;
     ctx->recordingOffsets = realloc(ctx->recordingOffsets, sizeof(int) * ctx->recordingCapacity);
+    ctx->scriptRecordingOffsets = realloc(ctx->scriptRecordingOffsets, sizeof(int) * ctx->recordingCapacity);
   }
   ctx->recordingOffsets[ctx->numRecording] = ctx->page.front - ctx->page.start;
+  ctx->scriptRecordingOffsets[ctx->numRecording] = ctx->script.front - ctx->script.start;
   ++ctx->numRecording;
 }
 
 char *uw_recordingRead(uw_context ctx) {
-  char *recording = ctx->page.start + ctx->recordingOffsets[--ctx->numRecording];
+  char *recording = ctx->page.start + ctx->recordingOffsets[ctx->numRecording-1];
+  return strdup(recording);
+}
+
+char *uw_recordingReadScript(uw_context ctx) {
+  char *recording = ctx->script.start + ctx->scriptRecordingOffsets[--ctx->numRecording];
   return strdup(recording);
 }
 
@@ -3814,6 +3835,34 @@ uw_Basis_string uw_Basis_checkEnvVar(uw_context ctx, uw_Basis_string s) {
     return NULL;
 }
 
+static int meta_format(const char *s) {
+  for (; *s; ++s)
+    if (!isalpha((int)*s) && *s != '-')
+      return 0;
+
+  return 1;
+}
+
+uw_Basis_string uw_Basis_blessMeta(uw_context ctx, uw_Basis_string s) {
+  if (!meta_format(s))
+    uw_error(ctx, FATAL, "Meta name \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
+
+  if (ctx->app->check_meta(s))
+    return s;
+  else
+    uw_error(ctx, FATAL, "Disallowed meta name %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkMeta(uw_context ctx, uw_Basis_string s) {
+  if (!meta_format(s))
+    return NULL;
+
+  if (ctx->app->check_meta(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);
 }
@@ -3915,9 +3964,18 @@ static char *old_headers(uw_context ctx) {
   if (uw_buffer_used(&ctx->outHeaders) == 0)
     return NULL;
   else {
-    char *s = strchr(ctx->outHeaders.start, '\n');
+    char *s;
+    int is_good;
+
+    if (strncasecmp(ctx->outHeaders.start, "Content-type: ", 14)) {
+      s = strchr(ctx->outHeaders.start, '\n');
+      is_good = !strncasecmp(s+1, "Content-type: ", 14);
+    } else {
+      s = ctx->outHeaders.start;
+      is_good = 1;
+    }
 
-    if (s == NULL || strncasecmp(s+1, "Content-type: ", 14))
+    if (!is_good)
       return NULL;
     else {
       s = strchr(s+15, '\n');
@@ -4566,6 +4624,7 @@ static void uw_Sqlcache_freeValue(uw_Sqlcache_Value *value) {
   if (value) {
     free(value->result);
     free(value->output);
+    free(value->scriptOutput);
     free(value);
   }
 }
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 2471ce59..b2c85a54 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3468,6 +3468,9 @@ fun p_file env (ds, ps) =
              makeChecker ("uw_check_envVar", Settings.getEnvVarRules ()),
              newline,
 
+             makeChecker ("uw_check_meta", Settings.getMetaRules ()),
+             newline,
+
              string "extern void uw_sign(const char *in, char *out);",
              newline,
              string "extern int uw_hash_blocksize;",
@@ -3652,7 +3655,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_check_envVar",
+                         "uw_input_num", "uw_cookie_sig", "uw_check_url", "uw_check_mime", "uw_check_requestHeader", "uw_check_responseHeader", "uw_check_envVar", "uw_check_meta",
                          case onError of NONE => "NULL" | SOME _ => "uw_onError", "my_periodics",
                          "\"" ^ Prim.toCString (Settings.getTimeFormat ()) ^ "\"",
                          if Settings.getIsHtml5 () then "1" else "0"],
diff --git a/src/compiler.sig b/src/compiler.sig
index c154240a..a4b3e562 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -55,6 +55,7 @@ signature COMPILER = sig
          filterRequest : Settings.rule list,
          filterResponse : Settings.rule list,
          filterEnv : Settings.rule list,
+         filterMeta : Settings.rule list,
          protocol : string option,
          dbms : string option,
          sigFile : string option,
diff --git a/src/compiler.sml b/src/compiler.sml
index 7580c5e4..76743fad 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -59,6 +59,7 @@ type job = {
      filterRequest : Settings.rule list,
      filterResponse : Settings.rule list,
      filterEnv : Settings.rule list,
+     filterMeta : Settings.rule list,
      protocol : string option,
      dbms : string option,
      sigFile : string option,
@@ -374,6 +375,7 @@ fun institutionalizeJob (job : job) =
      Settings.setRequestHeaderRules (#filterRequest job);
      Settings.setResponseHeaderRules (#filterResponse job);
      Settings.setEnvVarRules (#filterEnv job);
+     Settings.setMetaRules (#filterMeta job);
      Option.app Settings.setProtocol (#protocol job);
      Option.app Settings.setDbms (#dbms job);
      Settings.setSafeGets (#safeGets job);
@@ -453,6 +455,7 @@ fun parseUrp' accLibs fname =
                         filterRequest = [],
                         filterResponse = [],
                         filterEnv = [],
+                        filterMeta = [],
                         protocol = NONE,
                         dbms = NONE,
                         sigFile = NONE,
@@ -574,6 +577,7 @@ fun parseUrp' accLibs fname =
                      val request = ref []
                      val response = ref []
                      val env = ref []
+                     val meta = ref []
                      val libs = ref []
                      val protocol = ref NONE
                      val dbms = ref NONE
@@ -610,6 +614,7 @@ fun parseUrp' accLibs fname =
                                  filterRequest = rev (!request),
                                  filterResponse = rev (!response),
                                  filterEnv = rev (!env),
+                                 filterMeta = rev (!meta),
                                  sources = sources,
                                  protocol = !protocol,
                                  dbms = !dbms,
@@ -667,6 +672,7 @@ fun parseUrp' accLibs fname =
                                  filterRequest = #filterRequest old @ #filterRequest new,
                                  filterResponse = #filterResponse old @ #filterResponse new,
                                  filterEnv = #filterEnv old @ #filterEnv new,
+                                 filterMeta = #filterMeta old @ #filterMeta new,
                                  sources = #sources new
                                            @ List.filter (fn s => List.all (fn s' => s' <> s) (#sources new))
                                                          (#sources old),
@@ -710,6 +716,7 @@ fun parseUrp' accLibs fname =
                            | "requestHeader" => request
                            | "responseHeader" => response
                            | "env" => env
+                           | "meta" => meta
                            | _ => (ErrorMsg.error "Bad filter kind";
                                    url)
 
diff --git a/src/demo.sml b/src/demo.sml
index 17de80ee..0d9f0f4f 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -118,6 +118,7 @@ fun make' {prefix, dirname, guided} =
             filterRequest = #filterRequest combined @ #filterRequest urp,
             filterResponse = #filterResponse combined @ #filterResponse urp,
             filterEnv = #filterEnv combined @ #filterEnv urp,
+            filterMeta = #filterMeta combined @ #filterMeta urp,
             protocol = mergeWith #2 (#protocol combined, #protocol urp),
             dbms = mergeWith #2 (#dbms combined, #dbms urp),
             sigFile = mergeWith #2 (#sigFile combined, #sigFile urp),
@@ -318,12 +319,13 @@ fun make' {prefix, dirname, guided} =
                                                              Posix.FileSys.ST.mtime htmlSt)
                                                  end handle OS.SysErr _ => true
 
-                                             val cmd = "emacs --eval \"(progn "
+                                             val cmd = "emacs -no-init-file --eval \"(progn "
                                                        ^ "(global-font-lock-mode t) "
                                                        ^ "(add-to-list 'load-path \\\""
                                                        ^ !Settings.configSitelisp
                                                        ^ "/\\\") "
                                                        ^ "(load \\\"urweb-mode-startup\\\") "
+                                                       ^ "(load \\\"htmlize\\\") "
                                                        ^ "(urweb-mode) "
                                                        ^ "(find-file \\\""
                                                        ^ src
diff --git a/src/lru_cache.sml b/src/lru_cache.sml
index 81000458..f582bf6f 100644
--- a/src/lru_cache.sml
+++ b/src/lru_cache.sml
@@ -116,6 +116,8 @@ fun setupQuery {index, params} =
              newline,*)
              string "    uw_write(ctx, v->output);",
              newline,
+             string "    uw_write_script(ctx, v->scriptOutput);",
+             newline,
              string "    return v->result;",
              newline,
              string "  } else {",
@@ -148,6 +150,8 @@ fun setupQuery {index, params} =
              newline,
              string "  v->output = uw_recordingRead(ctx);",
              newline,
+             string "  v->scriptOutput = uw_recordingReadScript(ctx);",
+             newline,
              (*string ("  puts(\"SQLCACHE: stored " ^ i ^ ".\");"),
              newline,*)
              string ("  uw_Sqlcache_store(ctx, cache" ^ i ^ ", ks, v);"),
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 186f6c62..40b865b0 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -539,6 +539,17 @@ fun exp e =
              ESome ((TFfi ("Basis", "string"), loc), (se, loc))
          else
              ENone (TFfi ("Basis", "string"), loc))
+      | EFfiApp ("Basis", "blessMeta", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
+        (if Settings.checkMeta s then
+             ()
+         else
+             ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMeta'");
+         se)
+      | EFfiApp ("Basis", "checkMeta", [((se as EPrim (Prim.String (_, s)), loc), _)]) =>
+        (if Settings.checkMeta 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/mono_reduce.sml b/src/mono_reduce.sml
index 540d396b..5bcb6f57 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -44,6 +44,13 @@ structure SS = BinarySetFn(struct
                             val compare = String.compare
                             end)
 
+structure SLS = BinarySetFn(struct
+                             type ord_key = string list
+                             val compare = Order.joinL String.compare
+                             end)
+
+
+
 fun simpleTypeImpure tsyms =
     U.Typ.exists (fn TFun _ => true
                    | TDatatype (n, _) => IS.member (tsyms, n)
@@ -602,28 +609,35 @@ fun reduce' (file : file) =
                                 ERecord _ => true
                               | _ => false
 
+                        fun prefixFrom i (e : exp) =
+                            case #1 e of
+                                ERel i' => if i' = i then SOME [] else NONE
+                              | EField (e', s) =>
+                                (case prefixFrom i e' of
+                                     NONE => NONE
+                                   | SOME ss => SOME (ss @ [s]))
+                              | _ => NONE
+
                         fun whichProj i (e : exp) =
                             case #1 e of
-                                EPrim _ => SOME SS.empty
-                              | ERel i' => if i' = i then NONE else SOME SS.empty
-                              | ENamed _ => SOME SS.empty
-                              | ECon (_, _, NONE) => SOME SS.empty
+                                EPrim _ => SOME SLS.empty
+                              | ERel i' => if i' = i then NONE else SOME SLS.empty
+                              | ENamed _ => SOME SLS.empty
+                              | ECon (_, _, NONE) => SOME SLS.empty
                               | ECon (_, _, SOME e') => whichProj i e'
-                              | ENone _ => SOME SS.empty
+                              | ENone _ => SOME SLS.empty
                               | ESome (_, e') => whichProj i e'
-                              | EFfi _ => SOME SS.empty
+                              | EFfi _ => SOME SLS.empty
                               | EFfiApp (_, _, es) => whichProjs i (map #1 es)
                               | EApp (e1, e2) => whichProjs i [e1, e2]
                               | EAbs (_, _, _, e) => whichProj (i + 1) e
                               | EUnop (_, e1) => whichProj i e1
                               | EBinop (_, _, e1, e2) => whichProjs i [e1, e2]
                               | ERecord xets => whichProjs i (map #2 xets)
-                              | EField ((ERel i', _), s) =>
-                                if i' = i then
-                                    SOME (SS.singleton s)
-                                else
-                                    SOME SS.empty
-                              | EField (e1, _) => whichProj i e1
+                              | EField (e1, s) =>
+                                (case prefixFrom i e1 of
+                                     NONE => SOME SLS.empty
+                                   | SOME ss => SOME (SLS.singleton (ss @ [s])))
                               | ECase (e1, pes, _) =>
                                 whichProjs' i ((0, e1)
                                                :: map (fn (p, e) => (patBinds p, e)) pes)
@@ -656,12 +670,12 @@ fun reduce' (file : file) =
 
                         and whichProjs' i es =
                             case es of
-                                [] => SOME SS.empty
+                                [] => SOME SLS.empty
                               | (n, e) :: es' =>
                                 case (whichProj (i + n) e, whichProjs' i es') of
                                     (SOME m1, SOME m2) =>
-                                    if SS.isEmpty (SS.intersection (m1, m2)) then
-                                        SOME (SS.union (m1, m2))
+                                    if SLS.isEmpty (SLS.intersection (m1, m2)) then
+                                        SOME (SLS.union (m1, m2))
                                     else
                                         NONE
                                   | _ => NONE
diff --git a/src/monoize.sml b/src/monoize.sml
index 6715290f..86f2b4a5 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -234,6 +234,7 @@ fun monoType env =
                   | 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.CFfi ("Basis", "meta") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "data_attr_kind") => (L'.TFfi ("Basis", "string"), loc)
                   | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
 
@@ -2326,24 +2327,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
 
                 val body = case #1 arg1 of
                                L.CApp ((L.CFfi ("Basis", "option"), _), _) =>
-                                (L'.ECase ((L'.ERel 2, loc),
-                                           [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc),
-                                             strcat [str "((",
-                                                     (L'.ERel 1, loc),
-                                                     str " ",
-                                                     (L'.ERel 2, loc),
-                                                     str " ",
-                                                     (L'.ERel 0, loc),
-                                                     str ") OR ((",
-                                                     (L'.ERel 1, loc),
-                                                     str ") IS NULL AND (",
-                                                     (L'.ERel 0, loc),
-                                                     str ") IS NULL))"]),
-                                            ((L'.PVar ("_", s), loc),
-                                             default 1)],
-                                           {disc = s,
-                                            result = s}), loc)
-                             | _ => default 0
+                               (L'.ECase ((L'.ERel 2, loc),
+                                          [((L'.PPrim (Prim.String (Prim.Normal, "=")), loc),
+                                            if #supportsIsDistinctFrom (Settings.currentDbms ()) then
+                                                strcat [str "((",
+                                                        (L'.ERel 1, loc),
+                                                        str " IS NOT DISTINCT FROM ",
+                                                        (L'.ERel 0, loc),
+                                                        str "))"]
+                                            else
+                                                strcat [str "((",
+                                                        (L'.ERel 1, loc),
+                                                        str " ",
+                                                        (L'.ERel 2, loc),
+                                                        str " ",
+                                                        (L'.ERel 0, loc),
+                                                        str ") OR ((",
+                                                        (L'.ERel 1, loc),
+                                                        str ") IS NULL AND (",
+                                                        (L'.ERel 0, loc),
+                                                        str ") IS NULL))"]),
+                                           ((L'.PVar ("_", s), loc),
+                                            default 1)],
+                                          {disc = s,
+                                           result = s}), loc)
+                               | _ => default 0
             in
                 ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc),
                            (L'.EAbs ("e1", s, (L'.TFun (s, s), loc),
diff --git a/src/mysql.sml b/src/mysql.sml
index 692be0a2..539428f6 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -1608,6 +1608,7 @@ val () = addDbms {name = "mysql",
                   falseString = "FALSE",
                   onlyUnion = true,
                   nestedRelops = false,
-                  windowFunctions = false}
+                  windowFunctions = false,
+                  supportsIsDistinctFrom = true}
 
 end
diff --git a/src/postgres.sml b/src/postgres.sml
index 1c95f414..ddfe0ad6 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -1145,7 +1145,8 @@ val () = addDbms {name = "postgres",
                   falseString = "FALSE",
                   onlyUnion = false,
                   nestedRelops = true,
-                  windowFunctions = true}
+                  windowFunctions = true,
+                  supportsIsDistinctFrom = true}
 
 val () = setDbms "postgres"
 
diff --git a/src/settings.sig b/src/settings.sig
index c75f12a3..dd135bda 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -133,6 +133,10 @@ signature SETTINGS = sig
     val getEnvVarRules : unit -> rule list
     val checkEnvVar : string -> bool
 
+    val setMetaRules : rule list -> unit
+    val getMetaRules : unit -> rule list
+    val checkMeta : string -> bool
+
     (* Web protocols that generated programs may speak *)
     type protocol = {
         name : string,       (* Call it this on the command line *)
@@ -213,7 +217,8 @@ signature SETTINGS = sig
          falseString : string,
          onlyUnion : bool,
          nestedRelops : bool,
-         windowFunctions : bool
+         windowFunctions : bool,
+         supportsIsDistinctFrom : bool
     }
 
     val addDbms : dbms -> unit
diff --git a/src/settings.sml b/src/settings.sml
index 38ea30fc..85cab207 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -460,18 +460,21 @@ val mime = ref ([] : rule list)
 val request = ref ([] : rule list)
 val response = ref ([] : rule list)
 val env = ref ([] : rule list)
+val meta = 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 setMetaRules ls = meta := ls
 
 fun getUrlRules () = !url
 fun getMimeRules () = !mime
 fun getRequestHeaderRules () = !request
 fun getResponseHeaderRules () = !response
 fun getEnvVarRules () = !env
+fun getMetaRules () = !meta
 
 fun check f rules s =
     let
@@ -500,11 +503,13 @@ val checkUrl = check (fn _ => true) url
 
 val validMime = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"." orelse ch = #"+")
 val validEnv = CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"_" orelse ch = #".")
+val validMeta = CharVector.all (fn ch => Char.isAlpha ch orelse ch = #"-")
 
 val checkMime = check validMime mime
 val checkRequestHeader = check validMime request
 val checkResponseHeader = check validMime response
 val checkEnvVar = check validEnv env
+val checkMeta = check validMeta meta
 
 
 type protocol = {
@@ -621,7 +626,8 @@ type dbms = {
      falseString : string,
      onlyUnion : bool,
      nestedRelops : bool,
-     windowFunctions: bool
+     windowFunctions: bool,
+     supportsIsDistinctFrom : bool
 }
 
 val dbmses = ref ([] : dbms list)
@@ -653,7 +659,8 @@ val curDb = ref ({name = "",
                   falseString = "",
                   onlyUnion = false,
                   nestedRelops = false,
-                  windowFunctions = false} : dbms)
+                  windowFunctions = false,
+                  supportsIsDistinctFrom = false} : dbms)
 
 fun addDbms v = dbmses := v :: !dbmses
 fun setDbms s =
@@ -950,6 +957,7 @@ fun reset () =
      request := [];
      response := [];
      env := [];
+     meta := [];
      debug := false;
      dbstring := NONE;
      exe := NONE;
diff --git a/src/sources b/src/sources
index 8bf80bc6..1a09e7e8 100644
--- a/src/sources
+++ b/src/sources
@@ -186,9 +186,6 @@ $(SRC)/cache.sml
 $(SRC)/toy_cache.sml
 $(SRC)/lru_cache.sml
 
-$(SRC)/sqlcache.sig
-$(SRC)/sqlcache.sml
-
 $(SRC)/monoize.sig
 $(SRC)/monoize.sml
 
@@ -210,6 +207,9 @@ $(SRC)/fuse.sml
 $(SRC)/iflow.sig
 $(SRC)/iflow.sml
 
+$(SRC)/sqlcache.sig
+$(SRC)/sqlcache.sml
+
 $(SRC)/name_js.sig
 $(SRC)/name_js.sml
 
diff --git a/src/sql.sml b/src/sql.sml
index dfe2f968..409e205c 100644
--- a/src/sql.sml
+++ b/src/sql.sml
@@ -193,7 +193,7 @@ val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >=
                                         SOME (str (Char.toUpper (String.sub (s, 3)))
                                               ^ String.extract (s, 4, NONE))
                                     else
-                                        NONE)
+                                        SOME s)
 
 val field = wrap (follow (opt (follow t_ident (const ".")))
                          uw_ident)
@@ -221,6 +221,7 @@ datatype sqexp =
 fun cmp s r = wrap (const s) (fn () => RCmp r)
 
 val sqbrel = altL [cmp "=" Eq,
+                   cmp "IS NOT DISTINCT FROM" Eq,
                    cmp "<>" Ne,
                    cmp "<=" Le,
                    cmp "<" Lt,
@@ -334,11 +335,12 @@ fun sqexp chs =
     (altL [wrap (if !sqlcacheMode then primSqlcache else prim) SqConst,
            wrap (const "TRUE") (fn () => SqTrue),
            wrap (const "FALSE") (fn () => SqFalse),
+           wrap (follow (const "NULL::") ident) (fn ((), _) => Null),
            wrap (const "NULL") (fn () => Null),
-           wrap field Field,
-           wrap uw_ident Computed,
            wrap known SqKnown,
            wrap func SqFunc,
+           wrap field Field,
+           wrap uw_ident Computed,
            wrap (arithmetic sqexp) (fn _ => Unmodeled),
            wrap unmodeled (fn () => Unmodeled),
            wrap (if !sqlcacheMode then sqlifySqlcache else sqlify) Inj,
@@ -402,6 +404,11 @@ val orderby = log "orderby"
                                           (opt (ws (const "DESC"))))))
                     ignore)
 
+val groupby = log "groupby"
+                  (wrap (follow (ws (const "GROUP BY "))
+                                (list sqexp))
+                        ignore)
+
 val jtype = altL [wrap (const "JOIN") (fn () => Inner),
                   wrap (const "LEFT JOIN") (fn () => Left),
                   wrap (const "RIGHT JOIN") (fn () => Right),
@@ -444,7 +451,7 @@ and query chs = log "query"
                                                                   (follow query (const "))")))))
                                           (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2)))
                                     (wrap query1 Query1))
-                               (opt orderby))
+                               (follow (opt groupby) (opt orderby)))
                           #1)
                     chs
 
diff --git a/src/sqlcache.sml b/src/sqlcache.sml
index 75a17e48..83a264fd 100644
--- a/src/sqlcache.sml
+++ b/src/sqlcache.sml
@@ -1370,9 +1370,9 @@ fun cacheExp (env, exp', invalInfo, state : state) =
                                  (case arg of
                                       AsIs exp => SOME exp
                                     | Urlify exp =>
-                                      typOfExp env exp
+                                      (typOfExp env exp)
                                       <\obind\>
-                                       (fn typ => (MonoFooify.urlify env (exp, typ))))
+                                       (fn typ => MonoFooify.urlify env (exp, typ)))
                                  <\obind\>
                                   (fn arg' => SOME (arg' :: args'))))
                         (SOME [])
@@ -1588,18 +1588,19 @@ fun addFlushing ((file, {tableToIndices, indexToInvalInfo, ffiInfo, ...} : state
                 val inval =
                     case Sql.parse Sql.dml dmlText of
                         SOME dmlParsed =>
-                        SOME (map (fn i => (case IM.find (indexToInvalInfo, i) of
+                        SOME (map (fn i => case IM.find (indexToInvalInfo, i) of
                                                 SOME invalInfo =>
                                                 (i, invalidations (invalInfo, dmlParsed))
                                               (* TODO: fail more gracefully. *)
                                               (* This probably means invalidating everything.... *)
-                                              | NONE => raise Fail "Sqlcache: addFlushing (a)"))
+                                              | NONE => raise Fail "Sqlcache: addFlushing (a)")
                                   (SIMM.findList (tableToIndices, tableOfDml dmlParsed)))
                       | NONE => NONE
             in
                 case inval of
                     (* TODO: fail more gracefully. *)
-                    NONE => raise Fail "Sqlcache: addFlushing (b)"
+                    NONE => (Print.preface ("DML", MonoPrint.p_exp MonoEnv.empty dmlText);
+                             raise Fail "Sqlcache: addFlushing (b)")
                   | SOME invs => sequence (flushes invs @ [dmlExp])
             end
           | e' => e'
@@ -1723,8 +1724,9 @@ fun go file =
         (* Important that this happens after [MonoFooify.urlify] calls! *)
         val fmDecls = MonoFooify.getNewFmDecls ()
         val () = Sql.sqlcacheMode := false
+        val file = insertAfterDatatypes (file, rev fmDecls)
     in
-        insertAfterDatatypes (file, rev fmDecls)
+        MonoReduce.reduce file
     end
 
 end
diff --git a/src/sqlite.sml b/src/sqlite.sml
index a1095709..c7694cde 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -849,6 +849,7 @@ val () = addDbms {name = "sqlite",
                   falseString = "0",
                   onlyUnion = false,
                   nestedRelops = false,
-                  windowFunctions = false}
+                  windowFunctions = false,
+                  supportsIsDistinctFrom = true}
 
 end
diff --git a/src/urweb.grm b/src/urweb.grm
index 0f499e20..40101056 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2014, Adam Chlipala
+(* Copyright (c) 2008-2016, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -573,7 +573,7 @@ fun patternOut (e : exp) =
 %right JOIN INNER CROSS OUTER LEFT RIGHT FULL
 %right OR
 %right CAND
-%nonassoc EQ NE LT LE GT GE IS
+%nonassoc EQ NE LT LE GT GE IS LIKE
 %right ARROW
 
 %left REVAPP
@@ -1780,6 +1780,16 @@ attr   : SYMBOL EQ attrv                (case SYMBOL of
                                                                      (EApp ((EVar (["Basis"], "bless", Infer), loc),
                                                                             attrv), loc)
                                                                  end
+                                                             else if sym = "Nam"
+                                                                andalso (case #1 attrv of
+                                                                             EPrim _ => true
+                                                                           | _ => false) then
+                                                                 let
+                                                                     val loc = s (attrvleft, attrvright)
+                                                                 in
+                                                                     (EApp ((EVar (["Basis"], "blessMeta", Infer), loc),
+                                                                            attrv), loc)
+                                                                 end
                                                              else
                                                                  attrv)
                                                  end)
diff --git a/src/urweb.lex b/src/urweb.lex
index ca45eb6d..368b9f1b 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -224,6 +224,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
 <STRING,CHAR> "\\\""  => (str := #"\"" :: !str; continue());
 <STRING,CHAR> "\\'"   => (str := #"'" :: !str; continue());
 <STRING,CHAR> "\\n"   => (str := #"\n" :: !str; continue());
+<STRING,CHAR> "\\r"   => (str := #"\r" :: !str; continue());
 <STRING,CHAR> "\\\\"  => (str := #"\\" :: !str; continue());
 <STRING,CHAR> "\\t"   => (str := #"\t" :: !str; continue());
 <STRING,CHAR> "\n"    => (newline yypos;
diff --git a/tests/contentDisposition.ur b/tests/contentDisposition.ur
new file mode 100644
index 00000000..8fe2b26c
--- /dev/null
+++ b/tests/contentDisposition.ur
@@ -0,0 +1,4 @@
+fun main () : transaction page =
+    setHeader (blessResponseHeader "Content-Disposition")
+              ("attachment; filename=test.txt");
+    returnBlob (textBlob "Hi there!") (blessMime "text/plain")
diff --git a/tests/contentDisposition.urp b/tests/contentDisposition.urp
new file mode 100644
index 00000000..92b02871
--- /dev/null
+++ b/tests/contentDisposition.urp
@@ -0,0 +1,5 @@
+rewrite all ContentDisposition/*
+allow responseHeader Content-Disposition
+allow mime text/plain
+
+contentDisposition
\ No newline at end of file
diff --git a/tests/formLimit.ur b/tests/formLimit.ur
new file mode 100644
index 00000000..d591f736
--- /dev/null
+++ b/tests/formLimit.ur
@@ -0,0 +1,11 @@
+fun handler r = return <xml><body>
+  {[r.A]}, {[r.B]}
+</body></xml>
+
+fun main () = return <xml><body>
+  <form>
+    <textbox{#A}/>
+    <textbox{#B}/>
+    <submit action={handler}/>
+  </form>
+</body></xml>
diff --git a/tests/formLimit.urp b/tests/formLimit.urp
new file mode 100644
index 00000000..3fd7e5c3
--- /dev/null
+++ b/tests/formLimit.urp
@@ -0,0 +1,4 @@
+rewrite all FormLimit/*
+limit inputs 1
+
+formLimit
diff --git a/tests/formLimit.urs b/tests/formLimit.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/formLimit.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
diff --git a/tests/groupBy.ur b/tests/groupBy.ur
new file mode 100644
index 00000000..e91e33cc
--- /dev/null
+++ b/tests/groupBy.ur
@@ -0,0 +1,3 @@
+val main : transaction page = return <xml><body>
+  {[List.groupBy eq (1 :: 1 :: 2 :: 2 :: 3 :: 4 :: 4 :: 4 :: 5 :: [])]}
+</body></xml>
diff --git a/tests/groupBy.urp b/tests/groupBy.urp
new file mode 100644
index 00000000..de1db792
--- /dev/null
+++ b/tests/groupBy.urp
@@ -0,0 +1,4 @@
+rewrite all GroupBy/*
+
+$/list
+groupBy
diff --git a/tests/meta.ur b/tests/meta.ur
new file mode 100644
index 00000000..f8d12183
--- /dev/null
+++ b/tests/meta.ur
@@ -0,0 +1,48 @@
+fun main () : transaction page =
+    let
+        fun handler r = return <xml>
+          <head>
+            <meta name={blessMeta r.Nam} content={r.Content}/>
+            <title>Testing &lt;meta> tags</title>
+          </head>
+          <body>
+            <p>Did it work?</p>
+          </body>
+        </xml>
+
+        fun handler2 r =
+            case checkMeta r.Nam of
+                None => error <xml>Oh, that name won't do at all.</xml>
+              | Some name =>
+                return <xml>
+                  <head>
+                    <meta name={name} content={r.Content}/>
+                    <title>Testing &lt;meta> tags</title>
+                  </head>
+                  <body>
+                    <p>Did it work?</p>
+                  </body>
+                </xml>
+    in
+        return <xml>
+          <head>
+            <meta name="viewport" content="width=device-width, initial-scale=1.0"/>
+            <title>Testing &lt;meta> tags</title>
+          </head>
+          <body>
+            <p>Did it work?</p>
+
+            <form>
+              Name: <textbox{#Nam}/><br/>
+              Content: <textbox{#Content}/><br/>
+              <submit action={handler}/>
+            </form>
+
+            <form>
+              Name: <textbox{#Nam}/><br/>
+              Content: <textbox{#Content}/><br/>
+              <submit action={handler2}/>
+            </form>
+          </body>
+        </xml>
+    end
diff --git a/tests/meta.urp b/tests/meta.urp
new file mode 100644
index 00000000..95ede782
--- /dev/null
+++ b/tests/meta.urp
@@ -0,0 +1,4 @@
+rewrite all Meta/*
+allow meta viewport
+
+meta