From 6273c4602a8103f23856616966c34721ad726d3e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Aug 2019 11:13:03 -0400 Subject: Flush output on logging --- src/c/http.c | 2 ++ 1 file changed, 2 insertions(+) (limited to 'src') 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); } } -- cgit v1.2.3 From d7e10798f1905161e5790444e604f439281d4220 Mon Sep 17 00:00:00 2001 From: Oisín Mac Fhearaí Date: Sun, 11 Aug 2019 05:04:43 +0100 Subject: * When htmlifying characters, don't use numeric escapes if they're printable -- instead, try to convert them to UTF-8. * Add libicuio to linked C libraries --- src/c/Makefile.am | 2 +- src/c/urweb.c | 19 ++++++++++++++++--- src/compiler.sml | 8 ++++++-- 3 files changed, 23 insertions(+), 6 deletions(-) (limited to 'src') 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/urweb.c b/src/c/urweb.c index b820354f..dad15568 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -20,7 +20,6 @@ #include -#include #include #include "types.h" @@ -2347,7 +2346,21 @@ uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { int len; uw_check(ctx, INTS_MAX+3); - len = sprintf(ctx->page.front, "&#%u;", n); + + if(uw_Basis_isprint(ctx, ch)) { + + UChar32 ins[1] = { ch }; + char buf[5]; + int32_t len_written = 0; + UErrorCode err = U_ZERO_ERROR; + + u_strToUTF8(buf, 5, &len_written, ins, 1, &err); + sprintf(ctx->page.front, "%s", buf); + // printf("buf: %s, hex: %x, len_written: %d, err: %s\n", buf, ch, len_written, u_errorName(err)); + len = len_written; + } else { + len = sprintf(ctx->page.front, "&#%u;", n); + } ctx->page.front += len; return uw_unit_v; @@ -2459,7 +2472,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; } diff --git a/src/compiler.sml b/src/compiler.sml index 0aba3a40..c00fe807 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -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" -- cgit v1.2.3 From 71e1eb7be7ebd566a19be3cab381f813d9c2e4fc Mon Sep 17 00:00:00 2001 From: Oisín Mac Fhearaí Date: Sun, 11 Aug 2019 06:04:35 +0100 Subject: Add missing include --- src/c/urweb.c | 1 + 1 file changed, 1 insertion(+) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index dad15568..509ba10d 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -21,6 +21,7 @@ #include #include +#include #include "types.h" -- cgit v1.2.3 From 35eaf23643fcd2eb4376f07a490c959737179eef Mon Sep 17 00:00:00 2001 From: Oisín Mac Fhearaí Date: Sun, 11 Aug 2019 06:14:10 +0100 Subject: Try to avoid a pointer conversion error --- src/c/urweb.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index 509ba10d..a76f0004 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -20,8 +20,8 @@ #include -#include #include +#include #include "types.h" @@ -2350,7 +2350,7 @@ uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { if(uw_Basis_isprint(ctx, ch)) { - UChar32 ins[1] = { ch }; + const UChar ins[1] = { ch }; char buf[5]; int32_t len_written = 0; UErrorCode err = U_ZERO_ERROR; -- cgit v1.2.3 From 2bd1fc392c0b22f5eaa37919c6a26330dd72c7d4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 17 Aug 2019 10:21:42 -0400 Subject: Generic traversal for Elab should visit let-bound patterns --- src/elab_util.sml | 12 +- src/reduce_local.sml | 303 ++++++++++++++++++++++++++------------------------- 2 files changed, 164 insertions(+), 151 deletions(-) (limited to 'src') 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/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 -- cgit v1.2.3 From 5e2ebc973f19fe8e5fdbe20e102e445329b528b0 Mon Sep 17 00:00:00 2001 From: Oisín Mac Fhearaí Date: Wed, 28 Aug 2019 01:56:53 +0100 Subject: Minor cleanup -- handle the case where we couldn't successfully generate a UTF8 codepoint by outputting a HTML escape (the default behaviour before for all multi-byte characters). --- src/c/urweb.c | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index a76f0004..62561828 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -20,6 +20,7 @@ #include +#include #include #include @@ -2344,7 +2345,7 @@ 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); @@ -2359,7 +2360,10 @@ uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { sprintf(ctx->page.front, "%s", buf); // printf("buf: %s, hex: %x, len_written: %d, err: %s\n", buf, ch, len_written, u_errorName(err)); len = len_written; - } else { + } + + // 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; -- cgit v1.2.3 From 0490176b675eb3ea36cd51fa5d1fd41a3126c10c Mon Sep 17 00:00:00 2001 From: Oisín Mac Fhearaí Date: Thu, 29 Aug 2019 21:39:53 +0100 Subject: PR suggestions (with thanks to @fabriceleal). --- src/c/urweb.c | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index 62561828..af929269 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -2351,14 +2351,10 @@ uw_unit uw_Basis_htmlifySpecialChar_w(uw_context ctx, uw_Basis_char ch) { if(uw_Basis_isprint(ctx, ch)) { - const UChar ins[1] = { ch }; - char buf[5]; int32_t len_written = 0; UErrorCode err = U_ZERO_ERROR; - u_strToUTF8(buf, 5, &len_written, ins, 1, &err); - sprintf(ctx->page.front, "%s", buf); - // printf("buf: %s, hex: %x, len_written: %d, err: %s\n", buf, ch, len_written, u_errorName(err)); + u_strToUTF8(ctx->page.front, 5, &len_written, (const UChar*)&ch, 1, &err); len = len_written; } -- cgit v1.2.3 From 0d644b4350f3e6cbb676360b0fc6a9e448137092 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 30 Aug 2019 16:32:14 -0400 Subject: Smooth rough edges of daemon command-line behavior --- src/main.mlton.sml | 247 +++++++++++++++++++++++++++-------------------------- 1 file changed, 128 insertions(+), 119 deletions(-) (limited to 'src') diff --git a/src/main.mlton.sml b/src/main.mlton.sml index bfa40265..e9317d46 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -255,7 +255,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 _ => (); + OS.Process.exit OS.Process.success) | _ => () val sources = parse_flags (flag_info ()) args @@ -318,127 +319,135 @@ 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 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 + +val () = (Globals.setResetTime (); + case CommandLine.arguments () of + ["daemon", "start"] => startDaemon () + | args => OS.Process.exit (oneCommandLine args)) -- cgit v1.2.3 From f54687e989372470c2848890e9499feb9fd70352 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 30 Aug 2019 17:15:48 -0400 Subject: urweb daemon restart --- doc/manual.tex | 4 ++++ src/main.mlton.sml | 15 ++++++++++----- 2 files changed, 14 insertions(+), 5 deletions(-) (limited to 'src') diff --git a/doc/manual.tex b/doc/manual.tex index 62b322ae..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 diff --git a/src/main.mlton.sml b/src/main.mlton.sml index e9317d46..a6eaa7ea 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 @@ -256,7 +258,7 @@ fun oneRun args = val () = case args of ["daemon", "stop"] => (OS.FileSys.remove socket handle OS.SysErr _ => (); - OS.Process.exit OS.Process.success) + raise DaemonExit) | _ => () val sources = parse_flags (flag_info ()) args @@ -360,7 +362,7 @@ fun startDaemon () = OS.Process.exit OS.Process.success) | _ => let - val success = (oneRun (rev args)) + 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) @@ -445,9 +447,12 @@ fun oneCommandLine args = else (OS.FileSys.remove socket; raise OS.SysErr ("", NONE)) - end handle OS.SysErr _ => oneRun args + end handle OS.SysErr _ => oneRun args handle DaemonExit => OS.Process.success val () = (Globals.setResetTime (); case CommandLine.arguments () of - ["daemon", "start"] => startDaemon () - | args => OS.Process.exit (oneCommandLine args)) + ["daemon", "start"] => startDaemon () + | ["daemon", "restart"] => + (ignore (oneCommandLine ["daemon", "stop"]); + startDaemon ()) + | args => OS.Process.exit (oneCommandLine args)) -- cgit v1.2.3 From 39cf1b0633fd95ff82815741c9c3d35a0f762cf2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 14 Sep 2019 13:14:55 -0400 Subject: More detailed error message for bad path kind spec (closes #178) --- src/compiler.sml | 2 +- tests/badkind.ur | 1 + tests/badkind.urp | 3 +++ 3 files changed, 5 insertions(+), 1 deletion(-) create mode 100644 tests/badkind.ur create mode 100644 tests/badkind.urp (limited to 'src') diff --git a/src/compiler.sml b/src/compiler.sml index c00fe807..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 = 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 = ahoy! 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 -- cgit v1.2.3 From 2a7c54badfcd4e30105a0127b25975000ff09bbb Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 18 Sep 2019 13:51:13 -0400 Subject: Disallow wildcards in signatures (should help with #174) --- src/elab_err.sig | 2 ++ src/elab_err.sml | 6 ++++++ src/elaborate.sml | 35 ++++++++++++++++++++++++++--------- tests/wildsig.ur | 7 +++++++ 4 files changed, 41 insertions(+), 9 deletions(-) create mode 100644 tests/wildsig.ur (limited to 'src') 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/elaborate.sml b/src/elaborate.sml index 97b36a0b..6ffb7716 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -260,6 +260,19 @@ 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 f = + let + val inS = !inSignature + in + inSignature := true; + (f () handle ex => (inSignature := inS; raise ex)) + before inSignature := inS + end + fun elabKind env (k, loc) = case k of L.KType => (L'.KType, loc) @@ -268,7 +281,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 +544,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 @@ -4146,7 +4163,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)) @@ -4171,7 +4188,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 @@ -4221,7 +4238,7 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) = end | NONE => let - val (sgn', gs') = elabSgn (env, denv) sgn + val (sgn', gs') = enterSignature (fn () => elabSgn (env, denv) sgn) val (env', n) = E.pushStrNamed env x sgn' 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 -- cgit v1.2.3 From 3f8929c83b451837fcd9dc9475534c0e78967ab2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 18 Sep 2019 15:33:35 -0400 Subject: Signatures should be allowed to use wildcards for kinds associated with concrete constructors --- src/elaborate.sml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) (limited to 'src') diff --git a/src/elaborate.sml b/src/elaborate.sml index 6ffb7716..c6825150 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2577,7 +2577,14 @@ 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 => + case #1 k of + L.KWild => kunif env loc + (* Why duplicate this case of elabKind here? + * To avoid flagging a disallowed wildcard in + * a signature, since we are guaranteed to + * resolve this kind locally during elaboration. *) + | _ => elabKind env k val (c', ck, gs') = elabCon (env, denv) c val (env', n) = E.pushCNamed env x k' (SOME c') @@ -4756,6 +4763,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) = -- cgit v1.2.3 From abf8a0434cb1c1ab22a50182ffdc6cf0c4645523 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 20 Sep 2019 13:39:07 -0400 Subject: Laxer wildcard restriction for signatures --- src/elaborate.sml | 18 ++++++++---------- 1 file changed, 8 insertions(+), 10 deletions(-) (limited to 'src') diff --git a/src/elaborate.sml b/src/elaborate.sml index c6825150..fbbde303 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -264,14 +264,16 @@ * 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 f = + fun enterSignature' b f = let val inS = !inSignature in - inSignature := true; + 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 @@ -2577,14 +2579,10 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = let val k' = case ko of NONE => kunif env loc - | SOME k => - case #1 k of - L.KWild => kunif env loc - (* Why duplicate this case of elabKind here? - * To avoid flagging a disallowed wildcard in - * a signature, since we are guaranteed to - * resolve this kind locally during elaboration. *) - | _ => 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') -- cgit v1.2.3 From c388a91762e9dd9aef2eb097963af020c0e452f8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 21 Sep 2019 08:33:09 -0400 Subject: Desugaring of SQL constraints uses wildcards, so allow that even in signatures --- src/elaborate.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/elaborate.sml b/src/elaborate.sml index fbbde303..9718ccad 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2734,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'' @@ -2742,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''' -- cgit v1.2.3 From 8728f397bee2b567611dcd7a7c359c7e92159c1c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 25 Sep 2019 19:54:59 -0400 Subject: Unicode escapes in JSON --- include/urweb/urweb_cpp.h | 1 + lib/ur/basis.urs | 1 + lib/ur/json.ur | 29 +++++++++++++++++++++++++++++ src/c/urweb.c | 12 ++++++++++++ 4 files changed, 43 insertions(+) (limited to 'src') 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/ur/basis.urs b/lib/ur/basis.urs index 2a98bf6f..d29bf6e6 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 diff --git a/lib/ur/json.ur b/lib/ur/json.ur index 05406739..70f0c797 100644 --- a/lib/ur/json.ur +++ b/lib/ur/json.ur @@ -59,6 +59,17 @@ 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 Invalid hexadecimal digit "{[ch]}" + fun unescape s = let val len = String.length s @@ -75,6 +86,11 @@ fun unescape s = | #"\\" => if i+1 >= len then error JSON unescape: Bad escape sequence: {[s]} + else if String.sub s (i + 1) = #"u" then + if i+5 >= len then + error JSON unescape: Bad escape sequence: {[s]} + else + findEnd (i+6) else findEnd (i+2) | _ => findEnd (i+1) @@ -93,6 +109,19 @@ fun unescape s = #"\\" => if i+1 >= len then error JSON unescape: Bad escape sequence: {[s]} + else if String.sub s (i+1) = #"u" then + if i+5 >= len then + error JSON unescape: Unicode ends early + else + let + val n = + unhex (String.sub s (i+2)) * (256*16) + + unhex (String.sub s (i+3)) * 256 + + unhex (String.sub s (i+4)) * 16 + + unhex (String.sub s (i+5)) + in + ofUnicode n ^ unesc (i+6) + end else (case String.sub s (i+1) of #"n" => "\n" diff --git a/src/c/urweb.c b/src/c/urweb.c index af929269..8c445f39 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -2724,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; -- cgit v1.2.3 From 56bb940f305fb3d32cc218a6dbc8fa1b1fd7ef89 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Mon, 7 Oct 2019 16:47:39 -0400 Subject: Update urlification of unit values for RPC results, to track a previous change elsewhere --- src/cjr_print.sml | 59 ++++++++++++++++++++++--------------------------------- tests/rpc_unit.ur | 8 ++++++++ 2 files changed, 31 insertions(+), 36 deletions(-) create mode 100644 tests/rpc_unit.ur (limited to 'src') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 5dcfbe89..d7b8017e 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1014,52 +1014,39 @@ fun urlify env t = let fun urlify' level (t as (_, loc)) = case #1 t of - TFfi ("Basis", "unit") => box [] + TFfi ("Basis", "unit") => box [string "uw_Basis_urlifyString_w(ctx, \"\");", + newline] | TFfi (m, t) => box [string ("uw_" ^ ident m ^ "_urlify" ^ capitalize t ^ "_w(ctx, it" ^ Int.toString level ^ ");"), newline] - | TRecord 0 => box [] + | TRecord 0 => box [string "uw_Basis_urlifyString_w(ctx, \"\");", + newline] | TRecord i => let - fun empty (t, _) = - case t of - TFfi ("Basis", "unit") => true - | TRecord 0 => true - | TRecord j => - List.all (fn (_, t) => empty t) (E.lookupStruct env j) - | _ => false - val xts = E.lookupStruct env i val (blocks, _) = foldl (fn ((x, t), (blocks, printingSinceLastSlash)) => - let - val thisEmpty = empty t - in - if thisEmpty then - (blocks, printingSinceLastSlash) - else - (box [string "{", - newline, - p_typ env t, - space, - string ("it" ^ Int.toString (level + 1)), - space, - string "=", - space, - string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), - newline, - box (if printingSinceLastSlash then - [string "uw_write(ctx, \"/\");", - newline] - else - []), - urlify' (level + 1) t, - string "}", - newline] :: blocks, - true) - end) + (box [string "{", + newline, + p_typ env t, + space, + string ("it" ^ Int.toString (level + 1)), + space, + string "=", + space, + string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), + newline, + box (if printingSinceLastSlash then + [string "uw_write(ctx, \"/\");", + newline] + else + []), + urlify' (level + 1) t, + string "}", + newline] :: blocks, + true)) ([], false) xts in box (rev blocks) diff --git a/tests/rpc_unit.ur b/tests/rpc_unit.ur new file mode 100644 index 00000000..befd6045 --- /dev/null +++ b/tests/rpc_unit.ur @@ -0,0 +1,8 @@ +val callme = return ((), (), "A", (), ()) + +val main : transaction page = return + + + -- cgit v1.2.3 From ce9b6ef5ec667d474f6e6644046b27905441660a Mon Sep 17 00:00:00 2001 From: Simon Van Casteren Date: Mon, 4 Nov 2019 14:50:56 +0100 Subject: Fix for #181: unurlify x-www-form-urlencoded without custom serialization using period --- src/c/urweb.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index 8c445f39..a01b4aae 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -4941,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"); -- 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') 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:
+