diff options
40 files changed, 790 insertions, 374 deletions
diff --git a/doc/manual.tex b/doc/manual.tex index ba53f5d8..64fe0f24 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -238,6 +238,10 @@ Further \cd{urweb} invocations in the same working directory will send requests \begin{verbatim} urweb daemon stop \end{verbatim} +To restart a running (or crashed) daemon, run +\begin{verbatim} +urweb daemon restart +\end{verbatim} Communication happens via a UNIX domain socket in file \cd{.urweb\_daemon} in the working directory. \medskip @@ -2573,6 +2577,7 @@ It is possible to write JavaScript FFI code that interacts with the functional-r \item \cd{sr(v)} and \cd{sb(s, f)}, the ``return'' and ``bind'' monad operators, respectively \item \cd{ss(s)}, to produce the signal corresponding to source \cd{s} \item \cd{scur(s)}, to get the current value of signal \cd{s} + \item \cd{listen(s, f)}, to ask that function \cd{f} be called with the current value of \cd{s}, every time it changes, including immediately upon establishing this listener \end{itemize} \item The behavior of the \cd{<dyn>} pseudo-tag may be mimicked by following the right convention in a piece of HTML source code with a type like $\mt{xbody}$. Such a piece of source code may be encoded with a JavaScript string. To insert a dynamic section, include a \cd{<script>} tag whose content is just a call \cd{dyn(pnode, s)}. The argument \cd{pnode} specifies what the relevant enclosing parent tag is. Use value \cd{"tr"} when the immediate parent is \cd{<tr>}, use \cd{"table"} when the immediate parent is \cd{<table>}, and use \cd{"span"} otherwise. The argument \cd{s} is a string-valued signal giving the HTML code to be inserted at this point. As with the usual \cd{<dyn>} tag, that HTML subtree is automatically updated as the value of \cd{s} changes. diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index dcf67fef..e4ad6e61 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -166,6 +166,7 @@ uw_Basis_string uw_Basis_strchr(struct uw_context *, const char *, uw_Basis_char uw_Basis_int uw_Basis_strcspn(struct uw_context *, const char *, const char *); uw_Basis_string uw_Basis_substring(struct uw_context *, const char *, uw_Basis_int, uw_Basis_int); uw_Basis_string uw_Basis_str1(struct uw_context *, uw_Basis_char); +uw_Basis_string uw_Basis_ofUnicode(struct uw_context *, uw_Basis_int); uw_Basis_string uw_strdup(struct uw_context *, const char *); uw_Basis_string uw_maybe_strdup(struct uw_context *, const char *); diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 66d427c8..59e5ad2c 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -2135,6 +2135,16 @@ function active(s) { } } +function listen(s, onchange) { + var x = document.createElement("script"); + x.dead = false; + x.signal = s; + x.sources = null; + x.closures = null; + x.recreate = onchange; + populate(x); +} + function input(x, s, recreate, type, name) { if (name) x.name = name; if (type) x.type = type; @@ -3270,7 +3280,7 @@ function confrm(s) { } function currentUrl() { - return window.location; + return window.location.toString(); } diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index be13c684..dda48d2b 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -95,6 +95,7 @@ val strsindex : string -> string -> option int val strcspn : string -> string -> int val substring : string -> int -> int -> string val str1 : char -> string +val ofUnicode : int -> string class show val show : t ::: Type -> show t -> t -> string @@ -571,9 +572,6 @@ val sql_div : t ::: Type -> sql_arith t -> sql_binary t t t val sql_mod : sql_binary int int int val sql_eq : t ::: Type -> sql_binary t t bool -(* Note that the semantics of this operator on nullable types are different than for standard SQL! - * Instead, we do it the sane way, where [NULL = NULL]. *) - val sql_ne : t ::: Type -> sql_binary t t bool val sql_lt : t ::: Type -> sql_binary t t bool val sql_le : t ::: Type -> sql_binary t t bool @@ -625,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 @@ -1076,7 +1084,7 @@ val ctel : ctext val ccolor : ctext val cnumber : cformTag ([Source = source (option float), Min = float, Max = float, Step = float, Size = int] ++ boxAttrs ++ inputAttrs) [] -val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int] ++ boxAttrs ++ inputAttrs) [] +val crange : cformTag ([Source = source (option float), Min = float, Max = float, Size = int, Step = float] ++ boxAttrs ++ inputAttrs) [] val cdate : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val cdatetime : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] val cdatetime_local : cformTag ([Source = source string, Min = string, Max = string, Size = int] ++ boxAttrs ++ inputAttrs) [] diff --git a/lib/ur/datetime.ur b/lib/ur/datetime.ur index 9aeab291..99fd5a7d 100644 --- a/lib/ur/datetime.ur +++ b/lib/ur/datetime.ur @@ -88,7 +88,8 @@ fun intToMonth i = case i of | n => error <xml>Invalid month number {[n]}</xml> val eq_month = mkEq (fn a b => monthToInt a = monthToInt b) - +val ord_month = mkOrd {Lt = fn a b => monthToInt a < monthToInt b, + Le = fn a b => monthToInt a <= monthToInt b} fun toTime dt : time = fromDatetime dt.Year (monthToInt dt.Month) dt.Day dt.Hour dt.Minute dt.Second diff --git a/lib/ur/datetime.urs b/lib/ur/datetime.urs index 972f86bf..f8460443 100644 --- a/lib/ur/datetime.urs +++ b/lib/ur/datetime.urs @@ -20,6 +20,7 @@ val show_day_of_week : show day_of_week val show_month : show month val eq_day_of_week : eq day_of_week val eq_month : eq month +val ord_month : ord month val dayOfWeekToInt : day_of_week -> int val intToDayOfWeek : int -> day_of_week val monthToInt : month -> int diff --git a/lib/ur/json.ur b/lib/ur/json.ur index 05406739..58822d4b 100644 --- a/lib/ur/json.ur +++ b/lib/ur/json.ur @@ -59,42 +59,71 @@ fun escape s = "\"" ^ esc s end +fun unhex ch = + if Char.isDigit ch then + Char.toInt ch - Char.toInt #"0" + else if Char.isXdigit ch then + if Char.isUpper ch then + 10 + (Char.toInt ch - Char.toInt #"A") + else + 10 + (Char.toInt ch - Char.toInt #"a") + else + error <xml>Invalid hexadecimal digit "{[ch]}"</xml> + fun unescape s = let val len = String.length s - fun findEnd i = + fun findEnd i s = if i >= len then error <xml>JSON unescape: string ends before quote: {[s]}</xml> else let - val ch = String.sub s i + val ch = String.sub s 0 in case ch of #"\"" => i | #"\\" => if i+1 >= len then error <xml>JSON unescape: Bad escape sequence: {[s]}</xml> + else if String.sub s 1 = #"u" then + if i+5 >= len then + error <xml>JSON unescape: Bad escape sequence: {[s]}</xml> + else + findEnd (i+6) (String.suffix s 6) else - findEnd (i+2) - | _ => findEnd (i+1) + findEnd (i+2) (String.suffix s 2) + | _ => findEnd (i+1) (String.suffix s 1) end - val last = findEnd 1 + val last = findEnd 1 (String.suffix s 1) - fun unesc i = + fun unesc i s = if i >= last then "" else let - val ch = String.sub s i + val ch = String.sub s 0 in case ch of #"\\" => if i+1 >= len then error <xml>JSON unescape: Bad escape sequence: {[s]}</xml> + else if String.sub s 1 = #"u" then + if i+5 >= len then + error <xml>JSON unescape: Unicode ends early</xml> + else + let + val n = + unhex (String.sub s 2) * (256*16) + + unhex (String.sub s 3) * 256 + + unhex (String.sub s 4) * 16 + + unhex (String.sub s 5) + in + ofUnicode n ^ unesc (i+6) (String.suffix s 6) + end else - (case String.sub s (i+1) of + (case String.sub s 1 of #"n" => "\n" | #"r" => "\r" | #"t" => "\t" @@ -103,19 +132,66 @@ fun unescape s = | #"/" => "/" | x => error <xml>JSON unescape: Bad escape char: {[x]}</xml>) ^ - unesc (i+2) - | _ => String.str ch ^ unesc (i+1) + unesc (i+2) (String.suffix s 2) + | _ => String.str ch ^ unesc (i+1) (String.suffix s 1) end in if len = 0 || String.sub s 0 <> #"\"" then error <xml>JSON unescape: String doesn't start with double quote: {[s]}</xml> else - (unesc 1, String.substring s {Start = last+1, Len = len-last-1}) + (unesc 1 (String.suffix s 1), String.suffix s (last+1)) end val json_string = {ToJson = escape, FromJson = unescape} +fun rfc3339_out s = + let + val out1 = timef "%Y-%m-%dT%H:%M:%S%z" s + val len = String.length out1 + in + if len < 2 then + error <xml>timef output too short</xml> + else + String.substring out1 {Start = 0, Len = len - 2} ^ ":" + ^ String.suffix out1 (len - 2) + end + +fun rfc3339_in s = + case String.split s #"T" of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some (date, time) => + case String.msplit {Haystack = time, Needle = "Z+-"} of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some (time, sep, rest) => + let + val t = case readUtc (date ^ " " ^ time) of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some t => t + + fun withOffset multiplier = + case String.split rest #":" of + None => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + | Some (h, m) => + case (read h, read m) of + (Some h, Some m) => addSeconds t (multiplier * 60 * (60 * h + m)) + | _ => error <xml>Invalid RFC 3339 string "{[s]}"</xml> + in + case sep of + #"Z" => t + | #"+" => withOffset (-1) + | #"-" => withOffset 1 + | _ => error <xml>msplit returns impossible separator</xml> + end + +val json_time = {ToJson = fn tm => escape (rfc3339_out tm), + FromJson = fn s => + let + val (v, s') = unescape s + in + (rfc3339_in v, s') + end} + fun numIn [a] (_ : read a) s : a * string = let val len = String.length s @@ -258,6 +334,91 @@ fun skipOne s = skipOne s False False 0 0 end +fun json_record_withOptional [ts ::: {Type}] [ots ::: {Type}] [ts ~ ots] + (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) + (ofl : folder ots) (ojss : $(map json ots)) (onames : $(map (fn _ => string) ots)): json $(ts ++ map option ots) = + {ToJson = fn r => + let + val withRequired = + @foldR3 [json] [fn _ => string] [ident] [fn _ => string] + (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc => + escape name ^ ":" ^ j.ToJson v ^ (case acc of + "" => "" + | acc => "," ^ acc)) + "" fl jss names (r --- _) + + val withOptional = + @foldR3 [json] [fn _ => string] [option] [fn _ => string] + (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc => + case v of + None => acc + | Some v => + escape name ^ ":" ^ j.ToJson v ^ (case acc of + "" => "" + | acc => "," ^ acc)) + "" ofl ojss onames (r --- _) + in + "{" ^ withOptional ^ "}" + end, + FromJson = fn s => + let + fun fromJ s (r : $(map option (ts ++ ots))) : $(map option (ts ++ ots)) * string = + if String.length s = 0 then + error <xml>JSON object doesn't end in brace</xml> + else if String.sub s 0 = #"}" then + (r, String.substring s {Start = 1, Len = String.length s - 1}) + else let + val (name, s') = unescape s + val s' = skipSpaces s' + val s' = if String.length s' = 0 || String.sub s' 0 <> #":" then + error <xml>No colon after JSON object field name</xml> + else + skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1}) + + val (r, s') = @foldR2 [json] [fn _ => string] [fn ts => $(map option ts) -> $(map option ts) * string] + (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name' acc r => + if name = name' then + let + val (v, s') = j.FromJson s' + in + (r -- nm ++ {nm = Some v}, s') + end + else + let + val (r', s') = acc (r -- nm) + in + (r' ++ {nm = r.nm}, s') + end) + (fn r => (r, skipOne s')) + (@Folder.concat ! fl ofl) (jss ++ ojss) (names ++ onames) r + + val s' = skipSpaces s' + val s' = if String.length s' <> 0 && String.sub s' 0 = #"," then + skipSpaces (String.substring s' {Start = 1, Len = String.length s' - 1}) + else + s' + in + fromJ s' r + end + in + if String.length s = 0 || String.sub s 0 <> #"{" then + error <xml>JSON record doesn't begin with brace</xml> + else + let + val (r, s') = fromJ (skipSpaces (String.substring s {Start = 1, Len = String.length s - 1})) + (@map0 [option] (fn [t ::_] => None) (@Folder.concat ! fl ofl)) + in + (@map2 [option] [fn _ => string] [ident] (fn [t] (v : option t) name => + case v of + None => error <xml>Missing JSON object field {[name]}</xml> + | Some v => v) fl (r --- _) names + ++ (r --- _), s') + end +end} + +(* At the moment, the below code is largely copied and pasted from the last + * definition, because otherwise the compiler fails to inline enough for + * compilation to succeed. *) fun json_record [ts ::: {Type}] (fl : folder ts) (jss : $(map json ts)) (names : $(map (fn _ => string) ts)) : json $ts = {ToJson = fn r => "{" ^ @foldR3 [json] [fn _ => string] [ident] [fn _ => string] (fn [nm ::_] [t ::_] [r ::_] [[nm] ~ r] (j : json t) name v acc => diff --git a/lib/ur/json.urs b/lib/ur/json.urs index b4bd6350..ad49a40f 100644 --- a/lib/ur/json.urs +++ b/lib/ur/json.urs @@ -13,10 +13,20 @@ val json_string : json string val json_int : json int val json_float : json float val json_bool : json bool +val json_time : json time val json_option : a ::: Type -> json a -> json (option a) val json_list : a ::: Type -> json a -> json (list a) +(* By the way, time formatting follows RFC 3339, and we expose the more + * primitive formatting functions here. *) +val rfc3339_out : time -> string +val rfc3339_in : string -> time + val json_record : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json $ts +val json_record_withOptional : ts ::: {Type} -> ots ::: {Type} -> [ts ~ ots] + => folder ts -> $(map json ts) -> $(map (fn _ => string) ts) + -> folder ots -> $(map json ots) -> $(map (fn _ => string) ots) + -> json $(ts ++ map option ots) val json_variant : ts ::: {Type} -> folder ts -> $(map json ts) -> $(map (fn _ => string) ts) -> json (variant ts) val json_unit : json unit diff --git a/src/c/Makefile.am b/src/c/Makefile.am index 95582793..ff4b6eaf 100644 --- a/src/c/Makefile.am +++ b/src/c/Makefile.am @@ -11,7 +11,7 @@ AM_CFLAGS = -Wall -Wunused-parameter -Werror -Wno-format-security -Wno-deprecate liburweb_la_LDFLAGS = $(AM_LDFLAGS) $(OPENSSL_LDFLAGS) \ -export-symbols-regex '^(client_pruner|pthread_create_big|strcmp_nullsafe|uw_.*)' \ -version-info 1:0:0 -liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata +liburweb_la_LIBADD = $(PTHREAD_LIBS) -lm $(OPENSSL_LIBS) $(ICU_LIBS) -licui18n -licuuc -licudata -licuio liburweb_http_la_LIBADD = liburweb.la liburweb_http_la_LDFLAGS = -export-symbols-regex '^(main|uw_.*)' \ -version-info 1:0:0 diff --git a/src/c/http.c b/src/c/http.c index 68c16e0b..c1fccf4a 100644 --- a/src/c/http.c +++ b/src/c/http.c @@ -65,6 +65,7 @@ static void log_error(void *data, const char *fmt, ...) { va_start(ap, fmt); vfprintf(stderr, fmt, ap); + fflush(stderr); } static void log_debug(void *data, const char *fmt, ...) { @@ -75,6 +76,7 @@ static void log_debug(void *data, const char *fmt, ...) { va_start(ap, fmt); vprintf(fmt, ap); + fflush(stdout); } } diff --git a/src/c/urweb.c b/src/c/urweb.c index b820354f..a01b4aae 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -21,6 +21,7 @@ #include <pthread.h> #include <unicode/utf8.h> +#include <unicode/ustring.h> #include <unicode/uchar.h> #include "types.h" @@ -2344,10 +2345,23 @@ char *uw_Basis_htmlifySpecialChar(uw_context ctx, uw_Basis_char ch) { uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { unsigned int n = ch; - int len; + int len = 0; uw_check(ctx, INTS_MAX+3); - len = sprintf(ctx->page.front, "&#%u;", n); + + if(uw_Basis_isprint(ctx, ch)) { + + int32_t len_written = 0; + UErrorCode err = U_ZERO_ERROR; + + u_strToUTF8(ctx->page.front, 5, &len_written, (const UChar*)&ch, 1, &err); + len = len_written; + } + + // either it's a non-printable character, or we failed to convert to UTF-8 + if(len == 0) { + len = sprintf(ctx->page.front, "&#%u;", n); + } ctx->page.front += len; return uw_unit_v; @@ -2459,7 +2473,7 @@ uw_unit uw_Basis_htmlifyString_w(uw_context ctx, uw_Basis_string s) { else { uw_Basis_htmlifySpecialChar_w(ctx, c1); } - } + } return uw_unit_v; } @@ -2710,6 +2724,18 @@ uw_Basis_string uw_Basis_str1(uw_context ctx, uw_Basis_char ch) { return r; } +uw_Basis_string uw_Basis_ofUnicode(uw_context ctx, uw_Basis_int n) { + UChar buf16[] = {n}; + uw_Basis_string out = uw_malloc(ctx, 3); + int32_t outLen; + UErrorCode pErrorCode = 0; + + if (u_strToUTF8(out, 3, &outLen, buf16, 1, &pErrorCode) == NULL || outLen == 0) + uw_error(ctx, FATAL, "Bad Unicode string to unescape (error %s)", u_errorName(pErrorCode)); + + return out; +} + uw_Basis_string uw_strdup(uw_context ctx, uw_Basis_string s1) { int len = strlen(s1) + 1; char *s; @@ -4915,13 +4941,13 @@ uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) { f = uw_malloc(ctx, sizeof(uw_Basis_postField)); unurl = s; - f->name = uw_Basis_unurlifyString(ctx, &unurl); + f->name = uw_Basis_unurlifyString_fromClient(ctx, &unurl); s = strchr(s, 0); if (!s) uw_error(ctx, FATAL, "firstFormField: Missing null terminator"); ++s; unurl = s; - f->value = uw_Basis_unurlifyString(ctx, &unurl); + f->value = uw_Basis_unurlifyString_fromClient(ctx, &unurl); s = strchr(s, 0); if (!s) uw_error(ctx, FATAL, "firstFormField: Missing null terminator"); 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 5dcfbe89..70ebdf43 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) @@ -3243,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 @@ -3766,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 @@ -3850,6 +3840,9 @@ fun p_sql env (ds, _) = string ";", newline, newline] + | DDatabase {usesSimilar = s, ...} => + (usesSimilar := s; + box []) | _ => box [] in (pp, E.declBinds env dAll) @@ -3862,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/compiler.sml b/src/compiler.sml index 0aba3a40..fab939f9 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -745,7 +745,7 @@ fun parseUrp' accLibs fname = | "relation" => Settings.Relation | "cookie" => Settings.Cookie | "style" => Settings.Style - | _ => (ErrorMsg.error "Bad path kind spec"; + | _ => (ErrorMsg.error ("Bad path kind spec \"" ^ s ^ "\""); Settings.Any) fun parsePattern s = @@ -1610,9 +1610,13 @@ 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.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" 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.configIcuLibs ^ " -licui18n -licuuc -licudata -licuio" else "-L" ^ !Settings.configLib ^ " " ^ #linkDynamic proto ^ " -lurweb" diff --git a/src/elab_err.sig b/src/elab_err.sig index acf137df..fc80fcac 100644 --- a/src/elab_err.sig +++ b/src/elab_err.sig @@ -29,6 +29,7 @@ signature ELAB_ERR = sig datatype kind_error = UnboundKind of ErrorMsg.span * string + | KDisallowedWildcard of ErrorMsg.span val kindError : ElabEnv.env -> kind_error -> unit @@ -47,6 +48,7 @@ signature ELAB_ERR = sig | DuplicateField of ErrorMsg.span * string | ProjBounds of Elab.con * int | ProjMismatch of Elab.con * Elab.kind + | CDisallowedWildcard of ErrorMsg.span val conError : ElabEnv.env -> con_error -> unit diff --git a/src/elab_err.sml b/src/elab_err.sml index 385caca3..bbe1c160 100644 --- a/src/elab_err.sml +++ b/src/elab_err.sml @@ -40,11 +40,14 @@ val p_kind = P.p_kind datatype kind_error = UnboundKind of ErrorMsg.span * string + | KDisallowedWildcard of ErrorMsg.span fun kindError env err = case err of UnboundKind (loc, s) => ErrorMsg.errorAt loc ("Unbound kind variable " ^ s) + | KDisallowedWildcard loc => + ErrorMsg.errorAt loc "Wildcard not allowed in signature" datatype kunify_error = KOccursCheckFailed of kind * kind @@ -76,6 +79,7 @@ datatype con_error = | DuplicateField of ErrorMsg.span * string | ProjBounds of con * int | ProjMismatch of con * kind + | CDisallowedWildcard of ErrorMsg.span fun conError env err = case err of @@ -101,6 +105,8 @@ fun conError env err = (ErrorMsg.errorAt (#2 c) "Projection from non-tuple constructor"; eprefaces' [("Constructor", p_con env c), ("Kind", p_kind env k)]) + | CDisallowedWildcard loc => + ErrorMsg.errorAt loc "Wildcard not allowed in signature" datatype cunify_error = CKind of kind * kind * E.env * kunify_error diff --git a/src/elab_util.sml b/src/elab_util.sml index 0cdb9cc1..aa5bc6a4 100644 --- a/src/elab_util.sml +++ b/src/elab_util.sml @@ -541,11 +541,13 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = and mfed ctx (dAll as (d, loc)) = case d of EDVal (p, t, e) => - S.bind2 (mfc ctx t, - fn t' => - S.map2 (mfe ctx e, - fn e' => - (EDVal (p, t', e'), loc))) + S.bind2 (mfp ctx p, + fn p' => + S.bind2 (mfc ctx t, + fn t' => + S.map2 (mfe ctx e, + fn e' => + (EDVal (p', t', e'), loc)))) | EDValRec vis => let val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis diff --git a/src/elaborate.sml b/src/elaborate.sml index 1c76250f..d5e190fa 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -260,6 +260,21 @@ end + (* Wildcards are disallowed inside signatures. + * We use a flag to indicate when we are in a signature, + * with a helper function for entering this mode and properly backing out afterward. *) + val inSignature = ref false + fun enterSignature' b f = + let + val inS = !inSignature + in + inSignature := b; + (f () handle ex => (inSignature := inS; raise ex)) + before inSignature := inS + end + fun enterSignature f = enterSignature' true f + fun exitSignature f = enterSignature' false f + fun elabKind env (k, loc) = case k of L.KType => (L'.KType, loc) @@ -268,7 +283,7 @@ | L.KRecord k => (L'.KRecord (elabKind env k), loc) | L.KUnit => (L'.KUnit, loc) | L.KTuple ks => (L'.KTuple (map (elabKind env) ks), loc) - | L.KWild => kunif env loc + | L.KWild => if !inSignature then (kindError env (KDisallowedWildcard loc); kerror) else kunif env loc | L.KVar s => (case E.lookupK env s of NONE => @@ -531,11 +546,15 @@ end | L.CWild k => - let - val k' = elabKind env k - in - (cunif env (loc, k'), k', []) - end + if !inSignature then + (conError env (CDisallowedWildcard loc); + (cerror, kerror, [])) + else + let + val k' = elabKind env k + in + (cunif env (loc, k'), k', []) + end fun kunifsRemain k = case k of @@ -2560,7 +2579,10 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val k' = case ko of NONE => kunif env loc - | SOME k => elabKind env k + | SOME k => exitSignature (fn () => elabKind env k) + (* Waive wildcard restriction within translation + * of kind annotation. The kind of [c] will allow + * us to resolve it fully. *) val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') @@ -2712,7 +2734,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val ct = (L'.CApp (ct, c'), loc) val ct = (L'.CApp (ct, (L'.CConcat (pkey, uniques), loc)), loc) - val (pe', pet, gs'') = elabExp (env', denv) pe + val (pe', pet, gs'') = exitSignature (fn () => elabExp (env', denv) pe) val gs'' = List.mapPartial (fn Disjoint x => SOME x | _ => NONE) gs'' @@ -2720,7 +2742,7 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = val pst = (L'.CApp (pst, c'), loc) val pst = (L'.CApp (pst, pkey), loc) - val (ce', cet, gs''') = elabExp (env', denv) ce + val (ce', cet, gs''') = exitSignature (fn () => elabExp (env', denv) ce) val gs''' = List.mapPartial (fn Disjoint x => SOME x | _ => NONE) gs''' @@ -4146,7 +4168,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = | L.DSgn (x, sgn) => let - val (sgn', gs') = elabSgn (env, denv) sgn + val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn) val (env', n) = E.pushSgnNamed env x sgn' in ([(L'.DSgn (x, n, sgn'), loc)], (env', denv, enD gs' @ gs)) @@ -4172,7 +4194,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = else () - val formal = Option.map (elabSgn (env, denv)) sgno + val formal = enterSignature (fn () => Option.map (elabSgn (env, denv)) sgno) val (str', sgn', gs') = case formal of @@ -4227,7 +4249,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = let val () = ErrorMsg.startElabStructure x - val (sgn', gs') = elabSgn (env, denv) sgn + val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn) val (env', n) = E.pushStrNamed env x sgn' @@ -4747,6 +4769,7 @@ fun elabFile basis basis_tm topStr topSgn top_tm env file = val () = mayDelay := true val () = delayedUnifs := [] val () = delayedExhaustives := [] + val () = inSignature := false val d = (L.DFfiStr ("Basis", (L.SgnConst basis, ErrorMsg.dummySpan), SOME basis_tm), ErrorMsg.dummySpan) val (basis_n, env', sgn) = diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bbee8c90..7f8540f2 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -107,6 +107,8 @@ fun usage flag_info = (* Encapsulate main invocation handler in a function, possibly to be called multiple times within a daemon. *) +exception DaemonExit + fun oneRun args = let val timing = ref false @@ -261,7 +263,8 @@ fun oneRun args = ] val () = case args of - ["daemon", "stop"] => OS.Process.exit OS.Process.success + ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => (); + raise DaemonExit) | _ => () val sources = parse_flags (flag_info ()) args @@ -324,128 +327,138 @@ fun send (sock, s) = send (sock, String.extract (s, n, NONE)) end -val () = (Globals.setResetTime (); - case CommandLine.arguments () of - ["daemon", "start"] => - (case Posix.Process.fork () of - SOME _ => () - | NONE => - let - val () = Elaborate.incremental := true - val listen = UnixSock.Strm.socket () - - fun loop () = - let - val (sock, _) = Socket.accept listen - - fun loop' (buf, args) = - let - val s = if CharVector.exists (fn ch => ch = #"\n") buf then - "" - else - MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024)))) - val s = buf ^ s - val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s) - in - if Substring.isEmpty after then - loop' (s, args) - else - let - val cmd = Substring.string befor - val rest = Substring.string (Substring.slice (after, 1, NONE)) - in - case cmd of - "" => - (case args of - ["stop", "daemon"] => - (((Socket.close listen; - OS.FileSys.remove socket) handle OS.SysErr _ => ()); - OS.Process.exit OS.Process.success) - | _ => - let - val success = (oneRun (rev args)) - handle ex => (print "unhandled exception:\n"; - print (General.exnMessage ex ^ "\n"); - OS.Process.failure) - in - TextIO.flushOut TextIO.stdOut; - TextIO.flushOut TextIO.stdErr; - send (sock, if OS.Process.isSuccess success then - "\001" - else - "\002") - end) - | _ => loop' (rest, cmd :: args) - end - end handle OS.SysErr _ => () - - fun redirect old = - Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)), - new = old} - - val oldStdout = Posix.IO.dup Posix.FileSys.stdout - val oldStderr = Posix.IO.dup Posix.FileSys.stderr - in - (* Redirect the daemon's output to the socket. *) - redirect Posix.FileSys.stdout; - redirect Posix.FileSys.stderr; - - loop' ("", []); - Socket.close sock; - - Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout}; - Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr}; - Posix.IO.close oldStdout; - Posix.IO.close oldStderr; - - Settings.reset (); - MLton.GC.pack (); - loop () - end - in - OS.Process.atExit (fn () => OS.FileSys.remove socket); - Socket.bind (listen, UnixSock.toAddr socket); - Socket.listen (listen, 1); - loop () - end) - | args => +fun startDaemon () = + if OS.FileSys.access (socket, []) then + (print ("It looks like a daemon is already listening in this directory,\n" + ^ "though it's possible a daemon died without cleaning up its socket.\n"); + OS.Process.exit OS.Process.failure) + else case Posix.Process.fork () of + SOME _ => () + | NONE => let - val sock = UnixSock.Strm.socket () + val () = Elaborate.incremental := true + val listen = UnixSock.Strm.socket () - fun wait () = + fun loop () = let - val v = Socket.recvVec (sock, 1024) - in - if Word8Vector.length v = 0 then - OS.Process.failure - else + val (sock, _) = Socket.accept listen + + fun loop' (buf, args) = let - val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v)) - val last = Word8Vector.sub (v, Word8Vector.length v - 1) - val (rc, s) = if last = Word8.fromInt 1 then - (SOME OS.Process.success, String.substring (s, 0, size s - 1)) - else if last = Word8.fromInt 2 then - (SOME OS.Process.failure, String.substring (s, 0, size s - 1)) - else - (NONE, s) + val s = if CharVector.exists (fn ch => ch = #"\n") buf then + "" + else + MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly (Socket.recvVec (sock, 1024)))) + val s = buf ^ s + val (befor, after) = Substring.splitl (fn ch => ch <> #"\n") (Substring.full s) in - print s; - case rc of - NONE => wait () - | SOME rc => rc - end - end handle OS.SysErr _ => OS.Process.failure + if Substring.isEmpty after then + loop' (s, args) + else + let + val cmd = Substring.string befor + val rest = Substring.string (Substring.slice (after, 1, NONE)) + in + case cmd of + "" => + (case args of + ["stop", "daemon"] => + (((Socket.close listen; + OS.FileSys.remove socket) handle OS.SysErr _ => ()); + OS.Process.exit OS.Process.success) + | _ => + let + val success = (oneRun (rev args) handle DaemonExit => OS.Process.exit OS.Process.success) + handle ex => (print "unhandled exception:\n"; + print (General.exnMessage ex ^ "\n"); + OS.Process.failure) + in + TextIO.flushOut TextIO.stdOut; + TextIO.flushOut TextIO.stdErr; + send (sock, if OS.Process.isSuccess success then + "\001" + else + "\002") + end) + | _ => loop' (rest, cmd :: args) + end + end handle OS.SysErr _ => () + + fun redirect old = + Posix.IO.dup2 {old = valOf (Posix.FileSys.iodToFD (Socket.ioDesc sock)), + new = old} + + val oldStdout = Posix.IO.dup Posix.FileSys.stdout + val oldStderr = Posix.IO.dup Posix.FileSys.stderr + in + (* Redirect the daemon's output to the socket. *) + redirect Posix.FileSys.stdout; + redirect Posix.FileSys.stderr; + + loop' ("", []); + Socket.close sock; + + Posix.IO.dup2 {old = oldStdout, new = Posix.FileSys.stdout}; + Posix.IO.dup2 {old = oldStderr, new = Posix.FileSys.stderr}; + Posix.IO.close oldStdout; + Posix.IO.close oldStderr; + + Settings.reset (); + MLton.GC.pack (); + loop () + end in - if Socket.connectNB (sock, UnixSock.toAddr socket) - orelse not (List.null (#wrs (Socket.select {rds = [], - wrs = [Socket.sockDesc sock], - exs = [], - timeout = SOME (Time.fromSeconds 1)}))) then - (app (fn arg => send (sock, arg ^ "\n")) args; - send (sock, "\n"); - OS.Process.exit (wait ())) - else - (OS.FileSys.remove socket; - raise OS.SysErr ("", NONE)) - end handle OS.SysErr _ => - OS.Process.exit (oneRun args)) + OS.Process.atExit (fn () => OS.FileSys.remove socket); + Socket.bind (listen, UnixSock.toAddr socket); + Socket.listen (listen, 1); + loop () + end + +fun oneCommandLine args = + let + val sock = UnixSock.Strm.socket () + + fun wait () = + let + val v = Socket.recvVec (sock, 1024) + in + if Word8Vector.length v = 0 then + OS.Process.failure + else + let + val s = MLton.CharVector.fromPoly (Vector.map (chr o Word8.toInt) (MLton.Word8Vector.toPoly v)) + val last = Word8Vector.sub (v, Word8Vector.length v - 1) + val (rc, s) = if last = Word8.fromInt 1 then + (SOME OS.Process.success, String.substring (s, 0, size s - 1)) + else if last = Word8.fromInt 2 then + (SOME OS.Process.failure, String.substring (s, 0, size s - 1)) + else + (NONE, s) + in + print s; + case rc of + NONE => wait () + | SOME rc => rc + end + end handle OS.SysErr _ => OS.Process.failure + in + if Socket.connectNB (sock, UnixSock.toAddr socket) + orelse not (List.null (#wrs (Socket.select {rds = [], + wrs = [Socket.sockDesc sock], + exs = [], + timeout = SOME (Time.fromSeconds 1)}))) then + (app (fn arg => send (sock, arg ^ "\n")) args; + send (sock, "\n"); + wait ()) + else + (OS.FileSys.remove socket; + raise OS.SysErr ("", NONE)) + end handle OS.SysErr _ => oneRun args handle DaemonExit => OS.Process.success + +val () = (Globals.setResetTime (); + case CommandLine.arguments () of + ["daemon", "start"] => startDaemon () + | ["daemon", "restart"] => + (ignore (oneCommandLine ["daemon", "stop"]); + startDaemon ()) + | args => OS.Process.exit (oneCommandLine args)) 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/mono_reduce.sml b/src/mono_reduce.sml index 5bcb6f57..c3c9da98 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -597,8 +597,7 @@ fun reduce' (file : file) = ((*Print.prefaces "trySub" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*) case t of - (TFfi ("Basis", "string"), _) => doSub () - | (TSignal _, _) => e + (TSignal _, _) => e | _ => case e' of (ECase _, _) => e 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/reduce_local.sml b/src/reduce_local.sml index 06f49fef..aee8e7a9 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -54,6 +54,14 @@ val deKnown = List.filter (fn Known _ => false | KnownC _ => false | _ => true) +fun p_env_item ei = + Print.PD.string (case ei of + Unknown => "?" + | Known _ => "K" + | UnknownC => "C?" + | KnownC _ => "CK" + | Lift _ => "^") + datatype result = Yes of env | No | Maybe fun match (env, p : pat, e : exp) = @@ -124,7 +132,8 @@ fun match (env, p : pat, e : exp) = end fun con env (all as (c, loc)) = - ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all)];*) + ((*Print.prefaces "con" [("c", CorePrint.p_con CoreEnv.empty all), + ("env", Print.p_list p_env_item env)];*) case c of TFun (c1, c2) => (TFun (con env c1, con env c2), loc) | TCFun (x, k, c2) => (TCFun (x, k, con (UnknownC :: env) c2), loc) @@ -139,7 +148,7 @@ fun con env (all as (c, loc)) = | Unknown :: rest => find (n', rest, nudge, liftC) | Known _ :: rest => find (n', rest, nudge, liftC) | Lift (liftC', _) :: rest => find (n', rest, nudge + liftC', - liftC + liftC') + liftC + liftC') | UnknownC :: rest => if n' = 0 then (CRel (n + nudge), loc) @@ -228,154 +237,156 @@ fun patCon pc = kind = kind} fun exp env (all as (e, loc)) = - case e of - EPrim _ => all - | ERel n => - let - fun find (n', env, nudge, liftC, liftE) = - case env of - [] => (ERel (n + nudge), loc) - | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE') - | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE) - | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE) - | Unknown :: rest => - if n' = 0 then - (ERel (n + nudge), loc) - else - find (n' - 1, rest, nudge, liftC, liftE + 1) - | Known e :: rest => - if n' = 0 then - ((*print "SUBSTITUTING\n";*) - exp (Lift (liftC, liftE) :: rest) e) - else - find (n' - 1, rest, nudge - 1, liftC, liftE) - in - find (n, env, 0, 0, 0) - end - | ENamed _ => all - | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc) - | EFfi _ => all - | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) - - | EApp (e1, e2) => - let - val e1 = exp env e1 - val e2 = exp env e2 - in - case #1 e1 of - EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b - | _ => (EApp (e1, e2), loc) - end - - | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc) - - | ECApp (e, c) => - let - val e = exp env e - val c = con env c - in - case #1 e of - ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b - | _ => (ECApp (e, c), loc) - end - - | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc) - - | EKApp (e, k) => (EKApp (exp env e, k), loc) - | EKAbs (x, e) => (EKAbs (x, exp env e), loc) - - | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) - | EField (e, c, {field = f, rest = r}) => - let - val e = exp env e - val c = con env c - - fun default () = (EField (e, c, {field = con env f, rest = con env r}), loc) - in - case (#1 e, #1 c) of - (ERecord xcs, CName x) => - (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of - NONE => default () - | SOME (_, e, _) => e) - | _ => default () - end - - | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc) - | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e, - con env c, - {field = con env f, rest = con env r}), loc) - | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc) - - | ECase (e, pes, {disc = d, result = r}) => - let - val others = {disc = con env d, result = con env r} - - fun patBinds (p, _) = - case p of - PVar _ => 1 - | PPrim _ => 0 - | PCon (_, _, _, NONE) => 0 - | PCon (_, _, _, SOME p) => patBinds p - | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts - - fun pat (all as (p, loc)) = - case p of - PVar (x, t) => (PVar (x, con env t), loc) - | PPrim _ => all - | PCon (dk, pc, cs, po) => - (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) - | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) - - fun push () = - (ECase (exp env e, - map (fn (p, e) => (pat p, - exp (List.tabulate (patBinds p, - fn _ => Unknown) @ env) e)) - pes, others), loc) - - fun search pes = - case pes of - [] => push () - | (p, body) :: pes => - case match (env, p, e) of - No => search pes - | Maybe => push () - | Yes env' => exp env' body - in - search pes - end - - | EWrite e => (EWrite (exp env e), loc) - | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) - - | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) - - | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) + ((*Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all)];*) + case e of + EPrim _ => all + | ERel n => + let + fun find (n', env, nudge, liftC, liftE) = + case env of + [] => (ERel (n + nudge), loc) + | Lift (liftC', liftE') :: rest => find (n', rest, nudge + liftE', liftC + liftC', liftE + liftE') + | UnknownC :: rest => find (n', rest, nudge, liftC + 1, liftE) + | KnownC _ :: rest => find (n', rest, nudge, liftC, liftE) + | Unknown :: rest => + if n' = 0 then + (ERel (n + nudge), loc) + else + find (n' - 1, rest, nudge, liftC, liftE + 1) + | Known e :: rest => + if n' = 0 then + ((*print "SUBSTITUTING\n";*) + exp (Lift (liftC, liftE) :: rest) e) + else + find (n' - 1, rest, nudge - 1, liftC, liftE) + in + find (n, env, 0, 0, 0) + end + | ENamed _ => all + | ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc) + | EFfi _ => all + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) + + | EApp (e1, e2) => + let + val e1 = exp env e1 + val e2 = exp env e2 + in + case #1 e1 of + EAbs (_, _, _, b) => exp (Known e2 :: deKnown env) b + | _ => (EApp (e1, e2), loc) + end + + | EAbs (x, dom, ran, e) => (EAbs (x, con env dom, con env ran, exp (Unknown :: env) e), loc) + + | ECApp (e, c) => + let + val e = exp env e + val c = con env c + in + case #1 e of + ECAbs (_, _, b) => exp (KnownC c :: deKnown env) b + | _ => (ECApp (e, c), loc) + end + + | ECAbs (x, k, e) => (ECAbs (x, k, exp (UnknownC :: env) e), loc) + + | EKApp (e, k) => (EKApp (exp env e, k), loc) + | EKAbs (x, e) => (EKAbs (x, exp env e), loc) + + | ERecord xcs => (ERecord (map (fn (x, e, t) => (con env x, exp env e, con env t)) xcs), loc) + | EField (e, c, {field = f, rest = r}) => + let + val e = exp env e + val c = con env c + + fun default () = (EField (e, c, {field = con env f, rest = con env r}), loc) + in + case (#1 e, #1 c) of + (ERecord xcs, CName x) => + (case List.find (fn ((CName x', _), _, _) => x' = x | _ => false) xcs of + NONE => default () + | SOME (_, e, _) => e) + | _ => default () + end + + | EConcat (e1, c1, e2, c2) => (EConcat (exp env e1, con env c1, exp env e2, con env c2), loc) + | ECut (e, c, {field = f, rest = r}) => (ECut (exp env e, + con env c, + {field = con env f, rest = con env r}), loc) + | ECutMulti (e, c, {rest = r}) => (ECutMulti (exp env e, con env c, {rest = con env r}), loc) + + | ECase (e, pes, {disc = d, result = r}) => + let + val others = {disc = con env d, result = con env r} + + fun patBinds (p, _) = + case p of + PVar _ => 1 + | PPrim _ => 0 + | PCon (_, _, _, NONE) => 0 + | PCon (_, _, _, SOME p) => patBinds p + | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts + + fun pat (all as (p, loc)) = + case p of + PVar (x, t) => (PVar (x, con env t), loc) + | PPrim _ => all + | PCon (dk, pc, cs, po) => + (PCon (dk, patCon pc, map (con env) cs, Option.map pat po), loc) + | PRecord xpts => (PRecord (map (fn (x, p, t) => (x, pat p, con env t)) xpts), loc) + + fun push () = + (ECase (exp env e, + map (fn (p, e) => (pat p, + exp (List.tabulate (patBinds p, + fn _ => Unknown) @ env) e)) + pes, others), loc) + + fun search pes = + case pes of + [] => push () + | (p, body) :: pes => + case match (env, p, e) of + No => search pes + | Maybe => push () + | Yes env' => exp env' body + in + search pes + end + + | EWrite e => (EWrite (exp env e), loc) + | EClosure (n, es) => (EClosure (n, map (exp env) es), loc) + + | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) + + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc)) fun reduce file = let fun doDecl (d as (_, loc)) = - case #1 d of - DCon _ => d - | DDatatype _ => d - | DVal (x, n, t, e, s) => - let - val e = exp [] e - in - (DVal (x, n, t, e, s), loc) - end - | DValRec vis => - (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc) - | DExport _ => d - | DTable _ => d - | DSequence _ => d - | DView _ => d - | DDatabase _ => d - | DCookie _ => d - | DStyle _ => d - | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) - | DPolicy e1 => (DPolicy (exp [] e1), loc) - | DOnError _ => d + ((*Print.prefaces "decl" [("d", CorePrint.p_decl CoreEnv.empty d)];*) + case #1 d of + DCon _ => d + | DDatatype _ => d + | DVal (x, n, t, e, s) => + let + val e = exp [] e + in + (DVal (x, n, t, e, s), loc) + end + | DValRec vis => + (DValRec (map (fn (x, n, t, e, s) => (x, n, t, exp [] e, s)) vis), loc) + | DExport _ => d + | DTable _ => d + | DSequence _ => d + | DView _ => d + | DDatabase _ => d + | DCookie _ => d + | DStyle _ => d + | DTask (e1, e2) => (DTask (exp [] e1, exp [] e2), loc) + | DPolicy e1 => (DPolicy (exp [] e1), loc) + | DOnError _ => d) in map doDecl file end 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/badkind.ur b/tests/badkind.ur new file mode 100644 index 00000000..600f7a35 --- /dev/null +++ b/tests/badkind.ur @@ -0,0 +1 @@ +fun main () : transaction page = <xml>ahoy!</xml> diff --git a/tests/badkind.urp b/tests/badkind.urp new file mode 100644 index 00000000..934e4928 --- /dev/null +++ b/tests/badkind.urp @@ -0,0 +1,3 @@ +rewrite Badkind/main / + +badkind 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/html5_cforms.ur b/tests/html5_cforms.ur index be07d07e..317a0638 100644 --- a/tests/html5_cforms.ur +++ b/tests/html5_cforms.ur @@ -9,8 +9,8 @@ fun main () : transaction page = d <- source ""; e <- source ""; f <- source ""; - g <- source 1.0; - h <- source 1.0; + g <- source (Some 1.0); + h <- source (Some 1.0); i <- source "#CCCCCC"; j <- source "2014/11/16"; k <- source "2014/11/16 12:30:45"; 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 <xml><body> + <button value="CLICK ME" + onclick={fn _ => + (_, _, s, _, _) <- rpc callme; + alert s}/> +</body></xml> diff --git a/tests/tooEager.ur b/tests/tooEager.ur new file mode 100644 index 00000000..c84a6d6c --- /dev/null +++ b/tests/tooEager.ur @@ -0,0 +1,18 @@ +fun test (i: list int) : transaction unit = + a <- return (Some "abc"); + c <- (case a of + None => return "1" + | Some b => + debug "not happening :("; + return "2" + ); + (case i of + [] => return () + | first :: _ => debug c) + +fun main (): transaction page = + return <xml> + <body> + <button onclick={fn _ => rpc (test [])}>click</button> + </body> + </xml> 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 <xml><body> + Name: <ctextbox source={name}/><br/> + <button value="Add" onclick={fn _ => n <- get name; rpc (add n)}/><br/> + <button value="Search" onclick={fn _ => n <- get name; ls <- rpc (closest n); set results ls}/><br/> + <dyn signal={rs <- signal results; + return <xml><ol> + {List.mapX (fn n => <xml><li>{[n]}</li></xml>) rs} + </ol></xml>}/> + </body></xml> diff --git a/tests/trgm.urp b/tests/trgm.urp new file mode 100644 index 00000000..326151e7 --- /dev/null +++ b/tests/trgm.urp @@ -0,0 +1,6 @@ +database dbname=trgm +sql trgm.sql +rewrite all Trgm/* + +$/list +trgm diff --git a/tests/trgm.urs b/tests/trgm.urs new file mode 100644 index 00000000..61778b87 --- /dev/null +++ b/tests/trgm.urs @@ -0,0 +1 @@ +val main : transaction page diff --git a/tests/wildsig.ur b/tests/wildsig.ur new file mode 100644 index 00000000..336772a7 --- /dev/null +++ b/tests/wildsig.ur @@ -0,0 +1,7 @@ +signature S = sig + val x : _ +end + +structure M : S = struct + val x = 7 +end |