Mercurial > urweb
changeset 769:efceae06df17
allow/deny working in Mono_opt
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 02 May 2009 13:37:52 -0400 |
| parents | 3b7e46790fa7 |
| children | c125df6fabfc |
| files | src/compiler.sig src/compiler.sml src/demo.sml src/mono_opt.sig src/mono_opt.sml src/settings.sig src/settings.sml tests/url.urp |
| diffstat | 8 files changed, 96 insertions(+), 13 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sig Sat May 02 13:23:07 2009 -0400 +++ b/src/compiler.sig Sat May 02 13:37:52 2009 -0400 @@ -47,7 +47,9 @@ 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,
--- a/src/compiler.sml Sat May 02 13:23:07 2009 -0400 +++ b/src/compiler.sml Sat May 02 13:37:52 2009 -0400 @@ -51,7 +51,9 @@ 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 @@ 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 @@ serverOnly = rev (!serverOnly), jsFuncs = rev (!jsFuncs), rewrites = rev (!rewrites), + filterUrl = rev (!url), + filterMime = rev (!mime), sources = sources } @@ -372,6 +378,8 @@ 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 @@ 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 @@ | [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 @@ Settings.setServerOnly (#serverOnly job); Settings.setJsFuncs (#jsFuncs job); Settings.setRewriteRules (#rewrites job); + Settings.setUrlRules (#filterUrl job); + Settings.setMimeRules (#filterMime job); job end
--- a/src/demo.sml Sat May 02 13:23:07 2009 -0400 +++ b/src/demo.sml Sat May 02 13:37:52 2009 -0400 @@ -104,7 +104,9 @@ 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")
--- a/src/mono_opt.sig Sat May 02 13:23:07 2009 -0400 +++ b/src/mono_opt.sig Sat May 02 13:37:52 2009 -0400 @@ -30,7 +30,4 @@ val optimize : Mono.file -> Mono.file val optExp : Mono.exp -> Mono.exp - val bless : (string -> bool) ref - val blessMime : (string -> bool) ref - end
--- a/src/mono_opt.sml Sat May 02 13:23:07 2009 -0400 +++ b/src/mono_opt.sml Sat May 02 13:37:52 2009 -0400 @@ -30,9 +30,6 @@ 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 @@ | 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)]) =>
--- a/src/settings.sig Sat May 02 13:23:07 2009 -0400 +++ b/src/settings.sig Sat May 02 13:37:52 2009 -0400 @@ -76,4 +76,11 @@ 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
--- a/src/settings.sml Sat May 02 13:23:07 2009 -0400 +++ b/src/settings.sml Sat May 02 13:37:52 2009 -0400 @@ -191,4 +191,38 @@ 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