summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-05-02 13:23:07 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-05-02 13:23:07 -0400
commit3417bfbe670bd15796dd0fa8ca97209acfedfffb (patch)
treeff50f45f052221ffeee46c29630832c2d29d9161
parent471d5a79a82a673ca46d3a4e711f54ae1409c0f3 (diff)
Path rewriting
-rw-r--r--CHANGELOG2
-rw-r--r--src/compiler.sig3
-rw-r--r--src/compiler.sml47
-rw-r--r--src/corify.sig3
-rw-r--r--src/corify.sml20
-rw-r--r--src/demo.sml3
-rw-r--r--src/settings.sig11
-rw-r--r--src/settings.sml44
-rw-r--r--tests/rewrite.ur9
-rw-r--r--tests/rewrite.urp8
-rw-r--r--tests/rewrite.urs1
11 files changed, 131 insertions, 20 deletions
diff --git a/CHANGELOG b/CHANGELOG
index ebd60637..49a009b6 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -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