allow/deny working in Mono_opt

7 files changed, 95 insertions, 13 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 048ca39f..276cb4f2 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -47,7 +47,9 @@ signature COMPILER = sig
          clientOnly : Settings.ffi list,
          serverOnly : Settings.ffi list,
          jsFuncs : (Settings.ffi * string) list,
-         rewrites : Settings.rewrite list
+         rewrites : Settings.rewrite list,
+         filterUrl : Settings.rule list,
+         filterMime : Settings.rule list
     }
     val compile : string -> unit
     val compileC : {cname : string, oname : string, ename : string, libs : string,
diff --git a/src/compiler.sml b/src/compiler.sml
index 5a0a148a..66e8eda2 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -51,7 +51,9 @@ type job = {
      clientOnly : Settings.ffi list,
      serverOnly : Settings.ffi list,
      jsFuncs : (Settings.ffi * string) list,
-     rewrites : Settings.rewrite list
+     rewrites : Settings.rewrite list,
+     filterUrl : Settings.rule list,
+     filterMime : Settings.rule list
 }
 
 type ('src, 'dst) phase = {
@@ -314,6 +316,8 @@ fun parseUrp' filename =
         val serverOnly = ref []
         val jsFuncs = ref []
         val rewrites = ref []
+        val url = ref []
+        val mime = ref []
         val libs = ref []
 
         fun finish sources =
@@ -337,6 +341,8 @@ fun parseUrp' filename =
                     serverOnly = rev (!serverOnly),
                     jsFuncs = rev (!jsFuncs),
                     rewrites = rev (!rewrites),
+                    filterUrl = rev (!url),
+                    filterMime = rev (!mime),
                     sources = sources
                 }
 
@@ -372,6 +378,8 @@ fun parseUrp' filename =
                     serverOnly = #serverOnly old @ #serverOnly new,
                     jsFuncs = #jsFuncs old @ #jsFuncs new,
                     rewrites = #rewrites old @ #rewrites new,
+                    filterUrl = #filterUrl old @ #filterUrl new,
+                    filterMime = #filterMime old @ #filterMime new,
                     sources = #sources old @ #sources new
                 }
             in
@@ -397,6 +405,19 @@ fun parseUrp' filename =
             else
                 (Settings.Exact, s)
 
+        fun parseFkind s =
+            case s of
+                "url" => url
+              | "mime" => mime
+              | _ => (ErrorMsg.error "Bad filter kind";
+                      url)
+
+        fun parsePattern s =
+            if size s > 0 andalso String.sub (s, size s - 1) = #"*" then
+                (Settings.Prefix, String.substring (s, 0, size s - 1))
+            else
+                (Settings.Exact, s)
+
         fun read () =
             case TextIO.inputLine inf of
                 NONE => finish []
@@ -475,6 +496,26 @@ fun parseUrp' filename =
                               | [pkind, from] => doit (pkind, from, "")
                               | _ => ErrorMsg.error "Bad 'rewrite' syntax"
                         end
+                      | "allow" =>
+                        (case String.tokens Char.isSpace arg of
+                             [fkind, pattern] =>
+                             let
+                                 val fkind = parseFkind fkind
+                                 val (kind, pattern) = parsePattern pattern
+                             in
+                                 fkind := {action = Settings.Allow, kind = kind, pattern = pattern} :: !fkind
+                             end
+                           | _ => ErrorMsg.error "Bad 'allow' syntax")
+                      | "deny" =>
+                        (case String.tokens Char.isSpace arg of
+                             [fkind, pattern] =>
+                             let
+                                 val fkind = parseFkind fkind
+                                 val (kind, pattern) = parsePattern pattern
+                             in
+                                 fkind := {action = Settings.Deny, kind = kind, pattern = pattern} :: !fkind
+                             end
+                           | _ => ErrorMsg.error "Bad 'deny' syntax")
                       | "library" => libs := relify arg :: !libs
                       | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
                     read ()
@@ -493,6 +534,8 @@ fun parseUrp' filename =
         Settings.setServerOnly (#serverOnly job);
         Settings.setJsFuncs (#jsFuncs job);
         Settings.setRewriteRules (#rewrites job);
+        Settings.setUrlRules (#filterUrl job);
+        Settings.setMimeRules (#filterMime job);
         job
     end
 
diff --git a/src/demo.sml b/src/demo.sml
index c08ce0fe..dc4715d7 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -104,7 +104,9 @@ fun make {prefix, dirname, guided} =
             clientOnly = [],
             serverOnly = [],
             jsFuncs = [],
-            rewrites = []
+            rewrites = [],
+            filterUrl = #filterUrl combined @ #filterUrl urp,
+            filterMime = #filterMime combined @ #filterMime urp
         }
 
         val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/mono_opt.sig b/src/mono_opt.sig
index 905dc53b..d0268087 100644
--- a/src/mono_opt.sig
+++ b/src/mono_opt.sig
@@ -30,7 +30,4 @@ signature MONO_OPT = sig
     val optimize : Mono.file -> Mono.file
     val optExp : Mono.exp -> Mono.exp
 
-    val bless : (string -> bool) ref
-    val blessMime : (string -> bool) ref
-
 end
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 41724eb0..fefe24e1 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -30,9 +30,6 @@ structure MonoOpt :> MONO_OPT = struct
 open Mono
 structure U = MonoUtil
 
-val bless = ref (fn _ : string => true)
-val blessMime = ref (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"-" orelse ch = #"/" orelse ch = #"."))
-
 fun typ t = t
 fun decl d = d
 
@@ -382,16 +379,16 @@ fun exp e =
       | EJavaScript (_, _, SOME (e, _)) => e
 
       | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
-        (if !bless s then
+        (if Settings.checkUrl s then
              ()
          else
-             ErrorMsg.errorAt loc "Invalid URL passed to 'bless'";
+             ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
          se)
       | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
-        (if !blessMime s then
+        (if Settings.checkMime s then
              ()
          else
-             ErrorMsg.errorAt loc "Invalid string passed to 'blessMime'";
+             ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
          se)
 
       | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) => 
diff --git a/src/settings.sig b/src/settings.sig
index e5dd20d8..f750c14a 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -76,4 +76,11 @@ signature SETTINGS = sig
     val setRewriteRules : rewrite list -> unit
     val rewrite : path_kind -> string -> string
 
+    (* Validating URLs and MIME types *)
+    val setUrlRules : rule list -> unit
+    val checkUrl : string -> bool
+
+    val setMimeRules : rule list -> unit
+    val checkMime : string -> bool
+
 end
diff --git a/src/settings.sml b/src/settings.sml
index 5e97f44b..e7020615 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -191,4 +191,38 @@ fun rewrite pk s =
         rew (!rewrites)
     end
 
+val url = ref ([] : rule list)
+val mime = ref ([] : rule list)
+
+fun setUrlRules ls = url := ls
+fun setMimeRules ls = mime := ls
+
+fun check f rules s =
+    let
+        fun chk (ls : rule list) =
+            case ls of
+                [] => false
+              | rule :: ls =>
+                let
+                    val matches =
+                        case #kind rule of
+                            Exact => #pattern rule = s
+                          | Prefix => String.isPrefix (#pattern rule) s
+                in
+                    if matches then
+                        case #action rule of
+                            Allow => true
+                          | Deny => false
+                    else
+                        chk ls
+                end
+    in
+        f s andalso chk (!rules)
+    end
+
+val checkUrl = check (fn _ => true) url
+val checkMime = check
+                    (CharVector.all (fn ch => Char.isAlphaNum ch orelse ch = #"/" orelse ch = #"-" orelse ch = #"."))
+                    mime
+
 end