From 231c4bfd8d410f01f98801dff7a159068c552c64 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 2 May 2009 13:37:52 -0400 Subject: allow/deny working in Mono_opt --- src/compiler.sig | 4 +++- src/compiler.sml | 45 ++++++++++++++++++++++++++++++++++++++++++++- src/demo.sml | 4 +++- src/mono_opt.sig | 3 --- src/mono_opt.sml | 11 ++++------- src/settings.sig | 7 +++++++ src/settings.sml | 34 ++++++++++++++++++++++++++++++++++ 7 files changed, 95 insertions(+), 13 deletions(-) (limited to 'src') 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 -- cgit v1.2.3