summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sig2
-rw-r--r--src/cjr_print.sml12
-rw-r--r--src/compiler.sig7
-rw-r--r--src/compiler.sml120
-rw-r--r--src/corify.sml2
-rw-r--r--src/demo.sml5
-rw-r--r--src/jscomp.sml2
-rw-r--r--src/monoize.sig2
-rw-r--r--src/monoize.sml18
-rw-r--r--src/settings.sig39
-rw-r--r--src/settings.sml49
-rw-r--r--src/sources3
12 files changed, 196 insertions, 65 deletions
diff --git a/src/cjr_print.sig b/src/cjr_print.sig
index d7fb21a0..baef005e 100644
--- a/src/cjr_print.sig
+++ b/src/cjr_print.sig
@@ -36,6 +36,4 @@ signature CJR_PRINT = sig
val p_sql : CjrEnv.env -> Cjr.file Print.printer
val debug : bool ref
-
- val timeout : int ref
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 95ae53b8..e1d6d88b 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1250,8 +1250,6 @@ fun urlify env t =
urlify' IS.empty 0 t
end
-val timeout = ref 0
-
fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
@@ -2832,7 +2830,7 @@ fun p_file env (ds, ps) =
string (case side of
ServerOnly => ""
| _ => "<script src=\\\""
- ^ OS.Path.joinDirFile {dir = !Monoize.urlPrefix,
+ ^ OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
file = "app.js"}
^ "\\\"></script>\\n"),
string "\");",
@@ -2844,7 +2842,7 @@ fun p_file env (ds, ps) =
string ");",
newline,
string "uw_set_url_prefix(ctx, \"",
- string (!Monoize.urlPrefix),
+ string (Settings.getUrlPrefix ()),
string "\");",
newline]),
string "uw_set_needs_sig(ctx, ",
@@ -3185,6 +3183,10 @@ fun p_file env (ds, ps) =
else
box [],
newline,
+ p_list_sep (box []) (fn s => box [string "#include \"",
+ string s,
+ string "\"",
+ newline]) (Settings.getHeaders ()),
string "#include \"",
string (OS.Path.joinDirFile {dir = Config.includ,
file = "urweb.h"}),
@@ -3198,7 +3200,7 @@ fun p_file env (ds, ps) =
string ";",
newline,
string "int uw_timeout = ",
- string (Int.toString (!timeout)),
+ string (Int.toString (Settings.getTimeout ())),
string ";",
newline,
newline,
diff --git a/src/compiler.sig b/src/compiler.sig
index d00f111e..cae86472 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -37,11 +37,14 @@ signature COMPILER = sig
sql : string option,
debug : bool,
profile : bool,
- timeout : int
+ timeout : int,
+ ffi : string list,
+ link : string list,
+ headers : string list
}
val compile : string -> unit
val compileC : {cname : string, oname : string, ename : string, libs : string,
- profile : bool, debug : bool} -> unit
+ profile : bool, debug : bool, link : string list} -> unit
type ('src, 'dst) phase
type ('src, 'dst) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index 99954958..a5360f89 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2009, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -25,8 +25,6 @@
* POSSIBILITY OF SUCH DAMAGE.
*)
-(* Ur/Web language parser *)
-
structure Compiler :> COMPILER = struct
structure UrwebLrVals = UrwebLrValsFn(structure Token = LrParser.Token)
@@ -43,7 +41,10 @@ type job = {
sql : string option,
debug : bool,
profile : bool,
- timeout : int
+ timeout : int,
+ ffi : string list,
+ link : string list,
+ headers : string list
}
type ('src, 'dst) phase = {
@@ -201,7 +202,7 @@ val parseUr = {
handle LrParser.ParseError => [],
print = SourcePrint.p_file}
-fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout} =
+fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers} =
let
open Print.PD
open Print
@@ -228,6 +229,9 @@ fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout} =
string "Timeout: ",
string (Int.toString timeout),
newline,
+ p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi,
+ p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers,
+ p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link,
string "Sources:",
p_list string sources,
newline]
@@ -251,6 +255,10 @@ val parseUrp = {
OS.Path.concat (dir, fname)
handle OS.Path.Path => fname
+ val absDir = OS.Path.mkAbsolute {path = dir, relativeTo = OS.FileSys.getDir ()}
+
+ fun relifyA fname = OS.Path.mkAbsolute {path = fname, relativeTo = absDir}
+
fun readSources acc =
case TextIO.inputLine inf of
NONE => rev acc
@@ -270,21 +278,35 @@ val parseUrp = {
readSources acc
end
- fun finish (prefix, database, exe, sql, debug, profile, timeout, sources) =
- {prefix = Option.getOpt (prefix, "/"),
- database = database,
- exe = Option.getOpt (exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
- ext = SOME "exe"}),
- sql = sql,
- debug = debug,
- profile = profile,
- timeout = Option.getOpt (timeout, 60),
+ val prefix = ref NONE
+ val database = ref NONE
+ val exe = ref NONE
+ val sql = ref NONE
+ val debug = ref false
+ val profile = ref false
+ val timeout = ref NONE
+ val ffi = ref []
+ val link = ref []
+ val headers = ref []
+
+ fun finish sources =
+ {prefix = Option.getOpt (!prefix, "/"),
+ database = !database,
+ exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename,
+ ext = SOME "exe"}),
+ sql = !sql,
+ debug = !debug,
+ profile = !profile,
+ timeout = Option.getOpt (!timeout, 60),
+ ffi = !ffi,
+ link = !link,
+ headers = !headers,
sources = sources}
- fun read (prefix, database, exe, sql, debug, profile, timeout) =
+ fun read () =
case TextIO.inputLine inf of
- NONE => finish (prefix, database, exe, sql, debug, profile, timeout, [])
- | SOME "\n" => finish (prefix, database, exe, sql, debug, profile, timeout, readSources [])
+ NONE => finish []
+ | SOME "\n" => finish (readSources [])
| SOME line =>
let
val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line)
@@ -293,41 +315,45 @@ val parseUrp = {
in
case cmd of
"prefix" =>
- (case prefix of
+ (case !prefix of
NONE => ()
| SOME _ => ErrorMsg.error "Duplicate 'prefix' directive";
- read (SOME arg, database, exe, sql, debug, profile, timeout))
+ prefix := SOME arg)
| "database" =>
- (case database of
+ (case !database of
NONE => ()
| SOME _ => ErrorMsg.error "Duplicate 'database' directive";
- read (prefix, SOME arg, exe, sql, debug, profile, timeout))
+ database := SOME arg)
| "exe" =>
- (case exe of
+ (case !exe of
NONE => ()
| SOME _ => ErrorMsg.error "Duplicate 'exe' directive";
- read (prefix, database, SOME (relify arg), sql, debug, profile, timeout))
+ exe := SOME (relify arg))
| "sql" =>
- (case sql of
+ (case !sql of
NONE => ()
| SOME _ => ErrorMsg.error "Duplicate 'sql' directive";
- read (prefix, database, exe, SOME (relify arg), debug, profile, timeout))
- | "debug" => read (prefix, database, exe, sql, true, profile, timeout)
- | "profile" => read (prefix, database, exe, sql, debug, true, timeout)
+ sql := SOME (relify arg))
+ | "debug" => debug := true
+ | "profile" => profile := true
| "timeout" =>
- (case timeout of
+ (case !timeout of
NONE => ()
| SOME _ => ErrorMsg.error "Duplicate 'timeout' directive";
- read (prefix, database, exe, sql, debug, profile, SOME (valOf (Int.fromString arg))))
- | _ => (ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
- read (prefix, database, exe, sql, debug, profile, timeout))
+ timeout := SOME (valOf (Int.fromString arg)))
+ | "ffi" => ffi := relify arg :: !ffi
+ | "link" => link := relifyA arg :: !link
+ | "include" => headers := relifyA arg :: !headers
+ | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'");
+ read ()
end
- val job = read (NONE, NONE, NONE, NONE, false, false, NONE)
+ val job = read ()
in
TextIO.closeIn inf;
- Monoize.urlPrefix := #prefix job;
- CjrPrint.timeout := #timeout job;
+ Settings.setUrlPrefix (#prefix job);
+ Settings.setTimeout (#timeout job);
+ Settings.setHeaders (#headers job);
job
end,
print = p_job
@@ -339,10 +365,24 @@ fun capitalize "" = ""
| capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
val parse = {
- func = fn {database, sources = fnames, ...} : job =>
+ func = fn {database, sources = fnames, ffi, ...} : job =>
let
fun nameOf fname = capitalize (OS.Path.file fname)
+ fun parseFfi fname =
+ let
+ val mname = nameOf fname
+ val urs = OS.Path.joinBaseExt {base = fname, ext = SOME "urs"}
+
+ val loc = {file = urs,
+ first = ErrorMsg.dummyPos,
+ last = ErrorMsg.dummyPos}
+
+ val sgn = (Source.SgnConst (#func parseUrs urs), loc)
+ in
+ (Source.DFfiStr (mname, sgn), loc)
+ end
+
fun parseOne fname =
let
val mname = nameOf fname
@@ -367,12 +407,14 @@ val parse = {
(Source.DStr (mname, sgnO, (Source.StrConst ds, loc)), loc)
end
+ val dsFfi = map parseFfi ffi
val ds = map parseOne fnames
in
let
val final = nameOf (List.last fnames)
- val ds = ds @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
+ val ds = dsFfi @ ds
+ @ [(Source.DExport (Source.StrVar final, ErrorMsg.dummySpan), ErrorMsg.dummySpan)]
in
case database of
NONE => ds
@@ -605,7 +647,7 @@ val sqlify = {
val toSqlify = transform sqlify "sqlify" o toMono_opt2
-fun compileC {cname, oname, ename, libs, profile, debug} =
+fun compileC {cname, oname, ename, libs, profile, debug, link = link'} =
let
val urweb_o = clibFile "urweb.o"
val driver_o = clibFile "driver.o"
@@ -624,6 +666,8 @@ fun compileC {cname, oname, ename, libs, profile, debug} =
(compile ^ " -g", link ^ " -g")
else
(compile, link)
+
+ val link = foldl (fn (s, link) => link ^ " " ^ s) link link'
in
if not (OS.Process.isSuccess (OS.Process.system compile)) then
print "C compilation failed\n"
@@ -689,7 +733,7 @@ fun compile job =
end;
compileC {cname = cname, oname = oname, ename = ename, libs = libs,
- profile = #profile job, debug = #debug job};
+ profile = #profile job, debug = #debug job, link = #link job};
cleanup ()
end
diff --git a/src/corify.sml b/src/corify.sml
index f1895e19..19568b8b 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -890,7 +890,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
val st = St.bindStr st m n (St.ffi m cmap conmap)
in
- (rev ds, St.basisIs (st, n))
+ (rev ds, if m = "Basis" then St.basisIs (st, n) else st)
end
| _ => raise Fail "Non-const signature for FFI structure")
diff --git a/src/demo.sml b/src/demo.sml
index 43fa5ef0..4e73faea 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -94,7 +94,10 @@ fun make {prefix, dirname, guided} =
file = "demo.sql"}),
debug = false,
timeout = Int.max (#timeout combined, #timeout urp),
- profile = false
+ profile = false,
+ ffi = [],
+ link = [],
+ headers = []
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 0f545987..1c5132c2 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -965,7 +965,7 @@ fun process file =
val (ek, st) = jsE inner (ek, st)
val (unurl, st) = unurlifyExp loc (t, st)
in
- (strcat [str ("rc(cat(\"" ^ !Monoize.urlPrefix ^ "\","),
+ (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","),
e,
str ("), function(s){var t=s.split(\"/\");var i=0;return "
^ unurl ^ "},"),
diff --git a/src/monoize.sig b/src/monoize.sig
index 4e02e5ea..838d7c4c 100644
--- a/src/monoize.sig
+++ b/src/monoize.sig
@@ -27,8 +27,6 @@
signature MONOIZE = sig
- val urlPrefix : string ref
-
val monoize : CoreEnv.env -> Core.file -> Mono.file
val liftExpInExp : int -> Mono.exp -> Mono.exp
diff --git a/src/monoize.sml b/src/monoize.sml
index c54ab8ba..877e1a2c 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -36,8 +36,6 @@ structure L' = Mono
structure IM = IntBinaryMap
structure IS = IntBinarySet
-val urlPrefix = ref "/"
-
val dummyTyp = (L'.TDatatype (0, ref (L'.Enum, [])), E.dummySpan)
structure U = MonoUtil
@@ -376,7 +374,7 @@ fun fooifyExp fk env =
let
val (_, _, _, s) = Env.lookupENamed env fnam
in
- ((L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
+ ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
end
| L'.EClosure (fnam, args) =>
let
@@ -399,7 +397,7 @@ fun fooifyExp fk env =
| _ => (E.errorAt loc "Type mismatch encoding attribute";
(e, fm))
in
- attrify (args, ft, (L'.EPrim (Prim.String (!urlPrefix ^ s)), loc), fm)
+ attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm)
end
| _ =>
case t of
@@ -1257,7 +1255,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("c", s, (L'.TFun (t, (L'.TFun (un, un), loc)), loc),
(L'.EAbs ("v", t, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
- (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String (!urlPrefix)),
+ (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String
+ (Settings.getUrlPrefix ())),
loc),
(L'.ERel 2, loc),
e]), loc)),
@@ -3138,14 +3137,7 @@ datatype expungable = Client | Channel
fun monoize env file =
let
- val p = !urlPrefix
- val () =
- if p = "" then
- urlPrefix := "/"
- else if String.sub (p, size p - 1) <> #"/" then
- urlPrefix := p ^ "/"
- else
- ()
+
(* Calculate which exported functions need cookie signature protection *)
val rcook = foldl (fn ((d, _), rcook) =>
diff --git a/src/settings.sig b/src/settings.sig
new file mode 100644
index 00000000..ba4e1b9a
--- /dev/null
+++ b/src/settings.sig
@@ -0,0 +1,39 @@
+(* Copyright (c) 2008-2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature SETTINGS = sig
+
+ val setUrlPrefix : string -> unit
+ val getUrlPrefix : unit -> string
+
+ val setTimeout : int -> unit
+ val getTimeout : unit -> int
+
+ val setHeaders : string list -> unit
+ val getHeaders : unit -> string list
+
+end
diff --git a/src/settings.sml b/src/settings.sml
new file mode 100644
index 00000000..1bc14776
--- /dev/null
+++ b/src/settings.sml
@@ -0,0 +1,49 @@
+(* Copyright (c) 2008-2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ * this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ * this list of conditions and the following disclaimer in the documentation
+ * and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ * derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure Settings :> SETTINGS = struct
+
+val urlPrefix = ref "/"
+val timeout = ref 0
+val headers = ref ([] : string list)
+
+fun getUrlPrefix () = !urlPrefix
+fun setUrlPrefix p =
+ urlPrefix := (if p = "" then
+ "/"
+ else if String.sub (p, size p - 1) <> #"/" then
+ p ^ "/"
+ else
+ p)
+
+fun getTimeout () = !timeout
+fun setTimeout n = timeout := n
+
+fun getHeaders () = !headers
+fun setHeaders ls = headers := ls
+
+end
diff --git a/src/sources b/src/sources
index 43ee21b3..0f39fc74 100644
--- a/src/sources
+++ b/src/sources
@@ -13,6 +13,9 @@ order.sml
errormsg.sig
errormsg.sml
+settings.sig
+settings.sml
+
print.sig
print.sml
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-18 05:45:59 +0000