Runtime URL and MIME type filtering

9 files changed, 89 insertions, 14 deletions

diff --git a/CHANGELOG b/CHANGELOG
index 49a009b6..8df1b3b8 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -4,7 +4,7 @@ Next
 
 - Reimplement constructor class resolution to be more general and Prolog-like
 - SQL table constraints
-- URLs, with configurable gatekeeper function Basis.bless
+- URLs
 - Client-side error handling callbacks
 - CSS
 - Signing cookie values cryptographically to thwart cross site request forgery
diff --git a/include/urweb.h b/include/urweb.h
index 27ab799f..d2fa30da 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -169,6 +169,9 @@ uw_Basis_client uw_Basis_self(uw_context, uw_unit);
 uw_Basis_string uw_Basis_bless(uw_context, uw_Basis_string);
 uw_Basis_string uw_Basis_blessMime(uw_context, uw_Basis_string);
 
+uw_Basis_string uw_Basis_checkUrl(uw_context, uw_Basis_string);
+uw_Basis_string uw_Basis_checkMime(uw_context, uw_Basis_string);
+
 uw_Basis_string uw_unnull(uw_Basis_string);
 uw_Basis_string uw_Basis_makeSigString(uw_context, uw_Basis_string);
 uw_Basis_string uw_Basis_sigString(uw_context, uw_unit);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index e5175a08..25ad2786 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -514,6 +514,7 @@ con tr = [Body, Tr]
 
 type url
 val bless : string -> url
+val checkUrl : string -> option url
 
 val dyn : use ::: {Type} -> bind ::: {Type} -> unit
           -> tag [Signal = signal (xml body use bind)] body [] use bind
@@ -600,6 +601,7 @@ val upload : formTag file [] [Value = string, Size = int]
 
 type mimeType
 val blessMime : string -> mimeType
+val checkMime : string -> option mimeType
 val returnBlob : t ::: Type -> blob -> mimeType -> transaction t
 val blobSize : blob -> int
 
diff --git a/src/c/urweb.c b/src/c/urweb.c
index cc02b3d1..1f256681 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -2437,18 +2437,49 @@ failure_kind uw_initialize(uw_context ctx) {
   return r;
 }
 
+extern int uw_check_url(const char *);
+extern int uw_check_mime(const char *);
+
 uw_Basis_string uw_Basis_bless(uw_context ctx, uw_Basis_string s) {
-  return s;
+  if (uw_check_url(s))
+    return s;
+  else
+    uw_error(ctx, FATAL, "Disallowed URL %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkUrl(uw_context ctx, uw_Basis_string s) {
+  if (uw_check_url(s))
+    return s;
+  else
+    return NULL;
+}
+
+int mime_format(const char *s) {
+  for (; *s; ++s)
+    if (!isalnum(*s) && *s != '/' && *s != '-' && *s != '.')
+      return 0;
+
+  return 1;
 }
 
 uw_Basis_string uw_Basis_blessMime(uw_context ctx, uw_Basis_string s) {
-  char *s2;
+  if (!mime_format(s))
+    uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, s));
 
-  for (s2 = s; *s2; ++s2)
-    if (!isalnum(*s2) && *s2 != '/' && *s2 != '-' && *s2 != '.')
-      uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character %c\n", s, *s2);
-  
-  return s;
+  if (uw_check_mime(s))
+    return s;
+  else
+    uw_error(ctx, FATAL, "Disallowed MIME type %s", uw_Basis_htmlifyString(ctx, s));
+}
+
+uw_Basis_string uw_Basis_checkMime(uw_context ctx, uw_Basis_string s) {
+  if (!mime_format(s))
+    return NULL;
+
+  if (uw_check_mime(s))
+    return s;
+  else
+    return NULL;
 }
 
 uw_Basis_string uw_unnull(uw_Basis_string s) {
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 3a124ff4..cb92588d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3176,6 +3176,34 @@ fun p_file env (ds, ps) =
                                                               acc,
                                                               string "))"]))
                          NONE cookies
+
+        fun makeChecker (name, rules : Settings.rule list) =
+            box [string "int ",
+                 string name,
+                 string "(const char *s) {",
+                 newline,
+                 box [p_list_sep (box [])
+                      (fn rule =>
+                          box [string "if (!str",
+                               case #kind rule of
+                                   Settings.Exact => box [string "cmp(s, \"",
+                                                          string (String.toString (#pattern rule)),
+                                                          string "\"))"]
+                                 | Settings.Prefix => box [string "ncmp(s, \"",
+                                                           string (String.toString (#pattern rule)),
+                                                           string "\", ",
+                                                           string (Int.toString (size (#pattern rule))),
+                                                           string "))"],
+                               string " return ",
+                               string (case #action rule of
+                                           Settings.Allow => "1"
+                                         | Settings.Deny => "0"),
+                               string ";",
+                               newline]) rules,
+                      string "return 0;",
+                      newline],
+                 string "}",
+                 newline]
     in
         box [string "#include <stdio.h>",
              newline,
@@ -3218,6 +3246,12 @@ fun p_file env (ds, ps) =
              string "}",
              newline,
              newline,
+
+             makeChecker ("uw_check_url", Settings.getUrlRules ()),
+             newline,
+
+             makeChecker ("uw_check_mime", Settings.getMimeRules ()),
+             newline,
              
              string "extern void uw_sign(const char *in, char *out);",
              newline,
diff --git a/src/settings.sig b/src/settings.sig
index f750c14a..dd812ac4 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -78,9 +78,11 @@ signature SETTINGS = sig
 
     (* Validating URLs and MIME types *)
     val setUrlRules : rule list -> unit
+    val getUrlRules : unit -> rule list
     val checkUrl : string -> bool
 
     val setMimeRules : rule list -> unit
+    val getMimeRules : unit -> rule list
     val checkMime : string -> bool
 
 end
diff --git a/src/settings.sml b/src/settings.sml
index e7020615..24971eff 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -197,6 +197,9 @@ val mime = ref ([] : rule list)
 fun setUrlRules ls = url := ls
 fun setMimeRules ls = mime := ls
 
+fun getUrlRules () = !url
+fun getMimeRules () = !mime
+
 fun check f rules s =
     let
         fun chk (ls : rule list) =
diff --git a/tests/url.ur b/tests/url.ur
index c45681e0..ea236502 100644
--- a/tests/url.ur
+++ b/tests/url.ur
@@ -1,12 +1,11 @@
-val url = "http://www.yahoo.com/"
-
 fun readersChoice r = return <xml><body>
-  <a href={bless r.Url}>Your pick, boss</a>
+  {case checkUrl r.Url of
+       None => <xml>I can't do that, Dave.</xml>
+     | Some url => <xml><a href={url}>Your pick, boss</a></xml>}
 </body></xml>
 
 fun main () : transaction page = return <xml><body>
-  <a href="http://www.google.com/">Google!</a>
-  <a href={bless url}>Yahoo!</a><br/>
+  <a href="http://en.wikipedia.org/wiki/Wikipedia:About">Learn</a>
   <br/>
 
   <form><textbox{#Url}/> <submit action={readersChoice}/></form>
diff --git a/tests/url.urp b/tests/url.urp
index ab5ec1b7..aaa84900 100644
--- a/tests/url.urp
+++ b/tests/url.urp
@@ -1,4 +1,5 @@
 debug
-allow url http://*
+deny url http://en.wikipedia.org/wiki/Perl
+allow url http://en.wikipedia.org/*
 
 url