From c1932084390aca19c748da024b7b168c160a3aea Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 14 Dec 2018 15:42:59 -0500 Subject: New .urp option: safeGetDefault --- src/settings.sig | 1 + 1 file changed, 1 insertion(+) (limited to 'src/settings.sig') diff --git a/src/settings.sig b/src/settings.sig index 986d6ed7..6ba7e96a 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -258,6 +258,7 @@ signature SETTINGS = sig val getFileCache : unit -> string option (* Which GET-able functions should be allowed to have side effects? *) + val setSafeGetDefault : bool -> unit val setSafeGets : string list -> unit val isSafeGet : string -> bool -- cgit v1.2.3 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 +++++++- src/mysql.sml | 2 +- src/postgres.sml | 2 +- src/settings.sig | 4 +++- src/settings.sml | 7 ++++--- src/sqlite.sml | 2 +- 6 files changed, 17 insertions(+), 8 deletions(-) (limited to 'src/settings.sig') 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 diff --git a/src/mysql.sml b/src/mysql.sml index e7cad84e..768c5441 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1610,6 +1610,6 @@ val () = addDbms {name = "mysql", nestedRelops = false, windowFunctions = false, supportsIsDistinctFrom = true, - supportsSHA512 = false} + supportsSHA512 = NONE} end diff --git a/src/postgres.sml b/src/postgres.sml index 2b6bee8c..a33a1de4 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1154,7 +1154,7 @@ val () = addDbms {name = "postgres", nestedRelops = true, windowFunctions = true, supportsIsDistinctFrom = true, - supportsSHA512 = true} + supportsSHA512 = SOME "CREATE EXTENSION pgcrypto;"} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index 6ba7e96a..f94525bb 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -220,7 +220,9 @@ signature SETTINGS = sig nestedRelops : bool, windowFunctions : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : bool + supportsSHA512 : string option (* If supported, give the SQL code to + * enable the feature in a particular + * database. *) } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index 3772fc04..6499da67 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -647,7 +647,7 @@ type dbms = { nestedRelops : bool, windowFunctions: bool, supportsIsDistinctFrom : bool, - supportsSHA512 : bool + supportsSHA512 : string option } val dbmses = ref ([] : dbms list) @@ -681,7 +681,7 @@ val curDb = ref ({name = "", nestedRelops = false, windowFunctions = false, supportsIsDistinctFrom = false, - supportsSHA512 = false} : dbms) + supportsSHA512 = NONE} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = @@ -728,7 +728,8 @@ fun getSigFile () = !sigFile val fileCache = ref (NONE : string option) fun setFileCache v = - (if Option.isSome v andalso not (#supportsSHA512 (currentDbms ())) then + (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 (); diff --git a/src/sqlite.sml b/src/sqlite.sml index db7052d1..0a3ae4ea 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -856,6 +856,6 @@ val () = addDbms {name = "sqlite", nestedRelops = false, windowFunctions = false, supportsIsDistinctFrom = false, - supportsSHA512 = false} + supportsSHA512 = NONE} end -- cgit v1.2.3 From 757e40719735a45085343e90b53674b9b276b5cb Mon Sep 17 00:00:00 2001 From: fab Date: Mon, 17 Dec 2018 22:25:59 +0000 Subject: test 5 --- configure.ac | 1 + src/compiler.sml | 4 ++-- src/config.sig | 3 +++ src/config.sml.in | 3 +++ src/settings.sig | 1 + src/settings.sml | 2 +- 6 files changed, 11 insertions(+), 3 deletions(-) (limited to 'src/settings.sig') diff --git a/configure.ac b/configure.ac index bd52aa4c..d6b1c98f 100644 --- a/configure.ac +++ b/configure.ac @@ -126,6 +126,7 @@ AC_SUBST(VERSION) AC_SUBST(PTHREAD_CFLAGS) AC_SUBST(PTHREAD_LIBS) AC_SUBST(ICU_INCLUDES) +AC_SUBST(ICU_LIBS) AC_CONFIG_FILES([ Makefile diff --git a/src/compiler.sml b/src/compiler.sml index 9ee88c9b..06615bcf 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1585,9 +1585,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a -licui18n -licuuc -licudata" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a -licui18n -licuuc -licudata" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" diff --git a/src/config.sig b/src/config.sig index a3ad7d76..be72a8cc 100644 --- a/src/config.sig +++ b/src/config.sig @@ -20,4 +20,7 @@ signature CONFIG = sig val pthreadCflags : string val pthreadLibs : string + + val icuIncludes : string + val icuLibs : string end diff --git a/src/config.sml.in b/src/config.sml.in index ebcdb7b6..2d12e28d 100644 --- a/src/config.sml.in +++ b/src/config.sml.in @@ -28,6 +28,9 @@ val pgheader = "@PGHEADER@" val msheader = "@MSHEADER@" val sqheader = "@SQHEADER@" +val icuIncludes = "@ICU_INCLUDES@" +val icuLibs = "@ICU_LIBS@" + val versionNumber = "@VERSION@" val versionString = "The Ur/Web compiler, version " ^ versionNumber diff --git a/src/settings.sig b/src/settings.sig index 986d6ed7..22dc80a2 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -37,6 +37,7 @@ signature SETTINGS = sig val configSrcLib : string ref val configInclude : string ref val configSitelisp : string ref + val configIcuLibs : string ref val libUr : unit -> string val libC : unit -> string diff --git a/src/settings.sml b/src/settings.sml index cfbe98a5..8ae2d377 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -32,7 +32,7 @@ val configLib = ref Config.lib val configSrcLib = ref Config.srclib val configInclude = ref Config.includ val configSitelisp = ref Config.sitelisp - +val configIcuLibs = ref Config.icuLibs val configCCompiler = ref Config.ccompiler fun getCCompiler () = !configCCompiler -- cgit v1.2.3 From 2d699b85cfb3f137e8963ad9a355918e40b39d62 Mon Sep 17 00:00:00 2001 From: fab Date: Mon, 17 Dec 2018 22:41:16 +0000 Subject: test 6 --- src/compiler.sml | 4 ++-- src/settings.sig | 1 + src/settings.sml | 1 + 3 files changed, 4 insertions(+), 2 deletions(-) (limited to 'src/settings.sig') diff --git a/src/compiler.sml b/src/compiler.sml index 06615bcf..1f77a821 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1585,9 +1585,9 @@ fun compileC {cname, oname, ename, libs, profile, debug, linker, link = link'} = val proto = Settings.currentProtocol () val lib = if Settings.getBootLinking () then - !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuIncludes ^ " " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else if Settings.getStaticLinking () then - " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" + " -static " ^ !Settings.configLib ^ "/" ^ #linkStatic proto ^ " " ^ !Settings.configLib ^ "/liburweb.a " ^ !Settings.configIcuIncludes ^ " " ^ !Settings.configIcuLibs ^ " -licui18n -licuuc -licudata" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" diff --git a/src/settings.sig b/src/settings.sig index 22dc80a2..29817467 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -37,6 +37,7 @@ signature SETTINGS = sig val configSrcLib : string ref val configInclude : string ref val configSitelisp : string ref + val configIcuIncludes : string ref val configIcuLibs : string ref val libUr : unit -> string diff --git a/src/settings.sml b/src/settings.sml index 8ae2d377..2e386a4f 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -32,6 +32,7 @@ val configLib = ref Config.lib val configSrcLib = ref Config.srclib val configInclude = ref Config.includ val configSitelisp = ref Config.sitelisp +val configIcuIncludes = ref Config.icuIncludes val configIcuLibs = ref Config.icuLibs val configCCompiler = ref Config.ccompiler -- 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/settings.sig') 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 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/settings.sig') 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 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/settings.sig') 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 2bca6e48c0ea8043c5300f4ebdefa5167e6472bf Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 4 Dec 2019 09:19:55 -0500 Subject: SQL SIMILAR (via pg_trgm) --- lib/ur/basis.urs | 10 ++++++++++ src/cjr.sml | 2 +- src/cjr_print.sml | 21 +++++++++++++++++---- src/mono.sml | 2 +- src/mono_print.sml | 21 +++++++++++---------- src/monoize.sml | 49 +++++++++++++++++++++++++++++++++++++++++++++++-- src/mysql.sml | 3 ++- src/postgres.sml | 5 +++-- src/settings.sig | 3 ++- src/settings.sml | 6 ++++-- src/sqlite.sml | 3 ++- src/urweb.grm | 9 +++++++++ tests/filter.urp | 1 + tests/trgm.ur | 25 +++++++++++++++++++++++++ tests/trgm.urp | 6 ++++++ tests/trgm.urs | 1 + 16 files changed, 142 insertions(+), 25 deletions(-) create mode 100644 tests/trgm.ur create mode 100644 tests/trgm.urp create mode 100644 tests/trgm.urs (limited to 'src/settings.sig') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index a97c2855..dda48d2b 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -623,6 +623,16 @@ val sql_known : t ::: Type -> sql_ufunc t bool val sql_lower : sql_ufunc string string val sql_upper : sql_ufunc string string +con sql_bfunc :: Type -> Type -> Type -> Type +val sql_bfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} + -> dom1 ::: Type -> dom2 ::: Type -> ran ::: Type + -> sql_bfunc dom1 dom2 ran + -> sql_exp tables agg exps dom1 + -> sql_exp tables agg exps dom2 + -> sql_exp tables agg exps ran +val sql_similarity : sql_bfunc string string float +(* Only supported by Postgres for now, via the pg_trgm module *) + val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type -> sql_injectable_prim t -> sql_exp tables agg exps t diff --git a/src/cjr.sml b/src/cjr.sml index e582e6ae..9b154428 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -115,7 +115,7 @@ datatype decl' = | DTable of string * (string * typ) list * string * (string * string) list | DSequence of string | DView of string * (string * typ) list * string - | DDatabase of {name : string, expunge : int, initialize : int} + | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool} | DPreparedStatements of (string * int) list | DJavaScript of string diff --git a/src/cjr_print.sml b/src/cjr_print.sml index d7b8017e..70ebdf43 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3230,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 @@ -3753,6 +3754,8 @@ fun declaresAsForeignKey xs s = fun p_sql env (ds, _) = let + val usesSimilar = ref false + val (pps, _) = ListUtil.foldlMap (fn (dAll as (d, _), env) => let @@ -3837,6 +3840,9 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DDatabase {usesSimilar = s, ...} => + (usesSimilar := s; + box []) | _ => box [] in (pp, E.declBinds env dAll) @@ -3849,6 +3855,13 @@ fun p_sql env (ds, _) = 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 diff --git a/src/mono.sml b/src/mono.sml index cdadded5..754fe283 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -142,7 +142,7 @@ datatype decl' = | DTable of string * (string * typ) list * exp * exp | DSequence of string | DView of string * (string * typ) list * exp - | DDatabase of {name : string, expunge : int, initialize : int} + | DDatabase of {name : string, expunge : int, initialize : int, usesSimilar : bool} | DJavaScript of string diff --git a/src/mono_print.sml b/src/mono_print.sml index a3b55ec0..1114a4f0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -509,16 +509,17 @@ fun p_decl env (dAll as (d, _) : decl) = space, p_exp env e, string "*)"] - | DDatabase {name, expunge, initialize} => box [string "database", - space, - string name, - space, - string "(", - p_enamed env expunge, - string ",", - space, - p_enamed env initialize, - string ")"] + | DDatabase {name, expunge, initialize, ...} => + box [string "database", + space, + string name, + space, + string "(", + p_enamed env expunge, + string ",", + space, + p_enamed env initialize, + string ")"] | DJavaScript s => box [string "JavaScript(", string s, string ")"] diff --git a/src/monoize.sml b/src/monoize.sml index 4aeddcae..22b4e0e7 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -50,11 +50,13 @@ structure RM = BinaryMapFn(struct (L'.TRecord r2, E.dummySpan)) end) +val uses_similar = ref false + local val url_prefixes = ref [] in -fun reset () = url_prefixes := [] +fun reset () = (url_prefixes := []; uses_similar := false) fun addPrefix prefix = let @@ -355,6 +357,8 @@ fun monoType env = (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_ufunc"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_bfunc"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_partition"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "sql_window"), _), _), _), _), _), _), _), _) => @@ -2693,6 +2697,40 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) + | L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "sql_bfunc"), _), + _), _), + _), _), + _), _), + _), _), + _), _), + _) => + let + val s = (L'.TFfi ("Basis", "string"), loc) + in + ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), + (L'.EAbs ("x1", s, s, + (L'.EAbs ("x2", s, s, + strcat [(L'.ERel 2, loc), + str "(", + (L'.ERel 1, loc), + str ",", + (L'.ERel 0, loc), + str ")"]), loc)), loc)), loc), + fm) + end + | L.EFfi ("Basis", "sql_similarity") => + ((case #supportsSimilar (Settings.currentDbms ()) of + NONE => ErrorMsg.errorAt loc "The DBMS you've selected doesn't support SIMILAR." + | _ => ()); + uses_similar := true; + (str "similarity", fm)) + | (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -4593,7 +4631,8 @@ fun monoize env file = in (env, Fm.enter fm, (L'.DDatabase {name = s, expunge = nExp, - initialize = nIni}, loc) + initialize = nIni, + usesSimilar = false}, loc) :: (dExp, loc) :: (dIni, loc) :: ds) @@ -4617,6 +4656,12 @@ fun monoize env file = | _ => ds' @ Fm.decls fm @ (L'.DDatatype (!pvarDefs), loc) :: ds))) (env, Fm.empty mname, []) file + val ds = map (fn (L'.DDatabase r, loc) => + (L'.DDatabase {name = #name r, + expunge = #expunge r, + initialize = #initialize r, + usesSimilar = !uses_similar}, loc) + | x => x) ds val monoFile = (rev ds, []) in pvars := RM.empty; diff --git a/src/mysql.sml b/src/mysql.sml index ff1c379d..74954c0f 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1612,6 +1612,7 @@ val () = addDbms {name = "mysql", requiresTimestampDefaults = true, supportsIsDistinctFrom = true, supportsSHA512 = SOME {InitializeDb = "", - GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}} + GenerateHash = fn name => "SHA2(" ^ name ^ ", 512)"}, + supportsSimilar = NONE} end diff --git a/src/postgres.sml b/src/postgres.sml index 94f0e42e..3e53ed77 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -1155,8 +1155,9 @@ val () = addDbms {name = "postgres", windowFunctions = true, requiresTimestampDefaults = false, supportsIsDistinctFrom = true, - supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION pgcrypto;", - GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}} + supportsSHA512 = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pgcrypto;", + GenerateHash = fn name => "DIGEST(" ^ name ^ ", 'sha512')"}, + supportsSimilar = SOME {InitializeDb = "CREATE EXTENSION IF NOT EXISTS pg_trgm;"}} val () = setDbms "postgres" diff --git a/src/settings.sig b/src/settings.sig index a2a56407..6a409cdd 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -224,10 +224,11 @@ signature SETTINGS = sig requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, supportsSHA512 : {InitializeDb : string, - GenerateHash : string -> string} option + 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. *) + supportsSimilar : {InitializeDb : string} option } val addDbms : dbms -> unit diff --git a/src/settings.sml b/src/settings.sml index a85e8053..c8cb049c 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -653,7 +653,8 @@ type dbms = { windowFunctions: bool, requiresTimestampDefaults : bool, supportsIsDistinctFrom : bool, - supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option + supportsSHA512 : {InitializeDb : string, GenerateHash : string -> string} option, + supportsSimilar : {InitializeDb : string} option } val dbmses = ref ([] : dbms list) @@ -688,7 +689,8 @@ val curDb = ref ({name = "", windowFunctions = false, requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = NONE} : dbms) + supportsSHA512 = NONE, + supportsSimilar = NONE} : dbms) fun addDbms v = dbmses := v :: !dbmses fun setDbms s = diff --git a/src/sqlite.sml b/src/sqlite.sml index 9bb86ecf..0e97bf69 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -857,6 +857,7 @@ val () = addDbms {name = "sqlite", windowFunctions = false, requiresTimestampDefaults = false, supportsIsDistinctFrom = false, - supportsSHA512 = NONE} + supportsSHA512 = NONE, + supportsSimilar = NONE} end diff --git a/src/urweb.grm b/src/urweb.grm index afebff0a..dea7bdf5 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -2276,6 +2276,15 @@ sqlexp : TRUE (sql_inject (EVar (["Basis"], "True", In val e = (EApp (e, fname), loc) in (EApp (e, sqlexp), loc) + end) + | fname LPAREN sqlexp COMMA sqlexp RPAREN (let + val loc = s (fnameleft, RPARENright) + + val e = (EVar (["Basis"], "sql_bfunc", Infer), loc) + val e = (EApp (e, fname), loc) + val e = (EApp (e, sqlexp1), loc) + in + (EApp (e, sqlexp2), loc) end) | LPAREN query RPAREN (let val loc = s (LPARENleft, RPARENright) diff --git a/tests/filter.urp b/tests/filter.urp index 102a1871..ddf1a3df 100644 --- a/tests/filter.urp +++ b/tests/filter.urp @@ -1,4 +1,5 @@ debug database dbname=filter +sql filter.sql filter diff --git a/tests/trgm.ur b/tests/trgm.ur new file mode 100644 index 00000000..45783366 --- /dev/null +++ b/tests/trgm.ur @@ -0,0 +1,25 @@ +table turtles : { Nam : string } + +fun add name = + dml (INSERT INTO turtles(Nam) + VALUES ({[name]})) + +fun closest name = + List.mapQuery (SELECT * + FROM turtles + ORDER BY similarity(turtles.Nam, {[name]}) DESC + LIMIT 5) + (fn r => r.Turtles.Nam) + +val main = + name <- source ""; + results <- source []; + return + Name:
+