summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2016-05-15 09:47:49 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2016-05-15 09:47:49 -0400
commitd6453242560cfeaa31e74b2c77423b4ada288ac6 (patch)
tree1f28ac4db0a476a21e4234c38e19eb8ae8edf666
parenta0686c30f1315a6ca8c10acfca386df468f172a8 (diff)
Support for <meta> tags
-rw-r--r--doc/manual.tex11
-rw-r--r--include/urweb/types_cpp.h1
-rw-r--r--include/urweb/urweb_cpp.h2
-rw-r--r--lib/ur/basis.urs5
-rw-r--r--src/c/urweb.c28
-rw-r--r--src/cjr_print.sml5
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml7
-rw-r--r--src/demo.sml1
-rw-r--r--src/mono_opt.sml11
-rw-r--r--src/monoize.sml1
-rw-r--r--src/settings.sig4
-rw-r--r--src/settings.sml6
-rw-r--r--src/urweb.grm12
-rw-r--r--tests/meta.ur48
-rw-r--r--tests/meta.urp4
16 files changed, 144 insertions, 3 deletions
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 7eb976d4..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 *);
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index feebdef3..5b6c6221 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -239,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 d98134ff..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 *)
@@ -814,6 +818,7 @@ 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, Integrity = string, Crossorigin = string] head [] [] []
+val meta : unit -> tag [Nam = meta, Content = string, Id = id] head [] [] []
datatype mouseButton = Left | Right | Middle
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)
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