From c88aa571002f0dd713158f8b80bfeacbd0a69569 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 17 Dec 2018 17:05:22 -0500 Subject: When using a file cache, add plugin-loading code (for SHA512) to tops of .sql files --- src/cjr_print.sml | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 87d2576c..e0153944 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3783,7 +3783,13 @@ fun p_sql env (ds, _) = 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 line => [string line, newline, newline]) + @ string (#sqlPrefix (Settings.currentDbms ())) :: pps) end end -- cgit v1.2.3 From c9bb1becf98d02123666eb084de88a443e1a2544 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 19 Dec 2018 14:44:40 -0500 Subject: Output unurlification functions, even when they are first mentioned in e.g. expungers --- src/cjr_print.sml | 78 +++++++++++++++++++++++++++++++------------------------ 1 file changed, 44 insertions(+), 34 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index e0153944..31653a74 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3345,9 +3345,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 @@ -3467,7 +3478,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 +3489,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 +3628,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), @@ -3650,19 +3660,19 @@ fun p_file env (ds, ps) = 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);", -- cgit v1.2.3 From ba1871b3b9cc669c43420f993719690b45326e2f Mon Sep 17 00:00:00 2001 From: Artyom Shalkhakov Date: Sat, 12 Jan 2019 16:20:14 +0200 Subject: Including app.js in output of endpoints --- src/cjr_print.sml | 6 ++++-- src/compiler.sig | 4 +++- src/compiler.sml | 29 +++++++++++++++++++++++++---- src/demo.sml | 4 ++++ src/endpoints.sig | 5 ++++- src/endpoints.sml | 25 ++++++++++++++++++++++++- src/main.mlton.sml | 24 ++++++------------------ src/settings.sig | 3 +++ src/settings.sml | 7 ++++++- 9 files changed, 79 insertions(+), 28 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 31653a74..5983b9e5 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -2550,8 +2550,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), diff --git a/src/compiler.sig b/src/compiler.sig index d4521b9f..6ed2f9a6 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -35,6 +35,7 @@ signature COMPILER = sig sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -116,6 +117,7 @@ signature COMPILER = sig val css : (Core.file, Css.report) phase val monoize : (Core.file, Mono.file) phase val mono_opt : (Mono.file, Mono.file) phase + val endpoints : (Mono.file, Mono.file) phase val untangle : (Mono.file, Mono.file) phase val mono_reduce : (Mono.file, Mono.file) phase val mono_shake : (Mono.file, Mono.file) phase @@ -171,7 +173,7 @@ signature COMPILER = sig val toEffectize : (string, Core.file) transform val toCss : (string, Css.report) transform val toMonoize : (string, Mono.file) transform - val toEndpoints : (string, Endpoints.report) transform + val toEndpoints : (string, Mono.file) transform val toMono_opt1 : (string, Mono.file) transform val toUntangle : (string, Mono.file) transform val toMono_reduce : (string, Mono.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index 4ef9ba19..7099effc 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -39,6 +39,7 @@ type job = { sources : string list, exe : string, sql : string option, + endpoints : string option, debug : bool, profile : bool, timeout : int, @@ -275,7 +276,7 @@ val parseUr = { handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job ({prefix, database, exe, sql, sources, debug, profile, +fun p_job ({prefix, database, exe, sql, endpoints, sources, debug, profile, timeout, ffi, link, headers, scripts, clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) = let @@ -304,6 +305,10 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile, NONE => string "No SQL file." | SOME sql => string ("SQL fle: " ^ sql), newline, + case endpoints of + NONE => string "No endpoints file." + | SOME ep => string ("Endpoints fle: " ^ ep), + newline, string "Timeout: ", string (Int.toString timeout), newline, @@ -443,6 +448,7 @@ fun parseUrp' accLibs fname = sources = [fname], exe = fname ^ ".exe", sql = NONE, + endpoints = NONE, debug = Settings.getDebug (), profile = false, timeout = 120, @@ -581,6 +587,7 @@ fun parseUrp' accLibs fname = val database = ref (Settings.getDbstring ()) val exe = ref (Settings.getExe ()) val sql = ref (Settings.getSql ()) + val endpoints = ref (Settings.getEndpoints ()) val debug = ref (Settings.getDebug ()) val profile = ref false val timeout = ref NONE @@ -622,6 +629,7 @@ fun parseUrp' accLibs fname = exe = Option.getOpt (!exe, OS.Path.joinBaseExt {base = OS.Path.base filename, ext = SOME "exe"}), sql = !sql, + endpoints = !endpoints, debug = !debug, profile = !profile, timeout = Option.getOpt (!timeout, 60), @@ -684,6 +692,7 @@ fun parseUrp' accLibs fname = database = mergeO (fn (old, _) => old) (#database old, #database new), exe = #exe old, sql = #sql old, + endpoints = #endpoints old, debug = #debug old orelse #debug new, profile = #profile old orelse #profile new, timeout = #timeout old, @@ -1430,13 +1439,13 @@ val mono_opt = { } val endpoints = { - func = Endpoints.summarize, - print = Endpoints.p_report + func = Endpoints.collect, + print = MonoPrint.p_file MonoEnv.empty } val toEndpoints = transform endpoints "endpoints" o toMonoize -val toMono_opt1 = transform mono_opt "mono_opt1" o toMonoize +val toMono_opt1 = transform mono_opt "mono_opt1" o toEndpoints val untangle = { func = Untangle.untangle, @@ -1726,6 +1735,18 @@ fun compile job = TextIO.closeOut outf end; + case #endpoints job of + NONE => () + | SOME endpoints => + let + val report = Endpoints.summarize () + val outf = TextIO.openOut endpoints + val s = TextIOPP.openOut {dst = outf, wid = 80} + in + Print.fprint s (Endpoints.p_report report); + TextIO.closeOut outf + end; + compileC {cname = cname, oname = oname, ename = ename, libs = libs, profile = #profile job, debug = #debug job, linker = #linker job, link = #link job} diff --git a/src/demo.sml b/src/demo.sml index eaec38bb..ef57e65b 100644 --- a/src/demo.sml +++ b/src/demo.sml @@ -98,6 +98,10 @@ fun make' {prefix, dirname, guided} = NONE => OS.Path.joinDirFile {dir = dirname, file = "demo.sql"} | SOME s => s), + endpoints = SOME (case Settings.getEndpoints () of + NONE => OS.Path.joinDirFile {dir = dirname, + file = "demo-endpoints.json"} + | SOME e => e), debug = Settings.getDebug (), timeout = Int.max (#timeout combined, #timeout urp), profile = false, diff --git a/src/endpoints.sig b/src/endpoints.sig index f2c3c305..89e72add 100644 --- a/src/endpoints.sig +++ b/src/endpoints.sig @@ -36,6 +36,9 @@ signature ENDPOINTS = sig type report = {Endpoints : endpoint list} val p_report : report Print.printer - val summarize : Mono.file -> report + val reset : unit -> unit + val collect : Mono.file -> Mono.file + val setJavaScript : string -> unit + val summarize : unit -> report end diff --git a/src/endpoints.sml b/src/endpoints.sml index bb0b1d66..5699f319 100644 --- a/src/endpoints.sml +++ b/src/endpoints.sml @@ -59,7 +59,14 @@ fun p_report {Endpoints = el} = p_list_sep (box [string ",", newline]) p_endpoint el, string "]}"] -fun summarize file = +val endpoints = ref ([] : endpoint list) +val jsFile = ref (NONE : string option) + +fun setJavaScript x = jsFile := SOME x + +fun reset () = (endpoints := []; jsFile := NONE) + +fun collect file = let fun exportKindToMethod (Link _) = GET | exportKindToMethod (Action _) = POST @@ -75,6 +82,8 @@ fun summarize file = | _ => st end + val () = reset () + val (decls, _) = file val ep = foldl decl [] decls @@ -87,6 +96,20 @@ fun summarize file = {Method = GET, Url = f, LastModified = NONE, ContentType = SOME "text/javascript"} :: st val ep = foldl jsfile ep (Settings.listJsFiles ()) + in + endpoints := ep; + file + end + +fun summarize () = + let + val ep = !endpoints + val js = !jsFile + val ep = + case js of + NONE => ep + | SOME js => + {Method = GET, Url = js, LastModified = NONE, ContentType = SOME "text/javascript"} :: ep in {Endpoints = ep} end diff --git a/src/main.mlton.sml b/src/main.mlton.sml index 56d98587..bfa40265 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -114,7 +114,6 @@ fun oneRun args = val demo = ref (NONE : (string * bool) option) val tutorial = ref false val css = ref false - val endpoints = ref false val () = (Compiler.debug := false; Elaborate.verbose := false; @@ -163,8 +162,6 @@ fun oneRun args = SOME "print numeric version number and exit"), ("css", set_true css, SOME "print categories of CSS properties"), - ("endpoints", set_true endpoints, - SOME "print exposed URL endpoints"), ("print-ccompiler", ZERO printCCompiler, SOME "print C compiler and exit"), ("print-cinclude", ZERO printCInclude, @@ -220,6 +217,8 @@ fun oneRun args = SOME "serve JavaScript as "), ("sql", ONE ("", Settings.setSql o SOME), SOME "output sql script as "), + ("endpoints", ONE ("", Settings.setEndpoints o SOME), + SOME "output exposed URL endpoints in JSON as "), ("static", call_true Settings.setStaticLinking, SOME "enable static linking"), ("stop", ONE ("", Compiler.setStop), @@ -271,8 +270,8 @@ fun oneRun args = " only one is allowed.\nSpecified projects: "^ String.concatWith ", " files) in - case (!css, !demo, !tutorial, !endpoints) of - (true, _, _, _) => + case (!css, !demo, !tutorial) of + (true, _, _) => (case Compiler.run Compiler.toCss job of NONE => OS.Process.failure | SOME {Overall = ov, Classes = cl} => @@ -285,24 +284,13 @@ fun oneRun args = app (print o Css.othersToString) ots; print "\n")) cl; OS.Process.success)) - | (_, SOME (prefix, guided), _, _) => + | (_, SOME (prefix, guided), _) => if Demo.make' {prefix = prefix, dirname = job, guided = guided} then OS.Process.success else OS.Process.failure - | (_, _, true, _) => (Tutorial.make job; + | (_, _, true) => (Tutorial.make job; OS.Process.success) - | (_, _, _, true) => - (case Compiler.run Compiler.toEndpoints job of - NONE => OS.Process.failure - | SOME es => - let - val r = Endpoints.p_report es - in - Print.eprint r; - print "\n"; - OS.Process.success - end) | _ => if !tc then (Compiler.check Compiler.toElaborate job; diff --git a/src/settings.sig b/src/settings.sig index a6a9c5fc..97d56b45 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -240,6 +240,9 @@ signature SETTINGS = sig val setSql : string option -> unit val getSql : unit -> string option + val setEndpoints : string option -> unit + val getEndpoints : unit -> string option + val setCoreInline : int -> unit val getCoreInline : unit -> int diff --git a/src/settings.sml b/src/settings.sml index f42df135..0e999587 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -703,6 +703,10 @@ val sql = ref (NONE : string option) fun setSql so = sql := so fun getSql () = !sql +val endpoints = ref (NONE : string option) +fun setEndpoints so = endpoints := so +fun getEndpoints () = !endpoints + val coreInline = ref 5 fun setCoreInline n = coreInline := n fun getCoreInline () = !coreInline @@ -729,7 +733,7 @@ fun getSigFile () = !sigFile val fileCache = ref (NONE : string option) fun setFileCache v = - (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true + (if Option.isSome v andalso (case #supportsSHA512 (currentDbms ()) of NONE => true | SOME _ => false) then ErrorMsg.error "The selected database engine is incompatible with file caching." else @@ -1007,6 +1011,7 @@ fun reset () = dbstring := NONE; exe := NONE; sql := NONE; + endpoints := NONE; coreInline := 5; monoInline := 5; staticLinking := false; -- cgit v1.2.3 From 87d2eab53f8e9f81cc459429675123c9ff36f41e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 21 Jan 2019 18:09:59 -0500 Subject: Basis.textOfBlob; try creating filecache directory if it doesn't exist --- include/urweb/urweb_cpp.h | 1 + lib/ur/basis.urs | 2 ++ src/c/urweb.c | 16 +++++++++++++++- src/cjr_print.sml | 24 +++++++++++++++++++++++- 4 files changed, 41 insertions(+), 2 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index 25f97fb3..67312015 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -262,6 +262,7 @@ uw_Basis_string uw_Basis_fileMimeType(struct uw_context *, uw_Basis_file); uw_Basis_blob uw_Basis_fileData(struct uw_context *, uw_Basis_file); uw_Basis_int uw_Basis_blobSize(struct uw_context *, uw_Basis_blob); uw_Basis_blob uw_Basis_textBlob(struct uw_context *, uw_Basis_string); +uw_Basis_string uw_Basis_textOfBlob(struct uw_context *, uw_Basis_blob); uw_Basis_string uw_Basis_postType(struct uw_context *, uw_Basis_postBody); uw_Basis_string uw_Basis_postData(struct uw_context *, uw_Basis_postBody); diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c893e65d..be13c684 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -1019,6 +1019,8 @@ val checkMime : string -> option mimeType val returnBlob : t ::: Type -> blob -> mimeType -> transaction t val blobSize : blob -> int val textBlob : string -> blob +val textOfBlob : blob -> option string +(* Returns [Some] exactly when the blob contains no zero bytes. *) type postBody val postType : postBody -> string diff --git a/src/c/urweb.c b/src/c/urweb.c index ae2fc0a8..c8cfb0c6 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4075,6 +4075,20 @@ uw_Basis_blob uw_Basis_textBlob(uw_context ctx, uw_Basis_string s) { return b; } +uw_Basis_string uw_Basis_textOfBlob(uw_context ctx, uw_Basis_blob b) { + size_t i; + uw_Basis_string r; + + for (i = 0; i < b.size; ++i) + if (b.data[i] == 0) + return NULL; + + r = uw_malloc(ctx, b.size + 1); + memcpy(r, b.data, b.size); + r[b.size] = 0; + return r; +} + uw_Basis_blob uw_Basis_fileData(uw_context ctx, uw_Basis_file f) { (void)ctx; return f.data; @@ -5207,7 +5221,7 @@ uw_unit uw_Basis_cache_file(uw_context ctx, uw_Basis_blob contents) { fd = mkstemp(tempfile); if (fd < 0) - uw_error(ctx, FATAL, "Error creating temporary file for cache"); + uw_error(ctx, FATAL, "Error creating temporary file %s for cache", tempfile); while (written_so_far < contents.size) { ssize_t written_just_now = write(fd, contents.data + written_so_far, contents.size - written_so_far); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 31653a74..09cd9c7f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3391,6 +3391,14 @@ fun p_file env (ds, ps) = newline, string "#include ", newline, + (case Settings.getFileCache () of + NONE => box [] + | SOME _ => box [string "#include ", + newline, + string "#include ", + newline, + string "#include ", + newline]), if hasDb then box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), newline] @@ -3655,7 +3663,21 @@ 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);", -- cgit v1.2.3 From c4aba7a0befd9988ae032c5532790e5fabb321b9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 9 Apr 2019 15:33:45 -0400 Subject: Urlify unit values as underscores, to avoid confusing parser --- src/cjr_print.sml | 2 +- src/mono_fooify.sml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index d7416616..5ef891db 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, diff --git a/src/mono_fooify.sml b/src/mono_fooify.sml index e64207cd..9cb14400 100644 --- a/src/mono_fooify.sml +++ b/src/mono_fooify.sml @@ -165,12 +165,12 @@ fun fooifyExpWithExceptions fk lookupENamed lookupDatatype = end | _ => case t of - TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + TFfi ("Basis", "unit") => ((EPrim (Prim.String (Prim.Normal, "_")), loc), fm) | TFfi (m, x) => (if Settings.mayClientToServer (m, x) then ((EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) else raise CantPass (fm, tAll)) - | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "")), loc), fm) + | TRecord [] => ((EPrim (Prim.String (Prim.Normal, "_")), loc), fm) | TRecord ((x, t) :: xts) => let val (se, fm) = fooify fm ((EField (e, x), loc), t) -- cgit v1.2.3 From fb0d4f6c8492cc08bbf50609daa2cda1dc53a796 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 13 Apr 2019 11:32:14 -0400 Subject: Generate primary key constraints with normal CONSTRAINT clauses (initial motivation: apgdiff only supports this new form) --- src/cjr_print.sml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 5ef891db..1e948943 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3771,7 +3771,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, -- cgit v1.2.3 From 94ea84354715c4a2bb30cd4aaeaaba506358d1d6 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 31 May 2019 09:58:37 -0400 Subject: Filecache support for MySQL --- src/c/urweb.c | 5 ++--- src/cjr_print.sml | 2 +- src/filecache.sml | 5 ++++- src/mysql.sml | 3 ++- src/postgres.sml | 3 ++- src/settings.sig | 8 +++++--- src/settings.sml | 2 +- 7 files changed, 17 insertions(+), 11 deletions(-) (limited to 'src/cjr_print.sml') diff --git a/src/c/urweb.c b/src/c/urweb.c index 4d9e8630..8a7c439a 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -5327,9 +5327,8 @@ uw_Basis_blob uw_Basis_check_filecache(uw_context ctx, uw_Basis_string hash) { // Hashes come formatted for printing by Postgres, which means they start with // two extra characters. Let's remove them. - if (!hash[0] || !hash[1]) - uw_error(ctx, FATAL, "Hash to check against file cache came in not in Postgres format: %s", hash); - hash += 2; + if (hash[0] == '\\' && hash[1] == 'x') + hash += 2; if (!dir) uw_error(ctx, FATAL, "Checking file cache when no directory is set"); diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 1e948943..4aa8d51e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3827,7 +3827,7 @@ fun p_sql env (ds, _) = | SOME _ => case #supportsSHA512 (Settings.currentDbms ()) of NONE => (ErrorMsg.error "Using file cache with database that doesn't support SHA512"; []) - | SOME line => [string line, newline, newline]) + | SOME r => [string (#InitializeDb r), newline, newline]) @ string (#sqlPrefix (Settings.currentDbms ())) :: pps) end diff --git a/src/filecache.sml b/src/filecache.sml index e2291c10..a0da4b05 100644 --- a/src/filecache.sml +++ b/src/filecache.sml @@ -81,7 +81,10 @@ fun instrument file = fun wrapCol (name, t) = case #1 t of TFfi ("Basis", "blob") => - "DIGEST(" ^ name ^ ", 'sha512')" + (case #supportsSHA512 (Settings.currentDbms ()) of + NONE => (ErrorMsg.error "DBMS doesn't support SHA512."; + "ERROR") + | SOME r => #GenerateHash r name) | TOption t' => wrapCol (name, t') | _ => name diff --git a/src/mysql.sml b/src/mysql.sml index 768c5441..a826f3ef 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1610,6 +1610,7 @@ val () = addDbms {name = "mysql", nestedRelops = false, windowFunctions = false, supportsIsDistinctFrom = true, - supportsSHA512 = NONE} + supportsSHA512 = SOME {InitializeDb = "", + GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}} end diff --git a/src/postgres.sml b/src/postgres.sml index a33a1de4..2b0a710d 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1154,7 +1154,8 @@ val () = addDbms {name = "postgres", nestedRelops = true, windowFunctions = true, supportsIsDistinctFrom = true, - supportsSHA512 = SOME "CREATE EXTENSION pgcrypto;"} + supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION pgcrypto;", + GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index 97d56b45..7ca7a0cd 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -222,9 +222,11 @@ signature SETTINGS = sig nestedRelops : bool, windowFunctions : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : string option (* If supported, give the SQL code to - * enable the feature in a particular - * database. *) + supportsSHA512 : {InitializeDb : string, + GenerateHash : string -> string} option + (* If supported, give the SQL code to + * enable the feature in a particular + * database and to compute a hash of a value. *) } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index ac403027..a31f5cda 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -652,7 +652,7 @@ type dbms = { nestedRelops : bool, windowFunctions: bool, supportsIsDistinctFrom : bool, - supportsSHA512 : string option + supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option } val dbmses = ref ([] : dbms list) -- cgit v1.2.3 From 96f0331923f4ff4508175ab36a018e92525f7849 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 31 May 2019 12:41:51 -0400 Subject: Retool handling of text keys in MySQL --- src/cjr_print.sml | 32 ++++++++++++++++++++++++++++++-- src/monoize.sml | 4 ++-- tests/foreign_text.ur | 4 ++++ tests/foreign_text.urp | 5 +++++ 4 files changed, 41 insertions(+), 4 deletions(-) create mode 100644 tests/foreign_text.ur create mode 100644 tests/foreign_text.urp (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 4aa8d51e..b9795194 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3744,6 +3744,26 @@ 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 (pps, _) = ListUtil.foldlMap @@ -3756,11 +3776,19 @@ 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"] diff --git a/src/monoize.sml b/src/monoize.sml index 97ad1505..4aeddcae 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1369,7 +1369,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique)))), loc), @@ -1413,7 +1413,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) ^ (if #textKeysNeedLengths (Settings.currentDbms ()) andalso isBlobby t then - "(767)" + "(255)" else "")) unique) ^ ")"), diff --git a/tests/foreign_text.ur b/tests/foreign_text.ur new file mode 100644 index 00000000..8f404349 --- /dev/null +++ b/tests/foreign_text.ur @@ -0,0 +1,4 @@ +table t : { A : string } PRIMARY KEY A +table u : { A : string } CONSTRAINT A FOREIGN KEY A REFERENCES t(A) + +val main : transaction page = return diff --git a/tests/foreign_text.urp b/tests/foreign_text.urp new file mode 100644 index 00000000..f0777eb6 --- /dev/null +++ b/tests/foreign_text.urp @@ -0,0 +1,5 @@ +dbms mysql +database dbname=foreign_text +sql foreign_text.sql + +foreign_text -- cgit v1.2.3 From 3101960af6d13eb44c12dfb1ca2381fd16136f0a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 31 May 2019 13:32:19 -0400 Subject: MySQL forces NOT NULL TIMESTAMPs to have default values --- src/cjr_print.sml | 8 +++++++- src/mysql.sml | 1 + src/postgres.sml | 1 + src/settings.sig | 1 + src/settings.sml | 2 ++ src/sqlite.sml | 1 + 6 files changed, 13 insertions(+), 1 deletion(-) (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b9795194..5dcfbe89 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3791,7 +3791,13 @@ fun p_sql env (ds, _) = 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 [] diff --git a/src/mysql.sml b/src/mysql.sml index e2b0b3b0..ff1c379d 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1609,6 +1609,7 @@ val () = addDbms {name = "mysql", onlyUnion = true, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = true, supportsIsDistinctFrom = true, supportsSHA512 = SOME {InitializeDb = "", GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}} diff --git a/src/postgres.sml b/src/postgres.sml index 2b0a710d..94f0e42e 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1153,6 +1153,7 @@ val () = addDbms {name = "postgres", onlyUnion = false, nestedRelops = true, windowFunctions = true, + requiresTimestampDefaults = false, supportsIsDistinctFrom = true, supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION pgcrypto;", GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}} diff --git a/src/settings.sig b/src/settings.sig index 7ca7a0cd..a2a56407 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -221,6 +221,7 @@ signature SETTINGS = sig onlyUnion : bool, nestedRelops : bool, windowFunctions : bool, + requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option diff --git a/src/settings.sml b/src/settings.sml index a31f5cda..a85e8053 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -651,6 +651,7 @@ type dbms = { onlyUnion : bool, nestedRelops : bool, windowFunctions: bool, + requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option } @@ -685,6 +686,7 @@ val curDb = ref ({name = "", onlyUnion = false, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = false, supportsIsDistinctFrom = false, supportsSHA512 = NONE} : dbms) diff --git a/src/sqlite.sml b/src/sqlite.sml index 0a3ae4ea..9bb86ecf 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -855,6 +855,7 @@ val () = addDbms {name = "sqlite", onlyUnion = false, nestedRelops = false, windowFunctions = false, + requiresTimestampDefaults = false, supportsIsDistinctFrom = false, supportsSHA512 = NONE} -- cgit v1.2.3 From 56bb940f305fb3d32cc218a6dbc8fa1b1fd7ef89 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 7 Oct 2019 16:47:39 -0400 Subject: Update urlification of unit values for RPC results, to track a previous change elsewhere --- src/cjr_print.sml | 59 ++++++++++++++++++++++--------------------------------- tests/rpc_unit.ur | 8 ++++++++ 2 files changed, 31 insertions(+), 36 deletions(-) create mode 100644 tests/rpc_unit.ur (limited to 'src/cjr_print.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 5dcfbe89..d7b8017e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -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) diff --git a/tests/rpc_unit.ur b/tests/rpc_unit.ur new file mode 100644 index 00000000..befd6045 --- /dev/null +++ b/tests/rpc_unit.ur @@ -0,0 +1,8 @@ +val callme = return ((), (), "A", (), ()) + +val main : transaction page = return +