diff options
| -rw-r--r-- | .hgignore | 1 | ||||
| -rw-r--r-- | CHANGELOG | 14 | ||||
| -rw-r--r-- | configure.ac | 2 | ||||
| -rw-r--r-- | doc/manual.tex | 10 | ||||
| -rw-r--r-- | include/urweb/request.h | 1 | ||||
| -rw-r--r-- | lib/js/urweb.js | 82 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 2 | ||||
| -rw-r--r-- | lib/ur/list.ur | 10 | ||||
| -rw-r--r-- | lib/ur/list.urs | 2 | ||||
| -rw-r--r-- | src/c/fastcgi.c | 2 | ||||
| -rw-r--r-- | src/c/openssl.c | 10 | ||||
| -rw-r--r-- | src/c/urweb.c | 28 | ||||
| -rw-r--r-- | src/cjr_print.sml | 10 | ||||
| -rw-r--r-- | src/compiler.sml | 15 | ||||
| -rw-r--r-- | src/effectize.sml | 2 | ||||
| -rw-r--r-- | src/elaborate.sml | 111 | ||||
| -rw-r--r-- | src/elisp/urweb-mode.el | 75 | ||||
| -rw-r--r-- | src/jscomp.sml | 2 | ||||
| -rw-r--r-- | src/mono_opt.sml | 2 | ||||
| -rw-r--r-- | src/mono_reduce.sml | 56 | ||||
| -rw-r--r-- | src/monoize.sml | 49 | ||||
| -rw-r--r-- | src/mysql.sml | 2 | ||||
| -rw-r--r-- | src/postgres.sml | 6 | ||||
| -rw-r--r-- | src/settings.sml | 65 | ||||
| -rw-r--r-- | src/sidecheck.sig | 5 | ||||
| -rw-r--r-- | src/sidecheck.sml | 71 | ||||
| -rw-r--r-- | src/sqlite.sml | 2 | ||||
| -rw-r--r-- | src/urweb.grm | 33 | ||||
| -rw-r--r-- | src/urweb.lex | 16 | ||||
| -rw-r--r-- | tests/dynClassB.ur | 17 | ||||
| -rw-r--r-- | tests/dynClassB.urp | 5 | ||||
| -rw-r--r-- | tests/files.urp | 2 | ||||
| -rw-r--r-- | tests/nestedInput.ur | 10 | ||||
| -rw-r--r-- | tests/style.css | 7 |
34 files changed, 553 insertions, 174 deletions
@@ -62,6 +62,7 @@ m4/lt*.m4 config.* configure depcomp +compile install-sh ltmain.sh missing @@ -1,4 +1,18 @@ ======== +20150214 +======== + +- Bug fixes and improvements to type inference and optimization + +======== +20150103 +======== + +- New antiquote syntax for 'ORDER BY' clauses +- New standard library function: List.mem +- Bug fixes and improvements to type inference + +======== 20141206 ======== diff --git a/configure.ac b/configure.ac index 57a4dc02..3dd849ee 100644 --- a/configure.ac +++ b/configure.ac @@ -1,4 +1,4 @@ -AC_INIT([urweb], [20141206]) +AC_INIT([urweb], [20150214]) WORKING_VERSION=1 AC_USE_SYSTEM_EXTENSIONS diff --git a/doc/manual.tex b/doc/manual.tex index 5935ccbf..ad23d638 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -6,8 +6,8 @@ \newcommand{\mt}[1]{\mathsf{#1}} \newcommand{\rc}{+ \hspace{-.075in} + \;} -\newcommand{\rcut}{\; \texttt{--} \;} -\newcommand{\rcutM}{\; \texttt{---} \;} +\newcommand{\rcut}{\; \texttt{-{}-} \;} +\newcommand{\rcutM}{\; \texttt{-{}-{}-} \;} \begin{document} @@ -632,6 +632,10 @@ A signature item $\mt{table} \; x : c$ is shorthand for $\mt{val} \; x : \mt{Bas It is possible to write a $\mt{let}$ expression with its constituents in reverse order, along the lines of Haskell's \cd{where}. An expression $\mt{let} \; e \; \mt{where} \; ed^* \; \mt{end}$ desugars to $\mt{let} \; ed^* \; \mt{in} \; e \; \mt{end}$. +Ur/Web also includes a few more infix operators: $f \; \texttt{<|} \; x$ desugars to $f \; x$, $x \; \texttt{|>} \; f$ to $f \; x$, $f \; \texttt{<{}<{}<} \; g$ to $\mt{Top}.\mt{compose} \; f \; g$, and $g \; \texttt{>{}>{}>} \; f$ to $\mt{Top}.\mt{compose} \; f \; g$. (The latter two are doing function composition in the usual way.) Furthermore, any identifier may be changed into an infix operator by placing it between backticks, e.g. a silly way to do addition is $x \; \texttt{`}\mt{plus}\texttt{`} \; y$ instead of $x + y$. + +Hexadecimal integer literals are supported like \texttt{0xDEADBEEF}. Only capital letters are allowed. + \section{Static Semantics} @@ -2263,7 +2267,7 @@ $$\begin{array}{rrcll} \textrm{Pre-queries} & q &::=& \mt{SELECT} \; [\mt{DISTINCT}] \; P \; \mt{FROM} \; F,^+ \; [\mt{WHERE} \; E] \; [\mt{GROUP} \; \mt{BY} \; p,^+] \; [\mt{HAVING} \; E] \\ &&& \mid q \; R \; q \mid \{\{\{e\}\}\} \\ \textrm{Relational operators} & R &::=& \mt{UNION} \mid \mt{INTERSECT} \mid \mt{EXCEPT} \\ - \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O + \textrm{$\mt{ORDER \; BY}$ items} & O &::=& \mt{RANDOM} [()] \mid \hat{E} \; [o] \mid \hat{E} \; [o], O \mid \{\{\{e\}\}\} \end{array}$$ $$\begin{array}{rrcll} diff --git a/include/urweb/request.h b/include/urweb/request.h index 0b19e7f4..a15df10c 100644 --- a/include/urweb/request.h +++ b/include/urweb/request.h @@ -2,6 +2,7 @@ #define REQUEST_H #include <sys/types.h> +#include <pthread.h> #include "types.h" diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 342dc943..b599393b 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -112,6 +112,10 @@ function round(n) { return Math.round(n); } +function pow(n, m) { + return Math.pow(n, m); +} + // Time, represented as counts of microseconds since the epoch @@ -632,21 +636,25 @@ function cr(n) { return closures[n]; } -function flattenAcc(a, cls, tr) { - if (tr.cat1 != null) { - flattenAcc(a, cls, tr.cat1); - flattenAcc(a, cls, tr.cat2); - } else if (tr.closure != null) { - var cl = newClosure(tr.closure); - cls.v = cons(cl, cls.v); - a.push("cr(", cl.toString(), ")"); - } else - a.push(tr); +function flattenAcc(a, cls, trs) { + while (trs) { + var tr = trs.data; + trs = trs.next; + + if (tr.cat1 != null) { + trs = cons(tr.cat1, cons(tr.cat2, trs)); + } else if (tr.closure != null) { + var cl = newClosure(tr.closure); + cls.v = cons(cl, cls.v); + a.push("cr(", cl.toString(), ")"); + } else + a.push(tr); + } } function flatten(cls, tr) { var a = []; - flattenAcc(a, cls, tr); + flattenAcc(a, cls, cons(tr, null)); return a.join(""); } @@ -1233,6 +1241,56 @@ function dynClass(pnode, html, s_class, s_style) { } } +function bodyDynClass(s_class, s_style) { + if (suspendScripts) + return; + + var htmlCls = null; + + if (s_class) { + var x = document.createElement("script"); + x.dead = false; + x.signal = s_class; + x.sources = null; + x.closures = htmlCls; + + x.recreate = function(v) { + for (var ls = x.closures; ls != htmlCls; ls = ls.next) + freeClosure(ls.data); + + var cls = {v : null}; + document.body.className = flatten(cls, v); + console.log("className to + " + document.body.className); + x.closures = concat(cls.v, htmlCls); + } + + document.body.appendChild(x); + populate(x); + } + + if (s_style) { + var htmlCls2 = s_class ? null : htmlCls; + var y = document.createElement("script"); + y.dead = false; + y.signal = s_style; + y.sources = null; + y.closures = htmlCls2; + + y.recreate = function(v) { + for (var ls = y.closures; ls != htmlCls2; ls = ls.next) + freeClosure(ls.data); + + var cls = {v : null}; + document.body.style.cssText = flatten(cls, v); + console.log("style to + " + document.body.style.cssText); + y.closures = concat(cls.v, htmlCls2); + } + + document.body.appendChild(y); + populate(y); + } +} + function addOnChange(x, f) { var old = x.onchange; if (old == null) @@ -1261,6 +1319,8 @@ function eh(x) { function ts(x) { return x.toString() } function bs(b) { return (b ? "True" : "False") } +function s2b(s) { return s == "True" ? true : s == "False" ? false : null; } +function s2be(s) { return s == "True" ? true : s == "False" ? false : er("Illegal Boolean " ^ s); } function id(x) { return x; } function sub(s, i) { return s.charAt(i); } diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 326563d6..b8e52582 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -914,7 +914,7 @@ val time : bodyTag boxAttrs val wbr : bodyTag boxAttrs val bdi : bodyTag boxAttrs -val a : bodyTag ([Link = transaction page, Href = url, Target = string, Rel = string] ++ boxAttrs) +val a : bodyTag ([Link = transaction page, Href = url, Target = string, Rel = string, Download = string] ++ boxAttrs) val img : bodyTag ([Alt = string, Src = url, Width = int, Height = int, Onabort = transaction unit, Onerror = transaction unit, diff --git a/lib/ur/list.ur b/lib/ur/list.ur index cbb4faf2..11895884 100644 --- a/lib/ur/list.ur +++ b/lib/ur/list.ur @@ -216,6 +216,16 @@ fun foldlMap [a] [b] [c] f = fold [] end +fun mem [a] (_ : eq a) (x : a) = + let + fun mm ls = + case ls of + [] => False + | y :: ls => y = x || mm ls + in + mm + end + fun find [a] f = let fun find' ls = diff --git a/lib/ur/list.urs b/lib/ur/list.urs index 66007a39..55068935 100644 --- a/lib/ur/list.urs +++ b/lib/ur/list.urs @@ -54,6 +54,8 @@ val filterM : m ::: (Type -> Type) -> monad m -> a ::: Type val foldlMap : a ::: Type -> b ::: Type -> c ::: Type -> (a -> b -> c * b) -> b -> t a -> t c * b +val mem : a ::: Type -> eq a -> a -> t a -> bool + val find : a ::: Type -> (a -> bool) -> t a -> option a val search : a ::: Type -> b ::: Type -> (a -> option b) -> t a -> option b diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c index f3e66e3a..cda3e1f6 100644 --- a/src/c/fastcgi.c +++ b/src/c/fastcgi.c @@ -333,7 +333,7 @@ static void *worker(void *data) { size_t path_size = 0; char *path_buf = malloc(0); - hs.uppercased = malloc(0); + hs.uppercased = malloc(6); hs.uppercased_len = 0; hs.nvps = malloc(sizeof(nvp)); hs.n_nvps = 1; diff --git a/src/c/openssl.c b/src/c/openssl.c index 6a998e29..1d820a34 100644 --- a/src/c/openssl.c +++ b/src/c/openssl.c @@ -9,6 +9,7 @@ #include <string.h> #include <openssl/sha.h> +#include <openssl/rand.h> #define PASSSIZE 4 @@ -19,10 +20,11 @@ static int password[PASSSIZE]; char *uw_sig_file = NULL; static void random_password() { - int i; - - for (i = 0; i < PASSSIZE; ++i) - password[i] = rand(); + if (!RAND_bytes((unsigned char *)password, sizeof password)) { + fprintf(stderr, "Error generating random password\n"); + perror("RAND_bytes"); + exit(1); + } } void uw_init_crypto() { diff --git a/src/c/urweb.c b/src/c/urweb.c index d01cfaa2..53344c5e 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -167,6 +167,19 @@ void *uw_init_client_data(); void uw_free_client_data(void *); void uw_copy_client_data(void *dst, void *src); +static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; + +static uw_Basis_int my_rand() { + pthread_mutex_lock(&rand_mutex); + int ret, r = RAND_bytes((unsigned char *)&ret, sizeof ret); + pthread_mutex_unlock(&rand_mutex); + + if (r) + return abs(ret); + else + return -1; +} + static client *new_client() { client *c; @@ -192,7 +205,7 @@ static client *new_client() { pthread_mutex_lock(&c->lock); c->mode = USED; - c->pass = rand(); + c->pass = my_rand(); c->sock = -1; c->last_contact = time(NULL); uw_buffer_reset(&c->msgs); @@ -349,8 +362,6 @@ extern void uw_global_custom(); extern void uw_init_crypto(); void uw_global_init() { - srand(time(NULL) ^ getpid()); - clients = malloc(0); uw_global_custom(); @@ -4234,16 +4245,11 @@ uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) { return uw_unit_v; } -static pthread_mutex_t rand_mutex = PTHREAD_MUTEX_INITIALIZER; - uw_Basis_int uw_Basis_rand(uw_context ctx) { - uw_Basis_int ret; - pthread_mutex_lock(&rand_mutex); - int r = RAND_bytes((unsigned char *)&ret, sizeof ret); - pthread_mutex_unlock(&rand_mutex); + int r = my_rand(); - if (r) - return abs(ret); + if (r >= 0) + return r; else uw_error(ctx, FATAL, "Random number generation failed"); } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 73e0316d..1b1d656d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -3260,6 +3260,16 @@ fun p_file env (ds, ps) = string "))"])) NONE cookies + val cookieCode = foldl (fn (evar, acc) => + SOME (case acc of + NONE => string ("uw_unnull(uw_Basis_getenv(ctx, \"" + ^ Prim.toCString evar ^ "\"))") + | SOME acc => box [string ("uw_Basis_strcat(ctx, uw_unnull(uw_Basis_getenv(ctx, \"" + ^ Prim.toCString evar ^ "\")), uw_Basis_strcat(ctx, \"/\", "), + acc, + string "))"])) + cookieCode (SideCheck.readEnvVars ()) + fun makeChecker (name, rules : Settings.rule list) = box [string "static int ", string name, diff --git a/src/compiler.sml b/src/compiler.sml index fc4067a4..a45b8c69 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -461,14 +461,13 @@ fun parseUrp' accLibs fname = end else let - val thisPath = OS.Path.dir fname - val pathmap = ref (!pathmap) val bigLibs = ref [] fun pu filename = let val filename = OS.Path.mkAbsolute {path = filename, relativeTo = OS.FileSys.getDir ()} + val thisPath = OS.Path.dir filename val dir = OS.Path.dir filename fun opener () = TextIO.openIn (OS.Path.joinBaseExt {base = filename, ext = SOME "urp"}) @@ -693,8 +692,8 @@ fun parseUrp' accLibs fname = | _ => (ErrorMsg.error "Bad path kind spec"; Settings.Any) - fun parseFrom s = - if size s > 1 andalso String.sub (s, size s - 2) = #"/" andalso String.sub (s, size s - 1) = #"*" then + fun parsePattern s = + if size s > 0 andalso String.sub (s, size s - 1) = #"*" then (Settings.Prefix, String.substring (s, 0, size s - 1)) else (Settings.Exact, s) @@ -709,12 +708,6 @@ fun parseUrp' accLibs fname = | _ => (ErrorMsg.error "Bad filter kind"; url) - fun parsePattern s = - if size s > 0 andalso String.sub (s, size s - 1) = #"*" then - (Settings.Prefix, String.substring (s, 0, size s - 1)) - else - (Settings.Exact, s) - fun read () = case inputCommentableLine inf of EndOfFile => finish [] @@ -801,7 +794,7 @@ fun parseUrp' accLibs fname = fun doit (pkind, from, to, hyph) = let val pkind = parsePkind pkind - val (kind, from) = parseFrom from + val (kind, from) = parsePattern from in rewrites := {pkind = pkind, kind = kind, from = from, to = to, hyphenate = hyph} :: !rewrites end diff --git a/src/effectize.sml b/src/effectize.sml index d711e620..2c9b2374 100644 --- a/src/effectize.sml +++ b/src/effectize.sml @@ -79,6 +79,8 @@ fun effectize file = fun exp evs e = case e of EFfi ("Basis", "getCookie") => true + | EFfiApp ("Basis", "getHeader", _) => true + | EFfiApp ("Basis", "getenv", _) => true | ENamed n => IM.inDomain (evs, n) | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false diff --git a/src/elaborate.sml b/src/elaborate.sml index 749bd2f1..5b18ae94 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -2015,6 +2015,45 @@ fun chaseUnifs c = L'.CUnif (_, _, _, _, ref (L'.Known c)) => chaseUnifs c | _ => c +val consEqSimple = + let + fun ces env (c1 : L'.con, c2 : L'.con) = + let + val c1 = hnormCon env c1 + val c2 = hnormCon env c2 + in + case (#1 c1, #1 c2) of + (L'.CRel n1, L'.CRel n2) => n1 = n2 + | (L'.CNamed n1, L'.CNamed n2) => + n1 = n2 orelse + (case #3 (E.lookupCNamed env n1) of + SOME (L'.CNamed n2', _) => n2' = n1 + | _ => false) + | (L'.CModProj n1, L'.CModProj n2) => n1 = n2 + | (L'.CApp (f1, x1), L'.CApp (f2, x2)) => ces env (f1, f2) andalso ces env (x1, x2) + | (L'.CAbs (x1, k1, c1), L'.CAbs (_, _, c2)) => ces (E.pushCRel env x1 k1) (c1, c2) + | (L'.CName x1, L'.CName x2) => x1 = x2 + | (L'.CRecord (_, xts1), L'.CRecord (_, xts2)) => + ListPair.all (fn ((x1, t1), (x2, t2)) => + ces env (x1, x2) andalso ces env (t2, t2)) (xts1, xts2) + | (L'.CConcat (x1, y1), L'.CConcat (x2, y2)) => + ces env (x1, x2) andalso ces env (y1, y2) + | (L'.CMap _, L'.CMap _) => true + | (L'.CUnit, L'.CUnit) => true + | (L'.CTuple cs1, L'.CTuple cs2) => ListPair.all (ces env) (cs1, cs2) + | (L'.CProj (c1, n1), L'.CProj (c2, n2)) => ces env (c1, c2) andalso n1 = n2 + | (L'.CUnif (_, _, _, _, r1), L'.CUnif (_, _, _, _, r2)) => r1 = r2 + + | (L'.TFun (d1, r1), L'.TFun (d2, r2)) => ces env (d1, d2) andalso ces env (r1, r2) + | (L'.TRecord c1, L'.TRecord c2) => ces env (c1, c2) + + | _ => false + end + in + ces + end + + fun elabExp (env, denv) (eAll as (e, loc)) = let (*val () = eprefaces "elabExp" [("eAll", SourcePrint.p_exp eAll)]*) @@ -3020,26 +3059,7 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = | (L'.SgnConst sgis1, L'.SgnConst sgis2) => let - (* This reshuffling was added to avoid some unfortunate unification behavior. - * In particular, in sub-signature checking, constraints might be unified, - * even when we don't expect them to be unifiable, deciding on bad values - * for unification variables and dooming later unification. - * By putting all the constraints _last_, we allow all the other unifications - * to happen first, hoping that no unification variables survive to confuse - * constraint unification. *) - - val sgis2 = - let - val (constraints, others) = List.partition - (fn (L'.SgiConstraint _, _) => true - | _ => false) sgis2 - in - case constraints of - [] => sgis2 - | _ => others @ constraints - end - - (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), + (*val () = prefaces "subSgn" [("sgn1", p_sgn env sgn1), ("sgn2", p_sgn env sgn2), ("sgis1", p_sgn env (L'.SgnConst sgis1, loc2)), ("sgis2", p_sgn env (L'.SgnConst sgis2, loc2))]*) @@ -3329,7 +3349,12 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = L'.SgiStr (x', n1, sgn1) => if x = x' then let + (* Don't forget to save & restore the + * counterparts map around recursive calls! + * Otherwise, all sorts of mayhem may result. *) + val saved = !counterparts val () = subSgn' counterparts env loc sgn1 sgn2 + val () = counterparts := saved val env = E.pushStrNamedAs env x n1 sgn1 val env = if n1 = n2 then env @@ -3370,8 +3395,11 @@ and subSgn' counterparts env strLoc sgn1 (sgn2 as (_, loc2)) = seek (fn (env, sgi1All as (sgi1, loc)) => case sgi1 of L'.SgiConstraint (c1, d1) => - if consEq env loc (c1, c2) - andalso consEq env loc (d1, d2) then + (* It's important to do only simple equality checking here, + * with no unification, because constraints are unnamed. + * It's too easy to pick the wrong pair to unify! *) + if consEqSimple env (c1, c2) + andalso consEqSimple env (d1, d2) then SOME env else NONE @@ -3669,6 +3697,21 @@ and wildifyStr env (str, sgn) = | c => ((*Print.preface ("WTF?", p_con env (c, loc));*) NONE) + fun isClassOrFolder' env (c : L'.con) = + case #1 c of + L'.CAbs (x, k, c) => + let + val env = E.pushCRel env x k + + fun toHead (c : L'.con) = + case #1 c of + L'.CApp (c, _) => toHead c + | _ => isClassOrFolder env c + in + toHead (hnormCon env c) + end + | _ => isClassOrFolder env c + fun buildNeeded env sgis = #1 (foldl (fn ((sgi, loc), (nd, env')) => (case sgi of @@ -3680,19 +3723,23 @@ and wildifyStr env (str, sgn) = fun should t = let val t = normClassConstraint env' t + + fun shouldR c = + case hnormCon env' c of + (L'.CApp (f, _), _) => + (case hnormCon env' f of + (L'.CApp (f, cl), loc) => + (case hnormCon env' f of + (L'.CMap _, _) => isClassOrFolder' env' cl + | _ => false) + | _ => false) + | (L'.CConcat (c1, c2), _) => + shouldR c1 orelse shouldR c2 + | c => false in case #1 t of L'.CApp (f, _) => isClassOrFolder env' f - | L'.TRecord t => - (case hnormCon env' t of - (L'.CApp (f, _), _) => - (case hnormCon env' f of - (L'.CApp (f, cl), loc) => - (case hnormCon env' f of - (L'.CMap _, _) => isClassOrFolder env' cl - | _ => false) - | _ => false) - | _ => false) + | L'.TRecord t => shouldR t | _ => false end in diff --git a/src/elisp/urweb-mode.el b/src/elisp/urweb-mode.el index edbff1b0..fb9d18b5 100644 --- a/src/elisp/urweb-mode.el +++ b/src/elisp/urweb-mode.el @@ -171,42 +171,47 @@ See doc for the variable `urweb-mode-info'." (depth 0) (finished nil) (answer nil) + (bound (max 0 (- (point) 1024))) ) - (while (and (not finished) (re-search-backward "[-<{}]" nil t)) - (cond - ((looking-at "{") - (if (> depth 0) - (decf depth) - (setq finished t))) - ((looking-at "}") - (incf depth)) - ((looking-at "<xml>") - (if (> depth 0) - (decf depth) - (progn - (setq answer t) - (setq finished t)))) - ((looking-at "</xml>") - (incf depth)) - - ((looking-at "-") - (if (looking-at "->") - (setq finished (= depth 0)))) - - ((and (= depth 0) - (not (looking-at "<xml")) ;; ignore <xml/> - (eq font-lock-tag-face - (get-text-property (point) 'face))) - ;; previous code was highlighted as tag, seems we are in xml - (progn - (setq answer t) - (setq finished t))) - - ((= depth 0) - ;; previous thing was a tag like, but not tag - ;; seems we are in usual code or comment - (setq finished t)) - )) + (while (and (not finished) + (re-search-backward "\\(\\([-{}]\\)\\|<\\(/?xml\\)?\\)" + bound t)) + (let ((xml-tag (length (or (match-string 3) ""))) + (ch (match-string 2))) + (cond + ((equal ch ?\{) + (if (> depth 0) + (decf depth) + (setq finished t))) + ((equal ch ?\}) + (incf depth)) + ((= xml-tag 3) + (if (> depth 0) + (decf depth) + (progn + (setq answer t) + (setq finished t)))) + ((= xml-tag 4) + (incf depth)) + + ((equal ch ?-) + (if (looking-at "->") + (setq finished (= depth 0)))) + + ((and (= depth 0) + (not (looking-at "<xml")) ;; ignore <xml/> + (eq font-lock-tag-face + (get-text-property (point) 'face))) + ;; previous code was highlighted as tag, seems we are in xml + (progn + (setq answer t) + (setq finished t))) + + ((= depth 0) + ;; previous thing was a tag like, but not tag + ;; seems we are in usual code or comment + (setq finished t)) + ))) answer))) (defun amAttribute (face) diff --git a/src/jscomp.sml b/src/jscomp.sml index a4ee95f0..e5f7d234 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -724,6 +724,8 @@ fun process (file : file) = | "<" => "lt" | "<=" => "le" | "strcmp" => "strcmp" + | "powl" => "pow" + | "powf" => "pow" | _ => raise Fail ("Jscomp: Unknown binary operator " ^ s) val (e1, st) = jsE inner (e1, st) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 22ee36fc..f4cd6895 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -633,6 +633,8 @@ fun exp e = EFfiApp ("Basis", "writec", [e]) | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) + | EBinop (_, "-", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.- (n1, n2))) + | EBinop (_, "*", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.* (n1, n2))) | _ => e diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 8ca84c15..61866af7 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -330,7 +330,9 @@ val freeInAbs = U.Exp.existsB {typ = fn _ => false, U.Exp.RelE _ => n + 1 | _ => n} 0 -fun reduce (file : file) = +val yankedCase = ref false + +fun reduce' (file : file) = let val (timpures, impures, absCounts) = foldl (fn ((d, _), (timpures, impures, absCounts)) => @@ -770,17 +772,18 @@ fun reduce (file : file) = Print.PD.string "}"] in if List.all (safe o #2) pes then - EAbs ("y", dom, result, - (ECase (liftExpInExp 0 e', - map (fn (p, (EAbs (_, _, _, e), _)) => - (p, swapExpVarsPat (0, patBinds p) e) - | (p, (EError (e, (TFun (_, t), _)), loc)) => - (p, (EError (liftExpInExp (patBinds p) e, t), loc)) - | (p, e) => - (p, (EApp (liftExpInExp (patBinds p) e, - (ERel (patBinds p), loc)), loc))) - pes, - {disc = disc, result = result}), loc)) + (yankedCase := true; + EAbs ("y", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | (p, (EError (e, (TFun (_, t), _)), loc)) => + (p, (EError (liftExpInExp (patBinds p) e, t), loc)) + | (p, e) => + (p, (EApp (liftExpInExp (patBinds p) e, + (ERel (patBinds p), loc)), loc))) + pes, + {disc = disc, result = result}), loc))) else e end @@ -818,10 +821,19 @@ fun reduce (file : file) = search pes end - | EField ((ERecord xes, _), x) => - (case List.find (fn (x', _, _) => x' = x) xes of - SOME (_, e, _) => #1 e - | NONE => e) + | EField (e1, x) => + let + fun yankLets (e : exp) = + case #1 e of + ELet (x, t, e1, e2) => (ELet (x, t, e1, yankLets e2), #2 e) + | ERecord xes => + (case List.find (fn (x', _, _) => x' = x) xes of + SOME (_, e, _) => e + | NONE => (EField (e, x), #2 e)) + | _ => (EField (e, x), #2 e) + in + #1 (yankLets e1) + end | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) => let @@ -885,4 +897,16 @@ fun reduce (file : file) = U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file end +fun reduce file = + let + val () = yankedCase := false + val file' = reduce' file + in + if !yankedCase then + reduce file' + else + file' + end + + end diff --git a/src/monoize.sml b/src/monoize.sml index 4034e3ed..d1513ea6 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -89,7 +89,6 @@ val singletons = SS.addList (SS.empty, "p", "hr", "input", - "button", "img", "base", "meta", @@ -3279,6 +3278,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = else (NONE, NONE, attrs) + val (class, fm) = monoExp (env, st, fm) class + val (dynClass, fm) = monoExp (env, st, fm) dynClass + val (style, fm) = monoExp (env, st, fm) style + val (dynStyle, fm) = monoExp (env, st, fm) dynStyle + (* Special case for <button value=""> *) val (attrs, extraString) = case tag of "button" => @@ -3286,14 +3290,31 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ([(_, value, _)], rest) => (rest, SOME value) | _ => (attrs, NONE)) + | "body" => + (attrs, + if (case (#1 dynClass, #1 dynStyle) of + (L'.ESome _, _) => true + | (_, L'.ESome _) => true + | _ => false) then + let + fun jsify (e : L'.exp) = + case #1 e of + L'.ESome (_, ds) => strcat [str "execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str ")"] + | _ => str "null" + in + SOME (strcat [str "<script type=\"text/javascript\">bodyDynClass(", + jsify dynClass, + str ",", + jsify dynStyle, + str ")</script>"]) + end + else + NONE) | _ => (attrs, NONE) - val (class, fm) = monoExp (env, st, fm) class - val (dynClass, fm) = monoExp (env, st, fm) dynClass - val (style, fm) = monoExp (env, st, fm) style - val (dynStyle, fm) = monoExp (env, st, fm) dynStyle - val dynamics = ["dyn", "ctextbox", "cpassword", "ccheckbox", "cselect", "coption", "ctextarea", "active", "script", "cemail", "csearch", "curl", "ctel", "ccolor"] fun isSome (e, _) = @@ -3458,6 +3479,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => tagStart | SOME extra => (L'.EStrcat (tagStart, extra), loc) + val firstWord = Substring.string o #1 o Substring.splitl (fn ch => not (Char.isSpace ch)) o Substring.full + fun normal () = let val (xml, fm) = monoExp (env, st, fm) xml @@ -3468,7 +3491,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), (L'.EStrcat (xml, - strH (String.concat ["</", tag, ">"])), loc)), + strH (String.concat ["</", firstWord tag, ">"])), loc)), loc), fm) end @@ -3835,10 +3858,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | "tabl" => normal ("table", NONE) | _ => normal (tag, NONE) + + val (dynClass', dynStyle') = + case tag of + "body" => ((L'.ENone dummyTyp, ErrorMsg.dummySpan), + (L'.ENone dummyTyp, ErrorMsg.dummySpan)) + | _ => (dynClass, dynStyle) in - case #1 dynClass of + case #1 dynClass' of L'.ENone _ => - (case #1 dynStyle of + (case #1 dynStyle' of L'.ENone _ => baseAll | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(\"", str (pnode ()), @@ -3852,7 +3881,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = baseAll)) | L'.ESome (_, dc) => let - val e = case #1 dynStyle of + val e = case #1 dynStyle' of L'.ENone _ => str "null" | L'.ESome (_, ds) => strcat [str "execD(", (L'.EJavaScript (L'.Script, ds), loc), diff --git a/src/mysql.sml b/src/mysql.sml index 29a8c68f..bb654fee 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -446,7 +446,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => let fun uhoh this s args = box [p_list_sepi (box []) diff --git a/src/postgres.sml b/src/postgres.sml index b97226c1..6df0331a 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -340,14 +340,12 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => box [string "res = PQprepare(conn, \"uw", string (Int.toString i), string "\", \"", string (Prim.toCString s), - string "\", ", - string (Int.toString n), - string ", NULL);", + string "\", 0, NULL);", newline, string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", newline, diff --git a/src/settings.sml b/src/settings.sml index 81c33c08..bd958e22 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -297,6 +297,8 @@ val jsFuncsBase = basisM [("alert", "alert"), ("mouseEvent", "uw_mouseEvent"), ("keyEvent", "uw_keyEvent"), ("minTime", "0"), + ("stringToBool_error", "s2be"), + ("stringToBool", "s2b"), ("islower", "isLower"), ("isupper", "isUpper"), @@ -378,6 +380,22 @@ type rule = { action : action, kind : pattern_kind, pattern : string } datatype path_kind = Any | Url | Table | Sequence | View | Relation | Cookie | Style type rewrite = { pkind : path_kind, kind : pattern_kind, from : string, to : string, hyphenate : bool } +fun pak2s pak = + case pak of + Exact => "Exact" + | Prefix => "Prefix" +fun pk2s pk = + case pk of + Any => "Any" + | Url => "Url" + | Table => "Table" + | Sequence => "Sequence" + | View => "View" + | Relation => "Relation" + | Cookie => "Cookie" + | Style => "Style" +fun r2s (r : rewrite) = pak2s (#kind r) ^ " " ^ pk2s (#pkind r) ^ ", from<" ^ #from r ^ ">, to<" ^ #to r ^ ">" + val rewrites = ref ([] : rewrite list) fun subsume (pk1, pk2) = @@ -726,15 +744,46 @@ fun capitalize s = "" => "" | _ => str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE) +val allLower = CharVector.map Char.toLower + val mangle = ref true fun setMangleSql x = mangle := x -fun mangleSqlTable s = if !mangle then "uw_" ^ capitalize s - else if #name (currentDbms ()) = "mysql" then capitalize s - else lowercase s -fun mangleSql s = if !mangle then "uw_" ^ s - else if #name (currentDbms ()) = "mysql" then lowercase s - else lowercase s -fun mangleSqlCatalog s = if !mangle then "uw_" ^ s else lowercase s + +fun mangleSqlTable s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ capitalize s + else + lowercase s + +fun mangleSql s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s + +fun mangleSqlCatalog s = + if #name (currentDbms ()) = "mysql" then + if !mangle then + "uw_" ^ allLower s + else + allLower s + else + if !mangle then + "uw_" ^ s + else + lowercase s val html5 = ref false fun setIsHtml5 b = html5 := b @@ -822,7 +871,7 @@ fun setFilePath path = filePath := path fun addFile {Uri, LoadFromFilename} = let - val path = OS.Path.joinDirFile {dir = !filePath, file = LoadFromFilename} + val path = OS.Path.mkAbsolute {relativeTo = !filePath, path = LoadFromFilename} in case SM.find (!files, Uri) of SOME (path', _) => diff --git a/src/sidecheck.sig b/src/sidecheck.sig index 30abced6..1e3e2275 100644 --- a/src/sidecheck.sig +++ b/src/sidecheck.sig @@ -29,4 +29,9 @@ signature SIDE_CHECK = sig val check : Mono.file -> Mono.file + (* While we're checking, we'll do some other signature-related work, recording + * which environment variables are read. This function conveys the list, + * coming from the most recent call to [check]. *) + val readEnvVars : unit -> string list + end diff --git a/src/sidecheck.sml b/src/sidecheck.sml index b36d4935..bd11223a 100644 --- a/src/sidecheck.sml +++ b/src/sidecheck.sml @@ -31,29 +31,54 @@ open Mono structure E = ErrorMsg +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) + +val envVars = ref SS.empty + fun check ds = - (MonoUtil.File.appLoc (fn (e, loc) => - let - fun error (k as (k1, k2)) = - if Settings.isClientOnly k then - let - val k2 = case k1 of - "Basis" => - (case k2 of - "get_client_source" => "get" - | _ => k2) - | _ => k2 - in - E.errorAt loc ("Server-side code uses client-side-only identifier \"" ^ k1 ^ "." ^ k2 ^ "\"") - end - else - () - in - case e of - EFfi k => error k - | EFfiApp (k1, k2, _) => error (k1, k2) - | _ => () - end) ds; - ds) + let + val alreadyWarned = ref false + in + envVars := SS.empty; + MonoUtil.File.appLoc (fn (e, loc) => + let + fun error (k as (k1, k2)) = + if Settings.isClientOnly k then + let + val k2 = case k1 of + "Basis" => + (case k2 of + "get_client_source" => "get" + | _ => k2) + | _ => k2 + in + E.errorAt loc ("Server-side code uses client-side-only identifier \"" ^ k1 ^ "." ^ k2 ^ "\"") + end + else + () + in + case e of + EFfi k => error k + | EFfiApp ("Basis", "getenv", [(e, _)]) => + (case #1 e of + EPrim (Prim.String (_, s)) => + envVars := SS.add (!envVars, s) + | _ => if !alreadyWarned then + () + else + (alreadyWarned := true; + TextIO.output (TextIO.stdErr, "WARNING: " ^ ErrorMsg.spanToString loc ^ ": reading from an environment variable not determined at compile time, which can confuse CSRF protection"))) + | EFfiApp (k1, k2, _) => error (k1, k2) + | _ => () + end) ds; + ds + end + +fun readEnvVars () = SS.listItems (!envVars) end diff --git a/src/sqlite.sml b/src/sqlite.sml index c138415b..a1095709 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -202,7 +202,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} = newline, newline, - p_list_sepi newline (fn i => fn (s, n) => + p_list_sepi newline (fn i => fn (s, _) => let fun uhoh this s args = box [p_list_sepi (box []) diff --git a/src/urweb.grm b/src/urweb.grm index 995d1329..7fc34793 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -216,6 +216,14 @@ fun native_op (oper, e1, e2, loc) = (EApp (e, e2), loc) end +fun top_binop (oper, e1, e2, loc) = + let + val e = (EVar (["Top"], oper, Infer), loc) + val e = (EApp (e, e1), loc) + in + (EApp (e, e2), loc) + end + val inDml = ref false fun tagIn bt = @@ -395,6 +403,8 @@ fun patternOut (e : exp) = | CCONSTRAINT | UNIQUE | CHECK | PRIMARY | FOREIGN | KEY | ON | NO | ACTION | RESTRICT | CASCADE | REFERENCES | JOIN | INNER | CROSS | OUTER | LEFT | RIGHT | FULL | CIF | CTHEN | CELSE + | FWDAPP | REVAPP | COMPOSE | ANDTHEN + | BACKTICK_PATH of string %nonterm file of decl list @@ -565,6 +575,12 @@ fun patternOut (e : exp) = %right CAND %nonassoc EQ NE LT LE GT GE IS %right ARROW + +%left REVAPP +%right FWDAPP +%left BACKTICK_PATH +%right COMPOSE ANDTHEN + %right CARET PLUSPLUS %left MINUSMINUS MINUSMINUSMINUS %left PLUS MINUS @@ -1202,6 +1218,22 @@ eexp : eapps (case #1 eapps of | eexp GT eexp (native_op ("gt", eexp1, eexp2, s (eexp1left, eexp2right))) | eexp GE eexp (native_op ("ge", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp FWDAPP eexp (EApp (eexp1, eexp2), s (eexp1left, eexp2right)) + | eexp REVAPP eexp (EApp (eexp2, eexp1), s (eexp1left, eexp2right)) + | eexp COMPOSE eexp (top_binop ("compose", eexp1, eexp2, s (eexp1left, eexp2right))) + | eexp ANDTHEN eexp (top_binop ("compose", eexp2, eexp1, s (eexp1left, eexp2right))) + | eexp BACKTICK_PATH eexp (let + val path = String.tokens (fn ch => ch = #".") BACKTICK_PATH + val pathModules = List.take (path, (length path -1)) + val pathOp = List.last path + + val e = (EVar (pathModules, pathOp, Infer) + , s (BACKTICK_PATHleft, BACKTICK_PATHright)) + val e = (EApp (e, eexp1), s (eexp1left, BACKTICK_PATHright)) + in + (EApp (e, eexp2), s (eexp1left, eexp2right)) + end) + | eexp ANDALSO eexp (let val loc = s (eexp1left, eexp2right) in @@ -2235,6 +2267,7 @@ obopt : (ECApp ((EVar (["Basis"], "sql_order_by_ (CWild (KRecord (KType, dummy), dummy), dummy)), dummy) | ORDER BY obexps (obexps) + | ORDER BY LBRACE LBRACE LBRACE eexp RBRACE RBRACE RBRACE (eexp) obitem : sqlexp diropt (sqlexp, diropt) diff --git a/src/urweb.lex b/src/urweb.lex index 785f7a81..8b109727 100644 --- a/src/urweb.lex +++ b/src/urweb.lex @@ -182,6 +182,7 @@ cid = [A-Z][A-Za-z0-9_]*; ws = [\ \t\012\r]; intconst = [0-9]+; realconst = [0-9]+\.[0-9]*; +hexconst = 0x[0-9A-F]{1,8}; notags = ([^<{\n(]|(\([^\*<{\n]))+; xcom = ([^\-]|(-[^\-]))+; oint = [0-9][0-9][0-9]; @@ -376,6 +377,15 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <INITIAL> "&&" => (Tokens.ANDALSO (pos yypos, pos yypos + size yytext)); <INITIAL> "||" => (Tokens.ORELSE (pos yypos, pos yypos + size yytext)); +<INITIAL> "<<<" => (Tokens.COMPOSE (pos yypos, pos yypos + size yytext)); +<INITIAL> ">>>" => (Tokens.ANDTHEN (pos yypos, pos yypos + size yytext)); +<INITIAL> "<|" => (Tokens.FWDAPP (pos yypos, pos yypos + size yytext)); +<INITIAL> "|>" => (Tokens.REVAPP (pos yypos, pos yypos + size yytext)); + +<INITIAL> "`" ({cid} ".")* {id} "`" => (Tokens.BACKTICK_PATH ( (* strip backticks *) + substring (yytext,1,size yytext -2), + pos yypos, pos yypos + size yytext)); + <INITIAL> "=" => (Tokens.EQ (pos yypos, pos yypos + size yytext)); <INITIAL> "<>" => (Tokens.NE (pos yypos, pos yypos + size yytext)); <INITIAL> "<" => (Tokens.LT (pos yypos, pos yypos + size yytext)); @@ -532,6 +542,12 @@ xint = x[0-9a-fA-F][0-9a-fA-F]; <INITIAL> {id} => (Tokens.SYMBOL (yytext, pos yypos, pos yypos + size yytext)); <INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); +<INITIAL> {hexconst} => (case StringCvt.scanString (Int64.scan StringCvt.HEX) (String.extract (yytext, 2, NONE)) of + SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) + | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) + ("Expected hexInt, received: " ^ yytext); + continue ())); + <INITIAL> {intconst} => (case Int64.fromString yytext of SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext) | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos) diff --git a/tests/dynClassB.ur b/tests/dynClassB.ur new file mode 100644 index 00000000..fc7aeb43 --- /dev/null +++ b/tests/dynClassB.ur @@ -0,0 +1,17 @@ +style style1 +style style2 + +fun main () : transaction page = + toggle <- source False; + return <xml> + <head> + <link rel="stylesheet" type="text/css" href="/style.css"/> + </head> + <body dynClass={b <- signal toggle; + return (if b then style1 else style2)} + dynStyle={b <- signal toggle; + return (if b then STYLE "margin: 100px" else STYLE "")}> + Body + <button onclick={fn _ => b <- get toggle; set toggle (not b)}>TOGGLE</button> + </body> + </xml> diff --git a/tests/dynClassB.urp b/tests/dynClassB.urp new file mode 100644 index 00000000..e580b035 --- /dev/null +++ b/tests/dynClassB.urp @@ -0,0 +1,5 @@ +rewrite all DynClassB/* +file /style.css style.css +allow url /style.css + +dynClassB diff --git a/tests/files.urp b/tests/files.urp index 100992e5..3683f1a8 100644 --- a/tests/files.urp +++ b/tests/files.urp @@ -1,6 +1,6 @@ rewrite all Files/* file /hello_world.txt hello.txt file /img/web.png web.png -file /files.urp files.urp +file /files.urp ./files.urp files diff --git a/tests/nestedInput.ur b/tests/nestedInput.ur new file mode 100644 index 00000000..19a73e15 --- /dev/null +++ b/tests/nestedInput.ur @@ -0,0 +1,10 @@ +fun main () : transaction page = + let + fun handler _ = return <xml/> + in + return <xml><body> + <form> + <submit action={handler}>Uh oh!</submit> + </form> + </body></xml> + end diff --git a/tests/style.css b/tests/style.css new file mode 100644 index 00000000..78b33fc2 --- /dev/null +++ b/tests/style.css @@ -0,0 +1,7 @@ +body.style1 { + background-color: blue; +} + +body.style2 { + background-color: green; +} |