summaryrefslogtreecommitdiff
path: root/src/cjr_print.sml
diff options
context:
space:
mode:
Diffstat (limited to 'src/cjr_print.sml')
-rw-r--r--src/cjr_print.sml245
1 files changed, 162 insertions, 83 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 87d2576c..70ebdf43 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -952,7 +952,7 @@ fun unurlify fromClient env (t, loc) =
newline,
string ":",
space,
- string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", request), NULL))));"),
+ string ("(uw_error(ctx, FATAL, \"Error unurlifying list: %s\", *request), NULL))));"),
newline],
string "}",
newline,
@@ -1014,52 +1014,39 @@ fun urlify env t =
let
fun urlify' level (t as (_, loc)) =
case #1 t of
- TFfi ("Basis", "unit") => box []
+ TFfi ("Basis", "unit") => box [string "uw_Basis_urlifyString_w(ctx, \"\");",
+ newline]
| TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t
^ "_w(ctx, it" ^ Int.toString level ^ ");"),
newline]
- | TRecord 0 => box []
+ | TRecord 0 => box [string "uw_Basis_urlifyString_w(ctx, \"\");",
+ newline]
| TRecord i =>
let
- fun empty (t, _) =
- case t of
- TFfi ("Basis", "unit") => true
- | TRecord 0 => true
- | TRecord j =>
- List.all (fn (_, t) => empty t) (E.lookupStruct env j)
- | _ => false
-
val xts = E.lookupStruct env i
val (blocks, _) = foldl
(fn ((x, t), (blocks, printingSinceLastSlash)) =>
- let
- val thisEmpty = empty t
- in
- if thisEmpty then
- (blocks, printingSinceLastSlash)
- else
- (box [string "{",
- newline,
- p_typ env t,
- space,
- string ("it" ^ Int.toString (level + 1)),
- space,
- string "=",
- space,
- string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
- newline,
- box (if printingSinceLastSlash then
- [string "uw_write(ctx, \"/\");",
- newline]
- else
- []),
- urlify' (level + 1) t,
- string "}",
- newline] :: blocks,
- true)
- end)
+ (box [string "{",
+ newline,
+ p_typ env t,
+ space,
+ string ("it" ^ Int.toString (level + 1)),
+ space,
+ string "=",
+ space,
+ string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"),
+ newline,
+ box (if printingSinceLastSlash then
+ [string "uw_write(ctx, \"/\");",
+ newline]
+ else
+ []),
+ urlify' (level + 1) t,
+ string "}",
+ newline] :: blocks,
+ true))
([], false) xts
in
box (rev blocks)
@@ -2550,8 +2537,10 @@ fun p_decl env (dAll as (d, loc) : decl) =
(case Settings.getOutputJsFile () of
NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"
| SOME s => s)
- val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
- file = name}
+ val js = OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
+ file = name}
+ val () = app_js := js
+ val () = Endpoints.setJavaScript js
in
box [string "static char jslib[] = \"",
string (Prim.toCString s),
@@ -3241,10 +3230,11 @@ fun p_file env (ds, ps) =
val _ = foldl (fn (d, env) =>
((case #1 d of
- DDatabase {name = x, expunge = y, initialize = z} => (hasDb := true;
- dbstring := x;
- expunge := y;
- initialize := z)
+ DDatabase {name = x, expunge = y, initialize = z, ...} =>
+ (hasDb := true;
+ dbstring := x;
+ expunge := y;
+ initialize := z)
| DJavaScript _ => hasJs := true
| DTable (s, xts, _, _) => tables := (s, map (fn (x, t) =>
(x, sql_type_in env t)) xts) :: !tables
@@ -3345,9 +3335,20 @@ fun p_file env (ds, ps) =
string "}",
newline]
- val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
- val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
- val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) => SOME (n, x1, x2, e) | _ => NONE) ds
+ val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) =>
+ SOME (x1, x2, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e)
+ | _ => NONE) ds
+ val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) =>
+ SOME (x1, x2, p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
+ x2 dummyt) e)
+ | _ => NONE) ds
+ val periodics = List.mapPartial (fn (DTask (Periodic n, x1, x2, e), _) =>
+ SOME (n, x1, x2, p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e)
+ | _ => NONE) ds
+
+ val (protos', defs') = ListPair.unzip (latestUrlHandlers ())
+ val protos = protos @ protos'
+ val defs = defs @ defs'
val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
@@ -3380,6 +3381,14 @@ fun p_file env (ds, ps) =
newline,
string "#include <time.h>",
newline,
+ (case Settings.getFileCache () of
+ NONE => box []
+ | SOME _ => box [string "#include <sys/types.h>",
+ newline,
+ string "#include <sys/stat.h>",
+ newline,
+ string "#include <unistd.h>",
+ newline]),
if hasDb then
box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
newline]
@@ -3467,7 +3476,7 @@ fun p_file env (ds, ps) =
newline,
newline,
- box (ListUtil.mapi (fn (i, (_, x1, x2, e)) =>
+ box (ListUtil.mapi (fn (i, (_, x1, x2, pe)) =>
box [string "static void uw_periodic",
string (Int.toString i),
string "(uw_context ctx) {",
@@ -3478,7 +3487,7 @@ fun p_file env (ds, ps) =
string x2,
string "_1 = 0;",
newline,
- p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
+ pe,
string ";",
newline],
string "}",
@@ -3617,22 +3626,21 @@ fun p_file env (ds, ps) =
box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
newline,
- p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
- newline,
- string "uw_Basis_client __uwr_",
- string x1,
- string "_0 = cli;",
- newline,
- string "uw_unit __uwr_",
- string x2,
- string "_1 = 0;",
- newline,
- p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
- x2 dummyt) e,
- string ";",
- newline,
- string "});",
- newline]) expungers,
+ p_list_sep (box []) (fn (x1, x2, pe) => box [string "({",
+ newline,
+ string "uw_Basis_client __uwr_",
+ string x1,
+ string "_0 = cli;",
+ newline,
+ string "uw_unit __uwr_",
+ string x2,
+ string "_1 = 0;",
+ newline,
+ pe,
+ string ";",
+ newline,
+ string "});",
+ newline]) expungers,
if hasDb then
box [p_enamed env (!expunge),
@@ -3645,24 +3653,38 @@ fun p_file env (ds, ps) =
newline,
string "static void uw_initializer(uw_context ctx) {",
newline,
- box [string "uw_begin_initializing(ctx);",
+ box [(case Settings.getFileCache () of
+ NONE => box []
+ | SOME dir => box [newline,
+ string "struct stat st = {0};",
+ newline,
+ newline,
+ string "if (stat(\"",
+ string (Prim.toCString dir),
+ string "\", &st) == -1)",
+ newline,
+ box [string "mkdir(\"",
+ string (Prim.toCString dir),
+ string "\", 0700);",
+ newline]]),
+ string "uw_begin_initializing(ctx);",
newline,
p_list_sep newline (fn x => x) (rev (!global_initializers)),
string "uw_end_initializing(ctx);",
newline,
- p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
- newline,
- string "uw_unit __uwr_",
- string x1,
- string "_0 = 0, __uwr_",
- string x2,
- string "_1 = 0;",
- newline,
- p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
- string ";",
- newline,
- string "});",
- newline]) initializers,
+ p_list_sep (box []) (fn (x1, x2, pe) => box [string "({",
+ newline,
+ string "uw_unit __uwr_",
+ string x1,
+ string "_0 = 0, __uwr_",
+ string x2,
+ string "_1 = 0;",
+ newline,
+ pe,
+ string ";",
+ newline,
+ string "});",
+ newline]) initializers,
if hasDb then
box [p_enamed env (!initialize),
string "(ctx, 0);",
@@ -3710,8 +3732,30 @@ fun p_file env (ds, ps) =
newline]
end
+fun isText t =
+ case t of
+ String => true
+ | Nullable t => isText t
+ | _ => false
+
+fun declaresAsForeignKey xs s =
+ case String.tokens (fn ch => Char.isSpace ch orelse ch = #"," orelse ch = #"(" orelse ch = #")") s of
+ "FOREIGN" :: "KEY" :: rest =>
+ let
+ fun consume rest =
+ case rest of
+ [] => false
+ | "REFERENCES" :: _ => false
+ | xs' :: rest' => xs' = xs orelse consume rest'
+ in
+ consume rest
+ end
+ | _ => false
+
fun p_sql env (ds, _) =
let
+ val usesSimilar = ref false
+
val (pps, _) = ListUtil.foldlMap
(fn (dAll as (d, _), env) =>
let
@@ -3722,14 +3766,28 @@ fun p_sql env (ds, _) =
string "(",
p_list (fn (x, t) =>
let
+ val xs = Settings.mangleSql (CharVector.map Char.toLower x)
val t = sql_type_in env t
+
+ val ts = if #textKeysNeedLengths (Settings.currentDbms ()) andalso isText t
+ andalso (List.exists (declaresAsForeignKey xs o #2) csts
+ orelse List.exists (String.isSubstring (xs ^ "(255)")) (pk :: map #2 csts)) then
+ "varchar(255)"
+ else
+ #p_sql_type (Settings.currentDbms ()) t
in
- box [string (Settings.mangleSql (CharVector.map Char.toLower x)),
+ box [string xs,
space,
- string (#p_sql_type (Settings.currentDbms ()) t),
+ string ts,
case t of
Nullable _ => box []
- | _ => string " NOT NULL"]
+ | _ => string " NOT NULL",
+ case t of
+ Time => if #requiresTimestampDefaults (Settings.currentDbms ()) then
+ string " DEFAULT CURRENT_TIMESTAMP"
+ else
+ box []
+ | _ => box []]
end) xts,
case (pk, csts) of
("", []) => box []
@@ -3737,7 +3795,12 @@ fun p_sql env (ds, _) =
cut,
case pk of
"" => box []
- | _ => box [string "PRIMARY",
+ | _ => box [string "CONSTRAINT",
+ space,
+ string s,
+ string "_pkey",
+ space,
+ string "PRIMARY",
space,
string "KEY",
space,
@@ -3777,13 +3840,29 @@ fun p_sql env (ds, _) =
string ";",
newline,
newline]
+ | DDatabase {usesSimilar = s, ...} =>
+ (usesSimilar := s;
+ box [])
| _ => box []
in
(pp, E.declBinds env dAll)
end)
env ds
in
- box (string (#sqlPrefix (Settings.currentDbms ())) :: pps)
+ box ((case Settings.getFileCache () of
+ NONE => []
+ | SOME _ => case #supportsSHA512 (Settings.currentDbms ()) of
+ NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512";
+ [])
+ | SOME r => [string (#InitializeDb r), newline, newline])
+ @ (if !usesSimilar then
+ case #supportsSimilar (Settings.currentDbms ()) of
+ NONE => (ErrorMsg.error "Using SIMILAR with database that doesn't support it";
+ [])
+ | SOME r => [string (#InitializeDb r), newline, newline]
+ else
+ [])
+ @ string (#sqlPrefix (Settings.currentDbms ())) :: pps)
end
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-29 19:08:17 +0000