diff options
| author |  Adam Chlipala <adamc@csail.mit.edu> | 2019-04-15 16:20:12 -0400 |
|---|---|---|
| committer | Adam Chlipala <adamc@csail.mit.edu> | 2019-04-15 16:20:12 -0400 |
| commit | a19e53017364ceddbba557fb363ca26b273f89da (patch) | |
| tree | 7045f1d0231c7ccad224b04e23e52409dde74603 | |
| parent | fb0d4f6c8492cc08bbf50609daa2cda1dc53a796 (diff) | |
Catch clashing rewritten URL prefixes
| -rw-r--r-- | src/monoize.sml | 32 | ||||
| -rw-r--r-- | tests/prefixClash.ur | 3 | ||||
| -rw-r--r-- | tests/prefixClash.urp | 4 | ||||
| -rw-r--r-- | tests/prefixClash.urs | 3 |
4 files changed, 42 insertions, 0 deletions
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 |