Mercurial > urweb
changeset 768:3b7e46790fa7
Path rewriting
author | Adam Chlipala <adamc@hcoop.net> |
---|---|
date | Sat, 02 May 2009 13:23:07 -0400 (2009-05-02) |
parents | d27ed5ddeb52 |
children | efceae06df17 |
files | CHANGELOG src/compiler.sig src/compiler.sml src/corify.sig src/corify.sml src/demo.sml src/settings.sig src/settings.sml tests/rewrite.ur tests/rewrite.urp tests/rewrite.urs |
diffstat | 11 files changed, 131 insertions(+), 20 deletions(-) [+] |
line wrap: on
line diff
--- a/CHANGELOG Sat May 02 12:50:52 2009 -0400 +++ b/CHANGELOG Sat May 02 13:23:07 2009 -0400 @@ -12,6 +12,8 @@ - SQL outer joins - SQL views - Subforms +- C and JavaScript FFI +- Path rewriting ======== 20090405
--- a/src/compiler.sig Sat May 02 12:50:52 2009 -0400 +++ b/src/compiler.sig Sat May 02 13:23:07 2009 -0400 @@ -46,7 +46,8 @@ effectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, - jsFuncs : (Settings.ffi * string) list + jsFuncs : (Settings.ffi * string) list, + rewrites : Settings.rewrite list } val compile : string -> unit val compileC : {cname : string, oname : string, ename : string, libs : string,
--- a/src/compiler.sml Sat May 02 12:50:52 2009 -0400 +++ b/src/compiler.sml Sat May 02 13:23:07 2009 -0400 @@ -50,7 +50,8 @@ effectful : Settings.ffi list, clientOnly : Settings.ffi list, serverOnly : Settings.ffi list, - jsFuncs : (Settings.ffi * string) list + jsFuncs : (Settings.ffi * string) list, + rewrites : Settings.rewrite list } type ('src, 'dst) phase = { @@ -208,9 +209,9 @@ handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job {prefix, database, exe, sql, sources, debug, profile, - timeout, ffi, link, headers, scripts, - clientToServer, effectful, clientOnly, serverOnly, jsFuncs} = +fun p_job ({prefix, database, exe, sql, sources, debug, profile, + timeout, ffi, link, headers, scripts, + clientToServer, effectful, clientOnly, serverOnly, jsFuncs, ...} : job) = let open Print.PD open Print @@ -312,6 +313,7 @@ val clientOnly = ref [] val serverOnly = ref [] val jsFuncs = ref [] + val rewrites = ref [] val libs = ref [] fun finish sources = @@ -334,6 +336,7 @@ clientOnly = rev (!clientOnly), serverOnly = rev (!serverOnly), jsFuncs = rev (!jsFuncs), + rewrites = rev (!rewrites), sources = sources } @@ -368,12 +371,32 @@ clientOnly = #clientOnly old @ #clientOnly new, serverOnly = #serverOnly old @ #serverOnly new, jsFuncs = #jsFuncs old @ #jsFuncs new, + rewrites = #rewrites old @ #rewrites new, sources = #sources old @ #sources new } in foldr (fn (fname, job) => merge (job, parseUrp' fname)) job (!libs) end + fun parsePkind s = + case s of + "all" => Settings.Any + | "url" => Settings.Url + | "table" => Settings.Table + | "sequence" => Settings.Sequence + | "view" => Settings.View + | "relation" => Settings.Relation + | "cookie" => Settings.Cookie + | "style" => Settings.Style + | _ => (ErrorMsg.error "Bad path kind spec"; + Settings.Any) + + fun parseFrom s = + if size s > 1 andalso String.sub (s, size s - 2) = #"/" 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 [] @@ -437,6 +460,21 @@ | "clientOnly" => clientOnly := ffiS () :: !clientOnly | "serverOnly" => serverOnly := ffiS () :: !serverOnly | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs + | "rewrite" => + let + fun doit (pkind, from, to) = + let + val pkind = parsePkind pkind + val (kind, from) = parseFrom from + in + rewrites := {pkind = pkind, kind = kind, from = from, to = to} :: !rewrites + end + in + case String.tokens Char.isSpace arg of + [pkind, from, to] => doit (pkind, from, to) + | [pkind, from] => doit (pkind, from, "") + | _ => ErrorMsg.error "Bad 'rewrite' syntax" + end | "library" => libs := relify arg :: !libs | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () @@ -454,6 +492,7 @@ Settings.setClientOnly (#clientOnly job); Settings.setServerOnly (#serverOnly job); Settings.setJsFuncs (#jsFuncs job); + Settings.setRewriteRules (#rewrites job); job end
--- a/src/corify.sig Sat May 02 12:50:52 2009 -0400 +++ b/src/corify.sig Sat May 02 13:23:07 2009 -0400 @@ -27,9 +27,6 @@ signature CORIFY = sig - val restify : (string -> string) ref - (** Consulted to determine how to rewrite persistent paths *) - val corify : Expl.file -> Core.file end
--- a/src/corify.sml Sat May 02 12:50:52 2009 -0400 +++ b/src/corify.sml Sat May 02 13:23:07 2009 -0400 @@ -37,16 +37,14 @@ val compare = String.compare end) -val restify = ref (fn s : string => s) - -fun doRestify (mods, s) = +fun doRestify k (mods, s) = let val s = if String.isPrefix "wrap_" s then String.extract (s, 5, NONE) else s in - !restify (String.concatWith "/" (rev (s :: mods))) + Settings.rewrite k (String.concatWith "/" (rev (s :: mods))) end val relify = CharVector.map (fn #"/" => #"_" @@ -702,7 +700,7 @@ | L.DVal (x, n, t, e) => let val (st, n) = St.bindVal st x n - val s = doRestify (mods, x) + val s = doRestify Settings.Url (mods, x) in ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st) end @@ -720,7 +718,7 @@ val vis = map (fn (x, n, t, e) => let - val s = doRestify (mods, x) + val s = doRestify Settings.Url (mods, x) in (x, n, corifyCon st t, corifyExp st e, s) end) @@ -982,7 +980,7 @@ | L.DTable (_, x, n, c, pe, pc, ce, cc) => let val (st, n) = St.bindVal st x n - val s = relify (doRestify (mods, x)) + val s = relify (doRestify Settings.Table (mods, x)) in ([(L'.DTable (x, n, corifyCon st c, s, corifyExp st pe, corifyCon st pc, @@ -991,14 +989,14 @@ | L.DSequence (_, x, n) => let val (st, n) = St.bindVal st x n - val s = relify (doRestify (mods, x)) + val s = relify (doRestify Settings.Sequence (mods, x)) in ([(L'.DSequence (x, n, s), loc)], st) end | L.DView (_, x, n, e, c) => let val (st, n) = St.bindVal st x n - val s = relify (doRestify (mods, x)) + val s = relify (doRestify Settings.View (mods, x)) in ([(L'.DView (x, n, s, corifyExp st e, corifyCon st c), loc)], st) end @@ -1008,14 +1006,14 @@ | L.DCookie (_, x, n, c) => let val (st, n) = St.bindVal st x n - val s = doRestify (mods, x) + val s = doRestify Settings.Cookie (mods, x) in ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) end | L.DStyle (_, x, n) => let val (st, n) = St.bindVal st x n - val s = relify (doRestify (mods, x)) + val s = relify (doRestify Settings.Style (mods, x)) in ([(L'.DStyle (x, n, s), loc)], st) end
--- a/src/demo.sml Sat May 02 12:50:52 2009 -0400 +++ b/src/demo.sml Sat May 02 13:23:07 2009 -0400 @@ -103,7 +103,8 @@ effectful = [], clientOnly = [], serverOnly = [], - jsFuncs = [] + jsFuncs = [], + rewrites = [] } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
--- a/src/settings.sig Sat May 02 12:50:52 2009 -0400 +++ b/src/settings.sig Sat May 02 13:23:07 2009 -0400 @@ -65,4 +65,15 @@ val setJsFuncs : (ffi * string) list -> unit val jsFunc : ffi -> string option + datatype pattern_kind = Exact | Prefix + datatype action = Allow | Deny + type rule = { action : action, kind : pattern_kind, pattern : string } + + datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style + type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string } + + (* Rules for rewriting URLs from canonical forms *) + val setRewriteRules : rewrite list -> unit + val rewrite : path_kind -> string -> string + end
--- a/src/settings.sml Sat May 02 12:50:52 2009 -0400 +++ b/src/settings.sml Sat May 02 13:23:07 2009 -0400 @@ -147,4 +147,48 @@ fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls fun jsFunc x = M.find (!jsFuncs, x) +datatype pattern_kind = Exact | Prefix +datatype action = Allow | Deny +type rule = { action : action, kind : pattern_kind, pattern : string } + +datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style +type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string } + +val rewrites = ref ([] : rewrite list) + +fun subsume (pk1, pk2) = + pk1 = pk2 + orelse pk2 = Any + orelse pk2 = Relation andalso (pk1 = Table orelse pk1 = Sequence orelse pk1 = View) + +fun setRewriteRules ls = rewrites := ls +fun rewrite pk s = + let + fun rew (ls : rewrite list) = + case ls of + [] => s + | rewr :: ls => + let + fun match () = + case #kind rewr of + Exact => if #from rewr = s then + SOME (size s) + else + NONE + | Prefix => if String.isPrefix (#from rewr) s then + SOME (size (#from rewr)) + else + NONE + in + if subsume (pk, #pkind rewr) then + case match () of + NONE => rew ls + | SOME suffixStart => #to rewr ^ String.extract (s, suffixStart, NONE) + else + rew ls + end + in + rew (!rewrites) + end + end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rewrite.ur Sat May 02 13:23:07 2009 -0400 @@ -0,0 +1,9 @@ +table t : { A : int } + +fun other () = return <xml><body> + Other +</body></xml> + +fun main () = return <xml><body> + <a link={other ()}>Hi!</a> +</body></xml>