summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Ziv Scully <ziv@mit.edu>2015-03-27 11:26:06 -0400
committerGravatar Ziv Scully <ziv@mit.edu>2015-03-27 11:26:06 -0400
commit0b941d68e7ceba9302d57eb8083e8244602a09ce (patch)
treef74a786d667b2b1c70bb39e9a1bfb5c8f58bd5d5 /src
parentbef4dd04f19c2001561e9e889116f5a2f8905bc0 (diff)
parent8e114ff992a3e730f2eb42095267969eebf75c36 (diff)
Merge.
Diffstat (limited to 'src')
-rw-r--r--src/c/fastcgi.c2
-rw-r--r--src/c/openssl.c10
-rw-r--r--src/c/urweb.c28
-rw-r--r--src/cjr_print.sml10
-rw-r--r--src/compiler.sml15
-rw-r--r--src/effectize.sml2
-rw-r--r--src/elaborate.sml111
-rw-r--r--src/elisp/urweb-mode.el75
-rw-r--r--src/jscomp.sml2
-rw-r--r--src/mono_opt.sml2
-rw-r--r--src/mono_reduce.sml56
-rw-r--r--src/monoize.sml49
-rw-r--r--src/mysql.sml2
-rw-r--r--src/postgres.sml6
-rw-r--r--src/settings.sml65
-rw-r--r--src/sidecheck.sig5
-rw-r--r--src/sidecheck.sml71
-rw-r--r--src/sqlite.sml2
-rw-r--r--src/urweb.grm33
-rw-r--r--src/urweb.lex16
20 files changed, 405 insertions, 157 deletions
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)