diff options
| author |  Adam Chlipala <adam@chlipala.net> | 2011-12-17 13:10:23 -0500 |
|---|---|---|
| committer | Adam Chlipala <adam@chlipala.net> | 2011-12-17 13:10:23 -0500 |
| commit | 72bd165bd051d5d51cd04f05e0bd7c85ca670db2 (patch) | |
| tree | d66971cb868f768b134688c152b281c7850c46e2 | |
| parent | 566143a9c881c9e506c79af3f3cc39abebc37d8f (diff) | |
Allow .urp libraries to set prefix
| -rw-r--r-- | src/compiler.sml | 13 | ||||
| -rw-r--r-- | src/settings.sig | 4 | ||||
| -rw-r--r-- | src/settings.sml | 3 |
3 files changed, 18 insertions, 2 deletions
diff --git a/src/compiler.sml b/src/compiler.sml index 1318b561..2a890f32 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -500,7 +500,7 @@ fun parseUrp' accLibs fname = | OnlyComment => readSources acc | EndOfFile => rev acc - val prefix = ref (case Settings.getUrlPrefix () of "/" => NONE | s => SOME s) + val prefix = ref (case Settings.getUrlPrefixFull () of "/" => NONE | s => SOME s) val database = ref (Settings.getDbstring ()) val exe = ref (Settings.getExe ()) val sql = ref (Settings.getSql ()) @@ -580,7 +580,16 @@ fun parseUrp' accLibs fname = x)) fun merge (old : job, new : job) = { - prefix = #prefix old, + prefix = case #prefix old of + "/" => #prefix new + | pold => case #prefix new of + "/" => pold + | pnew => (if pold = pnew then + () + else + ErrorMsg.error ("Multiple prefix values that don't agree: " + ^ pold ^ ", " ^ pnew); + pold), database = mergeO (fn (old, _) => old) (#database old, #database new), exe = #exe old, sql = #sql old, diff --git a/src/settings.sig b/src/settings.sig index 8f82c8a5..26e220fd 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -36,6 +36,10 @@ signature SETTINGS = sig val setUrlPrefix : string -> unit val getUrlPrefix : unit -> string val getUrlPrePrefix : unit -> string + val getUrlPrefixFull : unit -> string + (* The full prefix is the value that was set explicitly, while the "pre" + * prefix gets the protocol/host/port part and the unqualified prefix gets + * the URI. *) (* How many seconds should the server wait before assuming a Comet client has left? *) val setTimeout : int -> unit diff --git a/src/settings.sml b/src/settings.sml index 02fd3c10..b421f38a 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -27,12 +27,14 @@ structure Settings :> SETTINGS = struct +val urlPrefixFull = ref "/" val urlPrefix = ref "/" val urlPrePrefix = ref "" val timeout = ref 0 val headers = ref ([] : string list) val scripts = ref ([] : string list) +fun getUrlPrefixFull () = !urlPrefixFull fun getUrlPrefix () = !urlPrefix fun getUrlPrePrefix () = !urlPrePrefix fun setUrlPrefix p = @@ -62,6 +64,7 @@ fun setUrlPrefix p = else ("", prefix) in + urlPrefixFull := p; urlPrePrefix := prepre; urlPrefix := prefix end |