From a19e53017364ceddbba557fb363ca26b273f89da Mon Sep 17 00:00:00 2001
From: Adam Chlipala <adamc@csail.mit.edu>
Date: Mon, 15 Apr 2019 16:20:12 -0400
Subject: Catch clashing rewritten URL prefixes

---
 src/monoize.sml       | 32 ++++++++++++++++++++++++++++++++
 tests/prefixClash.ur  |  3 +++
 tests/prefixClash.urp |  4 ++++
 tests/prefixClash.urs |  3 +++
 4 files changed, 42 insertions(+)
 create mode 100644 tests/prefixClash.ur
 create mode 100644 tests/prefixClash.urp
 create mode 100644 tests/prefixClash.urs

diff --git a/src/monoize.sml b/src/monoize.sml
index 48001a13..97ad1505 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -50,6 +50,36 @@ structure RM = BinaryMapFn(struct
                                                                         (L'.TRecord r2, E.dummySpan))
                            end)
 
+local
+    val url_prefixes = ref []
+in
+
+fun reset () = url_prefixes := []
+
+fun addPrefix prefix =
+    let
+        fun isPrefix s1 s2 =
+            String.isPrefix s1 s2
+            andalso (size s1 = size s2
+                     orelse String.sub (s2, size s1) = #"/")
+    in
+        if List.exists (fn prefix' =>
+                           let
+                               fun tryOne prefix' prefix =
+                                   isPrefix prefix' prefix
+                                   andalso (ErrorMsg.error ("Conflicting URL prefixes for page handlers: \"" ^ prefix' ^ "\" is a prefix of \"" ^ prefix ^ "\".");
+                                            true)
+                           in
+                               tryOne prefix' prefix
+                               orelse tryOne prefix prefix'
+                           end) (!url_prefixes) then
+            ()
+        else
+            url_prefixes := prefix :: !url_prefixes
+    end
+
+end
+                          
 val nextPvar = MonoFooify.nextPvar
 val pvars = ref (RM.empty : (int * (string * int * L'.typ) list) RM.map)
 val pvarDefs = MonoFooify.pvarDefs
@@ -4233,6 +4263,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
           | L.DExport (ek, n, b) =>
             let
                 val (_, t, _, s) = Env.lookupENamed env n
+                val () = addPrefix s
 
                 fun unwind (t, args) =
                     case #1 t of
@@ -4392,6 +4423,7 @@ datatype expungable = Client | Channel
 
 fun monoize env file =
     let
+        val () = reset ()
         val () = pvars := RM.empty
 
         (* Calculate which exported functions need cookie signature protection *)
diff --git a/tests/prefixClash.ur b/tests/prefixClash.ur
new file mode 100644
index 00000000..a2325077
--- /dev/null
+++ b/tests/prefixClash.ur
@@ -0,0 +1,3 @@
+val index = return <xml></xml>
+val other = return <xml></xml>
+val ather = return <xml></xml>
diff --git a/tests/prefixClash.urp b/tests/prefixClash.urp
new file mode 100644
index 00000000..cf4545d0
--- /dev/null
+++ b/tests/prefixClash.urp
@@ -0,0 +1,4 @@
+rewrite url PrefixClash/index foo
+rewrite url PrefixClash/* foo/ [-]
+
+prefixClash
diff --git a/tests/prefixClash.urs b/tests/prefixClash.urs
new file mode 100644
index 00000000..e5e58c0a
--- /dev/null
+++ b/tests/prefixClash.urs
@@ -0,0 +1,3 @@
+val index : transaction page
+val other : transaction page
+val ather : transaction page
-- 
cgit v1.2.3