diff options
| -rw-r--r-- | CHANGELOG | 2 | ||||
| -rw-r--r-- | src/compiler.sig | 3 | ||||
| -rw-r--r-- | src/compiler.sml | 47 | ||||
| -rw-r--r-- | src/corify.sig | 3 | ||||
| -rw-r--r-- | src/corify.sml | 20 | ||||
| -rw-r--r-- | src/demo.sml | 3 | ||||
| -rw-r--r-- | src/settings.sig | 11 | ||||
| -rw-r--r-- | src/settings.sml | 44 | ||||
| -rw-r--r-- | tests/rewrite.ur | 9 | ||||
| -rw-r--r-- | tests/rewrite.urp | 8 | ||||
| -rw-r--r-- | tests/rewrite.urs | 1 |
11 files changed, 131 insertions, 20 deletions
@@ -12,6 +12,8 @@ Next - SQL outer joins - SQL views - Subforms +- C and JavaScript FFI +- Path rewriting ======== 20090405 diff --git a/src/compiler.sig b/src/compiler.sig index fd3c86cf..048ca39f 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -46,7 +46,8 @@ signature COMPILER = sig 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, diff --git a/src/compiler.sml b/src/compiler.sml index 8d33023d..5a0a148a 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -50,7 +50,8 @@ type job = { 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 @@ val parseUr = { 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 @@ fun parseUrp' filename = val clientOnly = ref [] val serverOnly = ref [] val jsFuncs = ref [] + val rewrites = ref [] val libs = ref [] fun finish sources = @@ -334,6 +336,7 @@ fun parseUrp' filename = clientOnly = rev (!clientOnly), serverOnly = rev (!serverOnly), jsFuncs = rev (!jsFuncs), + rewrites = rev (!rewrites), sources = sources } @@ -368,12 +371,32 @@ fun parseUrp' filename = 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 @@ fun parseUrp' filename = | "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 @@ fun parseUrp' filename = Settings.setClientOnly (#clientOnly job); Settings.setServerOnly (#serverOnly job); Settings.setJsFuncs (#jsFuncs job); + Settings.setRewriteRules (#rewrites job); job end diff --git a/src/corify.sig b/src/corify.sig index 8dca5f01..0e1bb80d 100644 --- a/src/corify.sig +++ b/src/corify.sig @@ -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 diff --git a/src/corify.sml b/src/corify.sml index 6cd2b753..65f32fc2 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -37,16 +37,14 @@ structure SM = BinaryMapFn(struct 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 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | 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 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = 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 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | 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 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | 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 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | 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 diff --git a/src/demo.sml b/src/demo.sml index 0b7f3345..c08ce0fe 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -103,7 +103,8 @@ fun make {prefix, dirname, guided} = effectful = [], clientOnly = [], serverOnly = [], - jsFuncs = [] + jsFuncs = [], + rewrites = [] } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp") diff --git a/src/settings.sig b/src/settings.sig index 514fb0ee..e5dd20d8 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -65,4 +65,15 @@ signature SETTINGS = sig 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 diff --git a/src/settings.sml b/src/settings.sml index 9e619b54..5e97f44b 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -147,4 +147,48 @@ val jsFuncs = ref jsFuncsBase 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 diff --git a/tests/rewrite.ur b/tests/rewrite.ur new file mode 100644 index 00000000..8b9f5bb8 --- /dev/null +++ b/tests/rewrite.ur @@ -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> diff --git a/tests/rewrite.urp b/tests/rewrite.urp new file mode 100644 index 00000000..43f141b0 --- /dev/null +++ b/tests/rewrite.urp @@ -0,0 +1,8 @@ +debug +database dbname=rewrite +sql rewrite.sql +rewrite url Rewrite/other Schrewrite/brother +rewrite url Rewrite/* +rewrite relation Rewrite/t mytab + +rewrite diff --git a/tests/rewrite.urs b/tests/rewrite.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/rewrite.urs @@ -0,0 +1 @@ +val main : unit -> transaction page |