Support for <meta> tags

10 files changed, 74 insertions, 2 deletions

diff --git a/src/c/urweb.c b/src/c/urweb.c
index 7e535122..c23366fb 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -3835,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);
 }
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 2ff76ad1..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),
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/monoize.sml b/src/monoize.sml
index 6979474e..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)
 
diff --git a/src/settings.sig b/src/settings.sig
index 5b54ed44..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 *)
diff --git a/src/settings.sml b/src/settings.sml
index d689824e..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 = {
@@ -952,6 +957,7 @@ fun reset () =
      request := [];
      response := [];
      env := [];
+     meta := [];
      debug := false;
      dbstring := NONE;
      exe := NONE;
diff --git a/src/urweb.grm b/src/urweb.grm
index 968a3c44..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
@@ -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)