changeset 770:c125df6fabfc

Runtime URL and MIME type filtering
author Adam Chlipala <adamc@hcoop.net>
date Sat, 02 May 2009 18:20:15 -0400
parents efceae06df17
children eac1974924bb
files CHANGELOG include/urweb.h lib/ur/basis.urs src/c/urweb.c src/cjr_print.sml src/settings.sig src/settings.sml tests/url.ur tests/url.urp
diffstat 9 files changed, 90 insertions(+), 15 deletions(-) [+]
line wrap: on
line diff
--- a/CHANGELOG	Sat May 02 13:37:52 2009 -0400
+++ b/CHANGELOG	Sat May 02 18:20:15 2009 -0400
@@ -4,7 +4,7 @@
 
 - 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
--- a/include/urweb.h	Sat May 02 13:37:52 2009 -0400
+++ b/include/urweb.h	Sat May 02 18:20:15 2009 -0400
@@ -169,6 +169,9 @@
 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);
--- a/lib/ur/basis.urs	Sat May 02 13:37:52 2009 -0400
+++ b/lib/ur/basis.urs	Sat May 02 18:20:15 2009 -0400
@@ -514,6 +514,7 @@
 
 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 @@
 
 type mimeType
 val blessMime : string -> mimeType
+val checkMime : string -> option mimeType
 val returnBlob : t ::: Type -> blob -> mimeType -> transaction t
 val blobSize : blob -> int
 
--- a/src/c/urweb.c	Sat May 02 13:37:52 2009 -0400
+++ b/src/c/urweb.c	Sat May 02 18:20:15 2009 -0400
@@ -2437,18 +2437,49 @@
   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;
-
-  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 (!mime_format(s))
+    uw_error(ctx, FATAL, "MIME type \"%s\" contains invalid character", uw_Basis_htmlifyString(ctx, 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) {
--- a/src/cjr_print.sml	Sat May 02 13:37:52 2009 -0400
+++ b/src/cjr_print.sml	Sat May 02 18:20:15 2009 -0400
@@ -3176,6 +3176,34 @@
                                                               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 @@
              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,
--- a/src/settings.sig	Sat May 02 13:37:52 2009 -0400
+++ b/src/settings.sig	Sat May 02 18:20:15 2009 -0400
@@ -78,9 +78,11 @@
 
     (* 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
--- a/src/settings.sml	Sat May 02 13:37:52 2009 -0400
+++ b/src/settings.sml	Sat May 02 18:20:15 2009 -0400
@@ -197,6 +197,9 @@
 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) =
--- a/tests/url.ur	Sat May 02 13:37:52 2009 -0400
+++ b/tests/url.ur	Sat May 02 18:20:15 2009 -0400
@@ -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>
--- a/tests/url.urp	Sat May 02 13:37:52 2009 -0400
+++ b/tests/url.urp	Sat May 02 18:20:15 2009 -0400
@@ -1,4 +1,5 @@
 debug
-allow url http://*
+deny url http://en.wikipedia.org/wiki/Perl
+allow url http://en.wikipedia.org/*
 
 url