Path rewriting

7 files changed, 111 insertions, 20 deletions

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