From eb89ae4814a7cf17f76f5ab5d191349ba13bdef4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 14:37:19 -0400 Subject: Generated basic dummy Iflow conditions --- src/iflow.sml | 422 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 422 insertions(+) create mode 100644 src/iflow.sml (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml new file mode 100644 index 00000000..39b5610f --- /dev/null +++ b/src/iflow.sml @@ -0,0 +1,422 @@ +(* Copyright (c) 2010, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Iflow :> IFLOW = struct + +open Mono + +structure SS = BinarySetFn(struct + type ord_key = string + val compare = String.compare + end) + +val writers = ["htmlifyInt_w", + "htmlifyFloat_w", + "htmlifyString_w", + "htmlifyBool_w", + "htmlifyTime_w", + "attrifyInt_w", + "attrifyFloat_w", + "attrifyString_w", + "attrifyChar_w", + "urlifyInt_w", + "urlifyFloat_w", + "urlifyString_w", + "urlifyBool_w"] + +val writers = SS.addList (SS.empty, writers) + +type lvar = int + +datatype exp = + Const of Prim.t + | Var of int + | Lvar of lvar + | Func of string * exp list + | Recd of (string * exp) list + | Proj of exp * string + | Finish + +datatype reln = + Sql of string + | Eq + +datatype prop = + True + | False + | Unknown + | And of prop * prop + | Or of prop * prop + | Reln of reln * exp list + | Select of int * lvar * lvar * prop * exp + +local + val count = ref 0 +in +fun newLvar () = + let + val n = !count + in + count := n + 1; + n + end +end + +fun subExp (v, lv) = + let + fun sub e = + case e of + Const _ => e + | Var v' => if v' = v then Lvar lv else e + | Lvar _ => e + | Func (f, es) => Func (f, map sub es) + | Recd xes => Recd (map (fn (x, e) => (x, sub e)) xes) + | Proj (e, s) => Proj (sub e, s) + | Finish => Finish + in + sub + end + +fun subProp (v, lv) = + let + fun sub p = + case p of + True => p + | False => p + | Unknown => p + | And (p1, p2) => And (sub p1, sub p2) + | Or (p1, p2) => Or (sub p1, sub p2) + | Reln (r, es) => Reln (r, map (subExp (v, lv)) es) + | Select (v1, lv1, lv2, p, e) => Select (v1, lv1, lv2, sub p, subExp (v, lv) e) + in + sub + end + +fun eq' (e1, e2) = + case (e1, e2) of + (Const p1, Const p2) => Prim.equal (p1, p2) + | (Var n1, Var n2) => n1 = n2 + | (Lvar n1, Lvar n2) => n1 = n2 + | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) + | (Recd xes1, Recd xes2) => ListPair.allEq (fn ((x1, e1), (x2, e2)) => x1 = x2 andalso eq' (e1, e2)) (xes1, xes2) + | (Proj (e1, s1), Proj (e2, s2)) => eq' (e1, e2) andalso s1 = s2 + | (Finish, Finish) => true + | _ => false + +fun isKnown e = + case e of + Const _ => true + | Func (_, es) => List.all isKnown es + | Recd xes => List.all (isKnown o #2) xes + | Proj (e, _) => isKnown e + | _ => false + +fun isFinish e = + case e of + Finish => true + | _ => false + +fun simplify e = + case e of + Const _ => e + | Var _ => e + | Lvar _ => e + | Func (f, es) => + let + val es = map simplify es + in + if List.exists isFinish es then + Finish + else + Func (f, es) + end + | Recd xes => + let + val xes = map (fn (x, e) => (x, simplify e)) xes + in + if List.exists (isFinish o #2) xes then + Finish + else + Recd xes + end + | Proj (e, s) => + (case simplify e of + Recd xes => + getOpt (ListUtil.search (fn (x, e') => if x = s then SOME e' else NONE) xes, Recd xes) + | e' => + if isFinish e' then + Finish + else + Proj (e', s)) + | Finish => Finish + +fun eq (e1, e2) = eq' (simplify e1, simplify e2) + +fun decomp or = + let + fun decomp p k = + case p of + True => k [] + | False => true + | Unknown => k [] + | And (p1, p2) => + decomp p1 (fn ps1 => + decomp p2 (fn ps2 => + k (ps1 @ ps2))) + | Or (p1, p2) => + or (decomp p1 k, fn () => decomp p2 k) + | Reln x => k [x] + | Select _ => k [] + in + decomp + end + +fun rimp ((r1 : reln, es1), (r2, es2)) = + r1 = r2 andalso ListPair.allEq eq (es1, es2) + +fun imp (p1, p2) = + decomp (fn (e1, e2) => e1 andalso e2 ()) p1 + (fn hyps => + decomp (fn (e1, e2) => e1 orelse e2 ()) p2 + (fn goals => + List.all (fn r2 => List.exists (fn r1 => rimp (r1, r2)) hyps) goals)) + +fun patCon pc = + case pc of + PConVar n => "C" ^ Int.toString n + | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c + +exception Summaries of (string * exp * prop * (exp * prop) list) list + +datatype chunk = + String of string + | Exp of Mono.exp + +fun chunkify e = + case #1 e of + EPrim (Prim.String s) => [String s] + | EStrcat (e1, e2) => chunkify e1 @ chunkify e2 + | _ => [Exp e] + +fun queryProp rv e = + let + fun query chs = + case chs of + [] => raise Fail "Iflow: Empty query" + | Exp _ :: _ => Unknown + | String "" :: chs => query chs + | String s :: chs => True + in + query (chunkify e) + end + +fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = + let + fun default () = + (Var nv, (nv+1, p, sent)) + + fun addSent (p, e, sent) = + if isKnown e then + sent + else + (e, p) :: sent + in + case #1 e of + EPrim p => (Const p, st) + | ERel n => (List.nth (env, n), st) + | ENamed _ => default () + | ECon (_, pc, NONE) => (Func (patCon pc, []), st) + | ECon (_, pc, SOME e) => + let + val (e, st) = evalExp env (e, st) + in + (Func (patCon pc, [e]), st) + end + | ENone _ => (Func ("None", []), st) + | ESome (_, e) => + let + val (e, st) = evalExp env (e, st) + in + (Func ("Some", [e]), st) + end + | EFfi _ => default () + | EFfiApp (m, s, es) => + if m = "Basis" andalso SS.member (writers, s) then + let + val (es, st) = ListUtil.foldlMap (evalExp env) st es + in + (Func ("unit", []), (#1 st, p, foldl (fn (e, sent) => addSent (#2 st, e, sent)) sent es)) + end + else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then + default () + else + let + val (es, st) = ListUtil.foldlMap (evalExp env) st es + in + (Func (m ^ "." ^ s, es), st) + end + | EApp _ => default () + | EAbs _ => default () + | EUnop (s, e1) => + let + val (e1, st) = evalExp env (e1, st) + in + (Func (s, [e1]), st) + end + | EBinop (s, e1, e2) => + let + val (e1, st) = evalExp env (e1, st) + val (e2, st) = evalExp env (e2, st) + in + (Func (s, [e1, e2]), st) + end + | ERecord xets => + let + val (xes, st) = ListUtil.foldlMap (fn ((x, e, _), st) => + let + val (e, st) = evalExp env (e, st) + in + ((x, e), st) + end) st xets + in + (Recd xes, st) + end + | EField (e, s) => + let + val (e, st) = evalExp env (e, st) + in + (Proj (e, s), st) + end + | ECase _ => default () + | EStrcat (e1, e2) => + let + val (e1, st) = evalExp env (e1, st) + val (e2, st) = evalExp env (e2, st) + in + (Func ("cat", [e1, e2]), st) + end + | EError _ => (Finish, st) + | EReturnBlob {blob = b, mimeType = m, ...} => + let + val (b, st) = evalExp env (b, st) + val (m, st) = evalExp env (m, st) + in + (Finish, (#1 st, p, addSent (#2 st, b, addSent (#2 st, m, sent)))) + end + | ERedirect (e, _) => + let + val (e, st) = evalExp env (e, st) + in + (Finish, (#1 st, p, addSent (#2 st, e, sent))) + end + | EWrite e => + let + val (e, st) = evalExp env (e, st) + in + (Func ("unit", []), (#1 st, p, addSent (#2 st, e, sent))) + end + | ESeq (e1, e2) => + let + val (_, st) = evalExp env (e1, st) + in + evalExp env (e2, st) + end + | ELet (_, _, e1, e2) => + let + val (e1, st) = evalExp env (e1, st) + in + evalExp (e1 :: env) (e2, st) + end + | EClosure (n, es) => + let + val (es, st) = ListUtil.foldlMap (evalExp env) st es + in + (Func ("Cl" ^ Int.toString n, es), st) + end + + | EQuery {query = q, body = b, initial = i, ...} => + let + val (_, st) = evalExp env (q, st) + val (i, st) = evalExp env (i, st) + + val r = #1 st + val acc = #1 st + 1 + val st' = (#1 st + 2, #2 st, #3 st) + + val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') + + val r' = newLvar () + val acc' = newLvar () + val qp = queryProp r' q + + val doSubExp = subExp (r, r') o subExp (acc, acc') + val doSubProp = subProp (r, r') o subProp (acc, acc') + + val p = doSubProp (#2 st') + val p = And (p, qp) + val p = Select (r, r', acc', p, doSubExp b) + in + (Var r, (#1 st + 1, And (#2 st, p), map (fn (e, p) => (doSubExp e, And (qp, doSubProp p))) (#3 st'))) + end + | EDml _ => default () + | ENextval _ => default () + | ESetval _ => default () + + | EUnurlify _ => default () + | EJavaScript _ => default () + | ESignalReturn _ => default () + | ESignalBind _ => default () + | ESignalSource _ => default () + | EServerCall _ => default () + | ERecv _ => default () + | ESleep _ => default () + | ESpawn _ => default () + end + +fun check file = + let + fun decl ((d, _), summaries) = + case d of + DVal (x, _, _, e, _) => + let + fun deAbs (e, env, nv) = + case #1 e of + EAbs (_, _, _, e) => deAbs (e, Var nv :: env, nv + 1) + | _ => (e, env, nv) + + val (e, env, nv) = deAbs (e, [], 0) + + val (e, (_, p, sent)) = evalExp env (e, (nv, True, [])) + in + (x, e, p, sent) :: summaries + end + | _ => summaries + in + raise Summaries (foldl decl [] file) + end + +end -- cgit v1.2.3 From cfde341ff74fbee501da623d765c8ed6cbf3731f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 15:17:57 -0400 Subject: Generating a good Iflow condition for a test query --- src/iflow.sml | 125 +++++++++++++++++++++++++++++++++++++++++++++++++++----- tests/policy.ur | 5 +-- 2 files changed, 117 insertions(+), 13 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 39b5610f..ef677022 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -222,17 +222,122 @@ fun chunkify e = | EStrcat (e1, e2) => chunkify e1 @ chunkify e2 | _ => [Exp e] +type 'a parser = chunk list -> ('a * chunk list) option + +fun always v chs = SOME (v, chs) + +fun parse p chs = + case p chs of + SOME (v, []) => SOME v + | _ => NONE + +fun const s chs = + case chs of + String s' :: chs => if String.isPrefix s s' then + SOME ((), if size s = size s' then + chs + else + String (String.extract (s', size s, NONE)) :: chs) + else + NONE + | _ => NONE + +fun follow p1 p2 chs = + case p1 chs of + NONE => NONE + | SOME (v1, chs) => + case p2 chs of + NONE => NONE + | SOME (v2, chs) => SOME ((v1, v2), chs) + +fun wrap p f chs = + case p chs of + NONE => NONE + | SOME (v, chs) => SOME (f v, chs) + +fun alt p1 p2 chs = + case p1 chs of + NONE => p2 chs + | v => v + +fun skip cp chs = + case chs of + String "" :: chs => skip cp chs + | String s :: chs' => if cp (String.sub (s, 0)) then + skip cp (String (String.extract (s, 1, NONE)) :: chs') + else + SOME ((), chs) + | _ => SOME ((), chs) + +fun keep cp chs = + case chs of + String "" :: chs => keep cp chs + | String s :: chs' => + let + val (befor, after) = Substring.splitl cp (Substring.full s) + in + if Substring.isEmpty befor then + NONE + else + SOME (Substring.string befor, + if Substring.isEmpty after then + chs' + else + String (Substring.string after) :: chs') + end + | _ => NONE + +fun ws p = wrap (follow p (skip (fn ch => ch = #" "))) #1 + +fun list p chs = + (alt (wrap (follow p (follow (ws (const ",")) (list p))) + (fn (v, ((), ls)) => v :: ls)) + (alt (wrap (ws p) (fn v => [v])) + (always []))) chs + +val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_") + +val t_ident = wrap ident (fn s => if String.isPrefix "T_" s then + String.extract (s, 2, NONE) + else + raise Fail "Iflow: Bad table variable") +val uw_ident = wrap ident (fn s => if String.isPrefix "uw_" s then + String.extract (s, 3, NONE) + else + raise Fail "Iflow: Bad uw_* variable") + +val sitem = wrap (follow t_ident + (follow (const ".") + uw_ident)) + (fn (t, ((), f)) => (t, f)) + +val select = wrap (follow (const "SELECT ") (list sitem)) + (fn ((), ls) => ls) + +val fitem = wrap (follow uw_ident + (follow (const " AS ") + t_ident)) + (fn (t, ((), f)) => (t, f)) + +val from = wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls) + +val query = wrap (follow select from) + (fn (fs, ts) => {Select = fs, From = ts}) + fun queryProp rv e = - let - fun query chs = - case chs of - [] => raise Fail "Iflow: Empty query" - | Exp _ :: _ => Unknown - | String "" :: chs => query chs - | String s :: chs => True - in - query (chunkify e) - end + case parse query (chunkify e) of + NONE => Unknown + | SOME r => + foldl (fn ((t, v), p) => + And (p, + Reln (Sql t, + [Recd (foldl (fn ((v', f), fs) => + if v' = v then + (f, Proj (Proj (Lvar rv, v), f)) :: fs + else + fs) [] (#Select r))]))) + True (#From r) fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = let diff --git a/tests/policy.ur b/tests/policy.ur index 1087bab9..c381beac 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -3,9 +3,8 @@ table fruit : { Id : int, Nam : string, Weight : float, Secret : string } policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight FROM fruit) fun main () = - xml <- queryX (SELECT fruit.Nam - FROM fruit - ORDER BY fruit.Nam) + xml <- queryX (SELECT fruit.Id, fruit.Nam + FROM fruit) (fn x =>
  • {[x.Fruit.Nam]}
    • ); return -- cgit v1.2.3 From 7f707b5fc653de58077cafccbd867e5394b4ca7b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 16:17:23 -0400 Subject: Iflow tested with positive and negative cases --- src/iflow.sig | 2 +- src/iflow.sml | 248 +++++++++++++++++++++++++++++++++++++++++++++----------- tests/policy.ur | 6 +- 3 files changed, 204 insertions(+), 52 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sig b/src/iflow.sig index 8a11a008..2bdc9aae 100644 --- a/src/iflow.sig +++ b/src/iflow.sig @@ -51,7 +51,7 @@ signature IFLOW = sig | Reln of reln * exp list | Select of int * lvar * lvar * prop * exp - exception Summaries of (string * exp * prop * (exp * prop) list) list + exception Imply of prop * prop val check : Mono.file -> unit diff --git a/src/iflow.sml b/src/iflow.sml index ef677022..016e9a08 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -29,6 +29,8 @@ structure Iflow :> IFLOW = struct open Mono +structure IM = IntBinaryMap + structure SS = BinarySetFn(struct type ord_key = string val compare = String.compare @@ -75,7 +77,7 @@ datatype prop = | Select of int * lvar * lvar * prop * exp local - val count = ref 0 + val count = ref 1 in fun newLvar () = let @@ -116,17 +118,6 @@ fun subProp (v, lv) = sub end -fun eq' (e1, e2) = - case (e1, e2) of - (Const p1, Const p2) => Prim.equal (p1, p2) - | (Var n1, Var n2) => n1 = n2 - | (Lvar n1, Lvar n2) => n1 = n2 - | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) - | (Recd xes1, Recd xes2) => ListPair.allEq (fn ((x1, e1), (x2, e2)) => x1 = x2 andalso eq' (e1, e2)) (xes1, xes2) - | (Proj (e1, s1), Proj (e2, s2)) => eq' (e1, e2) andalso s1 = s2 - | (Finish, Finish) => true - | _ => false - fun isKnown e = case e of Const _ => true @@ -174,14 +165,12 @@ fun simplify e = Proj (e', s)) | Finish => Finish -fun eq (e1, e2) = eq' (simplify e1, simplify e2) - -fun decomp or = +fun decomp fals or = let fun decomp p k = case p of True => k [] - | False => true + | False => fals | Unknown => k [] | And (p1, p2) => decomp p1 (fn ps1 => @@ -195,22 +184,155 @@ fun decomp or = decomp end -fun rimp ((r1 : reln, es1), (r2, es2)) = - r1 = r2 andalso ListPair.allEq eq (es1, es2) +val unif = ref (IM.empty : exp IM.map) + +fun lvarIn lv = + let + fun lvi e = + case e of + Const _ => false + | Var _ => false + | Lvar lv' => lv' = lv + | Func (_, es) => List.exists lvi es + | Recd xes => List.exists (lvi o #2) xes + | Proj (e, _) => lvi e + | Finish => false + in + lvi + end + +fun eq' (e1, e2) = + case (e1, e2) of + (Const p1, Const p2) => Prim.equal (p1, p2) + | (Var n1, Var n2) => n1 = n2 + + | (Lvar n1, _) => + (case IM.find (!unif, n1) of + SOME e1 => eq' (e1, e2) + | NONE => + case e2 of + Lvar n2 => + (case IM.find (!unif, n2) of + SOME e2 => eq' (e1, e2) + | NONE => n1 = n2 + orelse (unif := IM.insert (!unif, n1, e2); + true)) + | _ => + if lvarIn n1 e2 then + false + else + (unif := IM.insert (!unif, n1, e2); + true)) + + | (_, Lvar n2) => + (case IM.find (!unif, n2) of + SOME e2 => eq' (e1, e2) + | NONE => + if lvarIn n2 e1 then + false + else + (unif := IM.insert (!unif, n2, e1); + true)) + + | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) + | (Recd xes1, Recd xes2) => ListPair.allEq (fn ((x1, e1), (x2, e2)) => x1 = x2 andalso eq' (e1, e2)) (xes1, xes2) + | (Proj (e1, s1), Proj (e2, s2)) => eq' (e1, e2) andalso s1 = s2 + | (Finish, Finish) => true + | _ => false + +fun eq (e1, e2) = + let + val saved = !unif + in + if eq' (simplify e1, simplify e2) then + true + else + (unif := saved; + false) + end + +exception Imply of prop * prop + +fun rimp ((r1, es1), (r2, es2)) = + case (r1, r2) of + (Sql r1', Sql r2') => + r1' = r2' andalso + (case (es1, es2) of + ([Recd xes1], [Recd xes2]) => + let + val saved = !unif + in + (*print ("Go: " ^ r1' ^ "\n");*) + (*raise Imply (Reln (r1, es1), Reln (r2, es2));*) + if List.all (fn (f, e2) => + List.exists (fn (f', e1) => + f' = f andalso eq (e1, e2)) xes1) xes2 then + true + else + (unif := saved; + false) + end + | _ => false) + | (Eq, Eq) => + (case (es1, es2) of + ([x1, y1], [x2, y2]) => + let + val saved = !unif + in + if eq (x1, x2) andalso eq (y1, y2) then + true + else + (unif := saved; + (*raise Imply (Reln (Eq, es1), Reln (Eq, es2));*) + eq (x1, y2) andalso eq (y1, x2)) + end + | _ => false) + | _ => false + +fun imply (p1, p2) = + (unif := IM.empty; + (*raise (Imply (p1, p2));*) + decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 + (fn hyps => + decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 + (fn goals => + let + fun gls goals onFail = + case goals of + [] => true + | g :: goals => + let + fun hps hyps = + case hyps of + [] => onFail () + | h :: hyps => + let + val saved = !unif + in + if rimp (h, g) then + let + val changed = IM.numItems (!unif) = IM.numItems saved + in + gls goals (fn () => (unif := saved; + changed andalso hps hyps)) + end + else + hps hyps + end + in + hps hyps + end + in + gls goals (fn () => false) + end))) -fun imp (p1, p2) = - decomp (fn (e1, e2) => e1 andalso e2 ()) p1 - (fn hyps => - decomp (fn (e1, e2) => e1 orelse e2 ()) p2 - (fn goals => - List.all (fn r2 => List.exists (fn r1 => rimp (r1, r2)) hyps) goals)) fun patCon pc = case pc of PConVar n => "C" ^ Int.toString n | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c -exception Summaries of (string * exp * prop * (exp * prop) list) list + datatype chunk = String of string @@ -226,8 +348,8 @@ type 'a parser = chunk list -> ('a * chunk list) option fun always v chs = SOME (v, chs) -fun parse p chs = - case p chs of +fun parse p s = + case p (chunkify s) of SOME (v, []) => SOME v | _ => NONE @@ -325,21 +447,33 @@ val from = wrap (follow (const "FROM ") (list fitem)) val query = wrap (follow select from) (fn (fs, ts) => {Select = fs, From = ts}) -fun queryProp rv e = - case parse query (chunkify e) of +fun queryProp rv oe e = + case parse query e of NONE => Unknown | SOME r => - foldl (fn ((t, v), p) => - And (p, - Reln (Sql t, - [Recd (foldl (fn ((v', f), fs) => - if v' = v then - (f, Proj (Proj (Lvar rv, v), f)) :: fs - else - fs) [] (#Select r))]))) - True (#From r) - -fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = + let + val p = + foldl (fn ((t, v), p) => + And (p, + Reln (Sql t, + [Recd (foldl (fn ((v', f), fs) => + if v' = v then + (f, Proj (Proj (Lvar rv, v), f)) :: fs + else + fs) [] (#Select r))]))) + True (#From r) + in + case oe of + NONE => p + | SOME oe => + And (p, + foldl (fn ((v, f), p) => + Or (p, + Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]))) + False (#Select r)) + end + +fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let fun default () = (Var nv, (nv+1, p, sent)) @@ -348,7 +482,7 @@ fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = if isKnown e then sent else - (e, p) :: sent + (loc, e, p) :: sent in case #1 e of EPrim p => (Const p, st) @@ -476,7 +610,7 @@ fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = val r' = newLvar () val acc' = newLvar () - val qp = queryProp r' q + val qp = queryProp r' NONE q val doSubExp = subExp (r, r') o subExp (acc, acc') val doSubProp = subProp (r, r') o subProp (acc, acc') @@ -485,7 +619,9 @@ fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = val p = And (p, qp) val p = Select (r, r', acc', p, doSubExp b) in - (Var r, (#1 st + 1, And (#2 st, p), map (fn (e, p) => (doSubExp e, And (qp, doSubProp p))) (#3 st'))) + (Var r, (#1 st + 1, And (#2 st, p), map (fn (loc, e, p) => (loc, + doSubExp e, + And (qp, doSubProp p))) (#3 st'))) end | EDml _ => default () | ENextval _ => default () @@ -504,7 +640,7 @@ fun evalExp env (e : Mono.exp, st as (nv, p, sent)) = fun check file = let - fun decl ((d, _), summaries) = + fun decl ((d, _), (vals, pols)) = case d of DVal (x, _, _, e, _) => let @@ -513,15 +649,31 @@ fun check file = EAbs (_, _, _, e) => deAbs (e, Var nv :: env, nv + 1) | _ => (e, env, nv) - val (e, env, nv) = deAbs (e, [], 0) + val (e, env, nv) = deAbs (e, [], 1) val (e, (_, p, sent)) = evalExp env (e, (nv, True, [])) in - (x, e, p, sent) :: summaries + ((x, e, p, sent) :: vals, pols) end - | _ => summaries + + | DPolicy (PolQuery e) => (vals, queryProp 0 (SOME (Var 0)) e :: pols) + + | _ => (vals, pols) + + val () = unif := IM.empty + + val (vals, pols) = foldl decl ([], []) file in - raise Summaries (foldl decl [] file) + app (fn (name, _, _, sent) => + app (fn (loc, e, p) => + let + val p = And (p, Reln (Eq, [Var 0, e])) + in + if List.exists (fn pol => imply (p, pol)) pols then + () + else + ErrorMsg.errorAt loc "The information flow policy may be violated here." + end) sent) vals end end diff --git a/tests/policy.ur b/tests/policy.ur index c381beac..2b9fb4b3 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -1,11 +1,11 @@ table fruit : { Id : int, Nam : string, Weight : float, Secret : string } -policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight FROM fruit) +policy query_policy (SELECT fruit.Id, fruit.Nam FROM fruit) fun main () = - xml <- queryX (SELECT fruit.Id, fruit.Nam + xml <- queryX (SELECT fruit.Id, fruit.Nam, fruit.Secret FROM fruit) - (fn x =>
  • {[x.Fruit.Nam]}
    • ); + (fn x =>
  • {[x.Fruit.Secret]}
    • ); return {xml} -- cgit v1.2.3 From ccb85d8fc50d86d6f51387d21cd3a4b9c867a8a4 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 16:44:34 -0400 Subject: Relax checking of table implications --- src/iflow.sml | 33 ++++++++++++++++++--------------- tests/policy.ur | 6 +++--- 2 files changed, 21 insertions(+), 18 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 016e9a08..dcdb7a5e 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -186,6 +186,10 @@ fun decomp fals or = val unif = ref (IM.empty : exp IM.map) +fun reset () = unif := IM.empty +fun save () = !unif +fun restore x = unif := x + fun lvarIn lv = let fun lvi e = @@ -242,12 +246,12 @@ fun eq' (e1, e2) = fun eq (e1, e2) = let - val saved = !unif + val saved = save () in if eq' (simplify e1, simplify e2) then true else - (unif := saved; + (restore saved; false) end @@ -260,16 +264,15 @@ fun rimp ((r1, es1), (r2, es2)) = (case (es1, es2) of ([Recd xes1], [Recd xes2]) => let - val saved = !unif + val saved = save () in - (*print ("Go: " ^ r1' ^ "\n");*) - (*raise Imply (Reln (r1, es1), Reln (r2, es2));*) if List.all (fn (f, e2) => - List.exists (fn (f', e1) => - f' = f andalso eq (e1, e2)) xes1) xes2 then + case ListUtil.search (fn (f', e1) => if f' = f then SOME e1 else NONE) xes1 of + NONE => true + | SOME e1 => eq (e1, e2)) xes2 then true else - (unif := saved; + (restore saved; false) end | _ => false) @@ -277,12 +280,12 @@ fun rimp ((r1, es1), (r2, es2)) = (case (es1, es2) of ([x1, y1], [x2, y2]) => let - val saved = !unif + val saved = save () in if eq (x1, x2) andalso eq (y1, y2) then true else - (unif := saved; + (restore saved; (*raise Imply (Reln (Eq, es1), Reln (Eq, es2));*) eq (x1, y2) andalso eq (y1, x2)) end @@ -290,7 +293,7 @@ fun rimp ((r1, es1), (r2, es2)) = | _ => false fun imply (p1, p2) = - (unif := IM.empty; + (reset (); (*raise (Imply (p1, p2));*) decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 (fn hyps => @@ -307,13 +310,13 @@ fun imply (p1, p2) = [] => onFail () | h :: hyps => let - val saved = !unif + val saved = save () in if rimp (h, g) then let - val changed = IM.numItems (!unif) = IM.numItems saved + val changed = IM.numItems (!unif) <> IM.numItems saved in - gls goals (fn () => (unif := saved; + gls goals (fn () => (restore saved; changed andalso hps hyps)) end else @@ -660,7 +663,7 @@ fun check file = | _ => (vals, pols) - val () = unif := IM.empty + val () = reset () val (vals, pols) = foldl decl ([], []) file in diff --git a/tests/policy.ur b/tests/policy.ur index 2b9fb4b3..bc4da5be 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -1,11 +1,11 @@ table fruit : { Id : int, Nam : string, Weight : float, Secret : string } -policy query_policy (SELECT fruit.Id, fruit.Nam FROM fruit) +policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight FROM fruit) fun main () = - xml <- queryX (SELECT fruit.Id, fruit.Nam, fruit.Secret + xml <- queryX (SELECT fruit.Id, fruit.Nam FROM fruit) - (fn x =>
  • {[x.Fruit.Secret]}
    • ); + (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}
    • ); return {xml} -- cgit v1.2.3 From 20f0e57e0e9e418ef08ce8bdb202b6d10de1c86b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 17:11:22 -0400 Subject: Parsed a WHERE clause --- src/iflow.sml | 51 +++++++++++++++++++++++++++++++++++++++++++++++---- tests/policy.ur | 25 ++++++++++++++++++++----- 2 files changed, 67 insertions(+), 9 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index dcdb7a5e..be49fa59 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -385,6 +385,11 @@ fun alt p1 p2 chs = NONE => p2 chs | v => v +fun opt p chs = + case p chs of + NONE => SOME (NONE, chs) + | SOME (v, chs) => SOME (SOME v, chs) + fun skip cp chs = case chs of String "" :: chs => skip cp chs @@ -412,7 +417,14 @@ fun keep cp chs = end | _ => NONE -fun ws p = wrap (follow p (skip (fn ch => ch = #" "))) #1 +fun ws p = wrap (follow (skip (fn ch => ch = #" ")) + (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) + +fun log name p chs = + (case chs of + String s :: [] => print (name ^ ": " ^ s ^ "\n") + | _ => print (name ^ ": blocked!\n"); + p chs) fun list p chs = (alt (wrap (follow p (follow (ws (const ",")) (list p))) @@ -436,6 +448,34 @@ val sitem = wrap (follow t_ident uw_ident)) (fn (t, ((), f)) => (t, f)) +datatype sqexp = + Field of string * string + | Binop of string * sqexp * sqexp + +val sqbrel = wrap (const "=") (fn () => "=") + +datatype ('a, 'b) sum = inl of 'a | inr of 'b + +fun sqexp chs = + alt + (wrap (follow (ws (const "(")) + (follow (ws sqexp) + (ws (const ")")))) + (fn ((), (e, ())) => e)) + (wrap + (follow (wrap sitem Field) + (alt + (wrap + (follow (ws sqbrel) + (ws sqexp)) + inl) + (always (inr ())))) + (fn (e1, sm) => + case sm of + inl (bo, e2) => Binop (bo, e1, e2) + | inr () => e1)) + chs + val select = wrap (follow (const "SELECT ") (list sitem)) (fn ((), ls) => ls) @@ -447,12 +487,15 @@ val fitem = wrap (follow uw_ident val from = wrap (follow (const "FROM ") (list fitem)) (fn ((), ls) => ls) -val query = wrap (follow select from) - (fn (fs, ts) => {Select = fs, From = ts}) +val wher = wrap (follow (ws (const "WHERE ")) sqexp) + (fn ((), ls) => ls) + +val query = wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}) fun queryProp rv oe e = case parse query e of - NONE => Unknown + NONE => (print "Crap\n"; Unknown) | SOME r => let val p = diff --git a/tests/policy.ur b/tests/policy.ur index bc4da5be..b821d1d1 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -1,12 +1,27 @@ -table fruit : { Id : int, Nam : string, Weight : float, Secret : string } +type fruit = int +table fruit : { Id : fruit, Nam : string, Weight : float, Secret : string } + PRIMARY KEY Id, + CONSTRAINT Nam UNIQUE Nam + +type order = int +table order : { Id : order, Fruit : fruit, Qty : int, Code : int } + PRIMARY KEY Id, + CONSTRAINT Fruit FOREIGN KEY Fruit REFERENCES fruit(Id) policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight FROM fruit) +policy query_policy (SELECT order.Id, order.Fruit, order.Qty FROM order) fun main () = - xml <- queryX (SELECT fruit.Id, fruit.Nam - FROM fruit) - (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}
    • ); + x1 <- queryX (SELECT fruit.Id, fruit.Nam + FROM fruit) + (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}
    • ); + + x2 <- queryX (SELECT fruit.Nam, order.Qty + FROM fruit, order + WHERE order.Fruit = fruit.Id) + (fn x =>
  • {[x.Fruit.Nam]}: {[x.Order.Qty]}
    • ); return - {xml} +
      {x1}
    +
      {x2}
     -- cgit v1.2.3 From 7e8e31fc6375ba9a0b9db891c3ecbc89fbf6d374 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 17:18:41 -0400 Subject: WHERE-dependent checking --- src/iflow.sml | 34 +++++++++++++++++++++++++++++----- tests/policy.ur | 9 ++++++--- 2 files changed, 35 insertions(+), 8 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index be49fa59..d5f677f4 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -508,15 +508,39 @@ fun queryProp rv oe e = else fs) [] (#Select r))]))) True (#From r) + + fun expIn e = + case e of + Field (v, f) => inl (Proj (Proj (Lvar rv, v), f)) + | Binop (bo, e1, e2) => + (case (expIn e1, expIn e2) of + (inr _, _) => inr Unknown + | (_, inr _) => inr Unknown + | (inl e1, inl e2) => + let + val bo = case bo of + "=" => SOME Eq + | _ => NONE + in + case bo of + NONE => inr Unknown + | SOME bo => inr (Reln (bo, [e1, e2])) + end) + + val p = case #Where r of + NONE => p + | SOME e => + case expIn e of + inr p' => And (p, p') + | _ => p in case oe of NONE => p | SOME oe => - And (p, - foldl (fn ((v, f), p) => - Or (p, - Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]))) - False (#Select r)) + And (p, foldl (fn ((v, f), p) => + Or (p, + Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]))) + False (#Select r)) end fun evalExp env (e as (_, loc), st as (nv, p, sent)) = diff --git a/tests/policy.ur b/tests/policy.ur index b821d1d1..9cc230bf 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -8,8 +8,11 @@ table order : { Id : order, Fruit : fruit, Qty : int, Code : int } PRIMARY KEY Id, CONSTRAINT Fruit FOREIGN KEY Fruit REFERENCES fruit(Id) -policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight FROM fruit) -policy query_policy (SELECT order.Id, order.Fruit, order.Qty FROM order) +policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight + FROM fruit) +policy query_policy (SELECT order.Id, order.Fruit, order.Qty + FROM order, fruit + WHERE order.Fruit = fruit.Id) fun main () = x1 <- queryX (SELECT fruit.Id, fruit.Nam @@ -18,7 +21,7 @@ fun main () = x2 <- queryX (SELECT fruit.Nam, order.Qty FROM fruit, order - WHERE order.Fruit = fruit.Id) + WHERE fruit.Id = order.Fruit) (fn x =>
  • {[x.Fruit.Nam]}: {[x.Order.Qty]}
    • ); return -- cgit v1.2.3 From 677c10e07e93c08f5990a9c74dae4da65b7270f8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 4 Apr 2010 17:44:12 -0400 Subject: Parsing more of WHERE --- src/iflow.sig | 2 ++ src/iflow.sml | 105 +++++++++++++++++++++++++++++++++++--------------------- tests/policy.ur | 6 ++-- 3 files changed, 72 insertions(+), 41 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sig b/src/iflow.sig index 2bdc9aae..2ef8be5f 100644 --- a/src/iflow.sig +++ b/src/iflow.sig @@ -55,4 +55,6 @@ signature IFLOW = sig val check : Mono.file -> unit + val debug : bool ref + end diff --git a/src/iflow.sml b/src/iflow.sml index d5f677f4..15db5b78 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -420,10 +420,15 @@ fun keep cp chs = fun ws p = wrap (follow (skip (fn ch => ch = #" ")) (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) +val debug = ref false + fun log name p chs = - (case chs of - String s :: [] => print (name ^ ": " ^ s ^ "\n") - | _ => print (name ^ ": blocked!\n"); + (if !debug then + case chs of + String s :: [] => print (name ^ ": " ^ s ^ "\n") + | _ => print (name ^ ": blocked!\n") + else + (); p chs) fun list p chs = @@ -448,34 +453,64 @@ val sitem = wrap (follow t_ident uw_ident)) (fn (t, ((), f)) => (t, f)) +datatype Rel = + Exps of exp * exp -> prop + | Props of prop * prop -> prop + datatype sqexp = - Field of string * string - | Binop of string * sqexp * sqexp + SqConst of Prim.t + | Field of string * string + | Binop of Rel * sqexp * sqexp -val sqbrel = wrap (const "=") (fn () => "=") +val sqbrel = alt (wrap (const "=") (fn () => Exps (fn (e1, e2) => Reln (Eq, [e1, e2])))) + (alt (wrap (const "AND") (fn () => Props And)) + (wrap (const "OR") (fn () => Props Or))) datatype ('a, 'b) sum = inl of 'a | inr of 'b +fun int chs = + case chs of + String s :: chs' => + let + val (befor, after) = Substring.splitl Char.isDigit (Substring.full s) + in + if Substring.isEmpty befor then + NONE + else case Int64.fromString (Substring.string befor) of + NONE => NONE + | SOME n => SOME (n, if Substring.isEmpty after then + chs' + else + String (Substring.string after) :: chs') + end + | _ => NONE + +val prim = wrap (follow (wrap int Prim.Int) (opt (const "::int8"))) #1 + fun sqexp chs = - alt - (wrap (follow (ws (const "(")) - (follow (ws sqexp) - (ws (const ")")))) - (fn ((), (e, ())) => e)) - (wrap - (follow (wrap sitem Field) - (alt - (wrap - (follow (ws sqbrel) - (ws sqexp)) - inl) - (always (inr ())))) - (fn (e1, sm) => - case sm of - inl (bo, e2) => Binop (bo, e1, e2) - | inr () => e1)) - chs - + log "sqexp" + (alt + (wrap prim SqConst) + (alt + (wrap sitem Field) + (wrap + (follow (ws (const "(")) + (follow (wrap + (follow sqexp + (alt + (wrap + (follow (ws sqbrel) + (ws sqexp)) + inl) + (always (inr ())))) + (fn (e1, sm) => + case sm of + inl (bo, e2) => Binop (bo, e1, e2) + | inr () => e1)) + (const ")"))) + (fn ((), (e, ())) => e)))) + chs + val select = wrap (follow (const "SELECT ") (list sitem)) (fn ((), ls) => ls) @@ -511,21 +546,13 @@ fun queryProp rv oe e = fun expIn e = case e of - Field (v, f) => inl (Proj (Proj (Lvar rv, v), f)) + SqConst p => inl (Const p) + | Field (v, f) => inl (Proj (Proj (Lvar rv, v), f)) | Binop (bo, e1, e2) => - (case (expIn e1, expIn e2) of - (inr _, _) => inr Unknown - | (_, inr _) => inr Unknown - | (inl e1, inl e2) => - let - val bo = case bo of - "=" => SOME Eq - | _ => NONE - in - case bo of - NONE => inr Unknown - | SOME bo => inr (Reln (bo, [e1, e2])) - end) + inr (case (bo, expIn e1, expIn e2) of + (Exps f, inl e1, inl e2) => f (e1, e2) + | (Props f, inr p1, inr p2) => f (p1, p2) + | _ => Unknown) val p = case #Where r of NONE => p diff --git a/tests/policy.ur b/tests/policy.ur index 9cc230bf..642e4efc 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -12,7 +12,8 @@ policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight FROM fruit) policy query_policy (SELECT order.Id, order.Fruit, order.Qty FROM order, fruit - WHERE order.Fruit = fruit.Id) + WHERE order.Fruit = fruit.Id + AND order.Qty = 13) fun main () = x1 <- queryX (SELECT fruit.Id, fruit.Nam @@ -21,7 +22,8 @@ fun main () = x2 <- queryX (SELECT fruit.Nam, order.Qty FROM fruit, order - WHERE fruit.Id = order.Fruit) + WHERE fruit.Id = order.Fruit + AND order.Qty = 13) (fn x =>
  • {[x.Fruit.Nam]}: {[x.Order.Qty]}
    • ); return -- cgit v1.2.3 From 9f1124b65aea0bdd0909184ebf8056cd64d7c546 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 09:51:36 -0400 Subject: Introduced the known() predicate --- lib/ur/basis.urs | 1 + src/iflow.sig | 3 +- src/iflow.sml | 277 +++++++++++++++++++++++++++++++++++++++++----------- src/mono_reduce.sml | 6 ++ src/monoize.sml | 2 + tests/policy.ur | 26 ++++- 6 files changed, 254 insertions(+), 61 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index aad04b5f..72970351 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -498,6 +498,7 @@ val sql_ufunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_ufunc dom ran -> sql_exp tables agg exps dom -> sql_exp tables agg exps ran val sql_octet_length : sql_ufunc blob int +val sql_known : t ::: Type -> sql_ufunc t bool val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type diff --git a/src/iflow.sig b/src/iflow.sig index 2ef8be5f..bc481022 100644 --- a/src/iflow.sig +++ b/src/iflow.sig @@ -39,7 +39,8 @@ signature IFLOW = sig | Finish datatype reln = - Sql of string + Known + | Sql of string | Eq datatype prop = diff --git a/src/iflow.sml b/src/iflow.sml index 15db5b78..6e54e9d9 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -29,6 +29,7 @@ structure Iflow :> IFLOW = struct open Mono +structure IS = IntBinarySet structure IM = IntBinaryMap structure SS = BinarySetFn(struct @@ -64,7 +65,8 @@ datatype exp = | Finish datatype reln = - Sql of string + Known + | Sql of string | Eq datatype prop = @@ -76,6 +78,85 @@ datatype prop = | Reln of reln * exp list | Select of int * lvar * lvar * prop * exp +local + open Print + val string = PD.string +in + +fun p_exp e = + case e of + Const p => Prim.p_t p + | Var n => string ("x" ^ Int.toString n) + | Lvar n => string ("X" ^ Int.toString n) + | Func (f, es) => box [string (f ^ "("), + p_list p_exp es, + string ")"] + | Recd xes => box [string "{", + p_list (fn (x, e) => box [string "x", + space, + string "=", + space, + p_exp e]) xes, + string "}"] + | Proj (e, x) => box [p_exp e, + string ("." ^ x)] + | Finish => string "FINISH" + +fun p_reln r es = + case r of + Known => + (case es of + [e] => box [string "known(", + p_exp e, + string ")"] + | _ => raise Fail "Iflow.p_reln: Known") + | Sql s => box [string (s ^ "("), + p_list p_exp es, + string ")"] + | Eq => + (case es of + [e1, e2] => box [p_exp e1, + space, + string "=", + space, + p_exp e2] + | _ => raise Fail "Iflow.p_reln: Eq") + +fun p_prop p = + case p of + True => string "True" + | False => string "False" + | Unknown => string "??" + | And (p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "&&", + space, + string "(", + p_prop p2, + string ")"] + | Or (p1, p2) => box [string "(", + p_prop p1, + string ")", + space, + string "||", + space, + string "(", + p_prop p2, + string ")"] + | Reln (r, es) => p_reln r es + | Select (n1, n2, n3, p, e) => box [string ("select(x" ^ Int.toString n1 + ^ ",X" ^ Int.toString n2 + ^ ",X" ^ Int.toString n3 + ^ "){"), + p_prop p, + string "}{", + p_exp e, + string "}"] + +end + local val count = ref 1 in @@ -290,6 +371,19 @@ fun rimp ((r1, es1), (r2, es2)) = eq (x1, y2) andalso eq (y1, x2)) end | _ => false) + | (Known, Known) => + (case (es1, es2) of + ([e1], [e2]) => + let + fun walk e2 = + eq (e1, e2) orelse + case e2 of + Proj (e2, _) => walk e2 + | _ => false + in + walk e2 + end + | _ => false) | _ => false fun imply (p1, p2) = @@ -344,7 +438,18 @@ datatype chunk = fun chunkify e = case #1 e of EPrim (Prim.String s) => [String s] - | EStrcat (e1, e2) => chunkify e1 @ chunkify e2 + | EStrcat (e1, e2) => + let + val chs1 = chunkify e1 + val chs2 = chunkify e2 + in + case chs2 of + String s2 :: chs2' => + (case List.last chs1 of + String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2' + | _ => chs1 @ chs2) + | _ => chs1 @ chs2 + end | _ => [Exp e] type 'a parser = chunk list -> ('a * chunk list) option @@ -385,6 +490,12 @@ fun alt p1 p2 chs = NONE => p2 chs | v => v +fun altL ps = + case rev ps of + [] => (fn _ => NONE) + | p :: ps => + foldl (fn (p1, p2) => alt p1 p2) p ps + fun opt p chs = case p chs of NONE => SOME (NONE, chs) @@ -425,17 +536,17 @@ val debug = ref false fun log name p chs = (if !debug then case chs of - String s :: [] => print (name ^ ": " ^ s ^ "\n") + String s :: _ => print (name ^ ": " ^ s ^ "\n") | _ => print (name ^ ": blocked!\n") else (); p chs) fun list p chs = - (alt (wrap (follow p (follow (ws (const ",")) (list p))) - (fn (v, ((), ls)) => v :: ls)) - (alt (wrap (ws p) (fn v => [v])) - (always []))) chs + altL [wrap (follow p (follow (ws (const ",")) (list p))) + (fn (v, ((), ls)) => v :: ls), + wrap (ws p) (fn v => [v]), + always []] chs val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_") @@ -461,10 +572,12 @@ datatype sqexp = SqConst of Prim.t | Field of string * string | Binop of Rel * sqexp * sqexp + | SqKnown of sqexp + | Inj of Mono.exp -val sqbrel = alt (wrap (const "=") (fn () => Exps (fn (e1, e2) => Reln (Eq, [e1, e2])))) - (alt (wrap (const "AND") (fn () => Props And)) - (wrap (const "OR") (fn () => Props Or))) +val sqbrel = altL [wrap (const "=") (fn () => Exps (fn (e1, e2) => Reln (Eq, [e1, e2]))), + wrap (const "AND") (fn () => Props And), + wrap (const "OR") (fn () => Props Or)] datatype ('a, 'b) sum = inl of 'a | inr of 'b @@ -487,50 +600,71 @@ fun int chs = val prim = wrap (follow (wrap int Prim.Int) (opt (const "::int8"))) #1 +fun known' chs = + case chs of + Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs) + | _ => NONE + +fun sqlify chs = + case chs of + Exp (EFfiApp ("Basis", f, [e]), _) :: chs => + if String.isPrefix "sqlify" f then + SOME (e, chs) + else + NONE + | _ => NONE + fun sqexp chs = log "sqexp" - (alt - (wrap prim SqConst) - (alt - (wrap sitem Field) - (wrap - (follow (ws (const "(")) - (follow (wrap - (follow sqexp - (alt - (wrap - (follow (ws sqbrel) - (ws sqexp)) - inl) - (always (inr ())))) - (fn (e1, sm) => - case sm of - inl (bo, e2) => Binop (bo, e1, e2) - | inr () => e1)) - (const ")"))) - (fn ((), (e, ())) => e)))) - chs - -val select = wrap (follow (const "SELECT ") (list sitem)) - (fn ((), ls) => ls) + (altL [wrap prim SqConst, + wrap sitem Field, + wrap known SqKnown, + wrap sqlify Inj, + wrap (follow (ws (const "(")) + (follow (wrap + (follow sqexp + (alt + (wrap + (follow (ws sqbrel) + (ws sqexp)) + inl) + (always (inr ())))) + (fn (e1, sm) => + case sm of + inl (bo, e2) => Binop (bo, e1, e2) + | inr () => e1)) + (const ")"))) + (fn ((), (e, ())) => e)]) + chs + +and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) + (fn ((), ((), (e, ()))) => e) chs + +val select = log "select" + (wrap (follow (const "SELECT ") (list sitem)) + (fn ((), ls) => ls)) val fitem = wrap (follow uw_ident (follow (const " AS ") t_ident)) (fn (t, ((), f)) => (t, f)) -val from = wrap (follow (const "FROM ") (list fitem)) - (fn ((), ls) => ls) +val from = log "from" + (wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls)) val wher = wrap (follow (ws (const "WHERE ")) sqexp) (fn ((), ls) => ls) -val query = wrap (follow (follow select from) (opt wher)) - (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher}) +val query = log "query" + (wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) -fun queryProp rv oe e = +fun queryProp env rv oe e = case parse query e of - NONE => (print "Crap\n"; Unknown) + NONE => (print ("Warning: Information flow checker can't parse SQL query at " + ^ ErrorMsg.spanToString (#2 e) ^ "\n"); + Unknown) | SOME r => let val p = @@ -553,6 +687,20 @@ fun queryProp rv oe e = (Exps f, inl e1, inl e2) => f (e1, e2) | (Props f, inr p1, inr p2) => f (p1, p2) | _ => Unknown) + | SqKnown e => + inr (case expIn e of + inl e => Reln (Known, [e]) + | _ => Unknown) + | Inj e => + let + fun deinj (e, _) = + case e of + ERel n => List.nth (env, n) + | EField (e, f) => Proj (deinj e, f) + | _ => raise Fail "Iflow: non-variable injected into query" + in + inl (deinj e) + end val p = case #Where r of NONE => p @@ -707,7 +855,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val r' = newLvar () val acc' = newLvar () - val qp = queryProp r' NONE q + val qp = queryProp env r' NONE q val doSubExp = subExp (r, r') o subExp (acc, acc') val doSubProp = subProp (r, r') o subProp (acc, acc') @@ -737,23 +885,34 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = fun check file = let + val exptd = foldl (fn ((d, _), exptd) => + case d of + DExport (_, _, n, _, _, _) => IS.add (exptd, n) + | _ => exptd) IS.empty file + fun decl ((d, _), (vals, pols)) = case d of - DVal (x, _, _, e, _) => + DVal (_, n, _, e, _) => let - fun deAbs (e, env, nv) = + val isExptd = IS.member (exptd, n) + + fun deAbs (e, env, nv, p) = case #1 e of - EAbs (_, _, _, e) => deAbs (e, Var nv :: env, nv + 1) - | _ => (e, env, nv) + EAbs (_, _, _, e) => deAbs (e, Var nv :: env, nv + 1, + if isExptd then + And (p, Reln (Known, [Var nv])) + else + p) + | _ => (e, env, nv, p) - val (e, env, nv) = deAbs (e, [], 1) + val (e, env, nv, p) = deAbs (e, [], 1, True) - val (e, (_, p, sent)) = evalExp env (e, (nv, True, [])) + val (e, (_, p, sent)) = evalExp env (e, (nv, p, [])) in - ((x, e, p, sent) :: vals, pols) + (sent @ vals, pols) end - | DPolicy (PolQuery e) => (vals, queryProp 0 (SOME (Var 0)) e :: pols) + | DPolicy (PolQuery e) => (vals, queryProp [] 0 (SOME (Var 0)) e :: pols) | _ => (vals, pols) @@ -761,16 +920,16 @@ fun check file = val (vals, pols) = foldl decl ([], []) file in - app (fn (name, _, _, sent) => - app (fn (loc, e, p) => - let - val p = And (p, Reln (Eq, [Var 0, e])) - in - if List.exists (fn pol => imply (p, pol)) pols then - () - else - ErrorMsg.errorAt loc "The information flow policy may be violated here." - end) sent) vals + app (fn (loc, e, p) => + let + val p = And (p, Reln (Eq, [Var 0, e])) + in + if List.exists (fn pol => imply (p, pol)) pols then + () + else + (ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.preface ("The state satisifes this predicate:", p_prop p)) + end) vals end end diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 6bd5ceb8..e5dd3213 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -193,6 +193,12 @@ fun match (env, p : pat, e : exp) = else No + | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) => + if String.isSuffix s' s then + Maybe + else + No + | (PPrim p, EPrim p') => if Prim.equal (p, p') then Yes env diff --git a/src/monoize.sml b/src/monoize.sml index 6f229766..073c26de 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2580,6 +2580,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = "octet_length" else "length")), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => + ((L'.EFfi ("Basis", "sql_known"), loc), fm) | (L.ECApp ( (L.ECApp ( diff --git a/tests/policy.ur b/tests/policy.ur index 642e4efc..db89fbe5 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -8,13 +8,31 @@ table order : { Id : order, Fruit : fruit, Qty : int, Code : int } PRIMARY KEY Id, CONSTRAINT Fruit FOREIGN KEY Fruit REFERENCES fruit(Id) -policy query_policy (SELECT fruit.Id, fruit.Nam, fruit.Weight +(* Everyone may knows IDs and names. *) +policy query_policy (SELECT fruit.Id, fruit.Nam FROM fruit) + +(* The weight is sensitive information; you must know the secret. *) +policy query_policy (SELECT fruit.Weight + FROM fruit + WHERE known(fruit.Secret)) + policy query_policy (SELECT order.Id, order.Fruit, order.Qty FROM order, fruit WHERE order.Fruit = fruit.Id AND order.Qty = 13) +fun fname r = + x <- queryX (SELECT fruit.Weight + FROM fruit + WHERE fruit.Nam = {[r.Nam]} + AND fruit.Secret = {[r.Secret]}) + (fn r => Weight is {[r.Fruit.Weight]}); + + return + {x} + + fun main () = x1 <- queryX (SELECT fruit.Id, fruit.Nam FROM fruit) @@ -29,4 +47,10 @@ fun main () = return
      {x1}
      {x2}
    + +
    + Fruit name:
    + Secret:
    + +
    -- cgit v1.2.3 From f91d0356ca6a514852a1dd1332a204cddf8dd1aa Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 10:39:15 -0400 Subject: Checking known() correctly, according to a pair of examples --- src/iflow.sml | 219 +++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 163 insertions(+), 56 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 6e54e9d9..27655109 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -212,11 +212,20 @@ fun isFinish e = Finish => true | _ => false +val unif = ref (IM.empty : exp IM.map) + +fun reset () = unif := IM.empty +fun save () = !unif +fun restore x = unif := x + fun simplify e = case e of Const _ => e | Var _ => e - | Lvar _ => e + | Lvar n => + (case IM.find (!unif, n) of + NONE => e + | SOME e => simplify e) | Func (f, es) => let val es = map simplify es @@ -265,12 +274,6 @@ fun decomp fals or = decomp end -val unif = ref (IM.empty : exp IM.map) - -fun reset () = unif := IM.empty -fun save () = !unif -fun restore x = unif := x - fun lvarIn lv = let fun lvi e = @@ -300,7 +303,7 @@ fun eq' (e1, e2) = (case IM.find (!unif, n2) of SOME e2 => eq' (e1, e2) | NONE => n1 = n2 - orelse (unif := IM.insert (!unif, n1, e2); + orelse (unif := IM.insert (!unif, n2, e1); true)) | _ => if lvarIn n1 e2 then @@ -338,7 +341,85 @@ fun eq (e1, e2) = exception Imply of prop * prop -fun rimp ((r1, es1), (r2, es2)) = +val debug = ref false + +(* Congruence closure *) +structure Cc :> sig + type t + val empty : t + val assert : t * exp * exp -> t + val query : t * exp * exp -> bool + val allPeers : t * exp -> exp list +end = struct + +fun eq' (e1, e2) = + case (e1, e2) of + (Const p1, Const p2) => Prim.equal (p1, p2) + | (Var n1, Var n2) => n1 = n2 + | (Lvar n1, Lvar n2) => n1 = n2 + | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) + | (Recd xes1, Recd xes2) => length xes1 = length xes2 andalso + List.all (fn (x2, e2) => + List.exists (fn (x1, e1) => x1 = x2 andalso eq' (e1, e2)) xes2) xes1 + | (Proj (e1, x1), Proj (e2, x2)) => eq' (e1, e2) andalso x1 = x2 + | (Finish, Finish) => true + | _ => false + +fun eq (e1, e2) = eq' (simplify e1, simplify e2) + +type t = (exp * exp) list + +val empty = [] + +fun lookup (t, e) = + case List.find (fn (e', _) => eq (e', e)) t of + NONE => e + | SOME (_, e2) => lookup (t, e2) + +fun assert (t, e1, e2) = + let + val r1 = lookup (t, e1) + val r2 = lookup (t, e2) + in + if eq (r1, r2) then + t + else + (r1, r2) :: t + end + +open Print + +fun query (t, e1, e2) = + (if !debug then + prefaces "CC query" [("e1", p_exp (simplify e1)), + ("e2", p_exp (simplify e2)), + ("t", p_list (fn (e1, e2) => box [p_exp (simplify e1), + space, + PD.string "->", + space, + p_exp (simplify e2)]) t)] + else + (); + eq (lookup (t, e1), lookup (t, e2))) + +fun allPeers (t, e) = + let + val r = lookup (t, e) + in + r :: List.mapPartial (fn (e1, e2) => + let + val r' = lookup (t, e2) + in + if eq (r, r') then + SOME e1 + else + NONE + end) t + end + +end + +fun rimp cc ((r1, es1), (r2, es2)) = case (r1, r2) of (Sql r1', Sql r2') => r1' = r2' andalso @@ -367,62 +448,81 @@ fun rimp ((r1, es1), (r2, es2)) = true else (restore saved; - (*raise Imply (Reln (Eq, es1), Reln (Eq, es2));*) - eq (x1, y2) andalso eq (y1, x2)) + if eq (x1, y2) andalso eq (y1, x2) then + true + else + (restore saved; + false)) end | _ => false) | (Known, Known) => (case (es1, es2) of - ([e1], [e2]) => + ([Var v], [e2]) => let - fun walk e2 = - eq (e1, e2) orelse - case e2 of - Proj (e2, _) => walk e2 + fun matches e = + case e of + Var v' => v' = v + | Proj (e, _) => matches e | _ => false in - walk e2 + List.exists matches (Cc.allPeers (cc, e2)) end | _ => false) | _ => false fun imply (p1, p2) = - (reset (); - (*raise (Imply (p1, p2));*) - decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 - (fn hyps => - decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 - (fn goals => - let - fun gls goals onFail = - case goals of - [] => true - | g :: goals => - let - fun hps hyps = - case hyps of - [] => onFail () - | h :: hyps => - let - val saved = save () - in - if rimp (h, g) then - let - val changed = IM.numItems (!unif) <> IM.numItems saved - in - gls goals (fn () => (restore saved; - changed andalso hps hyps)) - end - else - hps hyps - end - in - hps hyps - end - in - gls goals (fn () => false) - end))) - + let + fun doOne doKnown = + decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 + (fn hyps => + decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 + (fn goals => + let + val cc = foldl (fn (p, cc) => + case p of + (Eq, [e1, e2]) => Cc.assert (cc, e1, e2) + | _ => cc) Cc.empty hyps + + fun gls goals onFail = + case goals of + [] => true + | g :: goals => + case (doKnown, g) of + (false, (Known, _)) => gls goals onFail + | _ => + let + fun hps hyps = + case hyps of + [] => onFail () + | h :: hyps => + let + val saved = save () + in + if rimp cc (h, g) then + let + val changed = IM.numItems (!unif) + <> IM.numItems saved + in + gls goals (fn () => (restore saved; + changed andalso hps hyps)) + end + else + hps hyps + end + in + (case g of + (Eq, [e1, e2]) => Cc.query (cc, e1, e2) + | _ => false) + orelse hps hyps + end + in + gls goals (fn () => false) + end)) + in + reset (); + doOne false; + doOne true + end fun patCon pc = case pc of @@ -531,8 +631,6 @@ fun keep cp chs = fun ws p = wrap (follow (skip (fn ch => ch = #" ")) (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) -val debug = ref false - fun log name p chs = (if !debug then case chs of @@ -924,7 +1022,16 @@ fun check file = let val p = And (p, Reln (Eq, [Var 0, e])) in - if List.exists (fn pol => imply (p, pol)) pols then + if List.exists (fn pol => if imply (p, pol) then + (if !debug then + Print.prefaces "Match" + [("Hyp", p_prop p), + ("Goal", p_prop pol)] + else + (); + true) + else + false) pols then () else (ErrorMsg.errorAt loc "The information flow policy may be violated here."; -- cgit v1.2.3 From 80e769bec359d261a15235f58c951ffdfdc2d0e8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 11:07:19 -0400 Subject: Parsing float and string SQL literals --- src/iflow.sml | 60 +++++++++++++++++++++++++++++++++++++++++---------------- tests/policy.ur | 4 +++- 2 files changed, 46 insertions(+), 18 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 27655109..58b38e6c 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -585,6 +585,14 @@ fun wrap p f chs = NONE => NONE | SOME (v, chs) => SOME (f v, chs) +fun wrapP p f chs = + case p chs of + NONE => NONE + | SOME (v, chs) => + case f v of + NONE => NONE + | SOME r => SOME (r, chs) + fun alt p1 p2 chs = case p1 chs of NONE => p2 chs @@ -679,24 +687,42 @@ val sqbrel = altL [wrap (const "=") (fn () => Exps (fn (e1, e2) => Reln (Eq, [e1 datatype ('a, 'b) sum = inl of 'a | inr of 'b -fun int chs = +fun string chs = case chs of - String s :: chs' => - let - val (befor, after) = Substring.splitl Char.isDigit (Substring.full s) - in - if Substring.isEmpty befor then - NONE - else case Int64.fromString (Substring.string befor) of - NONE => NONE - | SOME n => SOME (n, if Substring.isEmpty after then - chs' - else - String (Substring.string after) :: chs') - end - | _ => NONE - -val prim = wrap (follow (wrap int Prim.Int) (opt (const "::int8"))) #1 + String s :: chs => + if size s >= 2 andalso String.sub (s, 0) = #"'" then + let + fun loop (cs, acc) = + case cs of + [] => NONE + | c :: cs => + if c = #"'" then + SOME (String.implode (rev acc), cs) + else if c = #"\\" then + case cs of + c :: cs => loop (cs, c :: acc) + | _ => raise Fail "Iflow.string: Unmatched backslash escape" + else + loop (cs, c :: acc) + in + case loop (String.explode (String.extract (s, 1, NONE)), []) of + NONE => NONE + | SOME (s, []) => SOME (s, chs) + | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs) + end + else + NONE + | _ => NONE + +val prim = + altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) + (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y)))) + (opt (const "::float8"))) #1, + wrap (follow (wrapP (keep Char.isDigit) + (Option.map Prim.Int o Int64.fromString)) + (opt (const "::int8"))) #1, + wrap (follow (opt (const "E")) (follow string (opt (const "::text")))) + (Prim.String o #1 o #2)] fun known' chs = case chs of diff --git a/tests/policy.ur b/tests/policy.ur index db89fbe5..6f2d2d5b 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -35,7 +35,9 @@ fun fname r = fun main () = x1 <- queryX (SELECT fruit.Id, fruit.Nam - FROM fruit) + FROM fruit + WHERE fruit.Nam = "apple" + AND fruit.Weight = 1.23) (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}
    • ); x2 <- queryX (SELECT fruit.Nam, order.Qty -- cgit v1.2.3 From 880a09d1b36d1b4db23d72404c3e54f351a6541a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 12:04:08 -0400 Subject: Parsing more comparison operators --- src/iflow.sig | 5 ++++ src/iflow.sml | 89 ++++++++++++++++++++++++++++++++++++++++----------------- tests/policy.ur | 13 ++++++--- 3 files changed, 76 insertions(+), 31 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sig b/src/iflow.sig index bc481022..f85322ef 100644 --- a/src/iflow.sig +++ b/src/iflow.sig @@ -42,6 +42,11 @@ signature IFLOW = sig Known | Sql of string | Eq + | Ne + | Lt + | Le + | Gt + | Ge datatype prop = True diff --git a/src/iflow.sml b/src/iflow.sml index 58b38e6c..4dfa4e8d 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -68,6 +68,11 @@ datatype reln = Known | Sql of string | Eq + | Ne + | Lt + | Le + | Gt + | Ge datatype prop = True @@ -92,7 +97,7 @@ fun p_exp e = p_list p_exp es, string ")"] | Recd xes => box [string "{", - p_list (fn (x, e) => box [string "x", + p_list (fn (x, e) => box [string x, space, string "=", space, @@ -102,6 +107,15 @@ fun p_exp e = string ("." ^ x)] | Finish => string "FINISH" +fun p_bop s es = + case es of + [e1, e2] => box [p_exp e1, + space, + string s, + space, + p_exp e2] + | _ => raise Fail "Iflow.p_bop" + fun p_reln r es = case r of Known => @@ -113,14 +127,12 @@ fun p_reln r es = | Sql s => box [string (s ^ "("), p_list p_exp es, string ")"] - | Eq => - (case es of - [e1, e2] => box [p_exp e1, - space, - string "=", - space, - p_exp e2] - | _ => raise Fail "Iflow.p_reln: Eq") + | Eq => p_bop "=" es + | Ne => p_bop "<>" es + | Lt => p_bop "<" es + | Le => p_bop "<=" es + | Gt => p_bop ">" es + | Ge => p_bop ">=" es fun p_prop p = case p of @@ -660,8 +672,9 @@ val t_ident = wrap ident (fn s => if String.isPrefix "T_" s then String.extract (s, 2, NONE) else raise Fail "Iflow: Bad table variable") -val uw_ident = wrap ident (fn s => if String.isPrefix "uw_" s then - String.extract (s, 3, NONE) +val uw_ident = wrap ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then + str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE) else raise Fail "Iflow: Bad uw_* variable") @@ -681,7 +694,14 @@ datatype sqexp = | SqKnown of sqexp | Inj of Mono.exp -val sqbrel = altL [wrap (const "=") (fn () => Exps (fn (e1, e2) => Reln (Eq, [e1, e2]))), +fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) + +val sqbrel = altL [cmp "=" Eq, + cmp "<>" Ne, + cmp "<=" Le, + cmp "<" Lt, + cmp ">=" Ge, + cmp ">" Gt, wrap (const "AND") (fn () => Props And), wrap (const "OR") (fn () => Props Or)] @@ -788,7 +808,7 @@ fun queryProp env rv oe e = case parse query e of NONE => (print ("Warning: Information flow checker can't parse SQL query at " ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - Unknown) + (Unknown, [])) | SOME r => let val p = @@ -826,6 +846,14 @@ fun queryProp env rv oe e = inl (deinj e) end + fun usedFields e = + case e of + SqConst _ => [] + | Field (v, f) => [Proj (Proj (Lvar rv, v), f)] + | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 + | SqKnown _ => [] + | Inj _ => [] + val p = case #Where r of NONE => p | SOME e => @@ -833,13 +861,17 @@ fun queryProp env rv oe e = inr p' => And (p, p') | _ => p in - case oe of - NONE => p - | SOME oe => - And (p, foldl (fn ((v, f), p) => - Or (p, - Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]))) - False (#Select r)) + (case oe of + NONE => p + | SOME oe => + And (p, foldl (fn ((v, f), p) => + Or (p, + Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]))) + False (#Select r)), + + case #Where r of + NONE => [] + | SOME e => usedFields e) end fun evalExp env (e as (_, loc), st as (nv, p, sent)) = @@ -979,18 +1011,21 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val r' = newLvar () val acc' = newLvar () - val qp = queryProp env r' NONE q + val (qp, used) = queryProp env r' NONE q val doSubExp = subExp (r, r') o subExp (acc, acc') val doSubProp = subProp (r, r') o subProp (acc, acc') val p = doSubProp (#2 st') - val p = And (p, qp) - val p = Select (r, r', acc', p, doSubExp b) + val p' = And (p, qp) + val p = Select (r, r', acc', p', doSubExp b) + + val sent = map (fn (loc, e, p) => (loc, + doSubExp e, + And (qp, doSubProp p))) (#3 st') + val sent = map (fn e => (loc, e, p')) used @ sent in - (Var r, (#1 st + 1, And (#2 st, p), map (fn (loc, e, p) => (loc, - doSubExp e, - And (qp, doSubProp p))) (#3 st'))) + (Var r, (#1 st + 1, And (#2 st, p), sent)) end | EDml _ => default () | ENextval _ => default () @@ -1036,7 +1071,7 @@ fun check file = (sent @ vals, pols) end - | DPolicy (PolQuery e) => (vals, queryProp [] 0 (SOME (Var 0)) e :: pols) + | DPolicy (PolQuery e) => (vals, #1 (queryProp [] 0 (SOME (Var 0)) e) :: pols) | _ => (vals, pols) diff --git a/tests/policy.ur b/tests/policy.ur index 6f2d2d5b..40850393 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -13,7 +13,7 @@ policy query_policy (SELECT fruit.Id, fruit.Nam FROM fruit) (* The weight is sensitive information; you must know the secret. *) -policy query_policy (SELECT fruit.Weight +policy query_policy (SELECT fruit.Weight, fruit.Secret FROM fruit WHERE known(fruit.Secret)) @@ -26,7 +26,12 @@ fun fname r = x <- queryX (SELECT fruit.Weight FROM fruit WHERE fruit.Nam = {[r.Nam]} - AND fruit.Secret = {[r.Secret]}) + AND fruit.Secret = {[r.Secret]} + AND fruit.Weight <> 3.14 + AND fruit.Weight < 100.0 + AND fruit.Weight <= 200.1 + AND fruit.Weight > 1.23 + AND fruit.Weight >= 1.24) (fn r => Weight is {[r.Fruit.Weight]}); return @@ -36,8 +41,7 @@ fun fname r = fun main () = x1 <- queryX (SELECT fruit.Id, fruit.Nam FROM fruit - WHERE fruit.Nam = "apple" - AND fruit.Weight = 1.23) + WHERE fruit.Nam = "apple") (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}
    • ); x2 <- queryX (SELECT fruit.Nam, order.Qty @@ -48,6 +52,7 @@ fun main () = return
      {x1}
    +
      {x2}
    -- cgit v1.2.3 From 725ed06c2c87b8466e9cc7e5f06aeee1fed4c0aa Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 13:59:16 -0400 Subject: About to try removing Select predicate --- src/iflow.sig | 32 -------- src/iflow.sml | 248 +++++++++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 204 insertions(+), 76 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sig b/src/iflow.sig index f85322ef..3e624bb1 100644 --- a/src/iflow.sig +++ b/src/iflow.sig @@ -27,38 +27,6 @@ signature IFLOW = sig - type lvar = int - - datatype exp = - Const of Prim.t - | Var of int - | Lvar of int - | Func of string * exp list - | Recd of (string * exp) list - | Proj of exp * string - | Finish - - datatype reln = - Known - | Sql of string - | Eq - | Ne - | Lt - | Le - | Gt - | Ge - - datatype prop = - True - | False - | Unknown - | And of prop * prop - | Or of prop * prop - | Reln of reln * exp list - | Select of int * lvar * lvar * prop * exp - - exception Imply of prop * prop - val check : Mono.file -> unit val debug : bool ref diff --git a/src/iflow.sml b/src/iflow.sml index 4dfa4e8d..5c8f6835 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -67,6 +67,7 @@ datatype exp = datatype reln = Known | Sql of string + | DtCon of string | Eq | Ne | Lt @@ -127,6 +128,9 @@ fun p_reln r es = | Sql s => box [string (s ^ "("), p_list p_exp es, string ")"] + | DtCon s => box [string (s ^ "("), + p_list p_exp es, + string ")"] | Eq => p_bop "=" es | Ne => p_bop "<>" es | Lt => p_bop "<" es @@ -241,11 +245,20 @@ fun simplify e = | Func (f, es) => let val es = map simplify es + + fun default () = Func (f, es) in if List.exists isFinish es then Finish + else if String.isPrefix "un" f then + case es of + [Func (f', [e])] => if f' = String.extract (f, 2, NONE) then + e + else + default () + | _ => default () else - Func (f, es) + default () end | Recd xes => let @@ -351,33 +364,31 @@ fun eq (e1, e2) = false) end -exception Imply of prop * prop - val debug = ref false -(* Congruence closure *) -structure Cc :> sig - type t - val empty : t - val assert : t * exp * exp -> t - val query : t * exp * exp -> bool - val allPeers : t * exp -> exp list -end = struct - -fun eq' (e1, e2) = +fun eeq (e1, e2) = case (e1, e2) of (Const p1, Const p2) => Prim.equal (p1, p2) | (Var n1, Var n2) => n1 = n2 | (Lvar n1, Lvar n2) => n1 = n2 - | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) + | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eeq (es1, es2) | (Recd xes1, Recd xes2) => length xes1 = length xes2 andalso List.all (fn (x2, e2) => - List.exists (fn (x1, e1) => x1 = x2 andalso eq' (e1, e2)) xes2) xes1 - | (Proj (e1, x1), Proj (e2, x2)) => eq' (e1, e2) andalso x1 = x2 + List.exists (fn (x1, e1) => x1 = x2 andalso eeq (e1, e2)) xes2) xes1 + | (Proj (e1, x1), Proj (e2, x2)) => eeq (e1, e2) andalso x1 = x2 | (Finish, Finish) => true | _ => false + +(* Congruence closure *) +structure Cc :> sig + type t + val empty : t + val assert : t * exp * exp -> t + val query : t * exp * exp -> bool + val allPeers : t * exp -> exp list +end = struct -fun eq (e1, e2) = eq' (simplify e1, simplify e2) +fun eq (e1, e2) = eeq (simplify e1, simplify e2) type t = (exp * exp) list @@ -475,6 +486,7 @@ fun rimp cc ((r1, es1), (r2, es2)) = case e of Var v' => v' = v | Proj (e, _) => matches e + | Func (f, [e]) => String.isPrefix "un" f andalso matches e | _ => false in List.exists matches (Cc.allPeers (cc, e2)) @@ -528,7 +540,23 @@ fun imply (p1, p2) = orelse hps hyps end in - gls goals (fn () => false) + if List.exists (fn (DtCon c1, [e]) => + List.exists (fn (DtCon c2, [e']) => + c1 <> c2 andalso + Cc.query (cc, e, e') + | _ => false) hyps + orelse List.exists (fn Func (c2, []) => c1 <> c2 + | Finish => true + | _ => false) + (Cc.allPeers (cc, e)) + | _ => false) hyps + orelse gls goals (fn () => false) then + true + else + (Print.prefaces "Can't prove" + [("hyps", Print.p_list (fn x => p_prop (Reln x)) hyps), + ("goals", Print.p_list (fn x => p_prop (Reln x)) goals)]; + false) end)) in reset (); @@ -668,17 +696,17 @@ fun list p chs = val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_") -val t_ident = wrap ident (fn s => if String.isPrefix "T_" s then - String.extract (s, 2, NONE) - else - raise Fail "Iflow: Bad table variable") -val uw_ident = wrap ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then - str (Char.toUpper (String.sub (s, 3))) - ^ String.extract (s, 4, NONE) +val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then + SOME (String.extract (s, 2, NONE)) else - raise Fail "Iflow: Bad uw_* variable") - -val sitem = wrap (follow t_ident + NONE) +val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then + SOME (str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE)) + else + NONE) + +val field = wrap (follow t_ident (follow (const ".") uw_ident)) (fn (t, ((), f)) => (t, f)) @@ -693,6 +721,8 @@ datatype sqexp = | Binop of Rel * sqexp * sqexp | SqKnown of sqexp | Inj of Mono.exp + | SqFunc of string * sqexp + | Count fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) @@ -758,12 +788,25 @@ fun sqlify chs = NONE | _ => NONE +fun constK s = wrap (const s) (fn () => s) + +val funcName = altL [constK "COUNT", + constK "MIN", + constK "MAX", + constK "SUM", + constK "AVG"] + fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, - wrap sitem Field, + wrap field Field, wrap known SqKnown, + wrap func SqFunc, + wrap (const "COUNT(*)") (fn () => Count), wrap sqlify Inj, + wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") + (follow (keep (fn ch => ch <> #")")) (const ")"))))) + (fn ((), (e, _)) => e), wrap (follow (ws (const "(")) (follow (wrap (follow sqexp @@ -782,7 +825,18 @@ fun sqexp chs = chs and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) - (fn ((), ((), (e, ()))) => e) chs + (fn ((), ((), (e, ()))) => e) chs + +and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) + (fn (f, ((), (e, ()))) => (f, e)) chs + +datatype sitem = + SqField of string * string + | SqExp of sqexp * string + +val sitem = alt (wrap field SqField) + (wrap (follow sqexp (follow (const " AS ") uw_ident)) + (fn (e, ((), s)) => SqExp (e, s))) val select = log "select" (wrap (follow (const "SELECT ") (list sitem)) @@ -804,6 +858,19 @@ val query = log "query" (wrap (follow (follow select from) (opt wher)) (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) +fun removeDups ls = + case ls of + [] => [] + | x :: ls => + let + val ls = removeDups ls + in + if List.exists (fn x' => x' = x) ls then + ls + else + x :: ls + end + fun queryProp env rv oe e = case parse query e of NONE => (print ("Warning: Information flow checker can't parse SQL query at " @@ -811,6 +878,21 @@ fun queryProp env rv oe e = (Unknown, [])) | SOME r => let + fun usedFields e = + case e of + SqConst _ => [] + | Field (v, f) => [(v, f)] + | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) + | SqKnown _ => [] + | Inj _ => [] + | SqFunc (_, e) => usedFields e + | Count => [] + + val allUsed = removeDups (List.mapPartial (fn SqField x => SOME x | _ => NONE) (#Select r) + @ (case #Where r of + NONE => [] + | SOME e => usedFields e)) + val p = foldl (fn ((t, v), p) => And (p, @@ -819,7 +901,7 @@ fun queryProp env rv oe e = if v' = v then (f, Proj (Proj (Lvar rv, v), f)) :: fs else - fs) [] (#Select r))]))) + fs) [] allUsed)]))) True (#From r) fun expIn e = @@ -845,14 +927,11 @@ fun queryProp env rv oe e = in inl (deinj e) end - - fun usedFields e = - case e of - SqConst _ => [] - | Field (v, f) => [Proj (Proj (Lvar rv, v), f)] - | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 - | SqKnown _ => [] - | Inj _ => [] + | SqFunc (f, e) => + inl (case expIn e of + inl e => Func (f, [e]) + | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) + | Count => inl (Func ("COUNT", [])) val p = case #Where r of NONE => p @@ -864,16 +943,79 @@ fun queryProp env rv oe e = (case oe of NONE => p | SOME oe => - And (p, foldl (fn ((v, f), p) => - Or (p, - Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]))) + And (p, foldl (fn (si, p) => + let + val p' = case si of + SqField (v, f) => Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]) + | SqExp (e, f) => + case expIn e of + inr _ => Unknown + | inl e => Reln (Eq, [oe, e]) + in + Or (p, p') + end) False (#Select r)), case #Where r of NONE => [] - | SOME e => usedFields e) + | SOME e => map (fn (v, f) => Proj (Proj (Lvar rv, v), f)) (usedFields e)) + end + +fun evalPat env e (pt, _) = + case pt of + PWild => (env, True) + | PVar _ => (e :: env, True) + | PPrim _ => (env, True) + | PCon (_, pc, NONE) => (env, Reln (DtCon (patCon pc), [e])) + | PCon (_, pc, SOME pt) => + let + val (env, p) = evalPat env (Func ("un" ^ patCon pc, [e])) pt + in + (env, And (p, Reln (DtCon (patCon pc), [e]))) + end + | PRecord xpts => + foldl (fn ((x, pt, _), (env, p)) => + let + val (env, p') = evalPat env (Proj (e, x)) pt + in + (env, And (p', p)) + end) (env, True) xpts + | PNone _ => (env, Reln (DtCon "None", [e])) + | PSome (_, pt) => + let + val (env, p) = evalPat env (Func ("unSome", [e])) pt + in + (env, And (p, Reln (DtCon "Some", [e]))) end +fun peq (p1, p2) = + case (p1, p2) of + (True, True) => true + | (False, False) => true + | (Unknown, Unknown) => true + | (And (x1, y1), And (x2, y2)) => peq (x1, x2) andalso peq (y1, y2) + | (Or (x1, y1), Or (x2, y2)) => peq (x1, x2) andalso peq (y1, y2) + | (Reln (r1, es1), Reln (r2, es2)) => r1 = r2 andalso ListPair.allEq eeq (es1, es2) + | (Select (n1, n2, n3, p1, e1), Select (n1', n2', n3', p2, e2)) => + n1 = n1' andalso n2 = n2' andalso n3 = n3' + andalso peq (p1, p2) andalso eeq (e1, e2) + | _ => false + +fun removeRedundant p1 = + let + fun rr p2 = + if peq (p1, p2) then + True + else + case p2 of + And (x, y) => And (rr x, rr y) + | Or (x, y) => Or (rr x, rr y) + | Select (n1, n2, n3, p, e) => Select (n1, n2, n3, rr p, e) + | _ => p2 + in + rr + end + fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let fun default () = @@ -951,7 +1093,25 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = in (Proj (e, s), st) end - | ECase _ => default () + | ECase (e, pes, _) => + let + val (e, st) = evalExp env (e, st) + val r = #1 st + val st = (r + 1, #2 st, #3 st) + val orig = #2 st + + val st = foldl (fn ((pt, pe), st) => + let + val (env, pp) = evalPat env e pt + val (pe, st') = evalExp env (pe, (#1 st, And (orig, pp), #3 st)) + + val this = And (removeRedundant orig (#2 st'), Reln (Eq, [Var r, pe])) + in + (#1 st', Or (#2 st, this), #3 st') + end) (#1 st, False, #3 st) pes + in + (Var r, (#1 st, And (orig, #2 st), #3 st)) + end | EStrcat (e1, e2) => let val (e1, st) = evalExp env (e1, st) -- cgit v1.2.3 From f0b1247489b51c752e1e937d79c026e794887b92 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 15:17:28 -0400 Subject: Replaced Select predicate with special-case handling for one-or-no-rows queries --- src/iflow.sml | 275 +++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 168 insertions(+), 107 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 5c8f6835..a8a413c4 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -82,7 +82,7 @@ datatype prop = | And of prop * prop | Or of prop * prop | Reln of reln * exp list - | Select of int * lvar * lvar * prop * exp + | Cond of exp * prop local open Print @@ -162,14 +162,13 @@ fun p_prop p = p_prop p2, string ")"] | Reln (r, es) => p_reln r es - | Select (n1, n2, n3, p, e) => box [string ("select(x" ^ Int.toString n1 - ^ ",X" ^ Int.toString n2 - ^ ",X" ^ Int.toString n3 - ^ "){"), - p_prop p, - string "}{", - p_exp e, - string "}"] + | Cond (e, p) => box [string "(", + p_exp e, + space, + string "==", + space, + p_prop p, + string ")"] end @@ -185,36 +184,6 @@ fun newLvar () = end end -fun subExp (v, lv) = - let - fun sub e = - case e of - Const _ => e - | Var v' => if v' = v then Lvar lv else e - | Lvar _ => e - | Func (f, es) => Func (f, map sub es) - | Recd xes => Recd (map (fn (x, e) => (x, sub e)) xes) - | Proj (e, s) => Proj (sub e, s) - | Finish => Finish - in - sub - end - -fun subProp (v, lv) = - let - fun sub p = - case p of - True => p - | False => p - | Unknown => p - | And (p1, p2) => And (sub p1, sub p2) - | Or (p1, p2) => Or (sub p1, sub p2) - | Reln (r, es) => Reln (r, map (subExp (v, lv)) es) - | Select (v1, lv1, lv2, p, e) => Select (v1, lv1, lv2, sub p, subExp (v, lv) e) - in - sub - end - fun isKnown e = case e of Const _ => true @@ -280,6 +249,15 @@ fun simplify e = Proj (e', s)) | Finish => Finish +datatype atom = + AReln of reln * exp list + | ACond of exp * prop + +fun p_atom a = + p_prop (case a of + AReln x => Reln x + | ACond x => Cond x) + fun decomp fals or = let fun decomp p k = @@ -293,8 +271,8 @@ fun decomp fals or = k (ps1 @ ps2))) | Or (p1, p2) => or (decomp p1 k, fn () => decomp p2 k) - | Reln x => k [x] - | Select _ => k [] + | Reln x => k [AReln x] + | Cond x => k [ACond x] in decomp end @@ -314,6 +292,51 @@ fun lvarIn lv = lvi end +fun lvarInP lv = + let + fun lvi p = + case p of + True => false + | False => false + | Unknown => true + | And (p1, p2) => lvi p1 orelse lvi p2 + | Or (p1, p2) => lvi p1 orelse lvi p2 + | Reln (_, es) => List.exists (lvarIn lv) es + | Cond (e, p) => lvarIn lv e orelse lvi p + in + lvi + end + +fun varIn lv = + let + fun lvi e = + case e of + Const _ => false + | Lvar _ => false + | Var lv' => lv' = lv + | Func (_, es) => List.exists lvi es + | Recd xes => List.exists (lvi o #2) xes + | Proj (e, _) => lvi e + | Finish => false + in + lvi + end + +fun varInP lv = + let + fun lvi p = + case p of + True => false + | False => false + | Unknown => false + | And (p1, p2) => lvi p1 orelse lvi p2 + | Or (p1, p2) => lvi p1 orelse lvi p2 + | Reln (_, es) => List.exists (varIn lv) es + | Cond (e, p) => varIn lv e orelse lvi p + in + lvi + end + fun eq' (e1, e2) = case (e1, e2) of (Const p1, Const p2) => Prim.equal (p1, p2) @@ -399,32 +422,6 @@ fun lookup (t, e) = NONE => e | SOME (_, e2) => lookup (t, e2) -fun assert (t, e1, e2) = - let - val r1 = lookup (t, e1) - val r2 = lookup (t, e2) - in - if eq (r1, r2) then - t - else - (r1, r2) :: t - end - -open Print - -fun query (t, e1, e2) = - (if !debug then - prefaces "CC query" [("e1", p_exp (simplify e1)), - ("e2", p_exp (simplify e2)), - ("t", p_list (fn (e1, e2) => box [p_exp (simplify e1), - space, - PD.string "->", - space, - p_exp (simplify e2)]) t)] - else - (); - eq (lookup (t, e1), lookup (t, e2))) - fun allPeers (t, e) = let val r = lookup (t, e) @@ -440,6 +437,49 @@ fun allPeers (t, e) = end) t end +fun assert (t, e1, e2) = + let + val r1 = lookup (t, e1) + val r2 = lookup (t, e2) + + fun doUn (t', e1, e2) = + case e2 of + Func (f, [e]) => + if String.isPrefix "un" f then + let + val f' = String.extract (f, 2, NONE) + in + foldl (fn (e', t') => + case e' of + Func (f'', [e'']) => + if f'' = f' then + (lookup (t', e1), e'') :: t' + else + t' + | _ => t') t' (allPeers (t, e)) + end + else + t' + | _ => t' + in + if eq (r1, r2) then + t + else + doUn (doUn ((r1, r2) :: t, e1, e2), e2, e1) + end + +open Print + +fun query (t, e1, e2) = + ((*prefaces "CC query" [("e1", p_exp (simplify e1)), + ("e2", p_exp (simplify e2)), + ("t", p_list (fn (e1, e2) => box [p_exp (simplify e1), + space, + PD.string "->", + space, + p_exp (simplify e2)]) t)];*) + eq (lookup (t, e1), lookup (t, e2))) + end fun rimp cc ((r1, es1), (r2, es2)) = @@ -504,13 +544,14 @@ fun imply (p1, p2) = let val cc = foldl (fn (p, cc) => case p of - (Eq, [e1, e2]) => Cc.assert (cc, e1, e2) + AReln (Eq, [e1, e2]) => Cc.assert (cc, e1, e2) | _ => cc) Cc.empty hyps fun gls goals onFail = case goals of [] => true - | g :: goals => + | ACond _ :: _ => false + | AReln g :: goals => case (doKnown, g) of (false, (Known, _)) => gls goals onFail | _ => @@ -518,7 +559,8 @@ fun imply (p1, p2) = fun hps hyps = case hyps of [] => onFail () - | h :: hyps => + | ACond _ :: hyps => hps hyps + | AReln h :: hyps => let val saved = save () in @@ -540,8 +582,8 @@ fun imply (p1, p2) = orelse hps hyps end in - if List.exists (fn (DtCon c1, [e]) => - List.exists (fn (DtCon c2, [e']) => + if List.exists (fn AReln (DtCon c1, [e]) => + List.exists (fn AReln (DtCon c2, [e']) => c1 <> c2 andalso Cc.query (cc, e, e') | _ => false) hyps @@ -553,9 +595,9 @@ fun imply (p1, p2) = orelse gls goals (fn () => false) then true else - (Print.prefaces "Can't prove" - [("hyps", Print.p_list (fn x => p_prop (Reln x)) hyps), - ("goals", Print.p_list (fn x => p_prop (Reln x)) goals)]; + ((*Print.prefaces "Can't prove" + [("hyps", Print.p_list p_atom hyps), + ("goals", Print.p_list p_atom goals)];*) false) end)) in @@ -569,8 +611,6 @@ fun patCon pc = PConVar n => "C" ^ Int.toString n | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c - - datatype chunk = String of string | Exp of Mono.exp @@ -871,6 +911,10 @@ fun removeDups ls = x :: ls end +datatype queryMode = + SomeCol of exp + | AllCols of exp + fun queryProp env rv oe e = case parse query e of NONE => (print ("Warning: Information flow checker can't parse SQL query at " @@ -899,7 +943,7 @@ fun queryProp env rv oe e = Reln (Sql t, [Recd (foldl (fn ((v', f), fs) => if v' = v then - (f, Proj (Proj (Lvar rv, v), f)) :: fs + (f, Proj (Proj (rv, v), f)) :: fs else fs) [] allUsed)]))) True (#From r) @@ -907,7 +951,7 @@ fun queryProp env rv oe e = fun expIn e = case e of SqConst p => inl (Const p) - | Field (v, f) => inl (Proj (Proj (Lvar rv, v), f)) + | Field (v, f) => inl (Proj (Proj (rv, v), f)) | Binop (bo, e1, e2) => inr (case (bo, expIn e1, expIn e2) of (Exps f, inl e1, inl e2) => f (e1, e2) @@ -931,7 +975,7 @@ fun queryProp env rv oe e = inl (case expIn e of inl e => Func (f, [e]) | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) - | Count => inl (Func ("COUNT", [])) + | Count => inl (Proj (rv, "$COUNT")) val p = case #Where r of NONE => p @@ -940,13 +984,12 @@ fun queryProp env rv oe e = inr p' => And (p, p') | _ => p in - (case oe of - NONE => p - | SOME oe => - And (p, foldl (fn (si, p) => + (And (p, case oe of + SomeCol oe => + foldl (fn (si, p) => let val p' = case si of - SqField (v, f) => Reln (Eq, [oe, Proj (Proj (Lvar rv, v), f)]) + SqField (v, f) => Reln (Eq, [oe, Proj (Proj (rv, v), f)]) | SqExp (e, f) => case expIn e of inr _ => Unknown @@ -954,11 +997,25 @@ fun queryProp env rv oe e = in Or (p, p') end) - False (#Select r)), + False (#Select r) + | AllCols oe => + foldl (fn (si, p) => + let + val p' = case si of + SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), + Proj (Proj (rv, v), f)]) + | SqExp (e, f) => + case expIn e of + inr p => Cond (Proj (oe, f), p) + | inl e => Reln (Eq, [Proj (oe, f), e]) + in + And (p, p') + end) + True (#Select r)), case #Where r of NONE => [] - | SOME e => map (fn (v, f) => Proj (Proj (Lvar rv, v), f)) (usedFields e)) + | SOME e => map (fn (v, f) => Proj (Proj (rv, v), f)) (usedFields e)) end fun evalPat env e (pt, _) = @@ -996,9 +1053,7 @@ fun peq (p1, p2) = | (And (x1, y1), And (x2, y2)) => peq (x1, x2) andalso peq (y1, y2) | (Or (x1, y1), Or (x2, y2)) => peq (x1, x2) andalso peq (y1, y2) | (Reln (r1, es1), Reln (r2, es2)) => r1 = r2 andalso ListPair.allEq eeq (es1, es2) - | (Select (n1, n2, n3, p1, e1), Select (n1', n2', n3', p2, e2)) => - n1 = n1' andalso n2 = n2' andalso n3 = n3' - andalso peq (p1, p2) andalso eeq (e1, e2) + | (Cond (e1, p1), Cond (e2, p2)) => eeq (e1, e2) andalso peq (p1, p2) | _ => false fun removeRedundant p1 = @@ -1010,7 +1065,6 @@ fun removeRedundant p1 = case p2 of And (x, y) => And (rr x, rr y) | Or (x, y) => Or (rr x, rr y) - | Select (n1, n2, n3, p, e) => Select (n1, n2, n3, rr p, e) | _ => p2 in rr @@ -1164,28 +1218,35 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val (i, st) = evalExp env (i, st) val r = #1 st - val acc = #1 st + 1 - val st' = (#1 st + 2, #2 st, #3 st) + val rv = #1 st + 1 + val acc = #1 st + 2 + val st' = (#1 st + 3, #2 st, #3 st) val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val r' = newLvar () - val acc' = newLvar () - val (qp, used) = queryProp env r' NONE q + val (qp, used) = queryProp env (Var rv) (AllCols (Var r)) q - val doSubExp = subExp (r, r') o subExp (acc, acc') - val doSubProp = subProp (r, r') o subProp (acc, acc') + val p' = And (qp, #2 st') - val p = doSubProp (#2 st') - val p' = And (p, qp) - val p = Select (r, r', acc', p', doSubExp b) - - val sent = map (fn (loc, e, p) => (loc, - doSubExp e, - And (qp, doSubProp p))) (#3 st') + val (nvs, p, res) = if varInP acc (#2 st') then + (#1 st + 1, #2 st, Var r) + else + let + val out = #1 st' + + val p = Or (Reln (Eq, [Var out, i]), + And (Reln (Eq, [Var out, b]), + And (Reln (Gt, [Proj (Var rv, "$COUNT"), + Const (Prim.Int 0)]), + p'))) + in + (out + 1, p, Var out) + end + + val sent = map (fn (loc, e, p) => (loc, e, And (qp, p))) (#3 st') val sent = map (fn e => (loc, e, p')) used @ sent in - (Var r, (#1 st + 1, And (#2 st, p), sent)) + (res, (nvs, p, sent)) end | EDml _ => default () | ENextval _ => default () @@ -1231,7 +1292,7 @@ fun check file = (sent @ vals, pols) end - | DPolicy (PolQuery e) => (vals, #1 (queryProp [] 0 (SOME (Var 0)) e) :: pols) + | DPolicy (PolQuery e) => (vals, #1 (queryProp [] (Lvar 0) (SomeCol (Var 0)) e) :: pols) | _ => (vals, pols) -- cgit v1.2.3 From db36e74c12b26c94ef387d66dc61858f06daa2d8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 6 Apr 2010 16:14:19 -0400 Subject: secret logon --- src/iflow.sml | 111 +++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 87 insertions(+), 24 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index a8a413c4..92181d87 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -49,7 +49,8 @@ val writers = ["htmlifyInt_w", "urlifyInt_w", "urlifyFloat_w", "urlifyString_w", - "urlifyBool_w"] + "urlifyBool_w", + "set_cookie"] val writers = SS.addList (SS.empty, writers) @@ -367,7 +368,9 @@ fun eq' (e1, e2) = if lvarIn n2 e1 then false else - (unif := IM.insert (!unif, n2, e1); + ((*Print.prefaces "unif" [("n2", Print.PD.string (Int.toString n2)), + ("e1", p_exp e1)];*) + unif := IM.insert (!unif, n2, e1); true)) | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) @@ -442,7 +445,7 @@ fun assert (t, e1, e2) = val r1 = lookup (t, e1) val r2 = lookup (t, e2) - fun doUn (t', e1, e2) = + fun doUn k (t', e1, e2) = case e2 of Func (f, [e]) => if String.isPrefix "un" f then @@ -453,19 +456,20 @@ fun assert (t, e1, e2) = case e' of Func (f'', [e'']) => if f'' = f' then - (lookup (t', e1), e'') :: t' + (lookup (t', e1), k e'') :: t' else t' | _ => t') t' (allPeers (t, e)) end else t' + | Proj (e2, f) => doUn (fn e' => k (Proj (e', f))) (t', e1, e2) | _ => t' in if eq (r1, r2) then t else - doUn (doUn ((r1, r2) :: t, e1, e2), e2, e1) + doUn (fn x => x) (doUn (fn x => x) ((r1, r2) :: t, e1, e2), e2, e1) end open Print @@ -558,7 +562,8 @@ fun imply (p1, p2) = let fun hps hyps = case hyps of - [] => onFail () + [] => ((*Print.preface ("Fail", p_prop (Reln g));*) + onFail ()) | ACond _ :: hyps => hps hyps | AReln h :: hyps => let @@ -570,7 +575,12 @@ fun imply (p1, p2) = <> IM.numItems saved in gls goals (fn () => (restore saved; - changed andalso hps hyps)) + changed (*andalso + (Print.preface ("Retry", + p_prop + (Reln g) + ); true)*) + andalso hps hyps)) end else hps hyps @@ -1073,7 +1083,9 @@ fun removeRedundant p1 = fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let fun default () = - (Var nv, (nv+1, p, sent)) + ((*Print.preface ("Default" ^ Int.toString nv, + MonoPrint.p_exp MonoEnv.empty e);*) + (Var nv, (nv+1, p, sent))) fun addSent (p, e, sent) = if isKnown e then @@ -1100,6 +1112,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = (Func ("Some", [e]), st) end | EFfi _ => default () + | EFfiApp (m, s, es) => if m = "Basis" andalso SS.member (writers, s) then let @@ -1115,7 +1128,16 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = in (Func (m ^ "." ^ s, es), st) end - | EApp _ => default () + + | EApp (e1, e2) => + let + val (e1, st) = evalExp env (e1, st) + in + case e1 of + Finish => (Finish, st) + | _ => default () + end + | EAbs _ => default () | EUnop (s, e1) => let @@ -1252,6 +1274,9 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = | ENextval _ => default () | ESetval _ => default () + | EUnurlify ((EFfiApp ("Basis", "get_cookie", _), _), _, _) => + (Var nv, (nv + 1, And (p, Reln (Known, [Var nv])), sent)) + | EUnurlify _ => default () | EJavaScript _ => default () | ESignalReturn _ => default () @@ -1265,6 +1290,12 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = fun check file = let + val file = MonoReduce.reduce file + val file = MonoOpt.optimize file + val file = Fuse.fuse file + val file = MonoOpt.optimize file + (*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*) + val exptd = foldl (fn ((d, _), exptd) => case d of DExport (_, _, n, _, _, _) => IS.add (exptd, n) @@ -1302,23 +1333,55 @@ fun check file = in app (fn (loc, e, p) => let - val p = And (p, Reln (Eq, [Var 0, e])) + fun doOne e = + let + val p = And (p, Reln (Eq, [Var 0, e])) + in + if List.exists (fn pol => if imply (p, pol) then + (if !debug then + Print.prefaces "Match" + [("Hyp", p_prop p), + ("Goal", p_prop pol)] + else + (); + true) + else + false) pols then + () + else + (ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.preface ("The state satisifes this predicate:", p_prop p)) + end + + fun doAll e = + case e of + Const _ => () + | Var _ => doOne e + | Lvar _ => raise Fail "Iflow.doAll: Lvar" + | Func (f, es) => if String.isPrefix "un" f then + doOne e + else + app doAll es + | Recd xes => app (doAll o #2) xes + | Proj _ => doOne e + | Finish => () in - if List.exists (fn pol => if imply (p, pol) then - (if !debug then - Print.prefaces "Match" - [("Hyp", p_prop p), - ("Goal", p_prop pol)] - else - (); - true) - else - false) pols then - () - else - (ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.preface ("The state satisifes this predicate:", p_prop p)) + doAll e end) vals end +val check = fn file => + let + val oldInline = Settings.getMonoInline () + in + (Settings.setMonoInline (case Int.maxInt of + NONE => 1000000 + | SOME n => n); + check file; + Settings.setMonoInline oldInline) + handle ex => (Settings.setMonoInline oldInline; + raise ex) + end + end + -- cgit v1.2.3 From ed25721e17d6798aad7b7a0cea8e5393bb840a91 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 8 Apr 2010 09:57:37 -0400 Subject: Change query_policy to sendClient; all arguments passed to SQL predicates are variables --- lib/ur/basis.urs | 6 +- src/iflow.sml | 207 ++++++++++++++++++++++++++++++++-------------------- src/mono.sml | 2 +- src/mono_print.sml | 6 +- src/mono_reduce.sml | 17 +++-- src/mono_shake.sml | 2 +- src/mono_util.sml | 4 +- src/monoize.sml | 6 +- tests/policy.ur | 20 ++--- 9 files changed, 162 insertions(+), 108 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 72970351..959a050d 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -800,9 +800,9 @@ val initialize : task_kind type sql_policy -val query_policy : tables ::: {{Type}} -> exps ::: {Type} - -> [tables ~ exps] => sql_query [] tables exps - -> sql_policy +val sendClient : tables ::: {{Type}} -> exps ::: {Type} + -> [tables ~ exps] => sql_query [] tables exps + -> sql_policy val debug : string -> transaction unit diff --git a/src/iflow.sml b/src/iflow.sml index 92181d87..e49700cf 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -412,6 +412,7 @@ structure Cc :> sig val assert : t * exp * exp -> t val query : t * exp * exp -> bool val allPeers : t * exp -> exp list + val p_t : t Print.printer end = struct fun eq (e1, e2) = eeq (simplify e1, simplify e2) @@ -440,50 +441,102 @@ fun allPeers (t, e) = end) t end -fun assert (t, e1, e2) = - let - val r1 = lookup (t, e1) - val r2 = lookup (t, e2) +open Print - fun doUn k (t', e1, e2) = - case e2 of - Func (f, [e]) => +val p_t = p_list (fn (e1, e2) => box [p_exp (simplify e1), + space, + PD.string "->", + space, + p_exp (simplify e2)]) + +fun query (t, e1, e2) = + let + fun doUn e = + case e of + Func (f, [e1]) => if String.isPrefix "un" f then let - val f' = String.extract (f, 2, NONE) + val s = String.extract (f, 2, NONE) in - foldl (fn (e', t') => - case e' of - Func (f'', [e'']) => - if f'' = f' then - (lookup (t', e1), k e'') :: t' - else - t' - | _ => t') t' (allPeers (t, e)) + case ListUtil.search (fn e => + case e of + Func (f', [e']) => + if f' = s then + SOME e' + else + NONE + | _ => NONE) (allPeers (t, e1)) of + NONE => e + | SOME e => doUn e end else - t' - | Proj (e2, f) => doUn (fn e' => k (Proj (e', f))) (t', e1, e2) - | _ => t' + e + | _ => e + + val e1' = doUn (lookup (t, doUn (simplify e1))) + val e2' = doUn (lookup (t, doUn (simplify e2))) + in + (*prefaces "CC query" [("e1", p_exp (simplify e1)), + ("e2", p_exp (simplify e2)), + ("e1'", p_exp (simplify e1')), + ("e2'", p_exp (simplify e2')), + ("t", p_t t)];*) + eq (e1', e2') + end + +fun assert (t, e1, e2) = + let + val r1 = lookup (t, e1) + val r2 = lookup (t, e2) in if eq (r1, r2) then t else - doUn (fn x => x) (doUn (fn x => x) ((r1, r2) :: t, e1, e2), e2, e1) + let + fun doUn (t, e1, e2) = + case e1 of + Func (f, [e]) => if String.isPrefix "un" f then + let + val s = String.extract (f, 2, NONE) + in + foldl (fn (e', t) => + case e' of + Func (f', [e']) => + if f' = s then + assert (assert (t, e', e1), e', e2) + else + t + | _ => t) t (allPeers (t, e)) + end + else + t + | _ => t + + fun doProj (t, e1, e2) = + foldl (fn ((e1', e2'), t) => + let + fun doOne (e, t) = + case e of + Proj (e', f) => + if query (t, e1, e') then + assert (t, e, Proj (e2, f)) + else + t + | _ => t + in + doOne (e1', doOne (e2', t)) + end) t t + + val t = (r1, r2) :: t + val t = doUn (t, r1, r2) + val t = doUn (t, r2, r1) + val t = doProj (t, r1, r2) + val t = doProj (t, r2, r1) + in + t + end end -open Print - -fun query (t, e1, e2) = - ((*prefaces "CC query" [("e1", p_exp (simplify e1)), - ("e2", p_exp (simplify e2)), - ("t", p_list (fn (e1, e2) => box [p_exp (simplify e1), - space, - PD.string "->", - space, - p_exp (simplify e2)]) t)];*) - eq (lookup (t, e1), lookup (t, e2))) - end fun rimp cc ((r1, es1), (r2, es2)) = @@ -491,19 +544,7 @@ fun rimp cc ((r1, es1), (r2, es2)) = (Sql r1', Sql r2') => r1' = r2' andalso (case (es1, es2) of - ([Recd xes1], [Recd xes2]) => - let - val saved = save () - in - if List.all (fn (f, e2) => - case ListUtil.search (fn (f', e1) => if f' = f then SOME e1 else NONE) xes1 of - NONE => true - | SOME e1 => eq (e1, e2)) xes2 then - true - else - (restore saved; - false) - end + ([e1], [e2]) => eq (e1, e2) | _ => false) | (Eq, Eq) => (case (es1, es2) of @@ -533,6 +574,9 @@ fun rimp cc ((r1, es1), (r2, es2)) = | Func (f, [e]) => String.isPrefix "un" f andalso matches e | _ => false in + (*Print.prefaces "Checking peers" [("e2", p_exp e2), + ("peers", Print.p_list p_exp (Cc.allPeers (cc, e2))), + ("db", Cc.p_t cc)];*) List.exists matches (Cc.allPeers (cc, e2)) end | _ => false) @@ -562,7 +606,8 @@ fun imply (p1, p2) = let fun hps hyps = case hyps of - [] => ((*Print.preface ("Fail", p_prop (Reln g));*) + [] => ((*Print.prefaces "Fail" [("g", p_prop (Reln g)), + ("db", Cc.p_t cc)];*) onFail ()) | ACond _ :: hyps => hps hyps | AReln h :: hyps => @@ -925,13 +970,27 @@ datatype queryMode = SomeCol of exp | AllCols of exp -fun queryProp env rv oe e = +fun queryProp env rvN rv oe e = case parse query e of NONE => (print ("Warning: Information flow checker can't parse SQL query at " ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - (Unknown, [])) + (rvN, Var 0, Unknown, [])) | SOME r => let + val (rvN, count) = rv rvN + + val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => + let + val (rvN, e) = rv rvN + in + ((v, e), rvN) + end) rvN (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.queryProp: Bad table variable" + | SOME (_, e) => e + fun usedFields e = case e of SqConst _ => [] @@ -942,26 +1001,13 @@ fun queryProp env rv oe e = | SqFunc (_, e) => usedFields e | Count => [] - val allUsed = removeDups (List.mapPartial (fn SqField x => SOME x | _ => NONE) (#Select r) - @ (case #Where r of - NONE => [] - | SOME e => usedFields e)) - val p = - foldl (fn ((t, v), p) => - And (p, - Reln (Sql t, - [Recd (foldl (fn ((v', f), fs) => - if v' = v then - (f, Proj (Proj (rv, v), f)) :: fs - else - fs) [] allUsed)]))) - True (#From r) + foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) fun expIn e = case e of SqConst p => inl (Const p) - | Field (v, f) => inl (Proj (Proj (rv, v), f)) + | Field (v, f) => inl (Proj (rvOf v, f)) | Binop (bo, e1, e2) => inr (case (bo, expIn e1, expIn e2) of (Exps f, inl e1, inl e2) => f (e1, e2) @@ -985,7 +1031,7 @@ fun queryProp env rv oe e = inl (case expIn e of inl e => Func (f, [e]) | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) - | Count => inl (Proj (rv, "$COUNT")) + | Count => inl count val p = case #Where r of NONE => p @@ -994,12 +1040,14 @@ fun queryProp env rv oe e = inr p' => And (p, p') | _ => p in - (And (p, case oe of + (rvN, + count, + And (p, case oe of SomeCol oe => foldl (fn (si, p) => let val p' = case si of - SqField (v, f) => Reln (Eq, [oe, Proj (Proj (rv, v), f)]) + SqField (v, f) => Reln (Eq, [oe, Proj (rvOf v, f)]) | SqExp (e, f) => case expIn e of inr _ => Unknown @@ -1013,7 +1061,7 @@ fun queryProp env rv oe e = let val p' = case si of SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), - Proj (Proj (rv, v), f)]) + Proj (rvOf v, f)]) | SqExp (e, f) => case expIn e of inr p => Cond (Proj (oe, f), p) @@ -1025,7 +1073,7 @@ fun queryProp env rv oe e = case #Where r of NONE => [] - | SOME e => map (fn (v, f) => Proj (Proj (rv, v), f)) (usedFields e)) + | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)) end fun evalPat env e (pt, _) = @@ -1118,7 +1166,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (es, st) = ListUtil.foldlMap (evalExp env) st es in - (Func ("unit", []), (#1 st, p, foldl (fn (e, sent) => addSent (#2 st, e, sent)) sent es)) + (Recd [], (#1 st, p, foldl (fn (e, sent) => addSent (#2 st, e, sent)) sent es)) end else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then default () @@ -1213,7 +1261,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (e, st) = evalExp env (e, st) in - (Func ("unit", []), (#1 st, p, addSent (#2 st, e, sent))) + (Recd [], (#1 st, p, addSent (#2 st, e, sent))) end | ESeq (e1, e2) => let @@ -1240,13 +1288,15 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val (i, st) = evalExp env (i, st) val r = #1 st - val rv = #1 st + 1 - val acc = #1 st + 2 - val st' = (#1 st + 3, #2 st, #3 st) + val acc = #1 st + 1 + val st' = (#1 st + 2, #2 st, #3 st) val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val (qp, used) = queryProp env (Var rv) (AllCols (Var r)) q + val (rvN, count, qp, used) = + queryProp env + (#1 st') (fn rvN => (rvN + 1, Var rvN)) + (AllCols (Var r)) q val p' = And (qp, #2 st') @@ -1254,11 +1304,11 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = (#1 st + 1, #2 st, Var r) else let - val out = #1 st' + val out = rvN val p = Or (Reln (Eq, [Var out, i]), And (Reln (Eq, [Var out, b]), - And (Reln (Gt, [Proj (Var rv, "$COUNT"), + And (Reln (Gt, [count, Const (Prim.Int 0)]), p'))) in @@ -1323,8 +1373,9 @@ fun check file = (sent @ vals, pols) end - | DPolicy (PolQuery e) => (vals, #1 (queryProp [] (Lvar 0) (SomeCol (Var 0)) e) :: pols) - + | DPolicy (PolClient e) => (vals, #3 (queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) + (SomeCol (Var 0)) e) :: pols) + | _ => (vals, pols) val () = reset () diff --git a/src/mono.sml b/src/mono.sml index 33ab5bd4..f8f57ae7 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -123,7 +123,7 @@ datatype exp' = withtype exp = exp' located -datatype policy = PolQuery of exp +datatype policy = PolClient of exp datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index 50c4717a..76a89cc7 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -414,9 +414,9 @@ fun p_datatype env (x, n, cons) = fun p_policy env pol = case pol of - PolQuery e => box [string "query", - space, - p_exp env e] + PolClient e => box [string "sendClient", + space, + p_exp env e] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e5dd3213..bb23a21a 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -423,18 +423,21 @@ fun reduce file = | ERecord xets => List.concat (map (summarize d o #2) xets) | EField (e, _) => summarize d e - | ECase (e, pes, _) => summarize d e @ [Unsure] - (*let + | ECase (e, pes, _) => + let val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes in case lss of [] => raise Fail "Empty pattern match" | ls :: lss => - if List.all (fn ls' => ls' = ls) lss then - summarize d e @ ls - else - [Unsure] - end*) + summarize d e + @ (if List.all (fn ls' => ls' = ls) lss then + ls + else if length (List.filter (not o List.null) (ls :: lss)) <= 1 then + valOf (List.find (not o List.null) (ls :: lss)) + else + [Unsure]) + end | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 | EError (e, _) => summarize d e @ [Unsure] diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 358b31d2..3a681302 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -61,7 +61,7 @@ fun shake file = | ((DPolicy pol, _), st) => let val e1 = case pol of - PolQuery e1 => e1 + PolClient e1 => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index 094f216b..a7f27fd8 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -541,9 +541,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = and mfpol ctx pol = case pol of - PolQuery e => + PolClient e => S.map2 (mfe ctx e, - PolQuery) + PolClient) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index 073c26de..a4e6a37c 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3744,9 +3744,9 @@ fun monoDecl (env, fm) (all as (d, loc)) = let val (e, make) = case #1 e of - L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "query_policy"), _), _), _), _), _), e) => - (e, L'.PolQuery) - | _ => (poly (); (e, L'.PolQuery)) + L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) => + (e, L'.PolClient) + | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e in diff --git a/tests/policy.ur b/tests/policy.ur index 40850393..6d4e341e 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -9,18 +9,18 @@ table order : { Id : order, Fruit : fruit, Qty : int, Code : int } CONSTRAINT Fruit FOREIGN KEY Fruit REFERENCES fruit(Id) (* Everyone may knows IDs and names. *) -policy query_policy (SELECT fruit.Id, fruit.Nam - FROM fruit) +policy sendClient (SELECT fruit.Id, fruit.Nam + FROM fruit) (* The weight is sensitive information; you must know the secret. *) -policy query_policy (SELECT fruit.Weight, fruit.Secret - FROM fruit - WHERE known(fruit.Secret)) - -policy query_policy (SELECT order.Id, order.Fruit, order.Qty - FROM order, fruit - WHERE order.Fruit = fruit.Id - AND order.Qty = 13) +policy sendClient (SELECT fruit.Weight, fruit.Secret + FROM fruit + WHERE known(fruit.Secret)) + +policy sendClient (SELECT order.Id, order.Fruit, order.Qty + FROM order, fruit + WHERE order.Fruit = fruit.Id + AND order.Qty = 13) fun fname r = x <- queryX (SELECT fruit.Weight -- cgit v1.2.3 From 6768acc57c8aea2a48a51d38f69596fd3e5cb1e0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 8 Apr 2010 12:46:21 -0400 Subject: Implemented proper congruence closure, to the point where tests/policy works --- src/iflow.sml | 871 +++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 552 insertions(+), 319 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index e49700cf..d1f36a96 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -32,10 +32,13 @@ open Mono structure IS = IntBinarySet structure IM = IntBinaryMap -structure SS = BinarySetFn(struct - type ord_key = string - val compare = String.compare - end) +structure SK = struct +type ord_key = string +val compare = String.compare +end + +structure SS = BinarySetFn(SK) +structure SM = BinaryMapFn(SK) val writers = ["htmlifyInt_w", "htmlifyFloat_w", @@ -56,11 +59,17 @@ val writers = SS.addList (SS.empty, writers) type lvar = int +datatype func = + DtCon0 of string + | DtCon1 of string + | UnCon of string + | Other of string + datatype exp = Const of Prim.t | Var of int | Lvar of lvar - | Func of string * exp list + | Func of func * exp list | Recd of (string * exp) list | Proj of exp * string | Finish @@ -68,7 +77,8 @@ datatype exp = datatype reln = Known | Sql of string - | DtCon of string + | PCon0 of string + | PCon1 of string | Eq | Ne | Lt @@ -85,17 +95,34 @@ datatype prop = | Reln of reln * exp list | Cond of exp * prop +val unif = ref (IM.empty : exp IM.map) + +fun reset () = unif := IM.empty +fun save () = !unif +fun restore x = unif := x + local open Print val string = PD.string in +fun p_func f = + string (case f of + DtCon0 s => s + | DtCon1 s => s + | UnCon s => "un" ^ s + | Other s => s) + fun p_exp e = case e of Const p => Prim.p_t p | Var n => string ("x" ^ Int.toString n) - | Lvar n => string ("X" ^ Int.toString n) - | Func (f, es) => box [string (f ^ "("), + | Lvar n => + (case IM.find (!unif, n) of + NONE => string ("X" ^ Int.toString n) + | SOME e => p_exp e) + | Func (f, es) => box [p_func f, + string "(", p_list p_exp es, string ")"] | Recd xes => box [string "{", @@ -129,7 +156,10 @@ fun p_reln r es = | Sql s => box [string (s ^ "("), p_list p_exp es, string ")"] - | DtCon s => box [string (s ^ "("), + | PCon0 s => box [string (s ^ "("), + p_list p_exp es, + string ")"] + | PCon1 s => box [string (s ^ "("), p_list p_exp es, string ")"] | Eq => p_bop "=" es @@ -198,12 +228,6 @@ fun isFinish e = Finish => true | _ => false -val unif = ref (IM.empty : exp IM.map) - -fun reset () = unif := IM.empty -fun save () = !unif -fun restore x = unif := x - fun simplify e = case e of Const _ => e @@ -212,42 +236,9 @@ fun simplify e = (case IM.find (!unif, n) of NONE => e | SOME e => simplify e) - | Func (f, es) => - let - val es = map simplify es - - fun default () = Func (f, es) - in - if List.exists isFinish es then - Finish - else if String.isPrefix "un" f then - case es of - [Func (f', [e])] => if f' = String.extract (f, 2, NONE) then - e - else - default () - | _ => default () - else - default () - end - | Recd xes => - let - val xes = map (fn (x, e) => (x, simplify e)) xes - in - if List.exists (isFinish o #2) xes then - Finish - else - Recd xes - end - | Proj (e, s) => - (case simplify e of - Recd xes => - getOpt (ListUtil.search (fn (x, e') => if x = s then SOME e' else NONE) xes, Recd xes) - | e' => - if isFinish e' then - Finish - else - Proj (e', s)) + | Func (f, es) => Func (f, map simplify es) + | Recd xes => Recd (map (fn (x, e) => (x, simplify e)) xes) + | Proj (e, s) => Proj (simplify e, s) | Finish => Finish datatype atom = @@ -259,25 +250,6 @@ fun p_atom a = AReln x => Reln x | ACond x => Cond x) -fun decomp fals or = - let - fun decomp p k = - case p of - True => k [] - | False => fals - | Unknown => k [] - | And (p1, p2) => - decomp p1 (fn ps1 => - decomp p2 (fn ps2 => - k (ps1 @ ps2))) - | Or (p1, p2) => - or (decomp p1 k, fn () => decomp p2 k) - | Reln x => k [AReln x] - | Cond x => k [ACond x] - in - decomp - end - fun lvarIn lv = let fun lvi e = @@ -407,260 +379,523 @@ fun eeq (e1, e2) = (* Congruence closure *) structure Cc :> sig - type t - val empty : t - val assert : t * exp * exp -> t - val query : t * exp * exp -> bool - val allPeers : t * exp -> exp list - val p_t : t Print.printer -end = struct + type database + type representative -fun eq (e1, e2) = eeq (simplify e1, simplify e2) + exception Contradiction + exception Undetermined -type t = (exp * exp) list + val database : unit -> database + val representative : database * exp -> representative -val empty = [] + val assert : database * atom -> unit + val check : database * atom -> bool -fun lookup (t, e) = - case List.find (fn (e', _) => eq (e', e)) t of - NONE => e - | SOME (_, e2) => lookup (t, e2) + val p_database : database Print.printer +end = struct -fun allPeers (t, e) = - let - val r = lookup (t, e) - in - r :: List.mapPartial (fn (e1, e2) => - let - val r' = lookup (t, e2) - in - if eq (r, r') then - SOME e1 - else - NONE - end) t - end +exception Contradiction +exception Undetermined + +structure CM = BinaryMapFn(struct + type ord_key = Prim.t + val compare = Prim.compare + end) + +datatype node = Node of {Rep : node ref option ref, + Cons : node ref SM.map ref, + Variety : variety, + Known : bool ref} + + and variety = + Dt0 of string + | Dt1 of string * node ref + | Prim of Prim.t + | Recrd of node ref SM.map ref + | VFinish + | Nothing + +type representative = node ref + +val finish = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = VFinish, + Known = ref false}) + +type database = {Vars : representative IM.map ref, + Consts : representative CM.map ref, + Con0s : representative SM.map ref, + Records : (representative SM.map * representative) list ref, + Funcs : ((string * representative list) * representative) list ref } + +fun database () = {Vars = ref IM.empty, + Consts = ref CM.empty, + Con0s = ref SM.empty, + Records = ref [], + Funcs = ref []} + +fun unNode n = + case !n of + Node r => r open Print +val string = PD.string +val newline = PD.newline + +fun p_rep n = + case !(#Rep (unNode n)) of + SOME n => p_rep n + | NONE => + case #Variety (unNode n) of + Nothing => string ("?" ^ Int.toString (Unsafe.cast n)) + | Dt0 s => string ("Dt0(" ^ s ^ ")") + | Dt1 (s, n) => box[string ("Dt1(" ^ s ^ ","), + space, + p_rep n, + string ")"] + | Prim p => Prim.p_t p + | Recrd (ref m) => box [string "{", + p_list (fn (x, n) => box [string x, + space, + string "=", + space, + p_rep n]) (SM.listItemsi m), + string "}"] + | VFinish => string "FINISH" + +fun p_database (db : database) = + box [string "Vars:", + newline, + p_list_sep newline (fn (i, n) => box [string ("x" ^ Int.toString i), + space, + string "=", + space, + p_rep n]) (IM.listItemsi (!(#Vars db)))] + +fun repOf (n : representative) : representative = + case !(#Rep (unNode n)) of + NONE => n + | SOME r => + let + val r = repOf r + in + #Rep (unNode n) := SOME r; + r + end -val p_t = p_list (fn (e1, e2) => box [p_exp (simplify e1), - space, - PD.string "->", - space, - p_exp (simplify e2)]) +fun markKnown r = + (#Known (unNode r) := true; + case #Variety (unNode r) of + Dt1 (_, r) => markKnown r + | Recrd xes => SM.app markKnown (!xes) + | _ => ()) -fun query (t, e1, e2) = +fun representative (db : database, e) = let - fun doUn e = + fun rep e = case e of - Func (f, [e1]) => - if String.isPrefix "un" f then - let - val s = String.extract (f, 2, NONE) - in - case ListUtil.search (fn e => - case e of - Func (f', [e']) => - if f' = s then - SOME e' - else - NONE - | _ => NONE) (allPeers (t, e1)) of - NONE => e - | SOME e => doUn e - end - else - e - | _ => e + Const p => (case CM.find (!(#Consts db), p) of + SOME r => repOf r + | NONE => + let + val r = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Prim p, + Known = ref false}) + in + #Consts db := CM.insert (!(#Consts db), p, r); + r + end) + | Var n => (case IM.find (!(#Vars db), n) of + SOME r => repOf r + | NONE => + let + val r = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref false}) + in + #Vars db := IM.insert (!(#Vars db), n, r); + r + end) + | Lvar n => + (case IM.find (!unif, n) of + NONE => raise Undetermined + | SOME e => rep e) + | Func (DtCon0 f, []) => (case SM.find (!(#Con0s db), f) of + SOME r => repOf r + | NONE => + let + val r = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt0 f, + Known = ref false}) + in + #Con0s db := SM.insert (!(#Con0s db), f, r); + r + end) + | Func (DtCon0 _, _) => raise Fail "Iflow.rep: DtCon0" + | Func (DtCon1 f, [e]) => + let + val r = rep e + in + case SM.find (!(#Cons (unNode r)), f) of + SOME r => repOf r + | NONE => + let + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt1 (f, r), + Known = ref false}) + in + #Cons (unNode r) := SM.insert (!(#Cons (unNode r)), f, r'); + r' + end + end + | Func (DtCon1 _, _) => raise Fail "Iflow.rep: DtCon1" + | Func (UnCon f, [e]) => + let + val r = rep e + in + case #Variety (unNode r) of + Dt1 (f', n) => if f' = f then + repOf n + else + raise Contradiction + | Nothing => + let + val cons = ref SM.empty + val r' = ref (Node {Rep = ref NONE, + Cons = cons, + Variety = Nothing, + Known = ref false}) + + val r'' = ref (Node {Rep = ref NONE, + Cons = #Cons (unNode r), + Variety = Dt1 (f, r'), + Known = #Known (unNode r)}) + in + cons := SM.insert (!cons, f, r''); + #Rep (unNode r) := SOME r''; + r' + end + | VFinish => r + | _ => raise Contradiction + end + | Func (UnCon _, _) => raise Fail "Iflow.rep: UnCon" + | Func (Other f, es) => + let + val rs = map rep es + in + case List.find (fn (x : string * representative list, _) => x = (f, rs)) (!(#Funcs db)) of + NONE => + let + val r = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref false}) + in + #Funcs db := ((f, rs), r) :: (!(#Funcs db)); + r + end + | SOME (_, r) => repOf r + end + | Recd xes => + let + val xes = map (fn (x, e) => (x, rep e)) xes + val len = length xes + in + case List.find (fn (xes', _) => + SM.numItems xes' = len + andalso List.all (fn (x, n) => + case SM.find (xes', x) of + NONE => false + | SOME n' => n = repOf n') xes) + (!(#Records db)) of + SOME (_, r) => repOf r + | NONE => + let + val xes = foldl SM.insert' SM.empty xes - val e1' = doUn (lookup (t, doUn (simplify e1))) - val e2' = doUn (lookup (t, doUn (simplify e2))) + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Recrd (ref xes), + Known = ref false}) + in + #Records db := (xes, r') :: (!(#Records db)); + r' + end + end + | Proj (e, f) => + let + val r = rep e + in + case #Variety (unNode r) of + Recrd xes => + (case SM.find (!xes, f) of + SOME r => repOf r + | NONE =>let + val r = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref false}) + in + xes := SM.insert (!xes, f, r); + r + end) + | Nothing => + let + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref false}) + + val r'' = ref (Node {Rep = ref NONE, + Cons = #Cons (unNode r), + Variety = Recrd (ref (SM.insert (SM.empty, f, r'))), + Known = #Known (unNode r)}) + in + #Rep (unNode r) := SOME r''; + r' + end + | VFinish => r + | _ => raise Contradiction + end + | Finish => finish in - (*prefaces "CC query" [("e1", p_exp (simplify e1)), - ("e2", p_exp (simplify e2)), - ("e1'", p_exp (simplify e1')), - ("e2'", p_exp (simplify e2')), - ("t", p_t t)];*) - eq (e1', e2') + rep e end -fun assert (t, e1, e2) = - let - val r1 = lookup (t, e1) - val r2 = lookup (t, e2) - in - if eq (r1, r2) then - t - else +fun assert (db, a) = + case a of + ACond _ => () + | AReln x => + case x of + (Known, [e]) => markKnown (representative (db, e)) + | (PCon0 f, [e]) => let - fun doUn (t, e1, e2) = - case e1 of - Func (f, [e]) => if String.isPrefix "un" f then - let - val s = String.extract (f, 2, NONE) - in - foldl (fn (e', t) => - case e' of - Func (f', [e']) => - if f' = s then - assert (assert (t, e', e1), e', e2) + val r = representative (db, e) + in + case #Variety (unNode r) of + Dt0 f' => if f = f' then + () + else + raise Contradiction + | Nothing => + let + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt0 f, + Known = ref false}) + in + #Rep (unNode r) := SOME r' + end + | _ => raise Contradiction + end + | (PCon1 f, [e]) => + let + val r = representative (db, e) + in + case #Variety (unNode r) of + Dt1 (f', e') => if f = f' then + () + else + raise Contradiction + | Nothing => + let + val r'' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref false}) + + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt1 (f, r''), + Known = ref false}) + in + #Rep (unNode r) := SOME r' + end + | _ => raise Contradiction + end + | (Eq, [e1, e2]) => + let + fun markEq (r1, r2) = + if r1 = r2 then + () + else case (#Variety (unNode r1), #Variety (unNode r2)) of + (Prim p1, Prim p2) => if Prim.equal (p1, p2) then + () + else + raise Contradiction + | (Dt0 f1, Dt0 f2) => if f1 = f2 then + () + else + raise Contradiction + | (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then + markEq (r1, r2) + else + raise Contradiction + | (Recrd xes1, Recrd xes2) => + let + fun unif (xes1, xes2) = + SM.appi (fn (x, r1) => + case SM.find (xes2, x) of + NONE => () + | SOME r2 => markEq (r1, r2)) xes1 + in + unif (!xes1, !xes2); + unif (!xes2, !xes1) + end + | (VFinish, VFinish) => () + | (Nothing, _) => + (#Rep (unNode r1) := SOME r2; + if !(#Known (unNode r1)) andalso not (!(#Known (unNode r2))) then + markKnown r2 + else + (); + #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); + compactFuncs ()) + | (_, Nothing) => + (#Rep (unNode r2) := SOME r1; + if !(#Known (unNode r2)) andalso not (!(#Known (unNode r1))) then + markKnown r1 + else + (); + #Cons (unNode r1) := SM.unionWith #1 (!(#Cons (unNode r1)), !(#Cons (unNode r2))); + compactFuncs ()) + | _ => raise Contradiction + + and compactFuncs () = + let + fun loop funcs = + case funcs of + [] => [] + | (fr as ((f, rs), r)) :: rest => + let + val rest = List.filter (fn ((f' : string, rs'), r') => + if f' = f + andalso ListPair.allEq (fn (r1, r2) => + repOf r1 = repOf r2) + (rs, rs') then + (markEq (r, r'); + false) else - t - | _ => t) t (allPeers (t, e)) - end - else - t - | _ => t - - fun doProj (t, e1, e2) = - foldl (fn ((e1', e2'), t) => - let - fun doOne (e, t) = - case e of - Proj (e', f) => - if query (t, e1, e') then - assert (t, e, Proj (e2, f)) - else - t - | _ => t - in - doOne (e1', doOne (e2', t)) - end) t t - - val t = (r1, r2) :: t - val t = doUn (t, r1, r2) - val t = doUn (t, r2, r1) - val t = doProj (t, r1, r2) - val t = doProj (t, r2, r1) + true) rest + in + fr :: loop rest + end + in + #Funcs db := loop (!(#Funcs db)) + end in - t + markEq (representative (db, e1), representative (db, e2)) end - end + | _ => () + +fun check (db, a) = + case a of + ACond _ => false + | AReln x => + case x of + (Known, [e]) => !(#Known (unNode (representative (db, e)))) + | (PCon0 f, [e]) => + (case #Variety (unNode (representative (db, e))) of + Dt0 f' => f' = f + | _ => false) + | (PCon1 f, [e]) => + (case #Variety (unNode (representative (db, e))) of + Dt1 (f', _) => f' = f + | _ => false) + | (Eq, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + repOf r1 = repOf r2 + end + | _ => false end -fun rimp cc ((r1, es1), (r2, es2)) = - case (r1, r2) of - (Sql r1', Sql r2') => - r1' = r2' andalso - (case (es1, es2) of - ([e1], [e2]) => eq (e1, e2) - | _ => false) - | (Eq, Eq) => - (case (es1, es2) of - ([x1, y1], [x2, y2]) => - let - val saved = save () - in - if eq (x1, x2) andalso eq (y1, y2) then - true - else - (restore saved; - if eq (x1, y2) andalso eq (y1, x2) then - true - else - (restore saved; - false)) - end - | _ => false) - | (Known, Known) => - (case (es1, es2) of - ([Var v], [e2]) => - let - fun matches e = - case e of - Var v' => v' = v - | Proj (e, _) => matches e - | Func (f, [e]) => String.isPrefix "un" f andalso matches e - | _ => false - in - (*Print.prefaces "Checking peers" [("e2", p_exp e2), - ("peers", Print.p_list p_exp (Cc.allPeers (cc, e2))), - ("db", Cc.p_t cc)];*) - List.exists matches (Cc.allPeers (cc, e2)) - end - | _ => false) - | _ => false - -fun imply (p1, p2) = +fun decomp fals or = let - fun doOne doKnown = - decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 - (fn hyps => - decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 - (fn goals => - let - val cc = foldl (fn (p, cc) => - case p of - AReln (Eq, [e1, e2]) => Cc.assert (cc, e1, e2) - | _ => cc) Cc.empty hyps - - fun gls goals onFail = - case goals of - [] => true - | ACond _ :: _ => false - | AReln g :: goals => - case (doKnown, g) of - (false, (Known, _)) => gls goals onFail - | _ => - let - fun hps hyps = - case hyps of - [] => ((*Print.prefaces "Fail" [("g", p_prop (Reln g)), - ("db", Cc.p_t cc)];*) - onFail ()) - | ACond _ :: hyps => hps hyps - | AReln h :: hyps => - let - val saved = save () - in - if rimp cc (h, g) then - let - val changed = IM.numItems (!unif) - <> IM.numItems saved - in - gls goals (fn () => (restore saved; - changed (*andalso - (Print.preface ("Retry", - p_prop - (Reln g) - ); true)*) - andalso hps hyps)) - end - else - hps hyps - end - in - (case g of - (Eq, [e1, e2]) => Cc.query (cc, e1, e2) - | _ => false) - orelse hps hyps - end - in - if List.exists (fn AReln (DtCon c1, [e]) => - List.exists (fn AReln (DtCon c2, [e']) => - c1 <> c2 andalso - Cc.query (cc, e, e') - | _ => false) hyps - orelse List.exists (fn Func (c2, []) => c1 <> c2 - | Finish => true - | _ => false) - (Cc.allPeers (cc, e)) - | _ => false) hyps - orelse gls goals (fn () => false) then - true - else - ((*Print.prefaces "Can't prove" - [("hyps", Print.p_list p_atom hyps), - ("goals", Print.p_list p_atom goals)];*) - false) - end)) + fun decomp p k = + case p of + True => k [] + | False => fals + | Unknown => k [] + | And (p1, p2) => + decomp p1 (fn ps1 => + decomp p2 (fn ps2 => + k (ps1 @ ps2))) + | Or (p1, p2) => + or (decomp p1 k, fn () => decomp p2 k) + | Reln x => k [AReln x] + | Cond x => k [ACond x] in - reset (); - doOne false; - doOne true + decomp end +fun imply (p1, p2) = + (reset (); + decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 + (fn hyps => + decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 + (fn goals => + let + fun gls goals onFail acc = + case goals of + [] => + (let + val cc = Cc.database () + val () = app (fn a => Cc.assert (cc, a)) hyps + in + (List.all (fn a => + if Cc.check (cc, a) then + true + else + ((*Print.prefaces "Can't prove" + [("a", p_atom a), + ("hyps", Print.p_list p_atom hyps), + ("db", Cc.p_database cc)];*) + false)) acc + orelse onFail ()) + handle Cc.Contradiction => onFail () + end handle Cc.Undetermined => onFail ()) + | AReln (Sql gf, [ge]) :: goals => + let + fun hps hyps = + case hyps of + [] => onFail () + | AReln (Sql hf, [he]) :: hyps => + if gf = hf then + let + val saved = save () + in + if eq (ge, he) then + let + val changed = IM.numItems (!unif) + <> IM.numItems saved + in + gls goals (fn () => (restore saved; + changed + andalso hps hyps)) + acc + end + else + hps hyps + end + else + hps hyps + | _ :: hyps => hps hyps + in + hps hyps + end + | g :: goals => gls goals onFail (g :: acc) + in + gls goals (fn () => false) [] + end handle Cc.Contradiction => true))) + fun patCon pc = case pc of PConVar n => "C" ^ Int.toString n @@ -953,7 +1188,7 @@ val query = log "query" (wrap (follow (follow select from) (opt wher)) (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) -fun removeDups ls = +fun removeDups (ls : (string * string) list) = case ls of [] => [] | x :: ls => @@ -1029,7 +1264,7 @@ fun queryProp env rvN rv oe e = end | SqFunc (f, e) => inl (case expIn e of - inl e => Func (f, [e]) + inl e => Func (Other f, [e]) | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) | Count => inl count @@ -1081,12 +1316,12 @@ fun evalPat env e (pt, _) = PWild => (env, True) | PVar _ => (e :: env, True) | PPrim _ => (env, True) - | PCon (_, pc, NONE) => (env, Reln (DtCon (patCon pc), [e])) + | PCon (_, pc, NONE) => (env, Reln (PCon0 (patCon pc), [e])) | PCon (_, pc, SOME pt) => let - val (env, p) = evalPat env (Func ("un" ^ patCon pc, [e])) pt + val (env, p) = evalPat env (Func (UnCon (patCon pc), [e])) pt in - (env, And (p, Reln (DtCon (patCon pc), [e]))) + (env, And (p, Reln (PCon1 (patCon pc), [e]))) end | PRecord xpts => foldl (fn ((x, pt, _), (env, p)) => @@ -1095,12 +1330,12 @@ fun evalPat env e (pt, _) = in (env, And (p', p)) end) (env, True) xpts - | PNone _ => (env, Reln (DtCon "None", [e])) + | PNone _ => (env, Reln (PCon0 "None", [e])) | PSome (_, pt) => let - val (env, p) = evalPat env (Func ("unSome", [e])) pt + val (env, p) = evalPat env (Func (UnCon "Some", [e])) pt in - (env, And (p, Reln (DtCon "Some", [e]))) + (env, And (p, Reln (PCon1 "Some", [e]))) end fun peq (p1, p2) = @@ -1145,19 +1380,19 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = EPrim p => (Const p, st) | ERel n => (List.nth (env, n), st) | ENamed _ => default () - | ECon (_, pc, NONE) => (Func (patCon pc, []), st) + | ECon (_, pc, NONE) => (Func (DtCon0 (patCon pc), []), st) | ECon (_, pc, SOME e) => let val (e, st) = evalExp env (e, st) in - (Func (patCon pc, [e]), st) + (Func (DtCon1 (patCon pc), [e]), st) end - | ENone _ => (Func ("None", []), st) + | ENone _ => (Func (DtCon0 "None", []), st) | ESome (_, e) => let val (e, st) = evalExp env (e, st) in - (Func ("Some", [e]), st) + (Func (DtCon1 "Some", [e]), st) end | EFfi _ => default () @@ -1174,7 +1409,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (es, st) = ListUtil.foldlMap (evalExp env) st es in - (Func (m ^ "." ^ s, es), st) + (Func (Other (m ^ "." ^ s), es), st) end | EApp (e1, e2) => @@ -1191,14 +1426,14 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (e1, st) = evalExp env (e1, st) in - (Func (s, [e1]), st) + (Func (Other s, [e1]), st) end | EBinop (s, e1, e2) => let val (e1, st) = evalExp env (e1, st) val (e2, st) = evalExp env (e2, st) in - (Func (s, [e1, e2]), st) + (Func (Other s, [e1, e2]), st) end | ERecord xets => let @@ -1241,7 +1476,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val (e1, st) = evalExp env (e1, st) val (e2, st) = evalExp env (e2, st) in - (Func ("cat", [e1, e2]), st) + (Func (Other "cat", [e1, e2]), st) end | EError _ => (Finish, st) | EReturnBlob {blob = b, mimeType = m, ...} => @@ -1279,7 +1514,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (es, st) = ListUtil.foldlMap (evalExp env) st es in - (Func ("Cl" ^ Int.toString n, es), st) + (Func (Other ("Cl" ^ Int.toString n), es), st) end | EQuery {query = q, body = b, initial = i, ...} => @@ -1409,10 +1644,8 @@ fun check file = Const _ => () | Var _ => doOne e | Lvar _ => raise Fail "Iflow.doAll: Lvar" - | Func (f, es) => if String.isPrefix "un" f then - doOne e - else - app doAll es + | Func (UnCon _, [e]) => doOne e + | Func (_, es) => app doAll es | Recd xes => app (doAll o #2) xes | Proj _ => doOne e | Finish => () -- cgit v1.2.3 From 2cb2de002e332310000a3573259ccb7347b4974c Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 8 Apr 2010 14:20:46 -0400 Subject: Some serious debugging of the new Cc --- src/iflow.sml | 279 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 160 insertions(+), 119 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index d1f36a96..eddf5bc2 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -546,7 +546,7 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r), - Known = ref false}) + Known = #Known (unNode r)}) in #Cons (unNode r) := SM.insert (!(#Cons (unNode r)), f, r'); r' @@ -568,7 +568,7 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = cons, Variety = Nothing, - Known = ref false}) + Known = #Known (unNode r)}) val r'' = ref (Node {Rep = ref NONE, Cons = #Cons (unNode r), @@ -634,11 +634,11 @@ fun representative (db : database, e) = Recrd xes => (case SM.find (!xes, f) of SOME r => repOf r - | NONE =>let + | NONE => let val r = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref false}) + Known = #Known (unNode r)}) in xes := SM.insert (!xes, f, r); r @@ -648,7 +648,7 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref false}) + Known = #Known (unNode r)}) val r'' = ref (Node {Rep = ref NONE, Cons = #Cons (unNode r), @@ -838,6 +838,8 @@ fun decomp fals or = fun imply (p1, p2) = (reset (); + (*Print.prefaces "Bigger go" [("p1", p_prop p1), + ("p2", p_prop p2)];*) decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 (fn hyps => decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 @@ -861,12 +863,12 @@ fun imply (p1, p2) = false)) acc orelse onFail ()) handle Cc.Contradiction => onFail () - end handle Cc.Undetermined => onFail ()) - | AReln (Sql gf, [ge]) :: goals => + end handle Cc.Undetermined => ((*print "Undetermined\n";*) onFail ())) + | (g as AReln (Sql gf, [ge])) :: goals => let fun hps hyps = case hyps of - [] => onFail () + [] => gls goals onFail (g :: acc) | AReln (Sql hf, [he]) :: hyps => if gf = hf then let @@ -893,6 +895,8 @@ fun imply (p1, p2) = end | g :: goals => gls goals onFail (g :: acc) in + (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), + ("goals", Print.p_list p_atom goals)];*) gls goals (fn () => false) [] end handle Cc.Contradiction => true))) @@ -1205,111 +1209,133 @@ datatype queryMode = SomeCol of exp | AllCols of exp +exception Default + fun queryProp env rvN rv oe e = - case parse query e of - NONE => (print ("Warning: Information flow checker can't parse SQL query at " - ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - (rvN, Var 0, Unknown, [])) - | SOME r => - let - val (rvN, count) = rv rvN - - val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => - let - val (rvN, e) = rv rvN - in - ((v, e), rvN) - end) rvN (#From r) - - fun rvOf v = - case List.find (fn (v', _) => v' = v) rvs of - NONE => raise Fail "Iflow.queryProp: Bad table variable" - | SOME (_, e) => e - - fun usedFields e = - case e of - SqConst _ => [] - | Field (v, f) => [(v, f)] - | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) - | SqKnown _ => [] - | Inj _ => [] - | SqFunc (_, e) => usedFields e - | Count => [] - - val p = - foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) - - fun expIn e = - case e of - SqConst p => inl (Const p) - | Field (v, f) => inl (Proj (rvOf v, f)) - | Binop (bo, e1, e2) => - inr (case (bo, expIn e1, expIn e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, inr p1, inr p2) => f (p1, p2) - | _ => Unknown) - | SqKnown e => - inr (case expIn e of - inl e => Reln (Known, [e]) - | _ => Unknown) - | Inj e => - let - fun deinj (e, _) = - case e of - ERel n => List.nth (env, n) - | EField (e, f) => Proj (deinj e, f) - | _ => raise Fail "Iflow: non-variable injected into query" - in - inl (deinj e) - end - | SqFunc (f, e) => - inl (case expIn e of - inl e => Func (Other f, [e]) - | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) - | Count => inl count - - val p = case #Where r of - NONE => p - | SOME e => - case expIn e of - inr p' => And (p, p') - | _ => p - in - (rvN, - count, - And (p, case oe of - SomeCol oe => - foldl (fn (si, p) => - let - val p' = case si of - SqField (v, f) => Reln (Eq, [oe, Proj (rvOf v, f)]) - | SqExp (e, f) => - case expIn e of - inr _ => Unknown - | inl e => Reln (Eq, [oe, e]) - in - Or (p, p') - end) - False (#Select r) - | AllCols oe => - foldl (fn (si, p) => - let - val p' = case si of - SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), - Proj (rvOf v, f)]) - | SqExp (e, f) => - case expIn e of - inr p => Cond (Proj (oe, f), p) - | inl e => Reln (Eq, [Proj (oe, f), e]) - in - And (p, p') - end) - True (#Select r)), - - case #Where r of - NONE => [] - | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)) - end + let + fun default () = (print ("Warning: Information flow checker can't parse SQL query at " + ^ ErrorMsg.spanToString (#2 e) ^ "\n"); + (rvN, Unknown, [])) + in + case parse query e of + NONE => default () + | SOME r => + let + val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => + let + val (rvN, e) = rv rvN + in + ((v, e), rvN) + end) rvN (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.queryProp: Bad table variable" + | SOME (_, e) => e + + fun usedFields e = + case e of + SqConst _ => [] + | Field (v, f) => [(v, f)] + | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) + | SqKnown _ => [] + | Inj _ => [] + | SqFunc (_, e) => usedFields e + | Count => [] + + val p = + foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) + + fun expIn e = + case e of + SqConst p => inl (Const p) + | Field (v, f) => inl (Proj (rvOf v, f)) + | Binop (bo, e1, e2) => + inr (case (bo, expIn e1, expIn e2) of + (Exps f, inl e1, inl e2) => f (e1, e2) + | (Props f, inr p1, inr p2) => f (p1, p2) + | _ => Unknown) + | SqKnown e => + inr (case expIn e of + inl e => Reln (Known, [e]) + | _ => Unknown) + | Inj e => + let + fun deinj (e, _) = + case e of + ERel n => List.nth (env, n) + | EField (e, f) => Proj (deinj e, f) + | _ => raise Fail "Iflow: non-variable injected into query" + in + inl (deinj e) + end + | SqFunc (f, e) => + inl (case expIn e of + inl e => Func (Other f, [e]) + | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) + | Count => raise Default + + val p = case #Where r of + NONE => p + | SOME e => + case expIn e of + inr p' => And (p, p') + | _ => p + + fun normal () = + (rvN, + And (p, case oe of + SomeCol oe => + foldl (fn (si, p) => + let + val p' = case si of + SqField (v, f) => Reln (Eq, [oe, Proj (rvOf v, f)]) + | SqExp (e, f) => + case expIn e of + inr _ => Unknown + | inl e => Reln (Eq, [oe, e]) + in + Or (p, p') + end) + False (#Select r) + | AllCols oe => + foldl (fn (si, p) => + let + val p' = case si of + SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), + Proj (rvOf v, f)]) + | SqExp (e, f) => + case expIn e of + inr p => Cond (Proj (oe, f), p) + | inl e => Reln (Eq, [Proj (oe, f), e]) + in + And (p, p') + end) + True (#Select r)), + case #Where r of + NONE => [] + | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)) + in + case #Select r of + [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of + Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + let + val oe = case oe of + SomeCol oe => oe + | AllCols oe => Proj (oe, f) + in + (rvN, + Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), + And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + p)), + []) + end + | _ => normal ()) + | _ => normal () + end + handle Default => default () + end fun evalPat env e (pt, _) = case pt of @@ -1463,6 +1489,22 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (env, pp) = evalPat env e pt val (pe, st') = evalExp env (pe, (#1 st, And (orig, pp), #3 st)) + (*val () = Print.prefaces "Case" [("loc", Print.PD.string + (ErrorMsg.spanToString (#2 pt))), + ("env", Print.p_list p_exp env), + ("sent", Print.p_list_sep Print.PD.newline + (fn (loc, e, p) => + Print.box [Print.PD.string + (ErrorMsg.spanToString loc), + Print.PD.string ":", + Print.space, + p_exp e, + Print.space, + Print.PD.string "in", + Print.space, + p_prop p]) + (List.take (#3 st', length (#3 st') + - length (#3 st))))]*) val this = And (removeRedundant orig (#2 st'), Reln (Eq, [Var r, pe])) in @@ -1528,7 +1570,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val (rvN, count, qp, used) = + val (rvN, qp, used) = queryProp env (#1 st') (fn rvN => (rvN + 1, Var rvN)) (AllCols (Var r)) q @@ -1543,9 +1585,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val p = Or (Reln (Eq, [Var out, i]), And (Reln (Eq, [Var out, b]), - And (Reln (Gt, [count, - Const (Prim.Int 0)]), - p'))) + p')) in (out + 1, p, Var out) end @@ -1579,6 +1619,7 @@ fun check file = val file = MonoOpt.optimize file val file = Fuse.fuse file val file = MonoOpt.optimize file + val file = MonoShake.shake file (*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*) val exptd = foldl (fn ((d, _), exptd) => @@ -1608,7 +1649,7 @@ fun check file = (sent @ vals, pols) end - | DPolicy (PolClient e) => (vals, #3 (queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) + | DPolicy (PolClient e) => (vals, #2 (queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) (SomeCol (Var 0)) e) :: pols) | _ => (vals, pols) @@ -1636,7 +1677,7 @@ fun check file = () else (ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.preface ("The state satisifes this predicate:", p_prop p)) + Print.preface ("The state satisifies this predicate:", p_prop p)) end fun doAll e = @@ -1644,7 +1685,7 @@ fun check file = Const _ => () | Var _ => doOne e | Lvar _ => raise Fail "Iflow.doAll: Lvar" - | Func (UnCon _, [e]) => doOne e + | Func (UnCon _, [_]) => doOne e | Func (_, es) => app doAll es | Recd xes => app (doAll o #2) xes | Proj _ => doOne e -- cgit v1.2.3 From 37bbd6359da2753a8751a51922a95a9778fb9dcd Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 10 Apr 2010 10:24:13 -0400 Subject: Abstract type for evalExp state; handle WHERE conditions soundly --- src/iflow.sml | 335 ++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 207 insertions(+), 128 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index eddf5bc2..ee825781 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -837,68 +837,66 @@ fun decomp fals or = end fun imply (p1, p2) = - (reset (); - (*Print.prefaces "Bigger go" [("p1", p_prop p1), - ("p2", p_prop p2)];*) - decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 - (fn hyps => - decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 - (fn goals => - let - fun gls goals onFail acc = - case goals of - [] => - (let - val cc = Cc.database () - val () = app (fn a => Cc.assert (cc, a)) hyps - in - (List.all (fn a => - if Cc.check (cc, a) then - true - else - ((*Print.prefaces "Can't prove" - [("a", p_atom a), - ("hyps", Print.p_list p_atom hyps), - ("db", Cc.p_database cc)];*) - false)) acc - orelse onFail ()) - handle Cc.Contradiction => onFail () - end handle Cc.Undetermined => ((*print "Undetermined\n";*) onFail ())) - | (g as AReln (Sql gf, [ge])) :: goals => - let - fun hps hyps = - case hyps of - [] => gls goals onFail (g :: acc) - | AReln (Sql hf, [he]) :: hyps => - if gf = hf then - let - val saved = save () - in - if eq (ge, he) then - let - val changed = IM.numItems (!unif) - <> IM.numItems saved - in - gls goals (fn () => (restore saved; - changed - andalso hps hyps)) - acc - end - else - hps hyps - end - else - hps hyps - | _ :: hyps => hps hyps + decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 + (fn hyps => + decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 + (fn goals => + let + fun gls goals onFail acc = + case goals of + [] => + (let + val cc = Cc.database () + val () = app (fn a => Cc.assert (cc, a)) hyps in - hps hyps - end - | g :: goals => gls goals onFail (g :: acc) - in - (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), - ("goals", Print.p_list p_atom goals)];*) - gls goals (fn () => false) [] - end handle Cc.Contradiction => true))) + (List.all (fn a => + if Cc.check (cc, a) then + true + else + ((*Print.prefaces "Can't prove" + [("a", p_atom a), + ("hyps", Print.p_list p_atom hyps), + ("db", Cc.p_database cc)];*) + false)) acc) + handle Cc.Contradiction => false + end handle Cc.Undetermined => false) + orelse onFail () + | (g as AReln (Sql gf, [ge])) :: goals => + let + fun hps hyps = + case hyps of + [] => gls goals onFail (g :: acc) + | (h as AReln (Sql hf, [he])) :: hyps => + if gf = hf then + let + val saved = save () + in + if eq (ge, he) then + let + val changed = IM.numItems (!unif) + <> IM.numItems saved + in + gls goals (fn () => (restore saved; + changed + andalso hps hyps)) + acc + end + else + hps hyps + end + else + hps hyps + | _ :: hyps => hps hyps + in + hps hyps + end + | g :: goals => gls goals onFail (g :: acc) + in + reset (); + (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), + ("goals", Print.p_list p_atom goals)];*) + gls goals (fn () => false) [] + end handle Cc.Contradiction => true)) fun patCon pc = case pc of @@ -1215,7 +1213,7 @@ fun queryProp env rvN rv oe e = let fun default () = (print ("Warning: Information flow checker can't parse SQL query at " ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - (rvN, Unknown, [])) + (rvN, Unknown, Unknown, [])) in case parse query e of NONE => default () @@ -1283,8 +1281,7 @@ fun queryProp env rvN rv oe e = | _ => p fun normal () = - (rvN, - And (p, case oe of + (And (p, case oe of SomeCol oe => foldl (fn (si, p) => let @@ -1312,27 +1309,29 @@ fun queryProp env rvN rv oe e = And (p, p') end) True (#Select r)), - case #Where r of - NONE => [] - | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)) + True) + + val (p, wp) = + case #Select r of + [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of + Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + let + val oe = case oe of + SomeCol oe => oe + | AllCols oe => Proj (oe, f) + in + (Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), + And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + p)), + Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])])) + end + | _ => normal ()) + | _ => normal () in - case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => - let - val oe = case oe of - SomeCol oe => oe - | AllCols oe => Proj (oe, f) - in - (rvN, - Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), - And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), - p)), - []) - end - | _ => normal ()) - | _ => normal () + (rvN, p, wp, case #Where r of + NONE => [] + | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)) end handle Default => default () end @@ -1389,18 +1388,83 @@ fun removeRedundant p1 = rr end -fun evalExp env (e as (_, loc), st as (nv, p, sent)) = +structure St :> sig + type t + val create : {Var : int, + Ambient : prop} -> t + + val curVar : t -> int + val nextVar : t -> t * int + + val ambient : t -> prop + val setAmbient : t * prop -> t + + type check = ErrorMsg.span * exp * prop + + val path : t -> check list + val addPath : t * check -> t + + val sent : t -> check list + val addSent : t * check -> t + val setSent : t * check list -> t +end = struct + +type check = ErrorMsg.span * exp * prop + +type t = {Var : int, + Ambient : prop, + Path : check list, + Sent : check list} + +fun create {Var = v, Ambient = p} = {Var = v, + Ambient = p, + Path = [], + Sent = []} + +fun curVar (t : t) = #Var t +fun nextVar (t : t) = ({Var = #Var t + 1, + Ambient = #Ambient t, + Path = #Path t, + Sent = #Sent t}, #Var t) + +fun ambient (t : t) = #Ambient t +fun setAmbient (t : t, p) = {Var = #Var t, + Ambient = p, + Path = #Path t, + Sent = #Sent t} + +fun path (t : t) = #Path t +fun addPath (t : t, c) = {Var = #Var t, + Ambient = #Ambient t, + Path = c :: #Path t, + Sent = #Sent t} + +fun sent (t : t) = #Sent t +fun addSent (t : t, c) = {Var = #Var t, + Ambient = #Ambient t, + Path = #Path t, + Sent = c :: #Sent t} +fun setSent (t : t, cs) = {Var = #Var t, + Ambient = #Ambient t, + Path = #Path t, + Sent = cs} + +end + +fun evalExp env (e as (_, loc), st) = let fun default () = - ((*Print.preface ("Default" ^ Int.toString nv, - MonoPrint.p_exp MonoEnv.empty e);*) - (Var nv, (nv+1, p, sent))) + let + val (st, nv) = St.nextVar st + in + (Var nv, st) + end - fun addSent (p, e, sent) = + fun addSent (p, e, st) = if isKnown e then - sent + st else - (loc, e, p) :: sent + St.addSent (st, (loc, e, p)) in case #1 e of EPrim p => (Const p, st) @@ -1427,7 +1491,7 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = let val (es, st) = ListUtil.foldlMap (evalExp env) st es in - (Recd [], (#1 st, p, foldl (fn (e, sent) => addSent (#2 st, e, sent)) sent es)) + (Recd [], foldl (fn (e, st) => addSent (St.ambient st, e, st)) st es) end else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then default () @@ -1481,14 +1545,13 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = | ECase (e, pes, _) => let val (e, st) = evalExp env (e, st) - val r = #1 st - val st = (r + 1, #2 st, #3 st) - val orig = #2 st + val (st, r) = St.nextVar st + val orig = St.ambient st val st = foldl (fn ((pt, pe), st) => let val (env, pp) = evalPat env e pt - val (pe, st') = evalExp env (pe, (#1 st, And (orig, pp), #3 st)) + val (pe, st') = evalExp env (pe, St.setAmbient (st, And (orig, pp))) (*val () = Print.prefaces "Case" [("loc", Print.PD.string (ErrorMsg.spanToString (#2 pt))), ("env", Print.p_list p_exp env), @@ -1506,12 +1569,13 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = (List.take (#3 st', length (#3 st') - length (#3 st))))]*) - val this = And (removeRedundant orig (#2 st'), Reln (Eq, [Var r, pe])) + val this = And (removeRedundant orig (St.ambient st'), + Reln (Eq, [Var r, pe])) in - (#1 st', Or (#2 st, this), #3 st') - end) (#1 st, False, #3 st) pes + St.setAmbient (st', Or (St.ambient st, this)) + end) (St.setAmbient (st, False)) pes in - (Var r, (#1 st, And (orig, #2 st), #3 st)) + (Var r, St.setAmbient (st, And (orig, St.ambient st))) end | EStrcat (e1, e2) => let @@ -1526,19 +1590,19 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val (b, st) = evalExp env (b, st) val (m, st) = evalExp env (m, st) in - (Finish, (#1 st, p, addSent (#2 st, b, addSent (#2 st, m, sent)))) + (Finish, addSent (St.ambient st, b, addSent (St.ambient st, m, st))) end | ERedirect (e, _) => let val (e, st) = evalExp env (e, st) in - (Finish, (#1 st, p, addSent (#2 st, e, sent))) + (Finish, addSent (St.ambient st, e, st)) end | EWrite e => let val (e, st) = evalExp env (e, st) in - (Recd [], (#1 st, p, addSent (#2 st, e, sent))) + (Recd [], addSent (St.ambient st, e, st)) end | ESeq (e1, e2) => let @@ -1564,43 +1628,57 @@ fun evalExp env (e as (_, loc), st as (nv, p, sent)) = val (_, st) = evalExp env (q, st) val (i, st) = evalExp env (i, st) - val r = #1 st - val acc = #1 st + 1 - val st' = (#1 st + 2, #2 st, #3 st) + val (st', r) = St.nextVar st + val (st', acc) = St.nextVar st' val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val (rvN, qp, used) = + val (st', qp, qwp, used) = queryProp env - (#1 st') (fn rvN => (rvN + 1, Var rvN)) + st' (fn st' => + let + val (st', rv) = St.nextVar st' + in + (st', Var rv) + end) (AllCols (Var r)) q - val p' = And (qp, #2 st') - - val (nvs, p, res) = if varInP acc (#2 st') then - (#1 st + 1, #2 st, Var r) - else - let - val out = rvN - - val p = Or (Reln (Eq, [Var out, i]), - And (Reln (Eq, [Var out, b]), - p')) - in - (out + 1, p, Var out) - end - - val sent = map (fn (loc, e, p) => (loc, e, And (qp, p))) (#3 st') + val p' = And (qp, St.ambient st') + + val (st, res) = if varInP acc (St.ambient st') then + let + val (st, r) = St.nextVar st + in + (st, Var r) + end + else + let + val (st, out) = St.nextVar st' + + val p = Or (Reln (Eq, [Var out, i]), + And (Reln (Eq, [Var out, b]), + p')) + in + (St.setAmbient (st, p), Var out) + end + + val sent = map (fn (loc, e, p) => (loc, e, And (qp, p))) (St.sent st') + + val p' = And (p', qwp) val sent = map (fn e => (loc, e, p')) used @ sent in - (res, (nvs, p, sent)) + (res, St.setSent (st, sent)) end | EDml _ => default () | ENextval _ => default () | ESetval _ => default () | EUnurlify ((EFfiApp ("Basis", "get_cookie", _), _), _, _) => - (Var nv, (nv + 1, And (p, Reln (Known, [Var nv])), sent)) + let + val (st, nv) = St.nextVar st + in + (Var nv, St.setAmbient (st, And (St.ambient st, Reln (Known, [Var nv])))) + end | EUnurlify _ => default () | EJavaScript _ => default () @@ -1644,9 +1722,10 @@ fun check file = val (e, env, nv, p) = deAbs (e, [], 1, True) - val (e, (_, p, sent)) = evalExp env (e, (nv, p, [])) + val (_, st) = evalExp env (e, St.create {Var = nv, + Ambient = p}) in - (sent @ vals, pols) + (St.sent st @ vals, pols) end | DPolicy (PolClient e) => (vals, #2 (queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) -- cgit v1.2.3 From 47ffafdfbbee9373b99a1284f0ac8b2cadc7652d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 10 Apr 2010 13:02:15 -0400 Subject: Path conditions, used to track implicit flows --- src/iflow.sml | 431 +++++++++++++++++++++++++++++++++------------------------- 1 file changed, 242 insertions(+), 189 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index ee825781..b3f1a6eb 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -380,18 +380,18 @@ fun eeq (e1, e2) = (* Congruence closure *) structure Cc :> sig type database - type representative exception Contradiction exception Undetermined val database : unit -> database - val representative : database * exp -> representative val assert : database * atom -> unit val check : database * atom -> bool val p_database : database Print.printer + + val builtFrom : database * {Base : exp list, Derived : exp} -> bool end = struct exception Contradiction @@ -420,7 +420,7 @@ type representative = node ref val finish = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = VFinish, - Known = ref false}) + Known = ref true}) type database = {Vars : representative IM.map ref, Consts : representative CM.map ref, @@ -470,7 +470,12 @@ fun p_database (db : database) = space, string "=", space, - p_rep n]) (IM.listItemsi (!(#Vars db)))] + p_rep n, + if !(#Known (unNode n)) then + box [space, + string "(known)"] + else + box []]) (IM.listItemsi (!(#Vars db)))] fun repOf (n : representative) : representative = case !(#Rep (unNode n)) of @@ -484,11 +489,15 @@ fun repOf (n : representative) : representative = end fun markKnown r = - (#Known (unNode r) := true; - case #Variety (unNode r) of - Dt1 (_, r) => markKnown r - | Recrd xes => SM.app markKnown (!xes) - | _ => ()) + if !(#Known (unNode r)) then + () + else + (#Known (unNode r) := true; + SM.app markKnown (!(#Cons (unNode r))); + case #Variety (unNode r) of + Dt1 (_, r) => markKnown r + | Recrd xes => SM.app markKnown (!xes) + | _ => ()) fun representative (db : database, e) = let @@ -529,7 +538,7 @@ fun representative (db : database, e) = val r = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Dt0 f, - Known = ref false}) + Known = ref true}) in #Con0s db := SM.insert (!(#Con0s db), f, r); r @@ -747,24 +756,23 @@ fun assert (db, a) = unif (!xes2, !xes1) end | (VFinish, VFinish) => () - | (Nothing, _) => - (#Rep (unNode r1) := SOME r2; - if !(#Known (unNode r1)) andalso not (!(#Known (unNode r2))) then - markKnown r2 - else - (); - #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); - compactFuncs ()) - | (_, Nothing) => - (#Rep (unNode r2) := SOME r1; - if !(#Known (unNode r2)) andalso not (!(#Known (unNode r1))) then - markKnown r1 - else - (); - #Cons (unNode r1) := SM.unionWith #1 (!(#Cons (unNode r1)), !(#Cons (unNode r2))); - compactFuncs ()) + | (Nothing, _) => mergeNodes (r1, r2) + | (_, Nothing) => mergeNodes (r2, r1) | _ => raise Contradiction + and mergeNodes (r1, r2) = + (#Rep (unNode r1) := SOME r2; + if !(#Known (unNode r1)) then + markKnown r2 + else + (); + if !(#Known (unNode r2)) then + markKnown r1 + else + (); + #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); + compactFuncs ()) + and compactFuncs () = let fun loop funcs = @@ -815,6 +823,27 @@ fun check (db, a) = end | _ => false +fun builtFrom (db, {Base = bs, Derived = d}) = + let + val bs = map (fn b => representative (db, b)) bs + + fun loop d = + let + val d = repOf d + in + List.exists (fn b => repOf b = d) bs + orelse case #Variety (unNode d) of + Dt0 _ => true + | Dt1 (_, d) => loop d + | Prim _ => true + | Recrd xes => List.all loop (SM.listItems (!xes)) + | VFinish => true + | Nothing => false + end + in + loop (representative (db, d)) + end + end fun decomp fals or = @@ -836,67 +865,66 @@ fun decomp fals or = decomp end -fun imply (p1, p2) = - decomp true (fn (e1, e2) => e1 andalso e2 ()) p1 - (fn hyps => - decomp false (fn (e1, e2) => e1 orelse e2 ()) p2 - (fn goals => - let - fun gls goals onFail acc = - case goals of - [] => - (let - val cc = Cc.database () - val () = app (fn a => Cc.assert (cc, a)) hyps - in - (List.all (fn a => - if Cc.check (cc, a) then - true - else - ((*Print.prefaces "Can't prove" - [("a", p_atom a), - ("hyps", Print.p_list p_atom hyps), - ("db", Cc.p_database cc)];*) - false)) acc) - handle Cc.Contradiction => false - end handle Cc.Undetermined => false) - orelse onFail () - | (g as AReln (Sql gf, [ge])) :: goals => - let - fun hps hyps = - case hyps of - [] => gls goals onFail (g :: acc) - | (h as AReln (Sql hf, [he])) :: hyps => - if gf = hf then - let - val saved = save () - in - if eq (ge, he) then - let - val changed = IM.numItems (!unif) - <> IM.numItems saved - in - gls goals (fn () => (restore saved; - changed - andalso hps hyps)) - acc - end - else - hps hyps - end - else - hps hyps - | _ :: hyps => hps hyps - in - hps hyps - end - | g :: goals => gls goals onFail (g :: acc) - in - reset (); - (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), - ("goals", Print.p_list p_atom goals)];*) - gls goals (fn () => false) [] - end handle Cc.Contradiction => true)) +fun imply (hyps, goals, outs) = + let + fun gls goals onFail acc = + case goals of + [] => + (let + val cc = Cc.database () + val () = app (fn a => Cc.assert (cc, a)) hyps + in + (List.all (fn a => + if Cc.check (cc, a) then + true + else + ((*Print.prefaces "Can't prove" + [("a", p_atom a), + ("hyps", Print.p_list p_atom hyps), + ("db", Cc.p_database cc)];*) + false)) acc + (*andalso (Print.preface ("Finding", Cc.p_database cc); true)*) + andalso Cc.builtFrom (cc, {Derived = Var 0, + Base = outs})) + handle Cc.Contradiction => false + end handle Cc.Undetermined => false) + orelse onFail () + | (g as AReln (Sql gf, [ge])) :: goals => + let + fun hps hyps = + case hyps of + [] => gls goals onFail (g :: acc) + | (h as AReln (Sql hf, [he])) :: hyps => + if gf = hf then + let + val saved = save () + in + if eq (ge, he) then + let + val changed = IM.numItems (!unif) + <> IM.numItems saved + in + gls goals (fn () => (restore saved; + changed + andalso hps hyps)) + acc + end + else + hps hyps + end + else + hps hyps + | _ :: hyps => hps hyps + in + hps hyps + end + | g :: goals => gls goals onFail (g :: acc) + in + reset (); + (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), + ("goals", Print.p_list p_atom goals)];*) + gls goals (fn () => false) [] + end handle Cc.Contradiction => true fun patCon pc = case pc of @@ -1204,7 +1232,7 @@ fun removeDups (ls : (string * string) list) = end datatype queryMode = - SomeCol of exp + SomeCol | AllCols of exp exception Default @@ -1213,7 +1241,7 @@ fun queryProp env rvN rv oe e = let fun default () = (print ("Warning: Information flow checker can't parse SQL query at " ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - (rvN, Unknown, Unknown, [])) + (rvN, Unknown, Unknown, [], [])) in case parse query e of NONE => default () @@ -1281,57 +1309,66 @@ fun queryProp env rvN rv oe e = | _ => p fun normal () = - (And (p, case oe of - SomeCol oe => - foldl (fn (si, p) => - let - val p' = case si of - SqField (v, f) => Reln (Eq, [oe, Proj (rvOf v, f)]) - | SqExp (e, f) => - case expIn e of - inr _ => Unknown - | inl e => Reln (Eq, [oe, e]) - in - Or (p, p') - end) - False (#Select r) - | AllCols oe => - foldl (fn (si, p) => - let - val p' = case si of - SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), - Proj (rvOf v, f)]) - | SqExp (e, f) => - case expIn e of - inr p => Cond (Proj (oe, f), p) - | inl e => Reln (Eq, [Proj (oe, f), e]) - in + case oe of + SomeCol => + (rvN, p, True, + List.mapPartial (fn si => + case si of + SqField (v, f) => SOME (Proj (rvOf v, f)) + | SqExp (e, f) => + case expIn e of + inr _ => NONE + | inl e => SOME e) (#Select r)) + | AllCols oe => + (rvN, And (p, foldl (fn (si, p) => + let + val p' = case si of + SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), + Proj (rvOf v, f)]) + | SqExp (e, f) => + case expIn e of + inr p => Cond (Proj (oe, f), p) + | inl e => Reln (Eq, [Proj (oe, f), e]) + in And (p, p') - end) - True (#Select r)), - True) + end) + True (#Select r)), + True, []) - val (p, wp) = + val (rvN, p, wp, outs) = case #Select r of [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => - let - val oe = case oe of - SomeCol oe => oe - | AllCols oe => Proj (oe, f) - in - (Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), - And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), - p)), - Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])])) - end + (case oe of + SomeCol => + let + val (rvN, oe) = rv rvN + in + (rvN, + Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), + And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + p)), + Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + [oe]) + end + | AllCols oe => + let + val oe = Proj (oe, f) + in + (rvN, + Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), + And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + p)), + Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + []) + end) | _ => normal ()) | _ => normal () in (rvN, p, wp, case #Where r of NONE => [] - | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)) + | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e), outs) end handle Default => default () end @@ -1388,6 +1425,10 @@ fun removeRedundant p1 = rr end +datatype cflow = Case | Where +datatype flow = Data | Control of cflow +type check = ErrorMsg.span * exp * prop + structure St :> sig type t val create : {Var : int, @@ -1399,22 +1440,21 @@ structure St :> sig val ambient : t -> prop val setAmbient : t * prop -> t - type check = ErrorMsg.span * exp * prop + val paths : t -> (check * cflow) list + val addPath : t * (check * cflow) -> t + val addPaths : t * (check * cflow) list -> t + val clearPaths : t -> t + val setPaths : t * (check * cflow) list -> t - val path : t -> check list - val addPath : t * check -> t - - val sent : t -> check list - val addSent : t * check -> t - val setSent : t * check list -> t + val sent : t -> (check * flow) list + val addSent : t * (check * flow) -> t + val setSent : t * (check * flow) list -> t end = struct -type check = ErrorMsg.span * exp * prop - type t = {Var : int, Ambient : prop, - Path : check list, - Sent : check list} + Path : (check * cflow) list, + Sent : (check * flow) list} fun create {Var = v, Ambient = p} = {Var = v, Ambient = p, @@ -1433,11 +1473,23 @@ fun setAmbient (t : t, p) = {Var = #Var t, Path = #Path t, Sent = #Sent t} -fun path (t : t) = #Path t +fun paths (t : t) = #Path t fun addPath (t : t, c) = {Var = #Var t, Ambient = #Ambient t, Path = c :: #Path t, Sent = #Sent t} +fun addPaths (t : t, cs) = {Var = #Var t, + Ambient = #Ambient t, + Path = cs @ #Path t, + Sent = #Sent t} +fun clearPaths (t : t) = {Var = #Var t, + Ambient = #Ambient t, + Path = [], + Sent = #Sent t} +fun setPaths (t : t, cs) = {Var = #Var t, + Ambient = #Ambient t, + Path = cs, + Sent = #Sent t} fun sent (t : t) = #Sent t fun addSent (t : t, c) = {Var = #Var t, @@ -1461,10 +1513,16 @@ fun evalExp env (e as (_, loc), st) = end fun addSent (p, e, st) = - if isKnown e then - st - else - St.addSent (st, (loc, e, p)) + let + val st = if isKnown e then + st + else + St.addSent (st, ((loc, e, p), Data)) + + val st = foldl (fn ((c, fl), st) => St.addSent (st, (c, Control fl))) st (St.paths st) + in + St.clearPaths st + end in case #1 e of EPrim p => (Const p, st) @@ -1542,38 +1600,31 @@ fun evalExp env (e as (_, loc), st) = in (Proj (e, s), st) end - | ECase (e, pes, _) => + | ECase (e, pes, {result = res, ...}) => let val (e, st) = evalExp env (e, st) val (st, r) = St.nextVar st val orig = St.ambient st + val origPaths = St.paths st + + val st = St.addPath (st, ((loc, e, orig), Case)) + + val (st, paths) = + foldl (fn ((pt, pe), (st, paths)) => + let + val (env, pp) = evalPat env e pt + val (pe, st') = evalExp env (pe, St.setAmbient (st, And (orig, pp))) + + val this = And (removeRedundant orig (St.ambient st'), + Reln (Eq, [Var r, pe])) + in + (St.setPaths (St.setAmbient (st', Or (St.ambient st, this)), origPaths), + St.paths st' @ paths) + end) (St.setAmbient (st, False), []) pes - val st = foldl (fn ((pt, pe), st) => - let - val (env, pp) = evalPat env e pt - val (pe, st') = evalExp env (pe, St.setAmbient (st, And (orig, pp))) - (*val () = Print.prefaces "Case" [("loc", Print.PD.string - (ErrorMsg.spanToString (#2 pt))), - ("env", Print.p_list p_exp env), - ("sent", Print.p_list_sep Print.PD.newline - (fn (loc, e, p) => - Print.box [Print.PD.string - (ErrorMsg.spanToString loc), - Print.PD.string ":", - Print.space, - p_exp e, - Print.space, - Print.PD.string "in", - Print.space, - p_prop p]) - (List.take (#3 st', length (#3 st') - - length (#3 st))))]*) - - val this = And (removeRedundant orig (St.ambient st'), - Reln (Eq, [Var r, pe])) - in - St.setAmbient (st', Or (St.ambient st, this)) - end) (St.setAmbient (st, False)) pes + val st = case #1 res of + TRecord [] => St.setPaths (st, origPaths) + | _ => St.setPaths (st, paths) in (Var r, St.setAmbient (st, And (orig, St.ambient st))) end @@ -1633,7 +1684,7 @@ fun evalExp env (e as (_, loc), st) = val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val (st', qp, qwp, used) = + val (st', qp, qwp, used, _) = queryProp env st' (fn st' => let @@ -1662,12 +1713,12 @@ fun evalExp env (e as (_, loc), st) = (St.setAmbient (st, p), Var out) end - val sent = map (fn (loc, e, p) => (loc, e, And (qp, p))) (St.sent st') + val sent = map (fn ((loc, e, p), fl) => ((loc, e, And (qp, p)), fl)) (St.sent st') val p' = And (p', qwp) - val sent = map (fn e => (loc, e, p')) used @ sent + val paths = map (fn e => ((loc, e, p'), Where)) used in - (res, St.setSent (st, sent)) + (res, St.addPaths (St.setSent (st, sent), paths)) end | EDml _ => default () | ENextval _ => default () @@ -1728,8 +1779,12 @@ fun check file = (St.sent st @ vals, pols) end - | DPolicy (PolClient e) => (vals, #2 (queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) - (SomeCol (Var 0)) e) :: pols) + | DPolicy (PolClient e) => + let + val (_, p, _, _, outs) = queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) SomeCol e + in + (vals, (p, outs) :: pols) + end | _ => (vals, pols) @@ -1737,22 +1792,20 @@ fun check file = val (vals, pols) = foldl decl ([], []) file in - app (fn (loc, e, p) => + app (fn ((loc, e, p), fl) => let fun doOne e = let val p = And (p, Reln (Eq, [Var 0, e])) in - if List.exists (fn pol => if imply (p, pol) then - (if !debug then - Print.prefaces "Match" - [("Hyp", p_prop p), - ("Goal", p_prop pol)] - else - (); - true) - else - false) pols then + if decomp true (fn (e1, e2) => e1 andalso e2 ()) p + (fn hyps => + (fl <> Control Where + andalso imply (hyps, [AReln (Known, [Var 0])], [Var 0])) + orelse List.exists (fn (p', outs) => + decomp false (fn (e1, e2) => e1 orelse e2 ()) p' + (fn goals => imply (hyps, goals, outs))) + pols) then () else (ErrorMsg.errorAt loc "The information flow policy may be violated here."; -- cgit v1.2.3 From 7d88a1ff974ad5eb76dd12f63d9063d8bd48583b Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 10 Apr 2010 13:12:42 -0400 Subject: Constants are known --- src/iflow.sml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index b3f1a6eb..af45ea53 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -510,7 +510,7 @@ fun representative (db : database, e) = val r = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Prim p, - Known = ref false}) + Known = ref true}) in #Consts db := CM.insert (!(#Consts db), p, r); r -- cgit v1.2.3 From 7b4f69ace67601a0f22de52f91f96deff540fd37 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 10:57:52 -0400 Subject: Insert policies --- lib/ur/basis.urs | 4 + src/iflow.sml | 369 ++++++++++++++++++++++++++++++++++++++++------------- src/mono.sml | 4 +- src/mono_print.sml | 3 + src/mono_shake.sml | 1 + src/mono_util.sml | 3 + src/monoize.sml | 2 + 7 files changed, 298 insertions(+), 88 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 959a050d..8ae6597e 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -804,5 +804,9 @@ val sendClient : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => sql_query [] tables exps -> sql_policy +val mayInsert : fs ::: {Type} -> tables ::: {{Type}} -> [[New] ~ tables] + => sql_query [] ([New = fs] ++ tables) [] + -> sql_policy + val debug : string -> transaction unit diff --git a/src/iflow.sml b/src/iflow.sml index af45ea53..cce52fec 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -884,8 +884,10 @@ fun imply (hyps, goals, outs) = ("db", Cc.p_database cc)];*) false)) acc (*andalso (Print.preface ("Finding", Cc.p_database cc); true)*) - andalso Cc.builtFrom (cc, {Derived = Var 0, - Base = outs})) + andalso (case outs of + NONE => true + | SOME outs => Cc.builtFrom (cc, {Derived = Var 0, + Base = outs}))) handle Cc.Contradiction => false end handle Cc.Undetermined => false) orelse onFail () @@ -1218,6 +1220,24 @@ val query = log "query" (wrap (follow (follow select from) (opt wher)) (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) +datatype dml = + Insert of string * (string * sqexp) list + +val insert = log "insert" + (wrapP (follow (const "INSERT INTO ") + (follow uw_ident + (follow (const " (") + (follow (list uw_ident) + (follow (const ") VALUES (") + (follow (list sqexp) + (const ")"))))))) + (fn ((), (tab, ((), (fs, ((), (es, ())))))) => + (SOME (Insert (tab, ListPair.zipEq (fs, es)))) + handle ListPair.UnequalLengths => NONE)) + +val dml = log "dml" + insert + fun removeDups (ls : (string * string) list) = case ls of [] => [] @@ -1235,7 +1255,66 @@ datatype queryMode = SomeCol | AllCols of exp -exception Default +fun expIn rv env rvOf = + let + fun expIn (e, rvN) = + let + fun default () = + let + val (rvN, e) = rv rvN + in + (inl e, rvN) + end + in + case e of + SqConst p => (inl (Const p), rvN) + | Field (v, f) => (inl (Proj (rvOf v, f)), rvN) + | Binop (bo, e1, e2) => + let + val (e1, rvN) = expIn (e1, rvN) + val (e2, rvN) = expIn (e2, rvN) + in + (inr (case (bo, e1, e2) of + (Exps f, inl e1, inl e2) => f (e1, e2) + | (Props f, inr p1, inr p2) => f (p1, p2) + | _ => Unknown), rvN) + end + | SqKnown e => + (case expIn (e, rvN) of + (inl e, rvN) => (inr (Reln (Known, [e])), rvN) + | _ => (inr Unknown, rvN)) + | Inj e => + let + fun deinj e = + case #1 e of + ERel n => (List.nth (env, n), rvN) + | EField (e, f) => + let + val (e, rvN) = deinj e + in + (Proj (e, f), rvN) + end + | _ => + let + val (rvN, e) = rv rvN + in + (e, rvN) + end + + val (e, rvN) = deinj e + in + (inl e, rvN) + end + | SqFunc (f, e) => + (case expIn (e, rvN) of + (inl e, rvN) => (inl (Func (Other f, [e])), rvN) + | _ => default ()) + + | Count => default () + end + in + expIn + end fun queryProp env rvN rv oe e = let @@ -1272,68 +1351,56 @@ fun queryProp env rvN rv oe e = val p = foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) - fun expIn e = - case e of - SqConst p => inl (Const p) - | Field (v, f) => inl (Proj (rvOf v, f)) - | Binop (bo, e1, e2) => - inr (case (bo, expIn e1, expIn e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, inr p1, inr p2) => f (p1, p2) - | _ => Unknown) - | SqKnown e => - inr (case expIn e of - inl e => Reln (Known, [e]) - | _ => Unknown) - | Inj e => - let - fun deinj (e, _) = - case e of - ERel n => List.nth (env, n) - | EField (e, f) => Proj (deinj e, f) - | _ => raise Fail "Iflow: non-variable injected into query" - in - inl (deinj e) - end - | SqFunc (f, e) => - inl (case expIn e of - inl e => Func (Other f, [e]) - | _ => raise Fail ("Iflow: non-expresion passed to function " ^ f)) - | Count => raise Default - - val p = case #Where r of - NONE => p - | SOME e => - case expIn e of - inr p' => And (p, p') - | _ => p + val expIn = expIn rv env rvOf + + val (p, rvN) = case #Where r of + NONE => (p, rvN) + | SOME e => + case expIn (e, rvN) of + (inr p', rvN) => (And (p, p'), rvN) + | _ => (p, rvN) fun normal () = case oe of SomeCol => - (rvN, p, True, - List.mapPartial (fn si => - case si of - SqField (v, f) => SOME (Proj (rvOf v, f)) - | SqExp (e, f) => - case expIn e of - inr _ => NONE - | inl e => SOME e) (#Select r)) - | AllCols oe => - (rvN, And (p, foldl (fn (si, p) => + let + val (sis, rvN) = + ListUtil.foldlMap + (fn (si, rvN) => + case si of + SqField (v, f) => (Proj (rvOf v, f), rvN) + | SqExp (e, f) => + case expIn (e, rvN) of + (inr _, _) => let - val p' = case si of - SqField (v, f) => Reln (Eq, [Proj (Proj (oe, v), f), - Proj (rvOf v, f)]) - | SqExp (e, f) => - case expIn e of - inr p => Cond (Proj (oe, f), p) - | inl e => Reln (Eq, [Proj (oe, f), e]) + val (rvN, e) = rv rvN in - And (p, p') - end) - True (#Select r)), - True, []) + (e, rvN) + end + | (inl e, rvN) => (e, rvN)) rvN (#Select r) + in + (rvN, p, True, sis) + end + | AllCols oe => + let + val (p', rvN) = + foldl (fn (si, (p, rvN)) => + let + val (p', rvN) = + case si of + SqField (v, f) => (Reln (Eq, [Proj (Proj (oe, v), f), + Proj (rvOf v, f)]), rvN) + | SqExp (e, f) => + case expIn (e, rvN) of + (inr p, rvN) => (Cond (Proj (oe, f), p), rvN) + | (inl e, rvN) => (Reln (Eq, [Proj (oe, f), e]), rvN) + in + (And (p, p'), rvN) + end) + (True, rvN) (#Select r) + in + (rvN, And (p, p'), True, []) + end val (rvN, p, wp, outs) = case #Select r of @@ -1370,7 +1437,50 @@ fun queryProp env rvN rv oe e = NONE => [] | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e), outs) end - handle Default => default () + end + +fun insertProp rvN rv e = + let + fun default () = (print ("Warning: Information flow checker can't parse SQL query at " + ^ ErrorMsg.spanToString (#2 e) ^ "\n"); + Unknown) + in + case parse query e of + NONE => default () + | SOME r => + let + val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => + let + val (rvN, e) = rv rvN + in + ((v, e), rvN) + end) rvN (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.insertProp: Bad table variable" + | SOME (_, e) => e + + val p = + foldl (fn ((t, v), p) => + let + val t = + case v of + "New" => "$New" + | _ => t + in + And (p, Reln (Sql t, [rvOf v])) + end) True (#From r) + + val expIn = expIn rv [] rvOf + in + case #Where r of + NONE => p + | SOME e => + case expIn (e, rvN) of + (inr p', _) => And (p, p') + | _ => p + end end fun evalPat env e (pt, _) = @@ -1428,6 +1538,7 @@ fun removeRedundant p1 = datatype cflow = Case | Where datatype flow = Data | Control of cflow type check = ErrorMsg.span * exp * prop +type insert = ErrorMsg.span * prop structure St :> sig type t @@ -1449,57 +1560,77 @@ structure St :> sig val sent : t -> (check * flow) list val addSent : t * (check * flow) -> t val setSent : t * (check * flow) list -> t + + val inserted : t -> insert list + val addInsert : t * insert -> t end = struct type t = {Var : int, Ambient : prop, Path : (check * cflow) list, - Sent : (check * flow) list} + Sent : (check * flow) list, + Insert : insert list} fun create {Var = v, Ambient = p} = {Var = v, Ambient = p, Path = [], - Sent = []} + Sent = [], + Insert = []} fun curVar (t : t) = #Var t fun nextVar (t : t) = ({Var = #Var t + 1, Ambient = #Ambient t, Path = #Path t, - Sent = #Sent t}, #Var t) + Sent = #Sent t, + Insert = #Insert t}, #Var t) fun ambient (t : t) = #Ambient t fun setAmbient (t : t, p) = {Var = #Var t, Ambient = p, Path = #Path t, - Sent = #Sent t} + Sent = #Sent t, + Insert = #Insert t} fun paths (t : t) = #Path t fun addPath (t : t, c) = {Var = #Var t, Ambient = #Ambient t, Path = c :: #Path t, - Sent = #Sent t} + Sent = #Sent t, + Insert = #Insert t} fun addPaths (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = cs @ #Path t, - Sent = #Sent t} + Sent = #Sent t, + Insert = #Insert t} fun clearPaths (t : t) = {Var = #Var t, Ambient = #Ambient t, Path = [], - Sent = #Sent t} + Sent = #Sent t, + Insert = #Insert t} fun setPaths (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = cs, - Sent = #Sent t} + Sent = #Sent t, + Insert = #Insert t} fun sent (t : t) = #Sent t fun addSent (t : t, c) = {Var = #Var t, Ambient = #Ambient t, Path = #Path t, - Sent = c :: #Sent t} + Sent = c :: #Sent t, + Insert = #Insert t} fun setSent (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = #Path t, - Sent = cs} + Sent = cs, + Insert = #Insert t} + +fun inserted (t : t) = #Insert t +fun addInsert (t : t, c) = {Var = #Var t, + Ambient = #Ambient t, + Path = #Path t, + Sent = #Sent t, + Insert = c :: #Insert t} end @@ -1720,7 +1851,44 @@ fun evalExp env (e as (_, loc), st) = in (res, St.addPaths (St.setSent (st, sent), paths)) end - | EDml _ => default () + | EDml e => + (case parse dml e of + NONE => (print ("Warning: Information flow checker can't parse DML command at " + ^ ErrorMsg.spanToString loc ^ "\n"); + default ()) + | SOME d => + case d of + Insert (tab, es) => + let + val (st, new) = St.nextVar st + + fun rv st = + let + val (st, n) = St.nextVar st + in + (st, Var n) + end + + val expIn = expIn rv env (fn "New" => Var new + | _ => raise Fail "Iflow.evalExp: Bad field expression in EDml") + + val (es, st) = ListUtil.foldlMap + (fn ((x, e), st) => + let + val (e, st) = case expIn (e, st) of + (inl e, st) => (e, st) + | (inr _, _) => raise Fail + ("Iflow.evalExp: Selecting " + ^ "boolean expression") + in + ((x, e), st) + end) + st es + in + (Recd [], St.addInsert (st, (loc, And (St.ambient st, + Reln (Sql "$New", [Recd es]))))) + end) + | ENextval _ => default () | ESetval _ => default () @@ -1756,7 +1924,7 @@ fun check file = DExport (_, _, n, _, _, _) => IS.add (exptd, n) | _ => exptd) IS.empty file - fun decl ((d, _), (vals, pols)) = + fun decl ((d, _), (vals, inserts, client, insert)) = case d of DVal (_, n, _, e, _) => let @@ -1776,21 +1944,36 @@ fun check file = val (_, st) = evalExp env (e, St.create {Var = nv, Ambient = p}) in - (St.sent st @ vals, pols) + (St.sent st @ vals, St.inserted st @ inserts, client, insert) end - | DPolicy (PolClient e) => + | DPolicy pol => let - val (_, p, _, _, outs) = queryProp [] 0 (fn rvN => (rvN + 1, Lvar rvN)) SomeCol e + fun rv rvN = (rvN + 1, Lvar rvN) in - (vals, (p, outs) :: pols) + case pol of + PolClient e => + let + val (_, p, _, _, outs) = queryProp [] 0 rv SomeCol e + in + (vals, inserts, (p, outs) :: client, insert) + end + | PolInsert e => + let + val p = insertProp 0 rv e + in + (vals, inserts,client, p :: insert) + end end - | _ => (vals, pols) + | _ => (vals, inserts, client, insert) val () = reset () - val (vals, pols) = foldl decl ([], []) file + val (vals, inserts, client, insert) = foldl decl ([], [], [], []) file + + val decompH = decomp true (fn (e1, e2) => e1 andalso e2 ()) + val decompG = decomp false (fn (e1, e2) => e1 orelse e2 ()) in app (fn ((loc, e, p), fl) => let @@ -1798,14 +1981,14 @@ fun check file = let val p = And (p, Reln (Eq, [Var 0, e])) in - if decomp true (fn (e1, e2) => e1 andalso e2 ()) p - (fn hyps => - (fl <> Control Where - andalso imply (hyps, [AReln (Known, [Var 0])], [Var 0])) - orelse List.exists (fn (p', outs) => - decomp false (fn (e1, e2) => e1 orelse e2 ()) p' - (fn goals => imply (hyps, goals, outs))) - pols) then + if decompH p + (fn hyps => + (fl <> Control Where + andalso imply (hyps, [AReln (Known, [Var 0])], SOME [Var 0])) + orelse List.exists (fn (p', outs) => + decompG p' + (fn goals => imply (hyps, goals, SOME outs))) + client) then () else (ErrorMsg.errorAt loc "The information flow policy may be violated here."; @@ -1824,7 +2007,19 @@ fun check file = | Finish => () in doAll e - end) vals + end) vals; + + app (fn (loc, p) => + if decompH p + (fn hyps => + List.exists (fn p' => + decompG p' + (fn goals => imply (hyps, goals, NONE))) + insert) then + () + else + (ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.preface ("The state satisifies this predicate:", p_prop p))) inserts end val check = fn file => diff --git a/src/mono.sml b/src/mono.sml index f8f57ae7..9585fbc1 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -123,7 +123,9 @@ datatype exp' = withtype exp = exp' located -datatype policy = PolClient of exp +datatype policy = + PolClient of exp + | PolInsert of exp datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index 76a89cc7..e98fc924 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -417,6 +417,9 @@ fun p_policy env pol = PolClient e => box [string "sendClient", space, p_exp env e] + | PolInsert e => box [string "mayInsert", + space, + p_exp env e] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 3a681302..4df9a6a0 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -62,6 +62,7 @@ fun shake file = let val e1 = case pol of PolClient e1 => e1 + | PolInsert e1 => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index a7f27fd8..fa019b00 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -544,6 +544,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = PolClient e => S.map2 (mfe ctx e, PolClient) + | PolInsert e => + S.map2 (mfe ctx e, + PolInsert) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index a4e6a37c..5bdc2aa2 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3746,6 +3746,8 @@ fun monoDecl (env, fm) (all as (d, loc)) = case #1 e of L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sendClient"), _), _), _), _), _), e) => (e, L'.PolClient) + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) => + (e, L'.PolInsert) | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e -- cgit v1.2.3 From accb8e1bf49e1c1e8300bda9be3cf72ce592ab44 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 12:38:21 -0400 Subject: Delete policies --- lib/ur/basis.urs | 4 + src/iflow.sml | 286 +++++++++++++++++++++++++++++++++++++++-------------- src/mono.sml | 1 + src/mono_print.sml | 3 + src/mono_shake.sml | 1 + src/mono_util.sml | 3 + src/monoize.sml | 2 + 7 files changed, 225 insertions(+), 75 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 8ae6597e..501284b7 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -808,5 +808,9 @@ val mayInsert : fs ::: {Type} -> tables ::: {{Type}} -> [[New] ~ tables] => sql_query [] ([New = fs] ++ tables) [] -> sql_policy +val mayDelete : fs ::: {Type} -> tables ::: {{Type}} -> [[Old] ~ tables] + => sql_query [] ([Old = fs] ++ tables) [] + -> sql_policy + val debug : string -> transaction unit diff --git a/src/iflow.sml b/src/iflow.sml index cce52fec..f275d013 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -411,7 +411,7 @@ datatype node = Node of {Rep : node ref option ref, Dt0 of string | Dt1 of string * node ref | Prim of Prim.t - | Recrd of node ref SM.map ref + | Recrd of node ref SM.map ref * bool | VFinish | Nothing @@ -446,22 +446,29 @@ fun p_rep n = case !(#Rep (unNode n)) of SOME n => p_rep n | NONE => - case #Variety (unNode n) of - Nothing => string ("?" ^ Int.toString (Unsafe.cast n)) - | Dt0 s => string ("Dt0(" ^ s ^ ")") - | Dt1 (s, n) => box[string ("Dt1(" ^ s ^ ","), - space, - p_rep n, - string ")"] - | Prim p => Prim.p_t p - | Recrd (ref m) => box [string "{", - p_list (fn (x, n) => box [string x, - space, - string "=", - space, - p_rep n]) (SM.listItemsi m), - string "}"] - | VFinish => string "FINISH" + box [string (Int.toString (Unsafe.cast n) ^ ":"), + space, + case #Variety (unNode n) of + Nothing => string "?" + | Dt0 s => string ("Dt0(" ^ s ^ ")") + | Dt1 (s, n) => box[string ("Dt1(" ^ s ^ ","), + space, + p_rep n, + string ")"] + | Prim p => Prim.p_t p + | Recrd (ref m, b) => box [string "{", + p_list (fn (x, n) => box [string x, + space, + string "=", + space, + p_rep n]) (SM.listItemsi m), + string "}", + if b then + box [space, + string "(complete)"] + else + box []] + | VFinish => string "FINISH"] fun p_database (db : database) = box [string "Vars:", @@ -489,15 +496,20 @@ fun repOf (n : representative) : representative = end fun markKnown r = - if !(#Known (unNode r)) then - () - else - (#Known (unNode r) := true; - SM.app markKnown (!(#Cons (unNode r))); - case #Variety (unNode r) of - Dt1 (_, r) => markKnown r - | Recrd xes => SM.app markKnown (!xes) - | _ => ()) + let + val r = repOf r + in + (*Print.preface ("markKnown", p_rep r);*) + if !(#Known (unNode r)) then + ()(*TextIO.print "Already known\n"*) + else + (#Known (unNode r) := true; + SM.app markKnown (!(#Cons (unNode r))); + case #Variety (unNode r) of + Dt1 (_, r) => markKnown r + | Recrd (xes, _) => SM.app markKnown (!xes) + | _ => ()) + end fun representative (db : database, e) = let @@ -555,7 +567,7 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r), - Known = #Known (unNode r)}) + Known = ref (!(#Known (unNode r)))}) in #Cons (unNode r) := SM.insert (!(#Cons (unNode r)), f, r'); r' @@ -577,7 +589,7 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = cons, Variety = Nothing, - Known = #Known (unNode r)}) + Known = ref (!(#Known (unNode r)))}) val r'' = ref (Node {Rep = ref NONE, Cons = #Cons (unNode r), @@ -628,7 +640,7 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, - Variety = Recrd (ref xes), + Variety = Recrd (ref xes, true), Known = ref false}) in #Records db := (xes, r') :: (!(#Records db)); @@ -640,14 +652,14 @@ fun representative (db : database, e) = val r = rep e in case #Variety (unNode r) of - Recrd xes => + Recrd (xes, _) => (case SM.find (!xes, f) of SOME r => repOf r | NONE => let val r = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = #Known (unNode r)}) + Known = ref (!(#Known (unNode r)))}) in xes := SM.insert (!xes, f, r); r @@ -657,11 +669,11 @@ fun representative (db : database, e) = val r' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = #Known (unNode r)}) + Known = ref (!(#Known (unNode r)))}) val r'' = ref (Node {Rep = ref NONE, Cons = #Cons (unNode r), - Variety = Recrd (ref (SM.insert (SM.empty, f, r'))), + Variety = Recrd (ref (SM.insert (SM.empty, f, r')), false), Known = #Known (unNode r)}) in #Rep (unNode r) := SOME r''; @@ -680,7 +692,12 @@ fun assert (db, a) = ACond _ => () | AReln x => case x of - (Known, [e]) => markKnown (representative (db, e)) + (Known, [e]) => + ((*Print.prefaces "Before" [("e", p_exp e), + ("db", p_database db)];*) + markKnown (representative (db, e))(*; + Print.prefaces "After" [("e", p_exp e), + ("db", p_database db)]*)) | (PCon0 f, [e]) => let val r = representative (db, e) @@ -744,7 +761,7 @@ fun assert (db, a) = markEq (r1, r2) else raise Contradiction - | (Recrd xes1, Recrd xes2) => + | (Recrd (xes1, _), Recrd (xes2, _)) => let fun unif (xes1, xes2) = SM.appi (fn (x, r1) => @@ -805,7 +822,23 @@ fun check (db, a) = ACond _ => false | AReln x => case x of - (Known, [e]) => !(#Known (unNode (representative (db, e)))) + (Known, [e]) => + let + fun isKnown r = + let + val r = repOf r + in + !(#Known (unNode r)) + orelse case #Variety (unNode r) of + Dt1 (_, r) => isKnown r + | Recrd (xes, true) => List.all isKnown (SM.listItems (!xes)) + | _ => false + end + + val r = representative (db, e) + in + isKnown r + end | (PCon0 f, [e]) => (case #Variety (unNode (representative (db, e))) of Dt0 f' => f' = f @@ -836,7 +869,7 @@ fun builtFrom (db, {Base = bs, Derived = d}) = Dt0 _ => true | Dt1 (_, d) => loop d | Prim _ => true - | Recrd xes => List.all loop (SM.listItems (!xes)) + | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) | VFinish => true | Nothing => false end @@ -874,6 +907,7 @@ fun imply (hyps, goals, outs) = val cc = Cc.database () val () = app (fn a => Cc.assert (cc, a)) hyps in + (*Print.preface ("db", Cc.p_database cc);*) (List.all (fn a => if Cc.check (cc, a) then true @@ -1222,6 +1256,7 @@ val query = log "query" datatype dml = Insert of string * (string * sqexp) list + | Delete of string * sqexp val insert = log "insert" (wrapP (follow (const "INSERT INTO ") @@ -1232,11 +1267,19 @@ val insert = log "insert" (follow (list sqexp) (const ")"))))))) (fn ((), (tab, ((), (fs, ((), (es, ())))))) => - (SOME (Insert (tab, ListPair.zipEq (fs, es)))) + (SOME (tab, ListPair.zipEq (fs, es))) handle ListPair.UnequalLengths => NONE)) +val delete = log "delete" + (wrap (follow (const "DELETE FROM ") + (follow uw_ident + (follow (const " AS T_T WHERE ") + sqexp))) + (fn ((), (tab, ((), es))) => (tab, es))) + val dml = log "dml" - insert + (altL [wrap insert Insert, + wrap delete Delete]) fun removeDups (ls : (string * string) list) = case ls of @@ -1421,13 +1464,13 @@ fun queryProp env rvN rv oe e = end | AllCols oe => let - val oe = Proj (oe, f) + fun oeEq e = Reln (Eq, [oe, Recd [(f, e)]]) in (rvN, - Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), - And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + Or (oeEq (Func (DtCon0 "Basis.bool.False", [])), + And (oeEq (Func (DtCon0 "Basis.bool.True", [])), p)), - Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + oeEq (Func (DtCon0 "Basis.bool.True", [])), []) end) | _ => normal ()) @@ -1483,6 +1526,43 @@ fun insertProp rvN rv e = end end +fun deleteProp rvN rv e = + let + fun default () = (print ("Warning: Information flow checker can't parse SQL query at " + ^ ErrorMsg.spanToString (#2 e) ^ "\n"); + Unknown) + in + case parse query e of + NONE => default () + | SOME r => + let + val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => + let + val (rvN, e) = rv rvN + in + ((v, e), rvN) + end) rvN (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.deleteProp: Bad table variable" + | SOME (_, e) => e + + val p = + foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) + + val expIn = expIn rv [] rvOf + in + And (Reln (Sql "$Old", [rvOf "Old"]), + case #Where r of + NONE => p + | SOME e => + case expIn (e, rvN) of + (inr p', _) => And (p, p') + | _ => p) + end + end + fun evalPat env e (pt, _) = case pt of PWild => (env, True) @@ -1538,7 +1618,7 @@ fun removeRedundant p1 = datatype cflow = Case | Where datatype flow = Data | Control of cflow type check = ErrorMsg.span * exp * prop -type insert = ErrorMsg.span * prop +type dml = ErrorMsg.span * prop structure St :> sig type t @@ -1561,76 +1641,98 @@ structure St :> sig val addSent : t * (check * flow) -> t val setSent : t * (check * flow) list -> t - val inserted : t -> insert list - val addInsert : t * insert -> t + val inserted : t -> dml list + val addInsert : t * dml -> t + + val deleted : t -> dml list + val addDelete : t * dml -> t end = struct type t = {Var : int, Ambient : prop, Path : (check * cflow) list, Sent : (check * flow) list, - Insert : insert list} + Insert : dml list, + Delete : dml list} fun create {Var = v, Ambient = p} = {Var = v, Ambient = p, Path = [], Sent = [], - Insert = []} + Insert = [], + Delete = []} fun curVar (t : t) = #Var t fun nextVar (t : t) = ({Var = #Var t + 1, Ambient = #Ambient t, Path = #Path t, Sent = #Sent t, - Insert = #Insert t}, #Var t) + Insert = #Insert t, + Delete = #Delete t}, #Var t) fun ambient (t : t) = #Ambient t fun setAmbient (t : t, p) = {Var = #Var t, Ambient = p, Path = #Path t, Sent = #Sent t, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun paths (t : t) = #Path t fun addPath (t : t, c) = {Var = #Var t, Ambient = #Ambient t, Path = c :: #Path t, Sent = #Sent t, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun addPaths (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = cs @ #Path t, Sent = #Sent t, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun clearPaths (t : t) = {Var = #Var t, Ambient = #Ambient t, Path = [], Sent = #Sent t, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun setPaths (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = cs, Sent = #Sent t, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun sent (t : t) = #Sent t fun addSent (t : t, c) = {Var = #Var t, Ambient = #Ambient t, Path = #Path t, Sent = c :: #Sent t, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun setSent (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = #Path t, Sent = cs, - Insert = #Insert t} + Insert = #Insert t, + Delete = #Delete t} fun inserted (t : t) = #Insert t fun addInsert (t : t, c) = {Var = #Var t, Ambient = #Ambient t, Path = #Path t, Sent = #Sent t, - Insert = c :: #Insert t} + Insert = c :: #Insert t, + Delete = #Delete t} + +fun deleted (t : t) = #Delete t +fun addDelete (t : t, c) = {Var = #Var t, + Ambient = #Ambient t, + Path = #Path t, + Sent = #Sent t, + Insert = #Insert t, + Delete = c :: #Delete t} end @@ -1870,7 +1972,7 @@ fun evalExp env (e as (_, loc), st) = end val expIn = expIn rv env (fn "New" => Var new - | _ => raise Fail "Iflow.evalExp: Bad field expression in EDml") + | _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE") val (es, st) = ListUtil.foldlMap (fn ((x, e), st) => @@ -1887,6 +1989,30 @@ fun evalExp env (e as (_, loc), st) = in (Recd [], St.addInsert (st, (loc, And (St.ambient st, Reln (Sql "$New", [Recd es]))))) + end + | Delete (tab, e) => + let + val (st, old) = St.nextVar st + + fun rv st = + let + val (st, n) = St.nextVar st + in + (st, Var n) + end + + val expIn = expIn rv env (fn "T" => Var old + | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") + + val (p, st) = case expIn (e, st) of + (inl e, _) => raise Fail "Iflow.evalExp: DELETE with non-boolean" + | (inr p, st) => (p, st) + + val p = And (p, + And (Reln (Sql "$Old", [Var old]), + Reln (Sql tab, [Var old]))) + in + (Recd [], St.addDelete (st, (loc, And (St.ambient st, p)))) end) | ENextval _ => default () @@ -1924,7 +2050,7 @@ fun check file = DExport (_, _, n, _, _, _) => IS.add (exptd, n) | _ => exptd) IS.empty file - fun decl ((d, _), (vals, inserts, client, insert)) = + fun decl ((d, _), (vals, inserts, deletes, client, insert, delete)) = case d of DVal (_, n, _, e, _) => let @@ -1944,7 +2070,7 @@ fun check file = val (_, st) = evalExp env (e, St.create {Var = nv, Ambient = p}) in - (St.sent st @ vals, St.inserted st @ inserts, client, insert) + (St.sent st @ vals, St.inserted st @ inserts, St.deleted st @ deletes, client, insert, delete) end | DPolicy pol => @@ -1956,24 +2082,43 @@ fun check file = let val (_, p, _, _, outs) = queryProp [] 0 rv SomeCol e in - (vals, inserts, (p, outs) :: client, insert) + (vals, inserts, deletes, (p, outs) :: client, insert, delete) end | PolInsert e => let val p = insertProp 0 rv e in - (vals, inserts,client, p :: insert) + (vals, inserts, deletes, client, p :: insert, delete) + end + | PolDelete e => + let + val p = deleteProp 0 rv e + in + (vals, inserts, deletes, client, insert, p :: delete) end end - | _ => (vals, inserts, client, insert) + | _ => (vals, inserts, deletes, client, insert, delete) val () = reset () - val (vals, inserts, client, insert) = foldl decl ([], [], [], []) file + val (vals, inserts, deletes, client, insert, delete) = foldl decl ([], [], [], [], [], []) file val decompH = decomp true (fn (e1, e2) => e1 andalso e2 ()) val decompG = decomp false (fn (e1, e2) => e1 orelse e2 ()) + + fun doDml (cmds, pols) = + app (fn (loc, p) => + if decompH p + (fn hyps => + List.exists (fn p' => + decompG p' + (fn goals => imply (hyps, goals, NONE))) + pols) then + () + else + (ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.preface ("The state satisifies this predicate:", p_prop p))) cmds in app (fn ((loc, e, p), fl) => let @@ -2009,17 +2154,8 @@ fun check file = doAll e end) vals; - app (fn (loc, p) => - if decompH p - (fn hyps => - List.exists (fn p' => - decompG p' - (fn goals => imply (hyps, goals, NONE))) - insert) then - () - else - (ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.preface ("The state satisifies this predicate:", p_prop p))) inserts + doDml (inserts, insert); + doDml (deletes, delete) end val check = fn file => diff --git a/src/mono.sml b/src/mono.sml index 9585fbc1..284d4cd3 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -126,6 +126,7 @@ withtype exp = exp' located datatype policy = PolClient of exp | PolInsert of exp + | PolDelete of exp datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index e98fc924..b1b3a8e0 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -420,6 +420,9 @@ fun p_policy env pol = | PolInsert e => box [string "mayInsert", space, p_exp env e] + | PolDelete e => box [string "mayDelete", + space, + p_exp env e] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 4df9a6a0..f1c2d70f 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -63,6 +63,7 @@ fun shake file = val e1 = case pol of PolClient e1 => e1 | PolInsert e1 => e1 + | PolDelete e1 => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index fa019b00..af01f560 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -547,6 +547,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | PolInsert e => S.map2 (mfe ctx e, PolInsert) + | PolDelete e => + S.map2 (mfe ctx e, + PolDelete) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index 5bdc2aa2..4a11b12d 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3748,6 +3748,8 @@ fun monoDecl (env, fm) (all as (d, loc)) = (e, L'.PolClient) | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayInsert"), _), _), _), _), _), e) => (e, L'.PolInsert) + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) => + (e, L'.PolDelete) | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e -- cgit v1.2.3 From efb882576e0fe75fa25829b417ea909b572634a5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 12:45:15 -0400 Subject: Express all query outputs using record literals --- src/iflow.sml | 41 +++++++++++++++++++++++++++-------------- 1 file changed, 27 insertions(+), 14 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index f275d013..2b67b9ea 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1426,21 +1426,34 @@ fun queryProp env rvN rv oe e = end | AllCols oe => let - val (p', rvN) = - foldl (fn (si, (p, rvN)) => - let - val (p', rvN) = - case si of - SqField (v, f) => (Reln (Eq, [Proj (Proj (oe, v), f), - Proj (rvOf v, f)]), rvN) - | SqExp (e, f) => + val (ts, es, rvN) = + foldl (fn (si, (ts, es, rvN)) => + case si of + SqField (v, f) => + let + val fs = getOpt (SM.find (ts, v), SM.empty) + in + (SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es, rvN) + end + | SqExp (e, f) => + let + val (e, rvN) = case expIn (e, rvN) of - (inr p, rvN) => (Cond (Proj (oe, f), p), rvN) - | (inl e, rvN) => (Reln (Eq, [Proj (oe, f), e]), rvN) - in - (And (p, p'), rvN) - end) - (True, rvN) (#Select r) + (inr _, rvN) => + let + val (rvN, e) = rv rvN + in + (e, rvN) + end + | (inl e, rvN) => (e, rvN) + in + (ts, SM.insert (es, f, e), rvN) + end) + (SM.empty, SM.empty, rvN) (#Select r) + + val p' = Reln (Eq, [oe, Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs))) + (SM.listItemsi ts) + @ SM.listItemsi es)]) in (rvN, And (p, p'), True, []) end -- cgit v1.2.3 From 30b7dba0eaa5a961ded15729ba64bbf67ce8903e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 13:11:25 -0400 Subject: Update policies --- lib/ur/basis.urs | 4 ++ src/iflow.sml | 180 ++++++++++++++++++++++++++++++++++++++++++++++------- src/mono.sml | 1 + src/mono_print.sml | 3 + src/mono_shake.sml | 1 + src/mono_util.sml | 3 + src/monoize.sml | 2 + 7 files changed, 170 insertions(+), 24 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 501284b7..3241cc9a 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -812,5 +812,9 @@ val mayDelete : fs ::: {Type} -> tables ::: {{Type}} -> [[Old] ~ tables] => sql_query [] ([Old = fs] ++ tables) [] -> sql_policy +val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] + => sql_query [] ([Old = fs, New = fs] ++ tables) [] + -> sql_policy + val debug : string -> transaction unit diff --git a/src/iflow.sml b/src/iflow.sml index 2b67b9ea..564cd20b 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -958,7 +958,7 @@ fun imply (hyps, goals, outs) = in reset (); (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), - ("goals", Print.p_list p_atom goals)];*) + ("goals", Print.p_list p_atom goals)];*) gls goals (fn () => false) [] end handle Cc.Contradiction => true @@ -1257,6 +1257,7 @@ val query = log "query" datatype dml = Insert of string * (string * sqexp) list | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp val insert = log "insert" (wrapP (follow (const "INSERT INTO ") @@ -1277,9 +1278,24 @@ val delete = log "delete" sqexp))) (fn ((), (tab, ((), es))) => (tab, es))) +val setting = log "setting" + (wrap (follow uw_ident (follow (const " = ") sqexp)) + (fn (f, ((), e)) => (f, e))) + +val update = log "update" + (wrap (follow (const "UPDATE ") + (follow uw_ident + (follow (const " AS T_T SET ") + (follow (list setting) + (follow (ws (const "WHERE ")) + sqexp))))) + (fn ((), (tab, ((), (fs, ((), e))))) => + (tab, fs, e))) + val dml = log "dml" (altL [wrap insert Insert, - wrap delete Delete]) + wrap delete Delete, + wrap update Update]) fun removeDups (ls : (string * string) list) = case ls of @@ -1576,6 +1592,51 @@ fun deleteProp rvN rv e = end end +fun updateProp rvN rv e = + let + fun default () = (print ("Warning: Information flow checker can't parse SQL query at " + ^ ErrorMsg.spanToString (#2 e) ^ "\n"); + Unknown) + in + case parse query e of + NONE => default () + | SOME r => + let + val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => + let + val (rvN, e) = rv rvN + in + ((v, e), rvN) + end) rvN (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.insertProp: Bad table variable" + | SOME (_, e) => e + + val p = + foldl (fn ((t, v), p) => + let + val t = + case v of + "New" => "$New" + | _ => t + in + And (p, Reln (Sql t, [rvOf v])) + end) True (#From r) + + val expIn = expIn rv [] rvOf + in + And (Reln (Sql "$Old", [rvOf "Old"]), + case #Where r of + NONE => p + | SOME e => + case expIn (e, rvN) of + (inr p', _) => And (p, p') + | _ => p) + end + end + fun evalPat env e (pt, _) = case pt of PWild => (env, True) @@ -1659,6 +1720,9 @@ structure St :> sig val deleted : t -> dml list val addDelete : t * dml -> t + + val updated : t -> dml list + val addUpdate : t * dml -> t end = struct type t = {Var : int, @@ -1666,14 +1730,16 @@ type t = {Var : int, Path : (check * cflow) list, Sent : (check * flow) list, Insert : dml list, - Delete : dml list} + Delete : dml list, + Update : dml list} fun create {Var = v, Ambient = p} = {Var = v, Ambient = p, Path = [], Sent = [], Insert = [], - Delete = []} + Delete = [], + Update = []} fun curVar (t : t) = #Var t fun nextVar (t : t) = ({Var = #Var t + 1, @@ -1681,7 +1747,8 @@ fun nextVar (t : t) = ({Var = #Var t + 1, Path = #Path t, Sent = #Sent t, Insert = #Insert t, - Delete = #Delete t}, #Var t) + Delete = #Delete t, + Update = #Update t}, #Var t) fun ambient (t : t) = #Ambient t fun setAmbient (t : t, p) = {Var = #Var t, @@ -1689,7 +1756,8 @@ fun setAmbient (t : t, p) = {Var = #Var t, Path = #Path t, Sent = #Sent t, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun paths (t : t) = #Path t fun addPath (t : t, c) = {Var = #Var t, @@ -1697,25 +1765,29 @@ fun addPath (t : t, c) = {Var = #Var t, Path = c :: #Path t, Sent = #Sent t, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun addPaths (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = cs @ #Path t, Sent = #Sent t, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun clearPaths (t : t) = {Var = #Var t, Ambient = #Ambient t, Path = [], Sent = #Sent t, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun setPaths (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = cs, Sent = #Sent t, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun sent (t : t) = #Sent t fun addSent (t : t, c) = {Var = #Var t, @@ -1723,13 +1795,15 @@ fun addSent (t : t, c) = {Var = #Var t, Path = #Path t, Sent = c :: #Sent t, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun setSent (t : t, cs) = {Var = #Var t, Ambient = #Ambient t, Path = #Path t, Sent = cs, Insert = #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun inserted (t : t) = #Insert t fun addInsert (t : t, c) = {Var = #Var t, @@ -1737,7 +1811,8 @@ fun addInsert (t : t, c) = {Var = #Var t, Path = #Path t, Sent = #Sent t, Insert = c :: #Insert t, - Delete = #Delete t} + Delete = #Delete t, + Update = #Update t} fun deleted (t : t) = #Delete t fun addDelete (t : t, c) = {Var = #Var t, @@ -1745,7 +1820,17 @@ fun addDelete (t : t, c) = {Var = #Var t, Path = #Path t, Sent = #Sent t, Insert = #Insert t, - Delete = c :: #Delete t} + Delete = c :: #Delete t, + Update = #Update t} + +fun updated (t : t) = #Update t +fun addUpdate (t : t, c) = {Var = #Var t, + Ambient = #Ambient t, + Path = #Path t, + Sent = #Sent t, + Insert = #Insert t, + Delete = #Delete t, + Update = c :: #Update t} end @@ -1984,8 +2069,7 @@ fun evalExp env (e as (_, loc), st) = (st, Var n) end - val expIn = expIn rv env (fn "New" => Var new - | _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE") + val expIn = expIn rv env (fn _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT") val (es, st) = ListUtil.foldlMap (fn ((x, e), st) => @@ -2026,6 +2110,45 @@ fun evalExp env (e as (_, loc), st) = Reln (Sql tab, [Var old]))) in (Recd [], St.addDelete (st, (loc, And (St.ambient st, p)))) + end + | Update (tab, fs, e) => + let + val (st, new) = St.nextVar st + val (st, old) = St.nextVar st + + fun rv st = + let + val (st, n) = St.nextVar st + in + (st, Var n) + end + + val expIn = expIn rv env (fn "T" => Var old + | _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE") + + val (fs, st) = ListUtil.foldlMap + (fn ((x, e), st) => + let + val (e, st) = case expIn (e, st) of + (inl e, st) => (e, st) + | (inr _, _) => raise Fail + ("Iflow.evalExp: Selecting " + ^ "boolean expression") + in + ((x, e), st) + end) + st fs + + val (p, st) = case expIn (e, st) of + (inl e, _) => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + | (inr p, st) => (p, st) + + val p = And (p, + And (Reln (Sql "$New", [Recd fs]), + And (Reln (Sql "$Old", [Var old]), + Reln (Sql tab, [Var old])))) + in + (Recd [], St.addUpdate (st, (loc, And (St.ambient st, p)))) end) | ENextval _ => default () @@ -2063,7 +2186,7 @@ fun check file = DExport (_, _, n, _, _, _) => IS.add (exptd, n) | _ => exptd) IS.empty file - fun decl ((d, _), (vals, inserts, deletes, client, insert, delete)) = + fun decl ((d, _), (vals, inserts, deletes, updates, client, insert, delete, update)) = case d of DVal (_, n, _, e, _) => let @@ -2083,7 +2206,8 @@ fun check file = val (_, st) = evalExp env (e, St.create {Var = nv, Ambient = p}) in - (St.sent st @ vals, St.inserted st @ inserts, St.deleted st @ deletes, client, insert, delete) + (St.sent st @ vals, St.inserted st @ inserts, St.deleted st @ deletes, St.updated st @ updates, + client, insert, delete, update) end | DPolicy pol => @@ -2095,27 +2219,34 @@ fun check file = let val (_, p, _, _, outs) = queryProp [] 0 rv SomeCol e in - (vals, inserts, deletes, (p, outs) :: client, insert, delete) + (vals, inserts, deletes, updates, (p, outs) :: client, insert, delete, update) end | PolInsert e => let val p = insertProp 0 rv e in - (vals, inserts, deletes, client, p :: insert, delete) + (vals, inserts, deletes, updates, client, p :: insert, delete, update) end | PolDelete e => let val p = deleteProp 0 rv e in - (vals, inserts, deletes, client, insert, p :: delete) + (vals, inserts, deletes, updates, client, insert, p :: delete, update) + end + | PolUpdate e => + let + val p = updateProp 0 rv e + in + (vals, inserts, deletes, updates, client, insert, delete, p :: update) end end - | _ => (vals, inserts, deletes, client, insert, delete) + | _ => (vals, inserts, deletes, updates, client, insert, delete, update) val () = reset () - val (vals, inserts, deletes, client, insert, delete) = foldl decl ([], [], [], [], [], []) file + val (vals, inserts, deletes, updates, client, insert, delete, update) = + foldl decl ([], [], [], [], [], [], [], []) file val decompH = decomp true (fn (e1, e2) => e1 andalso e2 ()) val decompG = decomp false (fn (e1, e2) => e1 orelse e2 ()) @@ -2168,7 +2299,8 @@ fun check file = end) vals; doDml (inserts, insert); - doDml (deletes, delete) + doDml (deletes, delete); + doDml (updates, update) end val check = fn file => diff --git a/src/mono.sml b/src/mono.sml index 284d4cd3..79cde237 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -127,6 +127,7 @@ datatype policy = PolClient of exp | PolInsert of exp | PolDelete of exp + | PolUpdate of exp datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index b1b3a8e0..b8016ff8 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -423,6 +423,9 @@ fun p_policy env pol = | PolDelete e => box [string "mayDelete", space, p_exp env e] + | PolUpdate e => box [string "mayUpdate", + space, + p_exp env e] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index f1c2d70f..6b248636 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -64,6 +64,7 @@ fun shake file = PolClient e1 => e1 | PolInsert e1 => e1 | PolDelete e1 => e1 + | PolUpdate e1 => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index af01f560..085b68f8 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -550,6 +550,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | PolDelete e => S.map2 (mfe ctx e, PolDelete) + | PolUpdate e => + S.map2 (mfe ctx e, + PolUpdate) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index 4a11b12d..601b690f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3750,6 +3750,8 @@ fun monoDecl (env, fm) (all as (d, loc)) = (e, L'.PolInsert) | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayDelete"), _), _), _), _), _), e) => (e, L'.PolDelete) + | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) => + (e, L'.PolUpdate) | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e -- cgit v1.2.3 From 750ee01b9760664192e6ff63d221033b141c3d70 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 13:18:32 -0400 Subject: Complete update records with fields that are not being set --- src/iflow.sml | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 564cd20b..f9b7cf08 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1834,6 +1834,8 @@ fun addUpdate (t : t, c) = {Var = #Var t, end +val tabs = ref (SM.empty : string list SM.map) + fun evalExp env (e as (_, loc), st) = let fun default () = @@ -2139,6 +2141,16 @@ fun evalExp env (e as (_, loc), st) = end) st fs + val fs' = case SM.find (!tabs, "uw_" ^ tab) of + NONE => raise Fail "Iflow.evalExp: Updating unknown table" + | SOME fs' => fs' + + val fs = foldl (fn (f, fs) => + if List.exists (fn (f', _) => f' = f) fs then + fs + else + (f, Proj (Var old, f)) :: fs) fs fs' + val (p, st) = case expIn (e, st) of (inl e, _) => raise Fail "Iflow.evalExp: UPDATE with non-boolean" | (inr p, st) => (p, st) @@ -2188,7 +2200,10 @@ fun check file = fun decl ((d, _), (vals, inserts, deletes, updates, client, insert, delete, update)) = case d of - DVal (_, n, _, e, _) => + DTable (tab, fs, _, _) => + (tabs := SM.insert (!tabs, tab, map #1 fs); + (vals, inserts, deletes, updates, client, insert, delete, update)) + | DVal (_, n, _, e, _) => let val isExptd = IS.member (exptd, n) @@ -2248,6 +2263,7 @@ fun check file = val (vals, inserts, deletes, updates, client, insert, delete, update) = foldl decl ([], [], [], [], [], [], [], []) file + val decompH = decomp true (fn (e1, e2) => e1 andalso e2 ()) val decompG = decomp false (fn (e1, e2) => e1 orelse e2 ()) -- cgit v1.2.3 From bf4cca51190145780073787e5aaca34bbfa3299f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 15:05:51 -0400 Subject: Use functional dependency information --- src/iflow.sml | 164 ++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 115 insertions(+), 49 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index f9b7cf08..aea79bbd 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -392,6 +392,8 @@ structure Cc :> sig val p_database : database Print.printer val builtFrom : database * {Base : exp list, Derived : exp} -> bool + + val p_repOf : database -> exp Print.printer end = struct exception Contradiction @@ -412,16 +414,10 @@ datatype node = Node of {Rep : node ref option ref, | Dt1 of string * node ref | Prim of Prim.t | Recrd of node ref SM.map ref * bool - | VFinish | Nothing type representative = node ref -val finish = ref (Node {Rep = ref NONE, - Cons = ref SM.empty, - Variety = VFinish, - Known = ref true}) - type database = {Vars : representative IM.map ref, Consts : representative CM.map ref, Con0s : representative SM.map ref, @@ -467,8 +463,7 @@ fun p_rep n = box [space, string "(complete)"] else - box []] - | VFinish => string "FINISH"] + box []]] fun p_database (db : database) = box [string "Vars:", @@ -600,7 +595,6 @@ fun representative (db : database, e) = #Rep (unNode r) := SOME r''; r' end - | VFinish => r | _ => raise Contradiction end | Func (UnCon _, _) => raise Fail "Iflow.rep: UnCon" @@ -679,14 +673,15 @@ fun representative (db : database, e) = #Rep (unNode r) := SOME r''; r' end - | VFinish => r | _ => raise Contradiction end - | Finish => finish + | Finish => raise Contradiction in rep e end +fun p_repOf db e = p_rep (representative (db, e)) + fun assert (db, a) = case a of ACond _ => () @@ -746,36 +741,40 @@ fun assert (db, a) = | (Eq, [e1, e2]) => let fun markEq (r1, r2) = - if r1 = r2 then - () - else case (#Variety (unNode r1), #Variety (unNode r2)) of - (Prim p1, Prim p2) => if Prim.equal (p1, p2) then - () - else - raise Contradiction - | (Dt0 f1, Dt0 f2) => if f1 = f2 then - () - else - raise Contradiction - | (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then - markEq (r1, r2) - else - raise Contradiction - | (Recrd (xes1, _), Recrd (xes2, _)) => - let - fun unif (xes1, xes2) = - SM.appi (fn (x, r1) => - case SM.find (xes2, x) of - NONE => () - | SOME r2 => markEq (r1, r2)) xes1 - in - unif (!xes1, !xes2); - unif (!xes2, !xes1) - end - | (VFinish, VFinish) => () - | (Nothing, _) => mergeNodes (r1, r2) - | (_, Nothing) => mergeNodes (r2, r1) - | _ => raise Contradiction + let + val r1 = repOf r1 + val r2 = repOf r2 + in + if r1 = r2 then + () + else case (#Variety (unNode r1), #Variety (unNode r2)) of + (Prim p1, Prim p2) => if Prim.equal (p1, p2) then + () + else + raise Contradiction + | (Dt0 f1, Dt0 f2) => if f1 = f2 then + () + else + raise Contradiction + | (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then + markEq (r1, r2) + else + raise Contradiction + | (Recrd (xes1, _), Recrd (xes2, _)) => + let + fun unif (xes1, xes2) = + SM.appi (fn (x, r1) => + case SM.find (!xes2, x) of + NONE => xes2 := SM.insert (!xes2, x, r1) + | SOME r2 => markEq (r1, r2)) (!xes1) + in + unif (xes1, xes2); + unif (xes2, xes1) + end + | (Nothing, _) => mergeNodes (r1, r2) + | (_, Nothing) => mergeNodes (r2, r1) + | _ => raise Contradiction + end and mergeNodes (r1, r2) = (#Rep (unNode r1) := SOME r2; @@ -870,7 +869,6 @@ fun builtFrom (db, {Base = bs, Derived = d}) = | Dt1 (_, d) => loop d | Prim _ => true | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) - | VFinish => true | Nothing => false end in @@ -898,6 +896,8 @@ fun decomp fals or = decomp end +val tabs = ref (SM.empty : (string list * string list list) SM.map) + fun imply (hyps, goals, outs) = let fun gls goals onFail acc = @@ -906,7 +906,59 @@ fun imply (hyps, goals, outs) = (let val cc = Cc.database () val () = app (fn a => Cc.assert (cc, a)) hyps + + (* Take advantage of table key information *) + fun findKeys hyps = + case hyps of + [] => () + | AReln (Sql tab, [r1]) :: hyps => + (case SM.find (!tabs, tab) of + NONE => findKeys hyps + | SOME (_, []) => findKeys hyps + | SOME (_, ks) => + let + fun finder hyps = + case hyps of + [] => () + | AReln (Sql tab', [r2]) :: hyps => + (if tab' = tab andalso + List.exists (List.all (fn f => + let + val r = + Cc.check (cc, + AReln (Eq, [Proj (r1, f), + Proj (r2, f)])) + in + (*Print.prefaces "Fs" + [("tab", + Print.PD.string tab), + ("r1", + p_exp (Proj (r1, f))), + ("r2", + p_exp (Proj (r2, f))), + ("r", + Print.PD.string + (Bool.toString r))];*) + r + end)) ks then + ((*Print.prefaces "Key match" [("tab", Print.PD.string tab), + ("r1", p_exp r1), + ("r2", p_exp r2), + ("rp1", Cc.p_repOf cc r1), + ("rp2", Cc.p_repOf cc r2)];*) + Cc.assert (cc, AReln (Eq, [r1, r2]))) + else + (); + finder hyps) + | _ :: hyps => finder hyps + in + finder hyps; + findKeys hyps + end) + | _ :: hyps => findKeys hyps in + findKeys hyps; + (*Print.preface ("db", Cc.p_database cc);*) (List.all (fn a => if Cc.check (cc, a) then @@ -1834,8 +1886,6 @@ fun addUpdate (t : t, c) = {Var = #Var t, end -val tabs = ref (SM.empty : string list SM.map) - fun evalExp env (e as (_, loc), st) = let fun default () = @@ -2141,9 +2191,9 @@ fun evalExp env (e as (_, loc), st) = end) st fs - val fs' = case SM.find (!tabs, "uw_" ^ tab) of + val fs' = case SM.find (!tabs, tab) of NONE => raise Fail "Iflow.evalExp: Updating unknown table" - | SOME fs' => fs' + | SOME (fs', _) => fs' val fs = foldl (fn (f, fs) => if List.exists (fn (f', _) => f' = f) fs then @@ -2200,9 +2250,25 @@ fun check file = fun decl ((d, _), (vals, inserts, deletes, updates, client, insert, delete, update)) = case d of - DTable (tab, fs, _, _) => - (tabs := SM.insert (!tabs, tab, map #1 fs); - (vals, inserts, deletes, updates, client, insert, delete, update)) + DTable (tab, fs, pk, _) => + let + val ks = + case #1 pk of + EPrim (Prim.String s) => + (case String.tokens (fn ch => ch = #"," orelse ch = #" ") s of + [] => [] + | pk => [pk]) + | _ => [] + in + if size tab >= 3 then + (tabs := SM.insert (!tabs, String.extract (tab, 3, NONE), + (map #1 fs, + map (map (fn s => str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE))) ks)); + (vals, inserts, deletes, updates, client, insert, delete, update)) + else + raise Fail "Table name does not begin with uw_" + end | DVal (_, n, _, e, _) => let val isExptd = IS.member (exptd, n) -- cgit v1.2.3 From 12e71069cc10ef1808a7abbd65411f0c07b5f8d1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 16:06:16 -0400 Subject: Iflow working with a UNION --- src/iflow.sml | 294 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 165 insertions(+), 129 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index aea79bbd..dffb0875 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -969,7 +969,7 @@ fun imply (hyps, goals, outs) = ("hyps", Print.p_list p_atom hyps), ("db", Cc.p_database cc)];*) false)) acc - (*andalso (Print.preface ("Finding", Cc.p_database cc); true)*) + andalso ((*Print.preface ("Finding", Cc.p_database cc);*) true) andalso (case outs of NONE => true | SOME outs => Cc.builtFrom (cc, {Derived = Var 0, @@ -1129,9 +1129,10 @@ fun ws p = wrap (follow (skip (fn ch => ch = #" ")) fun log name p chs = (if !debug then - case chs of - String s :: _ => print (name ^ ": " ^ s ^ "\n") - | _ => print (name ^ ": blocked!\n") + (print (name ^ ": "); + app (fn String s => print s + | _ => print "???") chs; + print "\n") else (); p chs) @@ -1302,10 +1303,27 @@ val from = log "from" val wher = wrap (follow (ws (const "WHERE ")) sqexp) (fn ((), ls) => ls) -val query = log "query" +type query1 = {Select : sitem list, + From : (string * string) list, + Where : sqexp option} + +val query1 = log "query1" (wrap (follow (follow select from) (opt wher)) (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) +datatype query = + Query1 of query1 + | Union of query * query + +fun query chs = log "query" + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + chs + datatype dml = Insert of string * (string * sqexp) list | Delete of string * sqexp @@ -1431,135 +1449,154 @@ fun queryProp env rvN rv oe e = let fun default () = (print ("Warning: Information flow checker can't parse SQL query at " ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - (rvN, Unknown, Unknown, [], [])) + (rvN, Unknown, [], [])) in case parse query e of NONE => default () - | SOME r => + | SOME q => let - val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => - let - val (rvN, e) = rv rvN - in - ((v, e), rvN) - end) rvN (#From r) - - fun rvOf v = - case List.find (fn (v', _) => v' = v) rvs of - NONE => raise Fail "Iflow.queryProp: Bad table variable" - | SOME (_, e) => e - - fun usedFields e = - case e of - SqConst _ => [] - | Field (v, f) => [(v, f)] - | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) - | SqKnown _ => [] - | Inj _ => [] - | SqFunc (_, e) => usedFields e - | Count => [] - - val p = - foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) - - val expIn = expIn rv env rvOf + fun doQuery (q, rvN) = + case q of + Query1 r => + let + val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => + let + val (rvN, e) = rv rvN + in + ((v, e), rvN) + end) rvN (#From r) + + fun rvOf v = + case List.find (fn (v', _) => v' = v) rvs of + NONE => raise Fail "Iflow.queryProp: Bad table variable" + | SOME (_, e) => e + + fun usedFields e = + case e of + SqConst _ => [] + | Field (v, f) => [(v, f)] + | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) + | SqKnown _ => [] + | Inj _ => [] + | SqFunc (_, e) => usedFields e + | Count => [] + + val p = + foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) + + val expIn = expIn rv env rvOf + + val (p, rvN) = case #Where r of + NONE => (p, rvN) + | SOME e => + case expIn (e, rvN) of + (inr p', rvN) => (And (p, p'), rvN) + | _ => (p, rvN) + + fun normal () = + case oe of + SomeCol => + let + val (sis, rvN) = + ListUtil.foldlMap + (fn (si, rvN) => + case si of + SqField (v, f) => (Proj (rvOf v, f), rvN) + | SqExp (e, f) => + case expIn (e, rvN) of + (inr _, _) => + let + val (rvN, e) = rv rvN + in + (e, rvN) + end + | (inl e, rvN) => (e, rvN)) rvN (#Select r) + in + (rvN, p, True, sis) + end + | AllCols oe => + let + val (ts, es, rvN) = + foldl (fn (si, (ts, es, rvN)) => + case si of + SqField (v, f) => + let + val fs = getOpt (SM.find (ts, v), SM.empty) + in + (SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es, rvN) + end + | SqExp (e, f) => + let + val (e, rvN) = + case expIn (e, rvN) of + (inr _, rvN) => + let + val (rvN, e) = rv rvN + in + (e, rvN) + end + | (inl e, rvN) => (e, rvN) + in + (ts, SM.insert (es, f, e), rvN) + end) + (SM.empty, SM.empty, rvN) (#Select r) - val (p, rvN) = case #Where r of - NONE => (p, rvN) - | SOME e => - case expIn (e, rvN) of - (inr p', rvN) => (And (p, p'), rvN) - | _ => (p, rvN) + val p' = Reln (Eq, [oe, Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs))) + (SM.listItemsi ts) + @ SM.listItemsi es)]) + in + (rvN, And (p, p'), True, []) + end - fun normal () = - case oe of - SomeCol => - let - val (sis, rvN) = - ListUtil.foldlMap - (fn (si, rvN) => - case si of - SqField (v, f) => (Proj (rvOf v, f), rvN) - | SqExp (e, f) => - case expIn (e, rvN) of - (inr _, _) => - let - val (rvN, e) = rv rvN - in - (e, rvN) - end - | (inl e, rvN) => (e, rvN)) rvN (#Select r) - in - (rvN, p, True, sis) - end - | AllCols oe => - let - val (ts, es, rvN) = - foldl (fn (si, (ts, es, rvN)) => - case si of - SqField (v, f) => + val (rvN, p, wp, outs) = + case #Select r of + [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of + Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + (case oe of + SomeCol => let - val fs = getOpt (SM.find (ts, v), SM.empty) + val (rvN, oe) = rv rvN in - (SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es, rvN) + (rvN, + Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), + And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + p)), + Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), + [oe]) end - | SqExp (e, f) => + | AllCols oe => let - val (e, rvN) = - case expIn (e, rvN) of - (inr _, rvN) => - let - val (rvN, e) = rv rvN - in - (e, rvN) - end - | (inl e, rvN) => (e, rvN) + fun oeEq e = Reln (Eq, [oe, Recd [(f, e)]]) in - (ts, SM.insert (es, f, e), rvN) + (rvN, + Or (oeEq (Func (DtCon0 "Basis.bool.False", [])), + And (oeEq (Func (DtCon0 "Basis.bool.True", [])), + p)), + oeEq (Func (DtCon0 "Basis.bool.True", [])), + []) end) - (SM.empty, SM.empty, rvN) (#Select r) - - val p' = Reln (Eq, [oe, Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs))) - (SM.listItemsi ts) - @ SM.listItemsi es)]) + | _ => normal ()) + | _ => normal () in - (rvN, And (p, p'), True, []) + (rvN, p, map (fn x => (wp, x)) + (case #Where r of + NONE => [] + | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)), outs) + end + | Union (q1, q2) => + let + val (rvN, p1, used1, outs1) = doQuery (q1, rvN) + val (rvN, p2, used2, outs2) = doQuery (q2, rvN) + in + case (outs1, outs2) of + ([], []) => (rvN, Or (p1, p2), + map (fn (p, e) => (And (p1, p), e)) used1 + @ map (fn (p, e) => (And (p2, p), e)) used2, []) + | _ => default () end - - val (rvN, p, wp, outs) = - case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => - (case oe of - SomeCol => - let - val (rvN, oe) = rv rvN - in - (rvN, - Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), - And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), - p)), - Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), - [oe]) - end - | AllCols oe => - let - fun oeEq e = Reln (Eq, [oe, Recd [(f, e)]]) - in - (rvN, - Or (oeEq (Func (DtCon0 "Basis.bool.False", [])), - And (oeEq (Func (DtCon0 "Basis.bool.True", [])), - p)), - oeEq (Func (DtCon0 "Basis.bool.True", [])), - []) - end) - | _ => normal ()) - | _ => normal () in - (rvN, p, wp, case #Where r of - NONE => [] - | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e), outs) + doQuery (q, rvN) end end @@ -1570,8 +1607,7 @@ fun insertProp rvN rv e = Unknown) in case parse query e of - NONE => default () - | SOME r => + SOME (Query1 r) => let val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => let @@ -1605,6 +1641,7 @@ fun insertProp rvN rv e = (inr p', _) => And (p, p') | _ => p end + | _ => default () end fun deleteProp rvN rv e = @@ -1614,8 +1651,7 @@ fun deleteProp rvN rv e = Unknown) in case parse query e of - NONE => default () - | SOME r => + SOME (Query1 r) => let val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => let @@ -1642,6 +1678,7 @@ fun deleteProp rvN rv e = (inr p', _) => And (p, p') | _ => p) end + | _ => default () end fun updateProp rvN rv e = @@ -1651,8 +1688,7 @@ fun updateProp rvN rv e = Unknown) in case parse query e of - NONE => default () - | SOME r => + SOME (Query1 r) => let val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => let @@ -1687,6 +1723,7 @@ fun updateProp rvN rv e = (inr p', _) => And (p, p') | _ => p) end + | _ => default () end fun evalPat env e (pt, _) = @@ -2067,7 +2104,7 @@ fun evalExp env (e as (_, loc), st) = val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val (st', qp, qwp, used, _) = + val (st', qp, used, _) = queryProp env st' (fn st' => let @@ -2098,8 +2135,7 @@ fun evalExp env (e as (_, loc), st) = val sent = map (fn ((loc, e, p), fl) => ((loc, e, And (qp, p)), fl)) (St.sent st') - val p' = And (p', qwp) - val paths = map (fn e => ((loc, e, p'), Where)) used + val paths = map (fn (p'', e) => ((loc, e, And (p', p'')), Where)) used in (res, St.addPaths (St.setSent (st, sent), paths)) end @@ -2298,7 +2334,7 @@ fun check file = case pol of PolClient e => let - val (_, p, _, _, outs) = queryProp [] 0 rv SomeCol e + val (_, p, _, outs) = queryProp [] 0 rv SomeCol e in (vals, inserts, deletes, updates, (p, outs) :: client, insert, delete, update) end -- cgit v1.2.3 From 0a67ec0c9536f5448682a491b6807e0f8d073171 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 16:46:38 -0400 Subject: Using multiple policies to check a written value --- src/iflow.sml | 110 +++++++++++++++++++++++++++++++++++++++++++++++++++----- tests/policy.ur | 11 +++++- 2 files changed, 112 insertions(+), 9 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index dffb0875..3ff3d100 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -310,6 +310,66 @@ fun varInP lv = lvi end +fun bumpLvars by = + let + fun lvi e = + case e of + Const _ => e + | Var _ => e + | Lvar lv => Lvar (lv + by) + | Func (f, es) => Func (f, map lvi es) + | Recd xes => Recd (map (fn (x, e) => (x, lvi e)) xes) + | Proj (e, f) => Proj (lvi e, f) + | Finish => e + in + lvi + end + +fun bumpLvarsP by = + let + fun lvi p = + case p of + True => p + | False => p + | Unknown => p + | And (p1, p2) => And (lvi p1, lvi p2) + | Or (p1, p2) => And (lvi p1, lvi p2) + | Reln (r, es) => Reln (r, map (bumpLvars by) es) + | Cond (e, p) => Cond (bumpLvars by e, lvi p) + in + lvi + end + +fun maxLvar e = + let + fun lvi e = + case e of + Const _ => 0 + | Var _ => 0 + | Lvar lv => lv + | Func (f, es) => foldl Int.max 0 (map lvi es) + | Recd xes => foldl Int.max 0 (map (lvi o #2) xes) + | Proj (e, f) => lvi e + | Finish => 0 + in + lvi e + end + +fun maxLvarP p = + let + fun lvi p = + case p of + True => 0 + | False => 0 + | Unknown => 0 + | And (p1, p2) => Int.max (lvi p1, lvi p2) + | Or (p1, p2) => Int.max (lvi p1, lvi p2) + | Reln (r, es) => foldl Int.max 0 (map maxLvar es) + | Cond (e, p) => Int.max (maxLvar e, lvi p) + in + lvi p + end + fun eq' (e1, e2) = case (e1, e2) of (Const p1, Const p2) => Prim.equal (p1, p2) @@ -2390,16 +2450,50 @@ fun check file = in if decompH p (fn hyps => - (fl <> Control Where - andalso imply (hyps, [AReln (Known, [Var 0])], SOME [Var 0])) - orelse List.exists (fn (p', outs) => - decompG p' - (fn goals => imply (hyps, goals, SOME outs))) - client) then + let + val avail = foldl (fn (AReln (Sql tab, _), avail) => SS.add (avail, tab) + | (_, avail) => avail) SS.empty hyps + + fun tryCombos (maxLv, pols, g, outs) = + case pols of + [] => + decompG g + (fn goals => imply (hyps, goals, SOME outs)) + | (g1, outs1) :: pols => + let + val g1 = bumpLvarsP (maxLv + 1) g1 + val outs1 = map (bumpLvars (maxLv + 1)) outs1 + fun skip () = tryCombos (maxLv, pols, g, outs) + in + if decompG g1 + (List.all (fn AReln (Sql tab, _) => + SS.member (avail, tab) + | _ => true)) then + skip () + orelse tryCombos (Int.max (maxLv, + maxLvarP g1), + pols, + And (g1, g), + outs1 @ outs) + else + skip () + end + in + (fl <> Control Where + andalso imply (hyps, [AReln (Known, [Var 0])], SOME [Var 0])) + orelse List.exists (fn (p', outs) => + decompG p' + (fn goals => imply (hyps, goals, SOME outs))) + client + orelse tryCombos (0, client, True, []) + orelse (reset (); + Print.preface ("Untenable hypotheses", + Print.p_list p_atom hyps); + false) + end) then () else - (ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.preface ("The state satisifies this predicate:", p_prop p)) + ErrorMsg.errorAt loc "The information flow policy may be violated here." end fun doAll e = diff --git a/tests/policy.ur b/tests/policy.ur index 6d4e341e..69455cd7 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -9,7 +9,9 @@ table order : { Id : order, Fruit : fruit, Qty : int, Code : int } CONSTRAINT Fruit FOREIGN KEY Fruit REFERENCES fruit(Id) (* Everyone may knows IDs and names. *) -policy sendClient (SELECT fruit.Id, fruit.Nam +policy sendClient (SELECT fruit.Id + FROM fruit) +policy sendClient (SELECT fruit.Nam FROM fruit) (* The weight is sensitive information; you must know the secret. *) @@ -50,11 +52,18 @@ fun main () = AND order.Qty = 13) (fn x =>
  • {[x.Fruit.Nam]}: {[x.Order.Qty]}
    • ); + ro <- oneOrNoRows (SELECT fruit.Id, fruit.Nam + FROM fruit); + return
      {x1}
      {x2}
    + {case ro of + None => None + | Some _ => Some} + Fruit name:
    Secret:
    -- cgit v1.2.3 From afc53b9b899188bc63c0d812b0104c4b04c91f0d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 11 Apr 2010 17:55:37 -0400 Subject: sendOwnIds policies --- lib/ur/basis.urs | 2 ++ src/iflow.sml | 49 +++++++++++++++++++++++++++++++++++++++---------- src/mono.sml | 1 + src/mono_print.sml | 3 +++ src/mono_shake.sml | 1 + src/mono_util.sml | 3 +++ src/monoize.sml | 2 ++ 7 files changed, 51 insertions(+), 10 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 3241cc9a..5a30f3f4 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -804,6 +804,8 @@ val sendClient : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => sql_query [] tables exps -> sql_policy +val sendOwnIds : sql_sequence -> sql_policy + val mayInsert : fs ::: {Type} -> tables ::: {{Type}} -> [[New] ~ tables] => sql_query [] ([New = fs] ++ tables) [] -> sql_policy diff --git a/src/iflow.sml b/src/iflow.sml index 3ff3d100..77f25a91 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -482,7 +482,7 @@ type database = {Vars : representative IM.map ref, Consts : representative CM.map ref, Con0s : representative SM.map ref, Records : (representative SM.map * representative) list ref, - Funcs : ((string * representative list) * representative) list ref } + Funcs : ((string * representative list) * representative) list ref} fun database () = {Vars = ref IM.empty, Consts = ref CM.empty, @@ -847,6 +847,7 @@ fun assert (db, a) = else (); #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); + compactFuncs ()) and compactFuncs () = @@ -1450,9 +1451,9 @@ fun expIn rv env rvOf = let fun default () = let - val (rvN, e) = rv rvN + val (rvN, e') = rv rvN in - (inl e, rvN) + (inl e', rvN) end in case e of @@ -1686,7 +1687,7 @@ fun insertProp rvN rv e = let val t = case v of - "New" => "$New" + "New" => t ^ "$New" | _ => t in And (p, Reln (Sql t, [rvOf v])) @@ -1767,7 +1768,7 @@ fun updateProp rvN rv e = let val t = case v of - "New" => "$New" + "New" => t ^ "$New" | _ => t in And (p, Reln (Sql t, [rvOf v])) @@ -1989,6 +1990,8 @@ fun evalExp env (e as (_, loc), st) = let val (st, nv) = St.nextVar st in + (*Print.prefaces "default" [("e", MonoPrint.p_exp MonoEnv.empty e), + ("nv", p_exp (Var nv))];*) (Var nv, st) end @@ -2233,7 +2236,7 @@ fun evalExp env (e as (_, loc), st) = st es in (Recd [], St.addInsert (st, (loc, And (St.ambient st, - Reln (Sql "$New", [Recd es]))))) + Reln (Sql (tab ^ "$New"), [Recd es]))))) end | Delete (tab, e) => let @@ -2302,13 +2305,19 @@ fun evalExp env (e as (_, loc), st) = | (inr p, st) => (p, st) val p = And (p, - And (Reln (Sql "$New", [Recd fs]), + And (Reln (Sql (tab ^ "$New"), [Recd fs]), And (Reln (Sql "$Old", [Var old]), Reln (Sql tab, [Var old])))) in (Recd [], St.addUpdate (st, (loc, And (St.ambient st, p)))) end) + | ENextval (EPrim (Prim.String seq), _) => + let + val (st, nv) = St.nextVar st + in + (Var nv, St.setAmbient (st, And (St.ambient st, Reln (Sql (String.extract (seq, 3, NONE)), [Var nv])))) + end | ENextval _ => default () | ESetval _ => default () @@ -2416,6 +2425,16 @@ fun check file = in (vals, inserts, deletes, updates, client, insert, delete, p :: update) end + | PolSequence e => + (case #1 e of + EPrim (Prim.String seq) => + let + val p = Reln (Sql (String.extract (seq, 3, NONE)), [Lvar 0]) + val outs = [Lvar 0] + in + (vals, inserts, deletes, updates, (p, outs) :: client, insert, delete, update) + end + | _ => (vals, inserts, deletes, updates, client, insert, delete, update)) end | _ => (vals, inserts, deletes, updates, client, insert, delete, update) @@ -2434,8 +2453,14 @@ fun check file = if decompH p (fn hyps => List.exists (fn p' => - decompG p' - (fn goals => imply (hyps, goals, NONE))) + if decompG p' + (fn goals => imply (hyps, goals, NONE)) then + ((*reset (); + Print.prefaces "Match" [("hyp", p_prop p), + ("goal", p_prop p')];*) + true) + else + false) pols) then () else @@ -2487,7 +2512,11 @@ fun check file = client orelse tryCombos (0, client, True, []) orelse (reset (); - Print.preface ("Untenable hypotheses", + Print.preface ("Untenable hypotheses" + ^ (case fl of + Control Where => " (WHERE clause)" + | Control Case => " (case discriminee)" + | Data => " (returned data value)"), Print.p_list p_atom hyps); false) end) then diff --git a/src/mono.sml b/src/mono.sml index 79cde237..9a960cd0 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -128,6 +128,7 @@ datatype policy = | PolInsert of exp | PolDelete of exp | PolUpdate of exp + | PolSequence of exp datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index b8016ff8..25a8e9d8 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -426,6 +426,9 @@ fun p_policy env pol = | PolUpdate e => box [string "mayUpdate", space, p_exp env e] + | PolSequence e => box [string "sendOwnIds", + space, + p_exp env e] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 6b248636..b42c9535 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -65,6 +65,7 @@ fun shake file = | PolInsert e1 => e1 | PolDelete e1 => e1 | PolUpdate e1 => e1 + | PolSequence e1 => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index 085b68f8..6bbbecb1 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -553,6 +553,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | PolUpdate e => S.map2 (mfe ctx e, PolUpdate) + | PolSequence e => + S.map2 (mfe ctx e, + PolSequence) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index 601b690f..3983624b 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3752,6 +3752,8 @@ fun monoDecl (env, fm) (all as (d, loc)) = (e, L'.PolDelete) | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) => (e, L'.PolUpdate) + | L.EFfiApp ("Basis", "sendOwnIds", [e]) => + (e, L'.PolSequence) | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e -- cgit v1.2.3 From 03da53257bc793d0435a325cd968dda7506b1b38 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 09:17:52 -0400 Subject: Havoc relations that have been updated --- src/iflow.sml | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 77f25a91..721a6c25 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1984,6 +1984,21 @@ fun addUpdate (t : t, c) = {Var = #Var t, end +fun havocReln r = + let + fun hr p = + case p of + True => p + | False => p + | Unknown => p + | And (p1, p2) => And (hr p1, hr p2) + | Or (p1, p2) => Or (hr p1, hr p2) + | Reln (r', _) => if r' = r then True else p + | Cond (e, p) => Cond (e, hr p) + in + hr + end + fun evalExp env (e as (_, loc), st) = let fun default () = @@ -2259,6 +2274,8 @@ fun evalExp env (e as (_, loc), st) = val p = And (p, And (Reln (Sql "$Old", [Var old]), Reln (Sql tab, [Var old]))) + + val st = St.setAmbient (st, havocReln (Sql tab) (St.ambient st)) in (Recd [], St.addDelete (st, (loc, And (St.ambient st, p)))) end @@ -2308,6 +2325,8 @@ fun evalExp env (e as (_, loc), st) = And (Reln (Sql (tab ^ "$New"), [Recd fs]), And (Reln (Sql "$Old", [Var old]), Reln (Sql tab, [Var old])))) + + val st = St.setAmbient (st, havocReln (Sql tab) (St.ambient st)) in (Recd [], St.addUpdate (st, (loc, And (St.ambient st, p)))) end) -- cgit v1.2.3 From 49a9ce1b2cd568bf5414e47f084198aed202fbff Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 09:25:45 -0400 Subject: Avoid pointless rebuilding of hypothesis E-graphs --- src/iflow.sml | 188 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 98 insertions(+), 90 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 721a6c25..560e0752 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -959,84 +959,86 @@ fun decomp fals or = val tabs = ref (SM.empty : (string list * string list list) SM.map) -fun imply (hyps, goals, outs) = +fun ccOf hyps = + let + val cc = Cc.database () + val () = app (fn a => Cc.assert (cc, a)) hyps + + (* Take advantage of table key information *) + fun findKeys hyps = + case hyps of + [] => () + | AReln (Sql tab, [r1]) :: hyps => + (case SM.find (!tabs, tab) of + NONE => findKeys hyps + | SOME (_, []) => findKeys hyps + | SOME (_, ks) => + let + fun finder hyps = + case hyps of + [] => () + | AReln (Sql tab', [r2]) :: hyps => + (if tab' = tab andalso + List.exists (List.all (fn f => + let + val r = + Cc.check (cc, + AReln (Eq, [Proj (r1, f), + Proj (r2, f)])) + in + (*Print.prefaces "Fs" + [("tab", + Print.PD.string tab), + ("r1", + p_exp (Proj (r1, f))), + ("r2", + p_exp (Proj (r2, f))), + ("r", + Print.PD.string + (Bool.toString r))];*) + r + end)) ks then + ((*Print.prefaces "Key match" [("tab", Print.PD.string tab), + ("r1", p_exp r1), + ("r2", p_exp r2), + ("rp1", Cc.p_repOf cc r1), + ("rp2", Cc.p_repOf cc r2)];*) + Cc.assert (cc, AReln (Eq, [r1, r2]))) + else + (); + finder hyps) + | _ :: hyps => finder hyps + in + finder hyps; + findKeys hyps + end) + | _ :: hyps => findKeys hyps + in + findKeys hyps; + cc + end + +fun imply (cc, hyps, goals, outs) = let fun gls goals onFail acc = case goals of [] => - (let - val cc = Cc.database () - val () = app (fn a => Cc.assert (cc, a)) hyps - - (* Take advantage of table key information *) - fun findKeys hyps = - case hyps of - [] => () - | AReln (Sql tab, [r1]) :: hyps => - (case SM.find (!tabs, tab) of - NONE => findKeys hyps - | SOME (_, []) => findKeys hyps - | SOME (_, ks) => - let - fun finder hyps = - case hyps of - [] => () - | AReln (Sql tab', [r2]) :: hyps => - (if tab' = tab andalso - List.exists (List.all (fn f => - let - val r = - Cc.check (cc, - AReln (Eq, [Proj (r1, f), - Proj (r2, f)])) - in - (*Print.prefaces "Fs" - [("tab", - Print.PD.string tab), - ("r1", - p_exp (Proj (r1, f))), - ("r2", - p_exp (Proj (r2, f))), - ("r", - Print.PD.string - (Bool.toString r))];*) - r - end)) ks then - ((*Print.prefaces "Key match" [("tab", Print.PD.string tab), - ("r1", p_exp r1), - ("r2", p_exp r2), - ("rp1", Cc.p_repOf cc r1), - ("rp2", Cc.p_repOf cc r2)];*) - Cc.assert (cc, AReln (Eq, [r1, r2]))) - else - (); - finder hyps) - | _ :: hyps => finder hyps - in - finder hyps; - findKeys hyps - end) - | _ :: hyps => findKeys hyps - in - findKeys hyps; - - (*Print.preface ("db", Cc.p_database cc);*) - (List.all (fn a => - if Cc.check (cc, a) then - true - else - ((*Print.prefaces "Can't prove" - [("a", p_atom a), - ("hyps", Print.p_list p_atom hyps), - ("db", Cc.p_database cc)];*) - false)) acc - andalso ((*Print.preface ("Finding", Cc.p_database cc);*) true) - andalso (case outs of - NONE => true - | SOME outs => Cc.builtFrom (cc, {Derived = Var 0, - Base = outs}))) - handle Cc.Contradiction => false - end handle Cc.Undetermined => false) + ((List.all (fn a => + if Cc.check (cc, a) then + true + else + ((*Print.prefaces "Can't prove" + [("a", p_atom a), + ("hyps", Print.p_list p_atom hyps), + ("db", Cc.p_database cc)];*) + false)) acc + andalso ((*Print.preface ("Finding", Cc.p_database cc);*) true) + andalso (case outs of + NONE => true + | SOME outs => Cc.builtFrom (cc, {Derived = Var 0, + Base = outs}))) + handle Cc.Contradiction => false + | Cc.Undetermined => false) orelse onFail () | (g as AReln (Sql gf, [ge])) :: goals => let @@ -1073,7 +1075,7 @@ fun imply (hyps, goals, outs) = (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), ("goals", Print.p_list p_atom goals)];*) gls goals (fn () => false) [] - end handle Cc.Contradiction => true + end fun patCon pc = case pc of @@ -2471,16 +2473,20 @@ fun check file = app (fn (loc, p) => if decompH p (fn hyps => - List.exists (fn p' => - if decompG p' - (fn goals => imply (hyps, goals, NONE)) then - ((*reset (); - Print.prefaces "Match" [("hyp", p_prop p), - ("goal", p_prop p')];*) - true) - else - false) - pols) then + let + val cc = ccOf hyps + in + List.exists (fn p' => + if decompG p' + (fn goals => imply (cc, hyps, goals, NONE)) then + ((*reset (); + Print.prefaces "Match" [("hyp", p_prop p), + ("goal", p_prop p')];*) + true) + else + false) + pols + end handle Cc.Contradiction => true) then () else (ErrorMsg.errorAt loc "The information flow policy may be violated here."; @@ -2495,6 +2501,8 @@ fun check file = if decompH p (fn hyps => let + val cc = ccOf hyps + val avail = foldl (fn (AReln (Sql tab, _), avail) => SS.add (avail, tab) | (_, avail) => avail) SS.empty hyps @@ -2502,7 +2510,7 @@ fun check file = case pols of [] => decompG g - (fn goals => imply (hyps, goals, SOME outs)) + (fn goals => imply (cc, hyps, goals, SOME outs)) | (g1, outs1) :: pols => let val g1 = bumpLvarsP (maxLv + 1) g1 @@ -2524,10 +2532,11 @@ fun check file = end in (fl <> Control Where - andalso imply (hyps, [AReln (Known, [Var 0])], SOME [Var 0])) + andalso imply (cc, hyps, [AReln (Known, [Var 0])], SOME [Var 0])) orelse List.exists (fn (p', outs) => decompG p' - (fn goals => imply (hyps, goals, SOME outs))) + (fn goals => imply (cc, hyps, goals, + SOME outs))) client orelse tryCombos (0, client, True, []) orelse (reset (); @@ -2538,7 +2547,7 @@ fun check file = | Data => " (returned data value)"), Print.p_list p_atom hyps); false) - end) then + end handle Cc.Contradiction => true) then () else ErrorMsg.errorAt loc "The information flow policy may be violated here." @@ -2577,4 +2586,3 @@ val check = fn file => end end - -- cgit v1.2.3 From 3f7a84cefc8df8cfb1c6442861331273c1d46ff3 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 09:31:04 -0400 Subject: When applying multiple policies at once, filter the policy set at the beginning, removing unmatchable policies --- src/iflow.sml | 35 ++++++++++++++++++++--------------- 1 file changed, 20 insertions(+), 15 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 560e0752..797f13d0 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -2503,8 +2503,19 @@ fun check file = let val cc = ccOf hyps - val avail = foldl (fn (AReln (Sql tab, _), avail) => SS.add (avail, tab) - | (_, avail) => avail) SS.empty hyps + fun relevant () = + let + val avail = foldl (fn (AReln (Sql tab, _), avail) => + SS.add (avail, tab) + | (_, avail) => avail) SS.empty hyps + in + List.filter + (fn (g1, _) => + decompG g1 + (List.all (fn AReln (Sql tab, _) => + SS.member (avail, tab) + | _ => true))) client + end fun tryCombos (maxLv, pols, g, outs) = case pols of @@ -2517,18 +2528,12 @@ fun check file = val outs1 = map (bumpLvars (maxLv + 1)) outs1 fun skip () = tryCombos (maxLv, pols, g, outs) in - if decompG g1 - (List.all (fn AReln (Sql tab, _) => - SS.member (avail, tab) - | _ => true)) then - skip () - orelse tryCombos (Int.max (maxLv, - maxLvarP g1), - pols, - And (g1, g), - outs1 @ outs) - else - skip () + skip () + orelse tryCombos (Int.max (maxLv, + maxLvarP g1), + pols, + And (g1, g), + outs1 @ outs) end in (fl <> Control Where @@ -2538,7 +2543,7 @@ fun check file = (fn goals => imply (cc, hyps, goals, SOME outs))) client - orelse tryCombos (0, client, True, []) + orelse tryCombos (0, relevant (), True, []) orelse (reset (); Print.preface ("Untenable hypotheses" ^ (case fl of -- cgit v1.2.3 From 4ba4ade9e6ae86ed07aed13eafd7d71d9fadddb7 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 10:40:55 -0400 Subject: Fix problem with overly weak ambients for queries; fix known-related bug in assert for Dt1 --- src/iflow.sml | 50 ++++++++++++++++++++++++++++++-------------------- 1 file changed, 30 insertions(+), 20 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 797f13d0..73ff07ea 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -787,12 +787,12 @@ fun assert (db, a) = val r'' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref false}) + Known = ref (!(#Known (unNode r)))}) val r' = ref (Node {Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r''), - Known = ref false}) + Known = #Known (unNode r)}) in #Rep (unNode r) := SOME r' end @@ -2109,8 +2109,12 @@ fun evalExp env (e as (_, loc), st) = val st = St.addPath (st, ((loc, e, orig), Case)) - val (st, paths) = - foldl (fn ((pt, pe), (st, paths)) => + (*val () = Print.prefaces "Case" [("loc", Print.PD.string (ErrorMsg.spanToString loc)), + ("e", Print.p_list (MonoPrint.p_exp MonoEnv.empty o #2) pes), + ("orig", p_prop orig)]*) + + val (st, ambients, paths) = + foldl (fn ((pt, pe), (st, ambients, paths)) => let val (env, pp) = evalPat env e pt val (pe, st') = evalExp env (pe, St.setAmbient (st, And (orig, pp))) @@ -2118,15 +2122,16 @@ fun evalExp env (e as (_, loc), st) = val this = And (removeRedundant orig (St.ambient st'), Reln (Eq, [Var r, pe])) in - (St.setPaths (St.setAmbient (st', Or (St.ambient st, this)), origPaths), + (St.setPaths (st', origPaths), + Or (ambients, this), St.paths st' @ paths) - end) (St.setAmbient (st, False), []) pes + end) (st, False, []) pes val st = case #1 res of TRecord [] => St.setPaths (st, origPaths) | _ => St.setPaths (st, paths) in - (Var r, St.setAmbient (st, And (orig, St.ambient st))) + (Var r, St.setAmbient (st, And (orig, ambients))) end | EStrcat (e1, e2) => let @@ -2183,6 +2188,7 @@ fun evalExp env (e as (_, loc), st) = val (st', acc) = St.nextVar st' val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') + val amb = removeRedundant (St.ambient st) (St.ambient st') val (st', qp, used, _) = queryProp env @@ -2194,8 +2200,6 @@ fun evalExp env (e as (_, loc), st) = end) (AllCols (Var r)) q - val p' = And (qp, St.ambient st') - val (st, res) = if varInP acc (St.ambient st') then let val (st, r) = St.nextVar st @@ -2204,17 +2208,19 @@ fun evalExp env (e as (_, loc), st) = end else let - val (st, out) = St.nextVar st' + val (st', out) = St.nextVar st' - val p = Or (Reln (Eq, [Var out, i]), - And (Reln (Eq, [Var out, b]), - p')) + val p = And (St.ambient st, + Or (Reln (Eq, [Var out, i]), + And (Reln (Eq, [Var out, b]), + And (qp, amb)))) in - (St.setAmbient (st, p), Var out) + (St.setAmbient (st', p), Var out) end val sent = map (fn ((loc, e, p), fl) => ((loc, e, And (qp, p)), fl)) (St.sent st') + val p' = And (qp, St.ambient st') val paths = map (fn (p'', e) => ((loc, e, And (p', p'')), Where)) used in (res, St.addPaths (St.setSent (st, sent), paths)) @@ -2508,13 +2514,16 @@ fun check file = val avail = foldl (fn (AReln (Sql tab, _), avail) => SS.add (avail, tab) | (_, avail) => avail) SS.empty hyps - in - List.filter - (fn (g1, _) => - decompG g1 - (List.all (fn AReln (Sql tab, _) => + + val ls = List.filter + (fn (g1, _) => + decompG g1 + (List.all (fn AReln (Sql tab, _) => SS.member (avail, tab) - | _ => true))) client + | _ => true))) client + in + (*print ("Max: " ^ Int.toString (length ls) ^ "\n");*) + ls end fun tryCombos (maxLv, pols, g, outs) = @@ -2551,6 +2560,7 @@ fun check file = | Control Case => " (case discriminee)" | Data => " (returned data value)"), Print.p_list p_atom hyps); + Print.preface ("DB", Cc.p_database cc); false) end handle Cc.Contradiction => true) then () -- cgit v1.2.3 From f865ba33dbdaa023deb71b8a68d8d0ffe3442a82 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 11:15:43 -0400 Subject: Catching lame FFI applications --- src/iflow.sml | 35 +++++++++++++++++++---------------- 1 file changed, 19 insertions(+), 16 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 73ff07ea..f0dfd1f3 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -2023,6 +2023,22 @@ fun evalExp env (e as (_, loc), st) = in St.clearPaths st end + + fun doFfi (m, s, es) = + if m = "Basis" andalso SS.member (writers, s) then + let + val (es, st) = ListUtil.foldlMap (evalExp env) st es + in + (Recd [], foldl (fn (e, st) => addSent (St.ambient st, e, st)) st es) + end + else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then + default () + else + let + val (es, st) = ListUtil.foldlMap (evalExp env) st es + in + (Func (Other (m ^ "." ^ s), es), st) + end in case #1 e of EPrim p => (Const p, st) @@ -2044,21 +2060,8 @@ fun evalExp env (e as (_, loc), st) = end | EFfi _ => default () - | EFfiApp (m, s, es) => - if m = "Basis" andalso SS.member (writers, s) then - let - val (es, st) = ListUtil.foldlMap (evalExp env) st es - in - (Recd [], foldl (fn (e, st) => addSent (St.ambient st, e, st)) st es) - end - else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then - default () - else - let - val (es, st) = ListUtil.foldlMap (evalExp env) st es - in - (Func (Other (m ^ "." ^ s), es), st) - end + | EFfiApp x => doFfi x + | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [e]) | EApp (e1, e2) => let @@ -2560,7 +2563,7 @@ fun check file = | Control Case => " (case discriminee)" | Data => " (returned data value)"), Print.p_list p_atom hyps); - Print.preface ("DB", Cc.p_database cc); + (*Print.preface ("DB", Cc.p_database cc);*) false) end handle Cc.Contradiction => true) then () -- cgit v1.2.3 From c77a8eb70eec73d741eccdf2c0705b28db847a92 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 11:34:59 -0400 Subject: Command-line use of Iflow --- src/compiler.sig | 1 + src/compiler.sml | 3 ++- src/iflow.sml | 43 ++++++++++++++++++++++++------------------- src/main.mlton.sml | 3 +++ src/sources | 6 +++--- 5 files changed, 33 insertions(+), 23 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/compiler.sig b/src/compiler.sig index d3b4e696..cc23fe74 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -164,6 +164,7 @@ signature COMPILER = sig val toSqlify : (string, Cjr.file) transform val debug : bool ref + val doIflow : bool ref val addPath : string * string -> unit val addModuleRoot : string * string -> unit diff --git a/src/compiler.sml b/src/compiler.sml index bb55dfce..def0e6c3 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -75,6 +75,7 @@ type ('src, 'dst) transform = { } val debug = ref false +val doIflow = ref false fun transform (ph : ('src, 'dst) phase) name = { func = fn input => let @@ -1072,7 +1073,7 @@ val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake val iflow = { - func = (fn file => (Iflow.check file; file)), + func = (fn file => (if !doIflow then Iflow.check file else (); file)), print = MonoPrint.p_file MonoEnv.empty } diff --git a/src/iflow.sml b/src/iflow.sml index f0dfd1f3..24d9d4a6 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -502,7 +502,7 @@ fun p_rep n = case !(#Rep (unNode n)) of SOME n => p_rep n | NONE => - box [string (Int.toString (Unsafe.cast n) ^ ":"), + box [string (Int.toString 0(*Unsafe.cast n*) ^ ":"), space, case #Variety (unNode n) of Nothing => string "?" @@ -2182,7 +2182,7 @@ fun evalExp env (e as (_, loc), st) = (Func (Other ("Cl" ^ Int.toString n), es), st) end - | EQuery {query = q, body = b, initial = i, ...} => + | EQuery {query = q, body = b, initial = i, state = state, ...} => let val (_, st) = evalExp env (q, st) val (i, st) = evalExp env (i, st) @@ -2203,23 +2203,28 @@ fun evalExp env (e as (_, loc), st) = end) (AllCols (Var r)) q - val (st, res) = if varInP acc (St.ambient st') then - let - val (st, r) = St.nextVar st - in - (st, Var r) - end - else - let - val (st', out) = St.nextVar st' - - val p = And (St.ambient st, - Or (Reln (Eq, [Var out, i]), - And (Reln (Eq, [Var out, b]), - And (qp, amb)))) - in - (St.setAmbient (st', p), Var out) - end + val (st, res) = + case #1 state of + TRecord [] => + (st, Func (DtCon0 "unit", [])) + | _ => + if varInP acc (St.ambient st') then + let + val (st, r) = St.nextVar st + in + (st, Var r) + end + else + let + val (st', out) = St.nextVar st' + + val p = And (St.ambient st, + Or (Reln (Eq, [Var out, i]), + And (Reln (Eq, [Var out, b]), + And (qp, amb)))) + in + (St.setAmbient (st', p), Var out) + end val sent = map (fn ((loc, e, p), fl) => ((loc, e, And (qp, p)), fl)) (St.sent st') diff --git a/src/main.mlton.sml b/src/main.mlton.sml index c6ca61c9..f4f74be2 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -82,6 +82,9 @@ fun doArgs args = | "-sigfile" :: name :: rest => (Settings.setSigFile (SOME name); doArgs rest) + | "-iflow" :: rest => + (Compiler.doIflow := true; + doArgs rest) | arg :: rest => (if size arg > 0 andalso String.sub (arg, 0) = #"-" then raise Fail ("Unknown flag " ^ arg) diff --git a/src/sources b/src/sources index ba8dac38..3e35c7c7 100644 --- a/src/sources +++ b/src/sources @@ -169,6 +169,9 @@ untangle.sml mono_shake.sig mono_shake.sml +fuse.sig +fuse.sml + iflow.sig iflow.sml @@ -178,9 +181,6 @@ jscomp.sml pathcheck.sig pathcheck.sml -fuse.sig -fuse.sml - cjr.sml postgres.sig -- cgit v1.2.3 From c4f4ed6ee7f6fe49d19ca68b9fff6735b8a86fec Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 16:30:46 -0400 Subject: Completely redid main Iflow logic; so far, policy and policy2 work --- src/compiler.sml | 2 +- src/iflow.sml | 1816 ++++++++++++++++++----------------------------------- tests/policy.ur | 4 +- tests/policy2.ur | 22 + tests/policy2.urp | 1 + tests/policy2.urs | 1 + 6 files changed, 629 insertions(+), 1217 deletions(-) create mode 100644 tests/policy2.ur create mode 100644 tests/policy2.urp create mode 100644 tests/policy2.urs (limited to 'src/iflow.sml') diff --git a/src/compiler.sml b/src/compiler.sml index def0e6c3..ba10ed74 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -75,7 +75,7 @@ type ('src, 'dst) transform = { } val debug = ref false -val doIflow = ref false +val doIflow = ref true fun transform (ph : ('src, 'dst) phase) name = { func = fn input => let diff --git a/src/iflow.sml b/src/iflow.sml index 24d9d4a6..c8a8df89 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -72,7 +72,6 @@ datatype exp = | Func of func * exp list | Recd of (string * exp) list | Proj of exp * string - | Finish datatype reln = Known @@ -95,12 +94,6 @@ datatype prop = | Reln of reln * exp list | Cond of exp * prop -val unif = ref (IM.empty : exp IM.map) - -fun reset () = unif := IM.empty -fun save () = !unif -fun restore x = unif := x - local open Print val string = PD.string @@ -117,10 +110,7 @@ fun p_exp e = case e of Const p => Prim.p_t p | Var n => string ("x" ^ Int.toString n) - | Lvar n => - (case IM.find (!unif, n) of - NONE => string ("X" ^ Int.toString n) - | SOME e => p_exp e) + | Lvar n => string ("X" ^ Int.toString n) | Func (f, es) => box [p_func f, string "(", p_list p_exp es, @@ -134,7 +124,6 @@ fun p_exp e = string "}"] | Proj (e, x) => box [p_exp e, string ("." ^ x)] - | Finish => string "FINISH" fun p_bop s es = case es of @@ -203,18 +192,6 @@ fun p_prop p = end -local - val count = ref 1 -in -fun newLvar () = - let - val n = !count - in - count := n + 1; - n - end -end - fun isKnown e = case e of Const _ => true @@ -223,23 +200,22 @@ fun isKnown e = | Proj (e, _) => isKnown e | _ => false -fun isFinish e = - case e of - Finish => true - | _ => false - -fun simplify e = - case e of - Const _ => e - | Var _ => e - | Lvar n => - (case IM.find (!unif, n) of - NONE => e - | SOME e => simplify e) - | Func (f, es) => Func (f, map simplify es) - | Recd xes => Recd (map (fn (x, e) => (x, simplify e)) xes) - | Proj (e, s) => Proj (simplify e, s) - | Finish => Finish +fun simplify unif = + let + fun simplify e = + case e of + Const _ => e + | Var _ => e + | Lvar n => + (case IM.find (unif, n) of + NONE => e + | SOME e => simplify e) + | Func (f, es) => Func (f, map simplify es) + | Recd xes => Recd (map (fn (x, e) => (x, simplify e)) xes) + | Proj (e, s) => Proj (simplify e, s) + in + simplify + end datatype atom = AReln of reln * exp list @@ -250,192 +226,7 @@ fun p_atom a = AReln x => Reln x | ACond x => Cond x) -fun lvarIn lv = - let - fun lvi e = - case e of - Const _ => false - | Var _ => false - | Lvar lv' => lv' = lv - | Func (_, es) => List.exists lvi es - | Recd xes => List.exists (lvi o #2) xes - | Proj (e, _) => lvi e - | Finish => false - in - lvi - end - -fun lvarInP lv = - let - fun lvi p = - case p of - True => false - | False => false - | Unknown => true - | And (p1, p2) => lvi p1 orelse lvi p2 - | Or (p1, p2) => lvi p1 orelse lvi p2 - | Reln (_, es) => List.exists (lvarIn lv) es - | Cond (e, p) => lvarIn lv e orelse lvi p - in - lvi - end - -fun varIn lv = - let - fun lvi e = - case e of - Const _ => false - | Lvar _ => false - | Var lv' => lv' = lv - | Func (_, es) => List.exists lvi es - | Recd xes => List.exists (lvi o #2) xes - | Proj (e, _) => lvi e - | Finish => false - in - lvi - end - -fun varInP lv = - let - fun lvi p = - case p of - True => false - | False => false - | Unknown => false - | And (p1, p2) => lvi p1 orelse lvi p2 - | Or (p1, p2) => lvi p1 orelse lvi p2 - | Reln (_, es) => List.exists (varIn lv) es - | Cond (e, p) => varIn lv e orelse lvi p - in - lvi - end - -fun bumpLvars by = - let - fun lvi e = - case e of - Const _ => e - | Var _ => e - | Lvar lv => Lvar (lv + by) - | Func (f, es) => Func (f, map lvi es) - | Recd xes => Recd (map (fn (x, e) => (x, lvi e)) xes) - | Proj (e, f) => Proj (lvi e, f) - | Finish => e - in - lvi - end - -fun bumpLvarsP by = - let - fun lvi p = - case p of - True => p - | False => p - | Unknown => p - | And (p1, p2) => And (lvi p1, lvi p2) - | Or (p1, p2) => And (lvi p1, lvi p2) - | Reln (r, es) => Reln (r, map (bumpLvars by) es) - | Cond (e, p) => Cond (bumpLvars by e, lvi p) - in - lvi - end - -fun maxLvar e = - let - fun lvi e = - case e of - Const _ => 0 - | Var _ => 0 - | Lvar lv => lv - | Func (f, es) => foldl Int.max 0 (map lvi es) - | Recd xes => foldl Int.max 0 (map (lvi o #2) xes) - | Proj (e, f) => lvi e - | Finish => 0 - in - lvi e - end - -fun maxLvarP p = - let - fun lvi p = - case p of - True => 0 - | False => 0 - | Unknown => 0 - | And (p1, p2) => Int.max (lvi p1, lvi p2) - | Or (p1, p2) => Int.max (lvi p1, lvi p2) - | Reln (r, es) => foldl Int.max 0 (map maxLvar es) - | Cond (e, p) => Int.max (maxLvar e, lvi p) - in - lvi p - end - -fun eq' (e1, e2) = - case (e1, e2) of - (Const p1, Const p2) => Prim.equal (p1, p2) - | (Var n1, Var n2) => n1 = n2 - - | (Lvar n1, _) => - (case IM.find (!unif, n1) of - SOME e1 => eq' (e1, e2) - | NONE => - case e2 of - Lvar n2 => - (case IM.find (!unif, n2) of - SOME e2 => eq' (e1, e2) - | NONE => n1 = n2 - orelse (unif := IM.insert (!unif, n2, e1); - true)) - | _ => - if lvarIn n1 e2 then - false - else - (unif := IM.insert (!unif, n1, e2); - true)) - - | (_, Lvar n2) => - (case IM.find (!unif, n2) of - SOME e2 => eq' (e1, e2) - | NONE => - if lvarIn n2 e1 then - false - else - ((*Print.prefaces "unif" [("n2", Print.PD.string (Int.toString n2)), - ("e1", p_exp e1)];*) - unif := IM.insert (!unif, n2, e1); - true)) - - | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eq' (es1, es2) - | (Recd xes1, Recd xes2) => ListPair.allEq (fn ((x1, e1), (x2, e2)) => x1 = x2 andalso eq' (e1, e2)) (xes1, xes2) - | (Proj (e1, s1), Proj (e2, s2)) => eq' (e1, e2) andalso s1 = s2 - | (Finish, Finish) => true - | _ => false - -fun eq (e1, e2) = - let - val saved = save () - in - if eq' (simplify e1, simplify e2) then - true - else - (restore saved; - false) - end - val debug = ref false - -fun eeq (e1, e2) = - case (e1, e2) of - (Const p1, Const p2) => Prim.equal (p1, p2) - | (Var n1, Var n2) => n1 = n2 - | (Lvar n1, Lvar n2) => n1 = n2 - | (Func (f1, es1), Func (f2, es2)) => f1 = f2 andalso ListPair.allEq eeq (es1, es2) - | (Recd xes1, Recd xes2) => length xes1 = length xes2 andalso - List.all (fn (x2, e2) => - List.exists (fn (x1, e1) => x1 = x2 andalso eeq (e1, e2)) xes2) xes1 - | (Proj (e1, x1), Proj (e2, x2)) => eeq (e1, e2) andalso x1 = x2 - | (Finish, Finish) => true - | _ => false (* Congruence closure *) structure Cc :> sig @@ -445,6 +236,7 @@ structure Cc :> sig exception Undetermined val database : unit -> database + val clear : database -> unit val assert : database * atom -> unit val check : database * atom -> bool @@ -490,6 +282,12 @@ fun database () = {Vars = ref IM.empty, Records = ref [], Funcs = ref []} +fun clear (t : database) = (#Vars t := IM.empty; + #Consts t := CM.empty; + #Con0s t := SM.empty; + #Records t := []; + #Funcs t := []) + fun unNode n = case !n of Node r => r @@ -594,10 +392,7 @@ fun representative (db : database, e) = #Vars db := IM.insert (!(#Vars db), n, r); r end) - | Lvar n => - (case IM.find (!unif, n) of - NONE => raise Undetermined - | SOME e => rep e) + | Lvar _ => raise Undetermined | Func (DtCon0 f, []) => (case SM.find (!(#Con0s db), f) of SOME r => repOf r | NONE => @@ -735,7 +530,6 @@ fun representative (db : database, e) = end | _ => raise Contradiction end - | Finish => raise Contradiction in rep e end @@ -938,25 +732,6 @@ fun builtFrom (db, {Base = bs, Derived = d}) = end -fun decomp fals or = - let - fun decomp p k = - case p of - True => k [] - | False => fals - | Unknown => k [] - | And (p1, p2) => - decomp p1 (fn ps1 => - decomp p2 (fn ps2 => - k (ps1 @ ps2))) - | Or (p1, p2) => - or (decomp p1 k, fn () => decomp p2 k) - | Reln x => k [AReln x] - | Cond x => k [ACond x] - in - decomp - end - val tabs = ref (SM.empty : (string list * string list list) SM.map) fun ccOf hyps = @@ -1018,65 +793,6 @@ fun ccOf hyps = cc end -fun imply (cc, hyps, goals, outs) = - let - fun gls goals onFail acc = - case goals of - [] => - ((List.all (fn a => - if Cc.check (cc, a) then - true - else - ((*Print.prefaces "Can't prove" - [("a", p_atom a), - ("hyps", Print.p_list p_atom hyps), - ("db", Cc.p_database cc)];*) - false)) acc - andalso ((*Print.preface ("Finding", Cc.p_database cc);*) true) - andalso (case outs of - NONE => true - | SOME outs => Cc.builtFrom (cc, {Derived = Var 0, - Base = outs}))) - handle Cc.Contradiction => false - | Cc.Undetermined => false) - orelse onFail () - | (g as AReln (Sql gf, [ge])) :: goals => - let - fun hps hyps = - case hyps of - [] => gls goals onFail (g :: acc) - | (h as AReln (Sql hf, [he])) :: hyps => - if gf = hf then - let - val saved = save () - in - if eq (ge, he) then - let - val changed = IM.numItems (!unif) - <> IM.numItems saved - in - gls goals (fn () => (restore saved; - changed - andalso hps hyps)) - acc - end - else - hps hyps - end - else - hps hyps - | _ :: hyps => hps hyps - in - hps hyps - end - | g :: goals => gls goals onFail (g :: acc) - in - reset (); - (*Print.prefaces "Big go" [("hyps", Print.p_list p_atom hyps), - ("goals", Print.p_list p_atom goals)];*) - gls goals (fn () => false) [] - end - fun patCon pc = case pc of PConVar n => "C" ^ Int.toString n @@ -1430,6 +1146,211 @@ val dml = log "dml" wrap delete Delete, wrap update Update]) +type check = exp * ErrorMsg.span + +structure St :> sig + val reset : unit -> unit + + type stashed + val stash : unit -> stashed + val reinstate : stashed -> unit + + val nextVar : unit -> int + + val assert : atom list -> unit + + val addPath : check -> unit + + val allowSend : atom list * exp list -> unit + val send : check -> unit + + val allowInsert : atom list -> unit + val insert : ErrorMsg.span -> unit + + val allowDelete : atom list -> unit + val delete : ErrorMsg.span -> unit + + val allowUpdate : atom list -> unit + val update : ErrorMsg.span -> unit + + val havocReln : reln -> unit +end = struct + +val hnames = ref 1 + +type hyps = int * atom list + +val db = Cc.database () +val path = ref ([] : (hyps * check) option ref list) +val hyps = ref (0, [] : atom list) +val nvar = ref 0 + +fun reset () = (Cc.clear db; + path := []; + hyps := (0, []); + nvar := 0) + +fun setHyps (h as (n', hs)) = + let + val (n, _) = !hyps + in + if n' = n then + () + else + (hyps := h; + Cc.clear db; + app (fn a => Cc.assert (db, a)) hs) + end + +type stashed = int * (hyps * check) option ref list * (int * atom list) +fun stash () = (!nvar, !path, !hyps) +fun reinstate (nv, p, h) = + (nvar := nv; + path := p; + setHyps h) + +fun nextVar () = + let + val n = !nvar + in + nvar := n + 1; + n + end + +fun assert ats = + let + val n = !hnames + val (_, hs) = !hyps + in + hnames := n + 1; + hyps := (n, ats @ hs); + app (fn a => Cc.assert (db, a)) ats + end + +fun addPath c = path := ref (SOME (!hyps, c)) :: !path + +val sendable = ref ([] : (atom list * exp list) list) + +fun checkGoals goals unifs succ fail = + case goals of + [] => succ (unifs, []) + | AReln (Sql tab, [Lvar lv]) :: goals => + let + val saved = stash () + val (_, hyps) = !hyps + + fun tryAll unifs hyps = + case hyps of + [] => fail () + | AReln (Sql tab', [e]) :: hyps => + if tab' = tab then + checkGoals goals (IM.insert (unifs, lv, e)) succ + (fn () => tryAll unifs hyps) + else + tryAll unifs hyps + | _ :: hyps => tryAll unifs hyps + in + tryAll unifs hyps + end + | AReln (r, es) :: goals => checkGoals goals unifs + (fn (unifs, ls) => succ (unifs, AReln (r, map (simplify unifs) es) :: ls)) + fail + | ACond _ :: _ => fail () + +fun buildable (e, loc) = + let + fun doPols pols acc fail = + case pols of + [] => ((*Print.prefaces "buildable" [("Base", Print.p_list p_exp acc), + ("Derived", p_exp e), + ("Hyps", Print.p_list p_atom (#2 (!hyps)))];*) + if Cc.builtFrom (db, {Base = acc, Derived = e}) then + () + else + fail ()) + | (goals, es) :: pols => + checkGoals goals IM.empty + (fn (unifs, goals) => + if List.all (fn a => Cc.check (db, a)) goals then + doPols pols (map (simplify unifs) es @ acc) fail + else + doPols pols acc fail) + (fn () => doPols pols acc fail) + in + doPols (!sendable) [] + (fn () => let + val (_, hs) = !hyps + in + ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.preface ("Hypotheses", Print.p_list p_atom hs) + end) + end + +fun checkPaths () = + let + val hs = !hyps + in + app (fn r => + case !r of + NONE => () + | SOME (hs, e) => + (r := NONE; + setHyps hs; + buildable e)) (!path); + setHyps hs + end + +fun allowSend v = sendable := v :: !sendable + +fun send (e, loc) = ((*Print.preface ("Send", p_exp e);*) + checkPaths (); + if isKnown e then + () + else + buildable (e, loc)) + +fun doable pols (loc : ErrorMsg.span) = + let + val pols = !pols + in + if List.exists (fn goals => + checkGoals goals IM.empty + (fn (_, goals) => List.all (fn a => Cc.check (db, a)) goals) + (fn () => false)) pols then + () + else + let + val (_, hs) = !hyps + in + ErrorMsg.errorAt loc "The database update policy may be violated here."; + Print.preface ("Hypotheses", Print.p_list p_atom hs) + end + end + +val insertable = ref ([] : atom list list) +fun allowInsert v = insertable := v :: !insertable +val insert = doable insertable + +val updatable = ref ([] : atom list list) +fun allowUpdate v = updatable := v :: !updatable +val update = doable updatable + +val deletable = ref ([] : atom list list) +fun allowDelete v = deletable := v :: !deletable +val delete = doable deletable + +fun havocReln r = + let + val n = !hnames + val (_, hs) = !hyps + in + hnames := n + 1; + hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs) + end + +end + + fun removeDups (ls : (string * string) list) = case ls of [] => [] @@ -1443,63 +1364,42 @@ fun removeDups (ls : (string * string) list) = x :: ls end -datatype queryMode = - SomeCol - | AllCols of exp - fun expIn rv env rvOf = let - fun expIn (e, rvN) = + fun expIn e = let - fun default () = - let - val (rvN, e') = rv rvN - in - (inl e', rvN) - end + fun default () = inl (rv ()) in case e of - SqConst p => (inl (Const p), rvN) - | Field (v, f) => (inl (Proj (rvOf v, f)), rvN) + SqConst p => inl (Const p) + | Field (v, f) => inl (Proj (rvOf v, f)) | Binop (bo, e1, e2) => let - val (e1, rvN) = expIn (e1, rvN) - val (e2, rvN) = expIn (e2, rvN) + val e1 = expIn e1 + val e2 = expIn e2 in - (inr (case (bo, e1, e2) of - (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, inr p1, inr p2) => f (p1, p2) - | _ => Unknown), rvN) + inr (case (bo, e1, e2) of + (Exps f, inl e1, inl e2) => f (e1, e2) + | (Props f, inr p1, inr p2) => f (p1, p2) + | _ => Unknown) end | SqKnown e => - (case expIn (e, rvN) of - (inl e, rvN) => (inr (Reln (Known, [e])), rvN) - | _ => (inr Unknown, rvN)) + (case expIn e of + inl e => inr (Reln (Known, [e])) + | _ => inr Unknown) | Inj e => let fun deinj e = case #1 e of - ERel n => (List.nth (env, n), rvN) - | EField (e, f) => - let - val (e, rvN) = deinj e - in - (Proj (e, f), rvN) - end - | _ => - let - val (rvN, e) = rv rvN - in - (e, rvN) - end - - val (e, rvN) = deinj e + ERel n => List.nth (env, n) + | EField (e, f) => Proj (deinj e, f) + | _ => rv () in - (inl e, rvN) + inl (deinj e) end | SqFunc (f, e) => - (case expIn (e, rvN) of - (inl e, rvN) => (inl (Func (Other f, [e])), rvN) + (case expIn e of + inl e => inl (Func (Other f, [e])) | _ => default ()) | Count => default () @@ -1508,32 +1408,67 @@ fun expIn rv env rvOf = expIn end -fun queryProp env rvN rv oe e = +fun decomp {Save = save, Restore = restore, Add = add} = + let + fun go p k = + case p of + True => k () + | False => () + | Unknown => () + | And (p1, p2) => go p1 (fn () => go p2 k) + | Or (p1, p2) => + let + val saved = save () + in + go p1 k; + restore saved; + go p2 k + end + | Reln x => (add (AReln x); k ()) + | Cond x => (add (ACond x); k ()) + in + go + end + +datatype queryMode = + SomeCol of exp list -> unit + | AllCols of exp -> unit + +type 'a doQuery = { + Env : exp list, + NextVar : unit -> exp, + Add : atom -> unit, + Save : unit -> 'a, + Restore : 'a -> unit, + UsedExp : exp -> unit, + Cont : queryMode +} + +fun doQuery (arg : 'a doQuery) e = let - fun default () = (print ("Warning: Information flow checker can't parse SQL query at " - ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - (rvN, Unknown, [], [])) + fun default () = print ("Warning: Information flow checker can't parse SQL query at " + ^ ErrorMsg.spanToString (#2 e) ^ "\n") in case parse query e of NONE => default () | SOME q => let - fun doQuery (q, rvN) = + fun doQuery q = case q of Query1 r => let - val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => - let - val (rvN, e) = rv rvN - in - ((v, e), rvN) - end) rvN (#From r) + val rvs = map (fn (_, v) => (v, #NextVar arg ())) (#From r) fun rvOf v = case List.find (fn (v', _) => v' = v) rvs of NONE => raise Fail "Iflow.queryProp: Bad table variable" | SOME (_, e) => e + val expIn = expIn (#NextVar arg) (#Env arg) rvOf + + val saved = #Save arg () + fun addFrom () = app (fn (t, v) => #Add arg (AReln (Sql t, [rvOf v]))) (#From r) + fun usedFields e = case e of SqConst _ => [] @@ -1544,695 +1479,276 @@ fun queryProp env rvN rv oe e = | SqFunc (_, e) => usedFields e | Count => [] - val p = - foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) - - val expIn = expIn rv env rvOf - - val (p, rvN) = case #Where r of - NONE => (p, rvN) - | SOME e => - case expIn (e, rvN) of - (inr p', rvN) => (And (p, p'), rvN) - | _ => (p, rvN) - - fun normal () = - case oe of - SomeCol => + fun doUsed () = case #Where r of + NONE => () + | SOME e => + #UsedExp arg (Recd (ListUtil.mapi + (fn (n, (v, f)) => (Int.toString n, + Proj (rvOf v, f))) + (usedFields e))) + + fun normal' () = + case #Cont arg of + SomeCol k => let - val (sis, rvN) = - ListUtil.foldlMap - (fn (si, rvN) => - case si of - SqField (v, f) => (Proj (rvOf v, f), rvN) - | SqExp (e, f) => - case expIn (e, rvN) of - (inr _, _) => - let - val (rvN, e) = rv rvN - in - (e, rvN) - end - | (inl e, rvN) => (e, rvN)) rvN (#Select r) + val sis = map (fn si => + case si of + SqField (v, f) => Proj (rvOf v, f) + | SqExp (e, f) => + case expIn e of + inr _ => #NextVar arg () + | inl e => e) (#Select r) in - (rvN, p, True, sis) + k sis end - | AllCols oe => + | AllCols k => let - val (ts, es, rvN) = - foldl (fn (si, (ts, es, rvN)) => + val (ts, es) = + foldl (fn (si, (ts, es)) => case si of SqField (v, f) => let val fs = getOpt (SM.find (ts, v), SM.empty) in - (SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es, rvN) + (SM.insert (ts, v, SM.insert (fs, f, Proj (rvOf v, f))), es) end | SqExp (e, f) => let - val (e, rvN) = - case expIn (e, rvN) of - (inr _, rvN) => - let - val (rvN, e) = rv rvN - in - (e, rvN) - end - | (inl e, rvN) => (e, rvN) + val e = + case expIn e of + inr _ => #NextVar arg () + | inl e => e in - (ts, SM.insert (es, f, e), rvN) + (ts, SM.insert (es, f, e)) end) - (SM.empty, SM.empty, rvN) (#Select r) - - val p' = Reln (Eq, [oe, Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs))) - (SM.listItemsi ts) - @ SM.listItemsi es)]) + (SM.empty, SM.empty) (#Select r) in - (rvN, And (p, p'), True, []) + k (Recd (map (fn (t, fs) => (t, Recd (SM.listItemsi fs))) + (SM.listItemsi ts) + @ SM.listItemsi es)) end - val (rvN, p, wp, outs) = - case #Select r of - [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => - (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of - Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => - (case oe of - SomeCol => - let - val (rvN, oe) = rv rvN - in - (rvN, - Or (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.False", [])]), - And (Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), - p)), - Reln (Eq, [oe, Func (DtCon0 "Basis.bool.True", [])]), - [oe]) - end - | AllCols oe => - let - fun oeEq e = Reln (Eq, [oe, Recd [(f, e)]]) - in - (rvN, - Or (oeEq (Func (DtCon0 "Basis.bool.False", [])), - And (oeEq (Func (DtCon0 "Basis.bool.True", [])), - p)), - oeEq (Func (DtCon0 "Basis.bool.True", [])), - []) - end) - | _ => normal ()) - | _ => normal () + fun doWhere final = + (addFrom (); + case #Where r of + NONE => (doUsed (); final ()) + | SOME e => + case expIn e of + inl _ => (doUsed (); final ()) + | inr p => + let + val saved = #Save arg () + in + decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} + p (fn () => (doUsed (); final ()) handle Cc.Contradiction => ()); + #Restore arg saved + end) + handle Cc.Contradiction => () + + fun normal () = doWhere normal' in - (rvN, p, map (fn x => (wp, x)) - (case #Where r of - NONE => [] - | SOME e => map (fn (v, f) => Proj (rvOf v, f)) (usedFields e)), outs) + (case #Select r of + [SqExp (Binop (Exps bo, Count, SqConst (Prim.Int 0)), f)] => + (case bo (Const (Prim.Int 1), Const (Prim.Int 2)) of + Reln (Gt, [Const (Prim.Int 1), Const (Prim.Int 2)]) => + (case #Cont arg of + SomeCol _ => () + | AllCols k => + let + fun answer e = k (Recd [(f, e)]) + + val () = answer (Func (DtCon0 "Basis.bool.False", [])) + val saved = #Save arg () + in + doWhere (fn () => answer (Func (DtCon0 "Basis.bool.True", []))); + #Restore arg saved + end) + | _ => normal ()) + | _ => normal ()) + before #Restore arg saved end | Union (q1, q2) => let - val (rvN, p1, used1, outs1) = doQuery (q1, rvN) - val (rvN, p2, used2, outs2) = doQuery (q2, rvN) + val saved = #Save arg () in - case (outs1, outs2) of - ([], []) => (rvN, Or (p1, p2), - map (fn (p, e) => (And (p1, p), e)) used1 - @ map (fn (p, e) => (And (p2, p), e)) used2, []) - | _ => default () + doQuery q1; + #Restore arg saved; + doQuery q2; + #Restore arg saved end in - doQuery (q, rvN) - end - end - -fun insertProp rvN rv e = - let - fun default () = (print ("Warning: Information flow checker can't parse SQL query at " - ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - Unknown) - in - case parse query e of - SOME (Query1 r) => - let - val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => - let - val (rvN, e) = rv rvN - in - ((v, e), rvN) - end) rvN (#From r) - - fun rvOf v = - case List.find (fn (v', _) => v' = v) rvs of - NONE => raise Fail "Iflow.insertProp: Bad table variable" - | SOME (_, e) => e - - val p = - foldl (fn ((t, v), p) => - let - val t = - case v of - "New" => t ^ "$New" - | _ => t - in - And (p, Reln (Sql t, [rvOf v])) - end) True (#From r) - - val expIn = expIn rv [] rvOf - in - case #Where r of - NONE => p - | SOME e => - case expIn (e, rvN) of - (inr p', _) => And (p, p') - | _ => p - end - | _ => default () - end - -fun deleteProp rvN rv e = - let - fun default () = (print ("Warning: Information flow checker can't parse SQL query at " - ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - Unknown) - in - case parse query e of - SOME (Query1 r) => - let - val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => - let - val (rvN, e) = rv rvN - in - ((v, e), rvN) - end) rvN (#From r) - - fun rvOf v = - case List.find (fn (v', _) => v' = v) rvs of - NONE => raise Fail "Iflow.deleteProp: Bad table variable" - | SOME (_, e) => e - - val p = - foldl (fn ((t, v), p) => And (p, Reln (Sql t, [rvOf v]))) True (#From r) - - val expIn = expIn rv [] rvOf - in - And (Reln (Sql "$Old", [rvOf "Old"]), - case #Where r of - NONE => p - | SOME e => - case expIn (e, rvN) of - (inr p', _) => And (p, p') - | _ => p) - end - | _ => default () - end - -fun updateProp rvN rv e = - let - fun default () = (print ("Warning: Information flow checker can't parse SQL query at " - ^ ErrorMsg.spanToString (#2 e) ^ "\n"); - Unknown) - in - case parse query e of - SOME (Query1 r) => - let - val (rvs, rvN) = ListUtil.foldlMap (fn ((_, v), rvN) => - let - val (rvN, e) = rv rvN - in - ((v, e), rvN) - end) rvN (#From r) - - fun rvOf v = - case List.find (fn (v', _) => v' = v) rvs of - NONE => raise Fail "Iflow.insertProp: Bad table variable" - | SOME (_, e) => e - - val p = - foldl (fn ((t, v), p) => - let - val t = - case v of - "New" => t ^ "$New" - | _ => t - in - And (p, Reln (Sql t, [rvOf v])) - end) True (#From r) - - val expIn = expIn rv [] rvOf - in - And (Reln (Sql "$Old", [rvOf "Old"]), - case #Where r of - NONE => p - | SOME e => - case expIn (e, rvN) of - (inr p', _) => And (p, p') - | _ => p) + doQuery q end - | _ => default () end fun evalPat env e (pt, _) = case pt of - PWild => (env, True) - | PVar _ => (e :: env, True) - | PPrim _ => (env, True) - | PCon (_, pc, NONE) => (env, Reln (PCon0 (patCon pc), [e])) + PWild => env + | PVar _ => e :: env + | PPrim _ => env + | PCon (_, pc, NONE) => (St.assert [AReln (PCon0 (patCon pc), [e])]; env) | PCon (_, pc, SOME pt) => let - val (env, p) = evalPat env (Func (UnCon (patCon pc), [e])) pt + val env = evalPat env (Func (UnCon (patCon pc), [e])) pt in - (env, And (p, Reln (PCon1 (patCon pc), [e]))) + St.assert [AReln (PCon1 (patCon pc), [e])]; + env end | PRecord xpts => - foldl (fn ((x, pt, _), (env, p)) => - let - val (env, p') = evalPat env (Proj (e, x)) pt - in - (env, And (p', p)) - end) (env, True) xpts - | PNone _ => (env, Reln (PCon0 "None", [e])) + foldl (fn ((x, pt, _), env) => evalPat env (Proj (e, x)) pt) env xpts + | PNone _ => (St.assert [AReln (PCon0 "None", [e])]; env) | PSome (_, pt) => let - val (env, p) = evalPat env (Func (UnCon "Some", [e])) pt + val env = evalPat env (Func (UnCon "Some", [e])) pt in - (env, And (p, Reln (PCon1 "Some", [e]))) + St.assert [AReln (PCon1 "Some", [e])]; + env end -fun peq (p1, p2) = - case (p1, p2) of - (True, True) => true - | (False, False) => true - | (Unknown, Unknown) => true - | (And (x1, y1), And (x2, y2)) => peq (x1, x2) andalso peq (y1, y2) - | (Or (x1, y1), Or (x2, y2)) => peq (x1, x2) andalso peq (y1, y2) - | (Reln (r1, es1), Reln (r2, es2)) => r1 = r2 andalso ListPair.allEq eeq (es1, es2) - | (Cond (e1, p1), Cond (e2, p2)) => eeq (e1, e2) andalso peq (p1, p2) - | _ => false - -fun removeRedundant p1 = +fun evalExp env (e as (_, loc)) k = let - fun rr p2 = - if peq (p1, p2) then - True - else - case p2 of - And (x, y) => And (rr x, rr y) - | Or (x, y) => Or (rr x, rr y) - | _ => p2 - in - rr - end - -datatype cflow = Case | Where -datatype flow = Data | Control of cflow -type check = ErrorMsg.span * exp * prop -type dml = ErrorMsg.span * prop - -structure St :> sig - type t - val create : {Var : int, - Ambient : prop} -> t - - val curVar : t -> int - val nextVar : t -> t * int - - val ambient : t -> prop - val setAmbient : t * prop -> t - - val paths : t -> (check * cflow) list - val addPath : t * (check * cflow) -> t - val addPaths : t * (check * cflow) list -> t - val clearPaths : t -> t - val setPaths : t * (check * cflow) list -> t + (*val () = Print.preface ("evalExp", MonoPrint.p_exp MonoEnv.empty e)*) - val sent : t -> (check * flow) list - val addSent : t * (check * flow) -> t - val setSent : t * (check * flow) list -> t - - val inserted : t -> dml list - val addInsert : t * dml -> t - - val deleted : t -> dml list - val addDelete : t * dml -> t - - val updated : t -> dml list - val addUpdate : t * dml -> t -end = struct - -type t = {Var : int, - Ambient : prop, - Path : (check * cflow) list, - Sent : (check * flow) list, - Insert : dml list, - Delete : dml list, - Update : dml list} - -fun create {Var = v, Ambient = p} = {Var = v, - Ambient = p, - Path = [], - Sent = [], - Insert = [], - Delete = [], - Update = []} - -fun curVar (t : t) = #Var t -fun nextVar (t : t) = ({Var = #Var t + 1, - Ambient = #Ambient t, - Path = #Path t, - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t}, #Var t) - -fun ambient (t : t) = #Ambient t -fun setAmbient (t : t, p) = {Var = #Var t, - Ambient = p, - Path = #Path t, - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} - -fun paths (t : t) = #Path t -fun addPath (t : t, c) = {Var = #Var t, - Ambient = #Ambient t, - Path = c :: #Path t, - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} -fun addPaths (t : t, cs) = {Var = #Var t, - Ambient = #Ambient t, - Path = cs @ #Path t, - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} -fun clearPaths (t : t) = {Var = #Var t, - Ambient = #Ambient t, - Path = [], - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} -fun setPaths (t : t, cs) = {Var = #Var t, - Ambient = #Ambient t, - Path = cs, - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} - -fun sent (t : t) = #Sent t -fun addSent (t : t, c) = {Var = #Var t, - Ambient = #Ambient t, - Path = #Path t, - Sent = c :: #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} -fun setSent (t : t, cs) = {Var = #Var t, - Ambient = #Ambient t, - Path = #Path t, - Sent = cs, - Insert = #Insert t, - Delete = #Delete t, - Update = #Update t} - -fun inserted (t : t) = #Insert t -fun addInsert (t : t, c) = {Var = #Var t, - Ambient = #Ambient t, - Path = #Path t, - Sent = #Sent t, - Insert = c :: #Insert t, - Delete = #Delete t, - Update = #Update t} - -fun deleted (t : t) = #Delete t -fun addDelete (t : t, c) = {Var = #Var t, - Ambient = #Ambient t, - Path = #Path t, - Sent = #Sent t, - Insert = #Insert t, - Delete = c :: #Delete t, - Update = #Update t} - -fun updated (t : t) = #Update t -fun addUpdate (t : t, c) = {Var = #Var t, - Ambient = #Ambient t, - Path = #Path t, - Sent = #Sent t, - Insert = #Insert t, - Delete = #Delete t, - Update = c :: #Update t} - -end - -fun havocReln r = - let - fun hr p = - case p of - True => p - | False => p - | Unknown => p - | And (p1, p2) => And (hr p1, hr p2) - | Or (p1, p2) => Or (hr p1, hr p2) - | Reln (r', _) => if r' = r then True else p - | Cond (e, p) => Cond (e, hr p) - in - hr - end - -fun evalExp env (e as (_, loc), st) = - let - fun default () = - let - val (st, nv) = St.nextVar st - in - (*Print.prefaces "default" [("e", MonoPrint.p_exp MonoEnv.empty e), - ("nv", p_exp (Var nv))];*) - (Var nv, st) - end - - fun addSent (p, e, st) = - let - val st = if isKnown e then - st - else - St.addSent (st, ((loc, e, p), Data)) - - val st = foldl (fn ((c, fl), st) => St.addSent (st, (c, Control fl))) st (St.paths st) - in - St.clearPaths st - end + fun default () = k (Var (St.nextVar ())) fun doFfi (m, s, es) = if m = "Basis" andalso SS.member (writers, s) then let - val (es, st) = ListUtil.foldlMap (evalExp env) st es + fun doArgs es = + case es of + [] => k (Recd []) + | e :: es => + evalExp env e (fn e => (St.send (e, loc); doArgs es)) in - (Recd [], foldl (fn (e, st) => addSent (St.ambient st, e, st)) st es) + doArgs es end else if Settings.isEffectful (m, s) andalso not (Settings.isBenignEffectful (m, s)) then default () else let - val (es, st) = ListUtil.foldlMap (evalExp env) st es + fun doArgs (es, acc) = + case es of + [] => k (Func (Other (m ^ "." ^ s), rev acc)) + | e :: es => + evalExp env e (fn e => doArgs (es, e :: acc)) in - (Func (Other (m ^ "." ^ s), es), st) + doArgs (es, []) end in case #1 e of - EPrim p => (Const p, st) - | ERel n => (List.nth (env, n), st) + EPrim p => k (Const p) + | ERel n => k (List.nth (env, n)) | ENamed _ => default () - | ECon (_, pc, NONE) => (Func (DtCon0 (patCon pc), []), st) - | ECon (_, pc, SOME e) => - let - val (e, st) = evalExp env (e, st) - in - (Func (DtCon1 (patCon pc), [e]), st) - end - | ENone _ => (Func (DtCon0 "None", []), st) - | ESome (_, e) => - let - val (e, st) = evalExp env (e, st) - in - (Func (DtCon1 "Some", [e]), st) - end + | ECon (_, pc, NONE) => k (Func (DtCon0 (patCon pc), [])) + | ECon (_, pc, SOME e) => evalExp env e (fn e => k (Func (DtCon1 (patCon pc), [e]))) + | ENone _ => k (Func (DtCon0 "None", [])) + | ESome (_, e) => evalExp env e (fn e => k (Func (DtCon1 "Some", [e]))) | EFfi _ => default () | EFfiApp x => doFfi x | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [e]) - | EApp (e1, e2) => - let - val (e1, st) = evalExp env (e1, st) - in - case e1 of - Finish => (Finish, st) - | _ => default () - end + | EApp (e1, e2) => evalExp env e1 (fn _ => evalExp env e2 (fn _ => default ())) | EAbs _ => default () - | EUnop (s, e1) => - let - val (e1, st) = evalExp env (e1, st) - in - (Func (Other s, [e1]), st) - end - | EBinop (s, e1, e2) => - let - val (e1, st) = evalExp env (e1, st) - val (e2, st) = evalExp env (e2, st) - in - (Func (Other s, [e1, e2]), st) - end + | EUnop (s, e1) => evalExp env e1 (fn e1 => k (Func (Other s, [e1]))) + | EBinop (s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2])))) | ERecord xets => let - val (xes, st) = ListUtil.foldlMap (fn ((x, e, _), st) => - let - val (e, st) = evalExp env (e, st) - in - ((x, e), st) - end) st xets + fun doFields (xes, acc) = + case xes of + [] => k (Recd (rev acc)) + | (x, e, _) :: xes => + evalExp env e (fn e => doFields (xes, (x, e) :: acc)) in - (Recd xes, st) - end - | EField (e, s) => - let - val (e, st) = evalExp env (e, st) - in - (Proj (e, s), st) + doFields (xets, []) end + | EField (e, s) => evalExp env e (fn e => k (Proj (e, s))) | ECase (e, pes, {result = res, ...}) => - let - val (e, st) = evalExp env (e, st) - val (st, r) = St.nextVar st - val orig = St.ambient st - val origPaths = St.paths st - - val st = St.addPath (st, ((loc, e, orig), Case)) - - (*val () = Print.prefaces "Case" [("loc", Print.PD.string (ErrorMsg.spanToString loc)), - ("e", Print.p_list (MonoPrint.p_exp MonoEnv.empty o #2) pes), - ("orig", p_prop orig)]*) - - val (st, ambients, paths) = - foldl (fn ((pt, pe), (st, ambients, paths)) => + evalExp env e (fn e => let - val (env, pp) = evalPat env e pt - val (pe, st') = evalExp env (pe, St.setAmbient (st, And (orig, pp))) - - val this = And (removeRedundant orig (St.ambient st'), - Reln (Eq, [Var r, pe])) + val () = St.addPath (e, loc) in - (St.setPaths (st', origPaths), - Or (ambients, this), - St.paths st' @ paths) - end) (st, False, []) pes - - val st = case #1 res of - TRecord [] => St.setPaths (st, origPaths) - | _ => St.setPaths (st, paths) - in - (Var r, St.setAmbient (st, And (orig, ambients))) - end + app (fn (p, pe) => + let + val saved = St.stash () + + val env = evalPat env e p + in + evalExp env pe k; + St.reinstate saved + end) pes + end handle Cc.Contradiction => ()) | EStrcat (e1, e2) => - let - val (e1, st) = evalExp env (e1, st) - val (e2, st) = evalExp env (e2, st) - in - (Func (Other "cat", [e1, e2]), st) - end - | EError _ => (Finish, st) + evalExp env e1 (fn e1 => + evalExp env e2 (fn e2 => + k (Func (Other "cat", [e1, e2])))) + | EError (e, _) => evalExp env e (fn e => St.send (e, loc)) | EReturnBlob {blob = b, mimeType = m, ...} => - let - val (b, st) = evalExp env (b, st) - val (m, st) = evalExp env (m, st) - in - (Finish, addSent (St.ambient st, b, addSent (St.ambient st, m, st))) - end + evalExp env b (fn b => + (St.send (b, loc); + evalExp env m + (fn m => St.send (m, loc)))) | ERedirect (e, _) => - let - val (e, st) = evalExp env (e, st) - in - (Finish, addSent (St.ambient st, e, st)) - end + evalExp env e (fn e => St.send (e, loc)) | EWrite e => - let - val (e, st) = evalExp env (e, st) - in - (Recd [], addSent (St.ambient st, e, st)) - end + evalExp env e (fn e => (St.send (e, loc); + k (Recd []))) | ESeq (e1, e2) => - let - val (_, st) = evalExp env (e1, st) - in - evalExp env (e2, st) - end + evalExp env e1 (fn _ => evalExp env e2 k) | ELet (_, _, e1, e2) => - let - val (e1, st) = evalExp env (e1, st) - in - evalExp (e1 :: env) (e2, st) - end + evalExp env e1 (fn e1 => evalExp (e1 :: env) e2 k) | EClosure (n, es) => let - val (es, st) = ListUtil.foldlMap (evalExp env) st es + fun doArgs (es, acc) = + case es of + [] => k (Func (Other ("Cl" ^ Int.toString n), rev acc)) + | e :: es => + evalExp env e (fn e => doArgs (es, e :: acc)) in - (Func (Other ("Cl" ^ Int.toString n), es), st) + doArgs (es, []) end | EQuery {query = q, body = b, initial = i, state = state, ...} => - let - val (_, st) = evalExp env (q, st) - val (i, st) = evalExp env (i, st) - - val (st', r) = St.nextVar st - val (st', acc) = St.nextVar st' - - val (b, st') = evalExp (Var acc :: Var r :: env) (b, st') - val amb = removeRedundant (St.ambient st) (St.ambient st') - - val (st', qp, used, _) = - queryProp env - st' (fn st' => - let - val (st', rv) = St.nextVar st' - in - (st', Var rv) - end) - (AllCols (Var r)) q - - val (st, res) = - case #1 state of - TRecord [] => - (st, Func (DtCon0 "unit", [])) - | _ => - if varInP acc (St.ambient st') then - let - val (st, r) = St.nextVar st - in - (st, Var r) - end - else - let - val (st', out) = St.nextVar st' - - val p = And (St.ambient st, - Or (Reln (Eq, [Var out, i]), - And (Reln (Eq, [Var out, b]), - And (qp, amb)))) - in - (St.setAmbient (st', p), Var out) - end - - val sent = map (fn ((loc, e, p), fl) => ((loc, e, And (qp, p)), fl)) (St.sent st') + evalExp env q (fn _ => + evalExp env i (fn i => + let + val saved = St.stash () - val p' = And (qp, St.ambient st') - val paths = map (fn (p'', e) => ((loc, e, And (p', p'')), Where)) used - in - (res, St.addPaths (St.setSent (st, sent), paths)) - end + val r = Var (St.nextVar ()) + val acc = Var (St.nextVar ()) + in + if MonoUtil.Exp.existsB {typ = fn _ => false, + exp = fn (n, e) => + case e of + ERel n' => n' = n + | _ => false, + bind = fn (n, b) => + case b of + MonoUtil.Exp.RelE _ => n + 1 + | _ => n} + 0 b then + doQuery {Env = env, + NextVar = Var o St.nextVar, + Add = fn a => St.assert [a], + Save = St.stash, + Restore = St.reinstate, + UsedExp = fn e => St.send (e, loc), + Cont = AllCols (fn _ => (St.reinstate saved; + evalExp + (acc :: r :: env) + b (fn _ => default ())))} q + else + doQuery {Env = env, + NextVar = Var o St.nextVar, + Add = fn a => St.assert [a], + Save = St.stash, + Restore = St.reinstate, + UsedExp = fn e => St.send (e, loc), + Cont = AllCols (fn x => + (St.assert [AReln (Eq, [r, x])]; + evalExp (acc :: r :: env) b k))} q + end)) | EDml e => (case parse dml e of NONE => (print ("Warning: Information flow checker can't parse DML command at " @@ -2242,86 +1758,66 @@ fun evalExp env (e as (_, loc), st) = case d of Insert (tab, es) => let - val (st, new) = St.nextVar st + val new = St.nextVar () - fun rv st = - let - val (st, n) = St.nextVar st - in - (st, Var n) - end + val expIn = expIn (Var o St.nextVar) env + (fn _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT [1]") - val expIn = expIn rv env (fn _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT") + val es = map (fn (x, e) => + case expIn e of + inl e => (x, e) + | inr _ => raise Fail "Iflow.evalExp: Bad field expression in INSERT [2]") + es - val (es, st) = ListUtil.foldlMap - (fn ((x, e), st) => - let - val (e, st) = case expIn (e, st) of - (inl e, st) => (e, st) - | (inr _, _) => raise Fail - ("Iflow.evalExp: Selecting " - ^ "boolean expression") - in - ((x, e), st) - end) - st es + val saved = St.stash () in - (Recd [], St.addInsert (st, (loc, And (St.ambient st, - Reln (Sql (tab ^ "$New"), [Recd es]))))) + St.assert [AReln (Sql (tab ^ "$New"), [Recd es])]; + St.insert loc; + St.reinstate saved; + k (Recd []) end | Delete (tab, e) => let - val (st, old) = St.nextVar st - - fun rv st = - let - val (st, n) = St.nextVar st - in - (st, Var n) - end - - val expIn = expIn rv env (fn "T" => Var old - | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") - - val (p, st) = case expIn (e, st) of - (inl e, _) => raise Fail "Iflow.evalExp: DELETE with non-boolean" - | (inr p, st) => (p, st) - - val p = And (p, - And (Reln (Sql "$Old", [Var old]), - Reln (Sql tab, [Var old]))) - - val st = St.setAmbient (st, havocReln (Sql tab) (St.ambient st)) + val old = St.nextVar () + + val expIn = expIn (Var o St.nextVar) env + (fn "T" => Var old + | _ => raise Fail "Iflow.evalExp: Bad field expression in DELETE") + + val p = case expIn e of + inl e => raise Fail "Iflow.evalExp: DELETE with non-boolean" + | inr p => p + + val saved = St.stash () in - (Recd [], St.addDelete (st, (loc, And (St.ambient st, p)))) + St.assert [AReln (Sql "$Old", [Var old]), + AReln (Sql tab, [Var old])]; + decomp {Save = St.stash, + Restore = St.reinstate, + Add = fn a => St.assert [a]} p + (fn () => (St.delete loc; + St.reinstate saved; + St.havocReln (Sql tab); + k (Recd [])) + handle Cc.Contradiction => ()) end | Update (tab, fs, e) => let - val (st, new) = St.nextVar st - val (st, old) = St.nextVar st - - fun rv st = - let - val (st, n) = St.nextVar st - in - (st, Var n) - end - - val expIn = expIn rv env (fn "T" => Var old - | _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE") - - val (fs, st) = ListUtil.foldlMap - (fn ((x, e), st) => - let - val (e, st) = case expIn (e, st) of - (inl e, st) => (e, st) - | (inr _, _) => raise Fail - ("Iflow.evalExp: Selecting " - ^ "boolean expression") - in - ((x, e), st) - end) - st fs + val new = St.nextVar () + val old = St.nextVar () + + val expIn = expIn (Var o St.nextVar) env + (fn "T" => Var old + | _ => raise Fail "Iflow.evalExp: Bad field expression in UPDATE") + + val fs = map + (fn (x, e) => + (x, case expIn e of + inl e => e + | inr _ => raise Fail + ("Iflow.evalExp: Selecting " + ^ "boolean expression"))) + fs val fs' = case SM.find (!tabs, tab) of NONE => raise Fail "Iflow.evalExp: Updating unknown table" @@ -2333,34 +1829,40 @@ fun evalExp env (e as (_, loc), st) = else (f, Proj (Var old, f)) :: fs) fs fs' - val (p, st) = case expIn (e, st) of - (inl e, _) => raise Fail "Iflow.evalExp: UPDATE with non-boolean" - | (inr p, st) => (p, st) - - val p = And (p, - And (Reln (Sql (tab ^ "$New"), [Recd fs]), - And (Reln (Sql "$Old", [Var old]), - Reln (Sql tab, [Var old])))) - - val st = St.setAmbient (st, havocReln (Sql tab) (St.ambient st)) + val p = case expIn e of + inl e => raise Fail "Iflow.evalExp: UPDATE with non-boolean" + | inr p => p + val saved = St.stash () in - (Recd [], St.addUpdate (st, (loc, And (St.ambient st, p)))) + St.assert [AReln (Sql (tab ^ "$New"), [Recd fs]), + AReln (Sql "$Old", [Var old]), + AReln (Sql tab, [Var old])]; + decomp {Save = St.stash, + Restore = St.reinstate, + Add = fn a => St.assert [a]} p + (fn () => (St.update loc; + St.reinstate saved; + St.havocReln (Sql tab); + k (Recd [])) + handle Cc.Contradiction => ()) end) | ENextval (EPrim (Prim.String seq), _) => let - val (st, nv) = St.nextVar st + val nv = St.nextVar () in - (Var nv, St.setAmbient (st, And (St.ambient st, Reln (Sql (String.extract (seq, 3, NONE)), [Var nv])))) + St.assert [AReln (Sql (String.extract (seq, 3, NONE)), [Var nv])]; + k (Var nv) end | ENextval _ => default () | ESetval _ => default () | EUnurlify ((EFfiApp ("Basis", "get_cookie", _), _), _, _) => let - val (st, nv) = St.nextVar st + val nv = St.nextVar () in - (Var nv, St.setAmbient (st, And (St.ambient st, Reln (Known, [Var nv])))) + St.assert [AReln (Known, [Var nv])]; + k (Var nv) end | EUnurlify _ => default () @@ -2376,6 +1878,8 @@ fun evalExp env (e as (_, loc), st) = fun check file = let + val () = St.reset () + val file = MonoReduce.reduce file val file = MonoOpt.optimize file val file = Fuse.fuse file @@ -2388,7 +1892,7 @@ fun check file = DExport (_, _, n, _, _, _) => IS.add (exptd, n) | _ => exptd) IS.empty file - fun decl ((d, _), (vals, inserts, deletes, updates, client, insert, delete, update)) = + fun decl (d, _) = case d of DTable (tab, fs, pk, _) => let @@ -2401,11 +1905,10 @@ fun check file = | _ => [] in if size tab >= 3 then - (tabs := SM.insert (!tabs, String.extract (tab, 3, NONE), - (map #1 fs, - map (map (fn s => str (Char.toUpper (String.sub (s, 3))) - ^ String.extract (s, 4, NONE))) ks)); - (vals, inserts, deletes, updates, client, insert, delete, update)) + tabs := SM.insert (!tabs, String.extract (tab, 3, NONE), + (map #1 fs, + map (map (fn s => str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE))) ks)) else raise Fail "Table name does not begin with uw_" end @@ -2413,186 +1916,73 @@ fun check file = let val isExptd = IS.member (exptd, n) - fun deAbs (e, env, nv, p) = - case #1 e of - EAbs (_, _, _, e) => deAbs (e, Var nv :: env, nv + 1, - if isExptd then - And (p, Reln (Known, [Var nv])) - else - p) - | _ => (e, env, nv, p) + val saved = St.stash () - val (e, env, nv, p) = deAbs (e, [], 1, True) + fun deAbs (e, env, ps) = + case #1 e of + EAbs (_, _, _, e) => + let + val nv = Var (St.nextVar ()) + in + deAbs (e, nv :: env, + if isExptd then + AReln (Known, [nv]) :: ps + else + ps) + end + | _ => (e, env, ps) - val (_, st) = evalExp env (e, St.create {Var = nv, - Ambient = p}) + val (e, env, ps) = deAbs (e, [], []) in - (St.sent st @ vals, St.inserted st @ inserts, St.deleted st @ deletes, St.updated st @ updates, - client, insert, delete, update) + St.assert ps; + (evalExp env e (fn _ => ()) handle Cc.Contradiction => ()); + St.reinstate saved end | DPolicy pol => let - fun rv rvN = (rvN + 1, Lvar rvN) - in - case pol of - PolClient e => + val rvN = ref 0 + fun rv () = let - val (_, p, _, outs) = queryProp [] 0 rv SomeCol e + val n = !rvN in - (vals, inserts, deletes, updates, (p, outs) :: client, insert, delete, update) + rvN := n + 1; + Lvar n end + + val atoms = ref ([] : atom list) + fun doQ k = doQuery {Env = [], + NextVar = rv, + Add = fn a => atoms := a :: !atoms, + Save = fn () => !atoms, + Restore = fn ls => atoms := ls, + UsedExp = fn _ => (), + Cont = SomeCol (fn es => k (!atoms, es))} + in + case pol of + PolClient e => + doQ (fn (ats, es) => St.allowSend (ats, es)) e | PolInsert e => - let - val p = insertProp 0 rv e - in - (vals, inserts, deletes, updates, client, p :: insert, delete, update) - end + doQ (fn (ats, _) => St.allowInsert ats) e | PolDelete e => - let - val p = deleteProp 0 rv e - in - (vals, inserts, deletes, updates, client, insert, p :: delete, update) - end + doQ (fn (ats, _) => St.allowDelete ats) e | PolUpdate e => - let - val p = updateProp 0 rv e - in - (vals, inserts, deletes, updates, client, insert, delete, p :: update) - end + doQ (fn (ats, _) => St.allowUpdate ats) e | PolSequence e => (case #1 e of EPrim (Prim.String seq) => let - val p = Reln (Sql (String.extract (seq, 3, NONE)), [Lvar 0]) + val p = AReln (Sql (String.extract (seq, 3, NONE)), [Lvar 0]) val outs = [Lvar 0] in - (vals, inserts, deletes, updates, (p, outs) :: client, insert, delete, update) + St.allowSend ([p], outs) end - | _ => (vals, inserts, deletes, updates, client, insert, delete, update)) + | _ => ()) end - | _ => (vals, inserts, deletes, updates, client, insert, delete, update) - - val () = reset () - - val (vals, inserts, deletes, updates, client, insert, delete, update) = - foldl decl ([], [], [], [], [], [], [], []) file - - - val decompH = decomp true (fn (e1, e2) => e1 andalso e2 ()) - val decompG = decomp false (fn (e1, e2) => e1 orelse e2 ()) - - fun doDml (cmds, pols) = - app (fn (loc, p) => - if decompH p - (fn hyps => - let - val cc = ccOf hyps - in - List.exists (fn p' => - if decompG p' - (fn goals => imply (cc, hyps, goals, NONE)) then - ((*reset (); - Print.prefaces "Match" [("hyp", p_prop p), - ("goal", p_prop p')];*) - true) - else - false) - pols - end handle Cc.Contradiction => true) then - () - else - (ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.preface ("The state satisifies this predicate:", p_prop p))) cmds + | _ => () in - app (fn ((loc, e, p), fl) => - let - fun doOne e = - let - val p = And (p, Reln (Eq, [Var 0, e])) - in - if decompH p - (fn hyps => - let - val cc = ccOf hyps - - fun relevant () = - let - val avail = foldl (fn (AReln (Sql tab, _), avail) => - SS.add (avail, tab) - | (_, avail) => avail) SS.empty hyps - - val ls = List.filter - (fn (g1, _) => - decompG g1 - (List.all (fn AReln (Sql tab, _) => - SS.member (avail, tab) - | _ => true))) client - in - (*print ("Max: " ^ Int.toString (length ls) ^ "\n");*) - ls - end - - fun tryCombos (maxLv, pols, g, outs) = - case pols of - [] => - decompG g - (fn goals => imply (cc, hyps, goals, SOME outs)) - | (g1, outs1) :: pols => - let - val g1 = bumpLvarsP (maxLv + 1) g1 - val outs1 = map (bumpLvars (maxLv + 1)) outs1 - fun skip () = tryCombos (maxLv, pols, g, outs) - in - skip () - orelse tryCombos (Int.max (maxLv, - maxLvarP g1), - pols, - And (g1, g), - outs1 @ outs) - end - in - (fl <> Control Where - andalso imply (cc, hyps, [AReln (Known, [Var 0])], SOME [Var 0])) - orelse List.exists (fn (p', outs) => - decompG p' - (fn goals => imply (cc, hyps, goals, - SOME outs))) - client - orelse tryCombos (0, relevant (), True, []) - orelse (reset (); - Print.preface ("Untenable hypotheses" - ^ (case fl of - Control Where => " (WHERE clause)" - | Control Case => " (case discriminee)" - | Data => " (returned data value)"), - Print.p_list p_atom hyps); - (*Print.preface ("DB", Cc.p_database cc);*) - false) - end handle Cc.Contradiction => true) then - () - else - ErrorMsg.errorAt loc "The information flow policy may be violated here." - end - - fun doAll e = - case e of - Const _ => () - | Var _ => doOne e - | Lvar _ => raise Fail "Iflow.doAll: Lvar" - | Func (UnCon _, [_]) => doOne e - | Func (_, es) => app doAll es - | Recd xes => app (doAll o #2) xes - | Proj _ => doOne e - | Finish => () - in - doAll e - end) vals; - - doDml (inserts, insert); - doDml (deletes, delete); - doDml (updates, update) + app decl file end val check = fn file => diff --git a/tests/policy.ur b/tests/policy.ur index 69455cd7..fedc3fcb 100644 --- a/tests/policy.ur +++ b/tests/policy.ur @@ -9,9 +9,7 @@ table order : { Id : order, Fruit : fruit, Qty : int, Code : int } CONSTRAINT Fruit FOREIGN KEY Fruit REFERENCES fruit(Id) (* Everyone may knows IDs and names. *) -policy sendClient (SELECT fruit.Id - FROM fruit) -policy sendClient (SELECT fruit.Nam +policy sendClient (SELECT fruit.Id, fruit.Nam FROM fruit) (* The weight is sensitive information; you must know the secret. *) diff --git a/tests/policy2.ur b/tests/policy2.ur new file mode 100644 index 00000000..b8480c0c --- /dev/null +++ b/tests/policy2.ur @@ -0,0 +1,22 @@ +type fruit = int +table fruit : { Id : fruit, Nam : string, Weight : float, Secret : string } + PRIMARY KEY Id, + CONSTRAINT Nam UNIQUE Nam + +(* Everyone may knows IDs and names. *) +policy sendClient (SELECT fruit.Id, fruit.Nam + FROM fruit) + +(* The weight is sensitive information; you must know the secret. *) +policy sendClient (SELECT fruit.Weight, fruit.Secret + FROM fruit + WHERE known(fruit.Secret)) + +fun main () = + x1 <- queryX (SELECT fruit.Id, fruit.Nam + FROM fruit + WHERE fruit.Nam = "apple") + (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}
    • ); + return +
      {x1}
    +     diff --git a/tests/policy2.urp b/tests/policy2.urp new file mode 100644 index 00000000..46509756 --- /dev/null +++ b/tests/policy2.urp @@ -0,0 +1 @@ +policy2 diff --git a/tests/policy2.urs b/tests/policy2.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/policy2.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From df3842b263a180df83ee60a85a499b0322c36e8e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 13 Apr 2010 16:36:16 -0400 Subject: More descriptive info flow error message --- src/iflow.sml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index c8a8df89..d0fc0d80 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1282,7 +1282,8 @@ fun buildable (e, loc) = val (_, hs) = !hyps in ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.preface ("Hypotheses", Print.p_list p_atom hs) + Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), + ("User learns", p_exp e)] end) end -- cgit v1.2.3 From cd858875a27b63d4627d609505657e6cd62946c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 14 Apr 2010 09:18:16 -0400 Subject: Get refurbished Iflow working with calendar --- src/iflow.sml | 385 +++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 249 insertions(+), 136 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index d0fc0d80..df41ad80 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -243,7 +243,7 @@ structure Cc :> sig val p_database : database Print.printer - val builtFrom : database * {Base : exp list, Derived : exp} -> bool + val builtFrom : database * {UseKnown : bool, Base : exp list, Derived : exp} -> bool val p_repOf : database -> exp Print.printer end = struct @@ -710,7 +710,7 @@ fun check (db, a) = end | _ => false -fun builtFrom (db, {Base = bs, Derived = d}) = +fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = let val bs = map (fn b => representative (db, b)) bs @@ -718,7 +718,8 @@ fun builtFrom (db, {Base = bs, Derived = d}) = let val d = repOf d in - List.exists (fn b => repOf b = d) bs + (uk andalso !(#Known (unNode d))) + orelse List.exists (fn b => repOf b = d) bs orelse case #Variety (unNode d) of Dt0 _ => true | Dt1 (_, d) => loop d @@ -726,8 +727,13 @@ fun builtFrom (db, {Base = bs, Derived = d}) = | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) | Nothing => false end + + fun decomp e = + case e of + Func (Other _, es) => List.all decomp es + | _ => loop (representative (db, e)) in - loop (representative (db, d)) + decomp d end end @@ -1162,7 +1168,7 @@ structure St :> sig val addPath : check -> unit val allowSend : atom list * exp list -> unit - val send : check -> unit + val send : bool -> check -> unit val allowInsert : atom list -> unit val insert : ErrorMsg.span -> unit @@ -1174,6 +1180,8 @@ structure St :> sig val update : ErrorMsg.span -> unit val havocReln : reln -> unit + + val debug : unit -> unit end = struct val hnames = ref 1 @@ -1185,11 +1193,6 @@ val path = ref ([] : (hyps * check) option ref list) val hyps = ref (0, [] : atom list) val nvar = ref 0 -fun reset () = (Cc.clear db; - path := []; - hyps := (0, []); - nvar := 0) - fun setHyps (h as (n', hs)) = let val (n, _) = !hyps @@ -1231,60 +1234,115 @@ fun addPath c = path := ref (SOME (!hyps, c)) :: !path val sendable = ref ([] : (atom list * exp list) list) -fun checkGoals goals unifs succ fail = - case goals of - [] => succ (unifs, []) - | AReln (Sql tab, [Lvar lv]) :: goals => - let - val saved = stash () - val (_, hyps) = !hyps - - fun tryAll unifs hyps = - case hyps of - [] => fail () - | AReln (Sql tab', [e]) :: hyps => - if tab' = tab then - checkGoals goals (IM.insert (unifs, lv, e)) succ - (fn () => tryAll unifs hyps) - else - tryAll unifs hyps - | _ :: hyps => tryAll unifs hyps - in - tryAll unifs hyps - end - | AReln (r, es) :: goals => checkGoals goals unifs - (fn (unifs, ls) => succ (unifs, AReln (r, map (simplify unifs) es) :: ls)) - fail - | ACond _ :: _ => fail () +fun checkGoals goals k = + let + fun checkGoals goals unifs = + case goals of + [] => k unifs + | AReln (Sql tab, [Lvar lv]) :: goals => + let + val saved = stash () + val (_, hyps) = !hyps + + fun tryAll unifs hyps = + case hyps of + [] => false + | AReln (Sql tab', [e]) :: hyps => + (tab' = tab andalso + checkGoals goals (IM.insert (unifs, lv, e))) + orelse tryAll unifs hyps + | _ :: hyps => tryAll unifs hyps + in + tryAll unifs hyps + end + | AReln (r, es) :: goals => + Cc.check (db, AReln (r, map (simplify unifs) es)) + andalso checkGoals goals unifs + | ACond _ :: _ => false + in + checkGoals goals IM.empty + end + +fun useKeys () = + let + fun findKeys hyps = + case hyps of + [] => () + | AReln (Sql tab, [r1]) :: hyps => + (case SM.find (!tabs, tab) of + NONE => findKeys hyps + | SOME (_, []) => findKeys hyps + | SOME (_, ks) => + let + fun finder hyps = + case hyps of + [] => () + | AReln (Sql tab', [r2]) :: hyps => + (if tab' = tab andalso + List.exists (List.all (fn f => + let + val r = + Cc.check (db, + AReln (Eq, [Proj (r1, f), + Proj (r2, f)])) + in + (*Print.prefaces "Fs" + [("tab", + Print.PD.string tab), + ("r1", + p_exp (Proj (r1, f))), + ("r2", + p_exp (Proj (r2, f))), + ("r", + Print.PD.string + (Bool.toString r))];*) + r + end)) ks then + ((*Print.prefaces "Key match" [("tab", Print.PD.string tab), + ("r1", p_exp r1), + ("r2", p_exp r2), + ("rp1", Cc.p_repOf cc r1), + ("rp2", Cc.p_repOf cc r2)];*) + Cc.assert (db, AReln (Eq, [r1, r2]))) + else + (); + finder hyps) + | _ :: hyps => finder hyps + in + finder hyps; + findKeys hyps + end) + | _ :: hyps => findKeys hyps + + val (_, hs) = !hyps + in + (*print "findKeys\n";*) + findKeys hs + end -fun buildable (e, loc) = +fun buildable uk (e, loc) = let - fun doPols pols acc fail = + fun doPols pols acc = case pols of [] => ((*Print.prefaces "buildable" [("Base", Print.p_list p_exp acc), ("Derived", p_exp e), ("Hyps", Print.p_list p_atom (#2 (!hyps)))];*) - if Cc.builtFrom (db, {Base = acc, Derived = e}) then - () - else - fail ()) + Cc.builtFrom (db, {UseKnown = uk, Base = acc, Derived = e})) | (goals, es) :: pols => - checkGoals goals IM.empty - (fn (unifs, goals) => - if List.all (fn a => Cc.check (db, a)) goals then - doPols pols (map (simplify unifs) es @ acc) fail - else - doPols pols acc fail) - (fn () => doPols pols acc fail) + checkGoals goals (fn unifs => doPols pols (map (simplify unifs) es @ acc)) + orelse doPols pols acc in - doPols (!sendable) [] - (fn () => let - val (_, hs) = !hyps - in - ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), - ("User learns", p_exp e)] - end) + useKeys (); + if doPols (!sendable) [] then + () + else + let + val (_, hs) = !hyps + in + ErrorMsg.errorAt loc "The information flow policy may be violated here."; + Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), + ("User learns", p_exp e)] + end end fun checkPaths () = @@ -1297,27 +1355,34 @@ fun checkPaths () = | SOME (hs, e) => (r := NONE; setHyps hs; - buildable e)) (!path); + buildable true e)) (!path); setHyps hs end -fun allowSend v = sendable := v :: !sendable +fun allowSend v = ((*Print.prefaces "Allow" [("goals", Print.p_list p_atom (#1 v)), + ("exps", Print.p_list p_exp (#2 v))];*) + sendable := v :: !sendable) -fun send (e, loc) = ((*Print.preface ("Send", p_exp e);*) - checkPaths (); - if isKnown e then - () - else - buildable (e, loc)) +fun send uk (e, loc) = ((*Print.preface ("Send", p_exp e);*) + checkPaths (); + if isKnown e then + () + else + buildable uk (e, loc)) fun doable pols (loc : ErrorMsg.span) = let val pols = !pols in if List.exists (fn goals => - checkGoals goals IM.empty - (fn (_, goals) => List.all (fn a => Cc.check (db, a)) goals) - (fn () => false)) pols then + if checkGoals goals (fn _ => true) then + ((*Print.prefaces "Match" [("goals", Print.p_list p_atom goals), + ("hyps", Print.p_list p_atom (#2 (!hyps)))];*) + true) + else + ((*Print.prefaces "No match" [("goals", Print.p_list p_atom goals), + ("hyps", Print.p_list p_atom (#2 (!hyps)))];*) + false)) pols then () else let @@ -1340,6 +1405,15 @@ val deletable = ref ([] : atom list list) fun allowDelete v = deletable := v :: !deletable val delete = doable deletable +fun reset () = (Cc.clear db; + path := []; + hyps := (0, []); + nvar := 0; + sendable := []; + insertable := []; + updatable := []; + deletable := []) + fun havocReln r = let val n = !hnames @@ -1349,6 +1423,13 @@ fun havocReln r = hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs) end +fun debug () = + let + val (_, hs) = !hyps + in + Print.preface ("Hyps", Print.p_list p_atom hs) + end + end @@ -1413,7 +1494,7 @@ fun decomp {Save = save, Restore = restore, Add = add} = let fun go p k = case p of - True => k () + True => (k () handle Cc.Contradiction => ()) | False => () | Unknown => () | And (p1, p2) => go p1 (fn () => go p2 k) @@ -1432,7 +1513,7 @@ fun decomp {Save = save, Restore = restore, Add = add} = end datatype queryMode = - SomeCol of exp list -> unit + SomeCol of {New : (string * exp) option, Old : (string * exp) option, Outs : exp list} -> unit | AllCols of exp -> unit type 'a doQuery = { @@ -1458,7 +1539,19 @@ fun doQuery (arg : 'a doQuery) e = case q of Query1 r => let - val rvs = map (fn (_, v) => (v, #NextVar arg ())) (#From r) + val new = ref NONE + val old = ref NONE + + val rvs = map (fn (tab, v) => + let + val nv = #NextVar arg () + in + case v of + "New" => new := SOME (tab, nv) + | "Old" => old := SOME (tab, nv) + | _ => (); + (v, nv) + end) (#From r) fun rvOf v = case List.find (fn (v', _) => v' = v) rvs of @@ -1500,7 +1593,7 @@ fun doQuery (arg : 'a doQuery) e = inr _ => #NextVar arg () | inl e => e) (#Select r) in - k sis + k {New = !new, Old = !old, Outs = sis} end | AllCols k => let @@ -1558,9 +1651,12 @@ fun doQuery (arg : 'a doQuery) e = let fun answer e = k (Recd [(f, e)]) - val () = answer (Func (DtCon0 "Basis.bool.False", [])) val saved = #Save arg () + val () = (answer (Func (DtCon0 "Basis.bool.False", []))) + handle Cc.Contradiction => () in + #Restore arg saved; + (*print "True time!\n";*) doWhere (fn () => answer (Func (DtCon0 "Basis.bool.True", []))); #Restore arg saved end) @@ -1608,6 +1704,7 @@ fun evalPat env e (pt, _) = fun evalExp env (e as (_, loc)) k = let + (*val () = St.debug ()*) (*val () = Print.preface ("evalExp", MonoPrint.p_exp MonoEnv.empty e)*) fun default () = k (Var (St.nextVar ())) @@ -1619,7 +1716,7 @@ fun evalExp env (e as (_, loc)) k = case es of [] => k (Recd []) | e :: es => - evalExp env e (fn e => (St.send (e, loc); doArgs es)) + evalExp env e (fn e => (St.send true (e, loc); doArgs es)) in doArgs es end @@ -1673,27 +1770,30 @@ fun evalExp env (e as (_, loc)) k = app (fn (p, pe) => let val saved = St.stash () - - val env = evalPat env e p in - evalExp env pe k; - St.reinstate saved + let + val env = evalPat env e p + in + evalExp env pe k; + St.reinstate saved + end + handle Cc.Contradiction => St.reinstate saved end) pes - end handle Cc.Contradiction => ()) + end) | EStrcat (e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other "cat", [e1, e2])))) - | EError (e, _) => evalExp env e (fn e => St.send (e, loc)) + | EError (e, _) => evalExp env e (fn e => St.send true (e, loc)) | EReturnBlob {blob = b, mimeType = m, ...} => evalExp env b (fn b => - (St.send (b, loc); + (St.send true (b, loc); evalExp env m - (fn m => St.send (m, loc)))) + (fn m => St.send true (m, loc)))) | ERedirect (e, _) => - evalExp env e (fn e => St.send (e, loc)) + evalExp env e (fn e => St.send true (e, loc)) | EWrite e => - evalExp env e (fn e => (St.send (e, loc); + evalExp env e (fn e => (St.send true (e, loc); k (Recd []))) | ESeq (e1, e2) => evalExp env e1 (fn _ => evalExp env e2 k) @@ -1711,45 +1811,47 @@ fun evalExp env (e as (_, loc)) k = end | EQuery {query = q, body = b, initial = i, state = state, ...} => - evalExp env q (fn _ => - evalExp env i (fn i => - let - val saved = St.stash () - - val r = Var (St.nextVar ()) - val acc = Var (St.nextVar ()) - in - if MonoUtil.Exp.existsB {typ = fn _ => false, - exp = fn (n, e) => - case e of - ERel n' => n' = n - | _ => false, - bind = fn (n, b) => - case b of - MonoUtil.Exp.RelE _ => n + 1 - | _ => n} - 0 b then - doQuery {Env = env, - NextVar = Var o St.nextVar, - Add = fn a => St.assert [a], - Save = St.stash, - Restore = St.reinstate, - UsedExp = fn e => St.send (e, loc), - Cont = AllCols (fn _ => (St.reinstate saved; - evalExp - (acc :: r :: env) - b (fn _ => default ())))} q - else - doQuery {Env = env, - NextVar = Var o St.nextVar, - Add = fn a => St.assert [a], - Save = St.stash, - Restore = St.reinstate, - UsedExp = fn e => St.send (e, loc), - Cont = AllCols (fn x => - (St.assert [AReln (Eq, [r, x])]; - evalExp (acc :: r :: env) b k))} q - end)) + evalExp env i (fn i => + let + val saved = St.stash () + + val () = (k i) + handle Cc.Contradiction => () + val () = St.reinstate saved + + val r = Var (St.nextVar ()) + val acc = Var (St.nextVar ()) + in + if MonoUtil.Exp.existsB {typ = fn _ => false, + exp = fn (n, e) => + case e of + ERel n' => n' = n + | _ => false, + bind = fn (n, b) => + case b of + MonoUtil.Exp.RelE _ => n + 1 + | _ => n} + 0 b then + doQuery {Env = env, + NextVar = Var o St.nextVar, + Add = fn a => St.assert [a], + Save = St.stash, + Restore = St.reinstate, + UsedExp = fn e => St.send false (e, loc), + Cont = AllCols (fn _ => evalExp + (acc :: r :: env) + b (fn _ => default ()))} q + else + doQuery {Env = env, + NextVar = Var o St.nextVar, + Add = fn a => St.assert [a], + Save = St.stash, + Restore = St.reinstate, + UsedExp = fn e => St.send false (e, loc), + Cont = AllCols (fn x => + (St.assert [AReln (Eq, [r, x])]; + evalExp (acc :: r :: env) b k))} q + end) | EDml e => (case parse dml e of NONE => (print ("Warning: Information flow checker can't parse DML command at " @@ -1791,8 +1893,7 @@ fun evalExp env (e as (_, loc)) k = val saved = St.stash () in - St.assert [AReln (Sql "$Old", [Var old]), - AReln (Sql tab, [Var old])]; + St.assert [AReln (Sql (tab ^ "$Old"), [Var old])]; decomp {Save = St.stash, Restore = St.reinstate, Add = fn a => St.assert [a]} p @@ -1836,8 +1937,7 @@ fun evalExp env (e as (_, loc)) k = val saved = St.stash () in St.assert [AReln (Sql (tab ^ "$New"), [Recd fs]), - AReln (Sql "$Old", [Var old]), - AReln (Sql tab, [Var old])]; + AReln (Sql (tab ^ "$Old"), [Var old])]; decomp {Save = St.stash, Restore = St.reinstate, Add = fn a => St.assert [a]} p @@ -1858,12 +1958,12 @@ fun evalExp env (e as (_, loc)) k = | ENextval _ => default () | ESetval _ => default () - | EUnurlify ((EFfiApp ("Basis", "get_cookie", _), _), _, _) => + | EUnurlify ((EFfiApp ("Basis", "get_cookie", [(EPrim (Prim.String cname), _)]), _), _, _) => let - val nv = St.nextVar () + val e = Var (St.nextVar ()) in - St.assert [AReln (Known, [Var nv])]; - k (Var nv) + St.assert [AReln (Known, [e])]; + k e end | EUnurlify _ => default () @@ -1913,8 +2013,10 @@ fun check file = else raise Fail "Table name does not begin with uw_" end - | DVal (_, n, _, e, _) => + | DVal (x, n, _, e, _) => let + (*val () = print ("\n=== " ^ x ^ " ===\n\n");*) + val isExptd = IS.member (exptd, n) val saved = St.stash () @@ -1958,17 +2060,28 @@ fun check file = Save = fn () => !atoms, Restore = fn ls => atoms := ls, UsedExp = fn _ => (), - Cont = SomeCol (fn es => k (!atoms, es))} + Cont = SomeCol (fn r => k (rev (!atoms), r))} + + fun untab tab = List.filter (fn AReln (Sql tab', _) => tab' <> tab + | _ => true) in case pol of PolClient e => - doQ (fn (ats, es) => St.allowSend (ats, es)) e + doQ (fn (ats, {Outs = es, ...}) => St.allowSend (ats, es)) e | PolInsert e => - doQ (fn (ats, _) => St.allowInsert ats) e + doQ (fn (ats, {New = SOME (tab, new), ...}) => + St.allowInsert (AReln (Sql (tab ^ "$New"), [new]) :: untab tab ats) + | _ => raise Fail "Iflow: No New in mayInsert policy") e | PolDelete e => - doQ (fn (ats, _) => St.allowDelete ats) e + doQ (fn (ats, {Old = SOME (tab, old), ...}) => + St.allowDelete (AReln (Sql (tab ^ "$Old"), [old]) :: untab tab ats) + | _ => raise Fail "Iflow: No Old in mayDelete policy") e | PolUpdate e => - doQ (fn (ats, _) => St.allowUpdate ats) e + doQ (fn (ats, {New = SOME (tab, new), Old = SOME (_, old), ...}) => + St.allowUpdate (AReln (Sql (tab ^ "$Old"), [old]) + :: AReln (Sql (tab ^ "$New"), [new]) + :: untab tab ats) + | _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e | PolSequence e => (case #1 e of EPrim (Prim.String seq) => -- cgit v1.2.3 From 19f990b4515554027feacfc2b52c1f89f0521759 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 15 Apr 2010 08:48:41 -0400 Subject: Parsing ORDER BY --- src/iflow.sml | 31 ++++++++++++++++++++++--------- 1 file changed, 22 insertions(+), 9 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index df41ad80..06566523 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -952,6 +952,7 @@ datatype Rel = datatype sqexp = SqConst of Prim.t | Field of string * string + | Computed of string | Binop of Rel * sqexp * sqexp | SqKnown of sqexp | Inj of Mono.exp @@ -1034,6 +1035,7 @@ fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, wrap field Field, + wrap uw_ident Computed, wrap known SqKnown, wrap func SqFunc, wrap (const "COUNT(*)") (fn () => Count), @@ -1068,9 +1070,9 @@ datatype sitem = SqField of string * string | SqExp of sqexp * string -val sitem = alt (wrap field SqField) - (wrap (follow sqexp (follow (const " AS ") uw_ident)) - (fn (e, ((), s)) => SqExp (e, s))) +val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident)) + (fn (e, ((), s)) => SqExp (e, s))) + (wrap field SqField) val select = log "select" (wrap (follow (const "SELECT ") (list sitem)) @@ -1100,13 +1102,22 @@ datatype query = Query1 of query1 | Union of query * query +val orderby = log "orderby" + (wrap (follow (ws (const "ORDER BY ")) + (list sqexp)) + ignore) + fun query chs = log "query" - (alt (wrap (follow (const "((") - (follow query - (follow (const ") UNION (") - (follow query (const "))"))))) - (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) - (wrap query1 Query1)) + (wrap + (follow + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + (opt orderby)) + #1) chs datatype dml = @@ -1455,6 +1466,7 @@ fun expIn rv env rvOf = case e of SqConst p => inl (Const p) | Field (v, f) => inl (Proj (rvOf v, f)) + | Computed _ => default () | Binop (bo, e1, e2) => let val e1 = expIn e1 @@ -1567,6 +1579,7 @@ fun doQuery (arg : 'a doQuery) e = case e of SqConst _ => [] | Field (v, f) => [(v, f)] + | Computed _ => [] | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) | SqKnown _ => [] | Inj _ => [] -- cgit v1.2.3 From 6e671bc0e12dc9f2019f6f82610ef15e292964c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 15 Apr 2010 14:21:12 -0400 Subject: Check for implicit flows via expressions injected into SQL --- src/iflow.sml | 47 +++++++++++++++++++++++++---------------------- 1 file changed, 25 insertions(+), 22 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 06566523..dcdfc130 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1457,6 +1457,15 @@ fun removeDups (ls : (string * string) list) = x :: ls end +fun deinj env e = + case #1 e of + ERel n => SOME (List.nth (env, n)) + | EField (e, f) => + (case deinj env e of + NONE => NONE + | SOME e => SOME (Proj (e, f))) + | _ => NONE + fun expIn rv env rvOf = let fun expIn e = @@ -1482,15 +1491,9 @@ fun expIn rv env rvOf = inl e => inr (Reln (Known, [e])) | _ => inr Unknown) | Inj e => - let - fun deinj e = - case #1 e of - ERel n => List.nth (env, n) - | EField (e, f) => Proj (deinj e, f) - | _ => rv () - in - inl (deinj e) - end + inl (case deinj env e of + NONE => rv () + | SOME e => e) | SqFunc (f, e) => (case expIn e of inl e => inl (Func (Other f, [e])) @@ -1534,14 +1537,13 @@ type 'a doQuery = { Add : atom -> unit, Save : unit -> 'a, Restore : 'a -> unit, - UsedExp : exp -> unit, + UsedExp : bool * exp -> unit, Cont : queryMode } -fun doQuery (arg : 'a doQuery) e = +fun doQuery (arg : 'a doQuery) (e as (_, loc)) = let - fun default () = print ("Warning: Information flow checker can't parse SQL query at " - ^ ErrorMsg.spanToString (#2 e) ^ "\n") + fun default () = ErrorMsg.errorAt loc "Information flow checker can't parse SQL query" in case parse query e of NONE => default () @@ -1578,21 +1580,22 @@ fun doQuery (arg : 'a doQuery) e = fun usedFields e = case e of SqConst _ => [] - | Field (v, f) => [(v, f)] + | Field (v, f) => [(false, Proj (rvOf v, f))] | Computed _ => [] - | Binop (_, e1, e2) => removeDups (usedFields e1 @ usedFields e2) + | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 | SqKnown _ => [] - | Inj _ => [] + | Inj e => + (case deinj (#Env arg) e of + NONE => (ErrorMsg.errorAt loc "Expression injected into SQL is too complicated"; + []) + | SOME e => [(true, e)]) | SqFunc (_, e) => usedFields e | Count => [] fun doUsed () = case #Where r of NONE => () | SOME e => - #UsedExp arg (Recd (ListUtil.mapi - (fn (n, (v, f)) => (Int.toString n, - Proj (rvOf v, f))) - (usedFields e))) + app (#UsedExp arg) (usedFields e) fun normal' () = case #Cont arg of @@ -1850,7 +1853,7 @@ fun evalExp env (e as (_, loc)) k = Add = fn a => St.assert [a], Save = St.stash, Restore = St.reinstate, - UsedExp = fn e => St.send false (e, loc), + UsedExp = fn (b, e) => St.send b (e, loc), Cont = AllCols (fn _ => evalExp (acc :: r :: env) b (fn _ => default ()))} q @@ -1860,7 +1863,7 @@ fun evalExp env (e as (_, loc)) k = Add = fn a => St.assert [a], Save = St.stash, Restore = St.reinstate, - UsedExp = fn e => St.send false (e, loc), + UsedExp = fn (b, e) => St.send b (e, loc), Cont = AllCols (fn x => (St.assert [AReln (Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q -- cgit v1.2.3 From aa2a60283c30137eb6de83727f56f9fd01107bfe Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 17 Apr 2010 14:26:52 -0400 Subject: At loop heads, havoc relations that might be changed by the loop --- src/iflow.sml | 56 +++++++++++++++++++++++++++----------------------------- 1 file changed, 27 insertions(+), 29 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index dcdfc130..d93b3c38 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1837,36 +1837,34 @@ fun evalExp env (e as (_, loc)) k = val r = Var (St.nextVar ()) val acc = Var (St.nextVar ()) + + val touched = MonoUtil.Exp.fold {typ = fn (_, touched) => touched, + exp = fn (e, touched) => + case e of + EDml e => + (case parse dml e of + NONE => touched + | SOME c => + case c of + Insert _ => touched + | Delete (tab, _) => + SS.add (touched, tab) + | Update (tab, _, _) => + SS.add (touched, tab)) + | _ => touched} + SS.empty b in - if MonoUtil.Exp.existsB {typ = fn _ => false, - exp = fn (n, e) => - case e of - ERel n' => n' = n - | _ => false, - bind = fn (n, b) => - case b of - MonoUtil.Exp.RelE _ => n + 1 - | _ => n} - 0 b then - doQuery {Env = env, - NextVar = Var o St.nextVar, - Add = fn a => St.assert [a], - Save = St.stash, - Restore = St.reinstate, - UsedExp = fn (b, e) => St.send b (e, loc), - Cont = AllCols (fn _ => evalExp - (acc :: r :: env) - b (fn _ => default ()))} q - else - doQuery {Env = env, - NextVar = Var o St.nextVar, - Add = fn a => St.assert [a], - Save = St.stash, - Restore = St.reinstate, - UsedExp = fn (b, e) => St.send b (e, loc), - Cont = AllCols (fn x => - (St.assert [AReln (Eq, [r, x])]; - evalExp (acc :: r :: env) b k))} q + SS.app (St.havocReln o Sql) touched; + + doQuery {Env = env, + NextVar = Var o St.nextVar, + Add = fn a => St.assert [a], + Save = St.stash, + Restore = St.reinstate, + UsedExp = fn (b, e) => St.send b (e, loc), + Cont = AllCols (fn x => + (St.assert [AReln (Eq, [r, x])]; + evalExp (acc :: r :: env) b k))} q end) | EDml e => (case parse dml e of -- cgit v1.2.3 From 883a81ff98c4aa079a8853b2ba35e8268c47c1f9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Apr 2010 10:56:39 -0400 Subject: Parsing boolean SQL constants and fixing a related prover bug --- src/iflow.sml | 315 ++++++++++++++++++++++++++++++++-------------------------- 1 file changed, 172 insertions(+), 143 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index d93b3c38..ff0ee937 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -300,8 +300,8 @@ fun p_rep n = case !(#Rep (unNode n)) of SOME n => p_rep n | NONE => - box [string (Int.toString 0(*Unsafe.cast n*) ^ ":"), - space, + box [(*string (Int.toString (Unsafe.cast n) ^ ":"), + space,*) case #Variety (unNode n) of Nothing => string "?" | Dt0 s => string ("Dt0(" ^ s ^ ")") @@ -537,139 +537,143 @@ fun representative (db : database, e) = fun p_repOf db e = p_rep (representative (db, e)) fun assert (db, a) = - case a of - ACond _ => () - | AReln x => - case x of - (Known, [e]) => - ((*Print.prefaces "Before" [("e", p_exp e), - ("db", p_database db)];*) - markKnown (representative (db, e))(*; - Print.prefaces "After" [("e", p_exp e), - ("db", p_database db)]*)) - | (PCon0 f, [e]) => + let + fun markEq (r1, r2) = let - val r = representative (db, e) + val r1 = repOf r1 + val r2 = repOf r2 in - case #Variety (unNode r) of - Dt0 f' => if f = f' then - () - else - raise Contradiction - | Nothing => - let - val r' = ref (Node {Rep = ref NONE, - Cons = ref SM.empty, - Variety = Dt0 f, - Known = ref false}) - in - #Rep (unNode r) := SOME r' - end - | _ => raise Contradiction + if r1 = r2 then + () + else case (#Variety (unNode r1), #Variety (unNode r2)) of + (Prim p1, Prim p2) => if Prim.equal (p1, p2) then + () + else + raise Contradiction + | (Dt0 f1, Dt0 f2) => if f1 = f2 then + () + else + raise Contradiction + | (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then + markEq (r1, r2) + else + raise Contradiction + | (Recrd (xes1, _), Recrd (xes2, _)) => + let + fun unif (xes1, xes2) = + SM.appi (fn (x, r1) => + case SM.find (!xes2, x) of + NONE => xes2 := SM.insert (!xes2, x, r1) + | SOME r2 => markEq (r1, r2)) (!xes1) + in + unif (xes1, xes2); + unif (xes2, xes1) + end + | (Nothing, _) => mergeNodes (r1, r2) + | (_, Nothing) => mergeNodes (r2, r1) + | _ => raise Contradiction end - | (PCon1 f, [e]) => + + and mergeNodes (r1, r2) = + (#Rep (unNode r1) := SOME r2; + if !(#Known (unNode r1)) then + markKnown r2 + else + (); + if !(#Known (unNode r2)) then + markKnown r1 + else + (); + #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); + + compactFuncs ()) + + and compactFuncs () = let - val r = representative (db, e) + fun loop funcs = + case funcs of + [] => [] + | (fr as ((f, rs), r)) :: rest => + let + val rest = List.filter (fn ((f' : string, rs'), r') => + if f' = f + andalso ListPair.allEq (fn (r1, r2) => + repOf r1 = repOf r2) + (rs, rs') then + (markEq (r, r'); + false) + else + true) rest + in + fr :: loop rest + end in - case #Variety (unNode r) of - Dt1 (f', e') => if f = f' then - () - else - raise Contradiction - | Nothing => - let - val r'' = ref (Node {Rep = ref NONE, - Cons = ref SM.empty, - Variety = Nothing, - Known = ref (!(#Known (unNode r)))}) - - val r' = ref (Node {Rep = ref NONE, - Cons = ref SM.empty, - Variety = Dt1 (f, r''), - Known = #Known (unNode r)}) - in - #Rep (unNode r) := SOME r' - end - | _ => raise Contradiction + #Funcs db := loop (!(#Funcs db)) end - | (Eq, [e1, e2]) => - let - fun markEq (r1, r2) = - let - val r1 = repOf r1 - val r2 = repOf r2 - in - if r1 = r2 then - () - else case (#Variety (unNode r1), #Variety (unNode r2)) of - (Prim p1, Prim p2) => if Prim.equal (p1, p2) then - () - else - raise Contradiction - | (Dt0 f1, Dt0 f2) => if f1 = f2 then - () - else - raise Contradiction - | (Dt1 (f1, r1), Dt1 (f2, r2)) => if f1 = f2 then - markEq (r1, r2) - else - raise Contradiction - | (Recrd (xes1, _), Recrd (xes2, _)) => - let - fun unif (xes1, xes2) = - SM.appi (fn (x, r1) => - case SM.find (!xes2, x) of - NONE => xes2 := SM.insert (!xes2, x, r1) - | SOME r2 => markEq (r1, r2)) (!xes1) - in - unif (xes1, xes2); - unif (xes2, xes1) - end - | (Nothing, _) => mergeNodes (r1, r2) - | (_, Nothing) => mergeNodes (r2, r1) - | _ => raise Contradiction - end + in + case a of + ACond _ => () + | AReln x => + case x of + (Known, [e]) => + ((*Print.prefaces "Before" [("e", p_exp e), + ("db", p_database db)];*) + markKnown (representative (db, e))(*; + Print.prefaces "After" [("e", p_exp e), + ("db", p_database db)]*)) + | (PCon0 f, [e]) => + let + val r = representative (db, e) + in + case #Variety (unNode r) of + Dt0 f' => if f = f' then + () + else + raise Contradiction + | Nothing => + (case SM.find (!(#Con0s db), f) of + SOME r' => markEq (r, r') + | NONE => + let + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt0 f, + Known = ref false}) + in + #Rep (unNode r) := SOME r'; + #Con0s db := SM.insert (!(#Con0s db), f, r') + end) + | _ => raise Contradiction + end + | (PCon1 f, [e]) => + let + val r = representative (db, e) + in + case #Variety (unNode r) of + Dt1 (f', e') => if f = f' then + () + else + raise Contradiction + | Nothing => + let + val r'' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Nothing, + Known = ref (!(#Known (unNode r)))}) - and mergeNodes (r1, r2) = - (#Rep (unNode r1) := SOME r2; - if !(#Known (unNode r1)) then - markKnown r2 - else - (); - if !(#Known (unNode r2)) then - markKnown r1 - else - (); - #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); - - compactFuncs ()) - - and compactFuncs () = - let - fun loop funcs = - case funcs of - [] => [] - | (fr as ((f, rs), r)) :: rest => - let - val rest = List.filter (fn ((f' : string, rs'), r') => - if f' = f - andalso ListPair.allEq (fn (r1, r2) => - repOf r1 = repOf r2) - (rs, rs') then - (markEq (r, r'); - false) - else - true) rest - in - fr :: loop rest - end - in - #Funcs db := loop (!(#Funcs db)) - end - in + val r' = ref (Node {Rep = ref NONE, + Cons = ref SM.empty, + Variety = Dt1 (f, r''), + Known = #Known (unNode r)}) + in + #Rep (unNode r) := SOME r' + end + | _ => raise Contradiction + end + | (Eq, [e1, e2]) => markEq (representative (db, e1), representative (db, e2)) - end - | _ => () + | _ => () + end fun check (db, a) = case a of @@ -951,6 +955,8 @@ datatype Rel = datatype sqexp = SqConst of Prim.t + | SqTrue + | SqFalse | Field of string * string | Computed of string | Binop of Rel * sqexp * sqexp @@ -1021,6 +1027,12 @@ fun sqlify chs = SOME (e, chs) else NONE + | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String "TRUE"), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String "FALSE"), _))], _), _) :: chs => + SOME (e, chs) + | _ => NONE fun constK s = wrap (const s) (fn () => s) @@ -1034,6 +1046,8 @@ val funcName = altL [constK "COUNT", fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, + wrap (const "TRUE") (fn () => SqTrue), + wrap (const "FALSE") (fn () => SqFalse), wrap field Field, wrap uw_ident Computed, wrap known SqKnown, @@ -1104,8 +1118,9 @@ datatype query = val orderby = log "orderby" (wrap (follow (ws (const "ORDER BY ")) - (list sqexp)) - ignore) + (follow (list sqexp) + (opt (ws (const "DESC"))))) + ignore) fun query chs = log "query" (wrap @@ -1266,7 +1281,7 @@ fun checkGoals goals k = in tryAll unifs hyps end - | AReln (r, es) :: goals => + | (g as AReln (r, es)) :: goals => Cc.check (db, AReln (r, map (simplify unifs) es)) andalso checkGoals goals unifs | ACond _ :: _ => false @@ -1352,7 +1367,8 @@ fun buildable uk (e, loc) = in ErrorMsg.errorAt loc "The information flow policy may be violated here."; Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), - ("User learns", p_exp e)] + ("User learns", p_exp e), + ("E-graph", Cc.p_database db)] end end @@ -1371,7 +1387,7 @@ fun checkPaths () = end fun allowSend v = ((*Print.prefaces "Allow" [("goals", Print.p_list p_atom (#1 v)), - ("exps", Print.p_list p_exp (#2 v))];*) + ("exps", Print.p_list p_exp (#2 v))];*) sendable := v :: !sendable) fun send uk (e, loc) = ((*Print.preface ("Send", p_exp e);*) @@ -1474,6 +1490,8 @@ fun expIn rv env rvOf = in case e of SqConst p => inl (Const p) + | SqTrue => inl (Func (DtCon0 "Basis.bool.True", [])) + | SqFalse => inl (Func (DtCon0 "Basis.bool.False", [])) | Field (v, f) => inl (Proj (rvOf v, f)) | Computed _ => default () | Binop (bo, e1, e2) => @@ -1483,7 +1501,15 @@ fun expIn rv env rvOf = in inr (case (bo, e1, e2) of (Exps f, inl e1, inl e2) => f (e1, e2) - | (Props f, inr p1, inr p2) => f (p1, p2) + | (Props f, v1, v2) => + let + fun pin v = + case v of + inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + | inr p => p + in + f (pin v1, pin v2) + end | _ => Unknown) end | SqKnown e => @@ -1580,6 +1606,8 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun usedFields e = case e of SqConst _ => [] + | SqTrue => [] + | SqFalse => [] | Field (v, f) => [(false, Proj (rvOf v, f))] | Computed _ => [] | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 @@ -1643,16 +1671,17 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = case #Where r of NONE => (doUsed (); final ()) | SOME e => - case expIn e of - inl _ => (doUsed (); final ()) - | inr p => - let - val saved = #Save arg () - in - decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} - p (fn () => (doUsed (); final ()) handle Cc.Contradiction => ()); - #Restore arg saved - end) + let + val p = case expIn e of + inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) + | inr p => p + + val saved = #Save arg () + in + decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} + p (fn () => (doUsed (); final ()) handle Cc.Contradiction => ()); + #Restore arg saved + end) handle Cc.Contradiction => () fun normal () = doWhere normal' -- cgit v1.2.3 From e5e3f392f94ee1064aab063be6b4033b5b5515c5 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Apr 2010 13:00:36 -0400 Subject: Use key information in more places, and catch cases where one key completion depends on another having happened already --- src/iflow.sml | 306 ++++++++++++++++++++++++++++------------------------------ 1 file changed, 149 insertions(+), 157 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index ff0ee937..c1205876 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -248,6 +248,18 @@ structure Cc :> sig val p_repOf : database -> exp Print.printer end = struct +local + val count = ref 0 +in +fun nodeId () = + let + val n = !count + in + count := n + 1; + n + end +end + exception Contradiction exception Undetermined @@ -256,7 +268,8 @@ structure CM = BinaryMapFn(struct val compare = Prim.compare end) -datatype node = Node of {Rep : node ref option ref, +datatype node = Node of {Id : int, + Rep : node ref option ref, Cons : node ref SM.map ref, Variety : variety, Known : bool ref} @@ -300,8 +313,8 @@ fun p_rep n = case !(#Rep (unNode n)) of SOME n => p_rep n | NONE => - box [(*string (Int.toString (Unsafe.cast n) ^ ":"), - space,*) + box [string (Int.toString (#Id (unNode n)) ^ ":"), + space, case #Variety (unNode n) of Nothing => string "?" | Dt0 s => string ("Dt0(" ^ s ^ ")") @@ -372,7 +385,8 @@ fun representative (db : database, e) = SOME r => repOf r | NONE => let - val r = ref (Node {Rep = ref NONE, + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Prim p, Known = ref true}) @@ -384,7 +398,8 @@ fun representative (db : database, e) = SOME r => repOf r | NONE => let - val r = ref (Node {Rep = ref NONE, + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, Known = ref false}) @@ -397,7 +412,8 @@ fun representative (db : database, e) = SOME r => repOf r | NONE => let - val r = ref (Node {Rep = ref NONE, + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Dt0 f, Known = ref true}) @@ -414,7 +430,8 @@ fun representative (db : database, e) = SOME r => repOf r | NONE => let - val r' = ref (Node {Rep = ref NONE, + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r), Known = ref (!(#Known (unNode r)))}) @@ -436,12 +453,14 @@ fun representative (db : database, e) = | Nothing => let val cons = ref SM.empty - val r' = ref (Node {Rep = ref NONE, + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = cons, Variety = Nothing, Known = ref (!(#Known (unNode r)))}) - val r'' = ref (Node {Rep = ref NONE, + val r'' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = #Cons (unNode r), Variety = Dt1 (f, r'), Known = #Known (unNode r)}) @@ -460,7 +479,8 @@ fun representative (db : database, e) = case List.find (fn (x : string * representative list, _) => x = (f, rs)) (!(#Funcs db)) of NONE => let - val r = ref (Node {Rep = ref NONE, + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, Known = ref false}) @@ -487,7 +507,8 @@ fun representative (db : database, e) = let val xes = foldl SM.insert' SM.empty xes - val r' = ref (Node {Rep = ref NONE, + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Recrd (ref xes, true), Known = ref false}) @@ -505,7 +526,8 @@ fun representative (db : database, e) = (case SM.find (!xes, f) of SOME r => repOf r | NONE => let - val r = ref (Node {Rep = ref NONE, + val r = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, Known = ref (!(#Known (unNode r)))}) @@ -515,12 +537,14 @@ fun representative (db : database, e) = end) | Nothing => let - val r' = ref (Node {Rep = ref NONE, + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, Known = ref (!(#Known (unNode r)))}) - val r'' = ref (Node {Rep = ref NONE, + val r'' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = #Cons (unNode r), Variety = Recrd (ref (SM.insert (SM.empty, f, r')), false), Known = #Known (unNode r)}) @@ -635,7 +659,8 @@ fun assert (db, a) = SOME r' => markEq (r, r') | NONE => let - val r' = ref (Node {Rep = ref NONE, + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Dt0 f, Known = ref false}) @@ -656,12 +681,14 @@ fun assert (db, a) = raise Contradiction | Nothing => let - val r'' = ref (Node {Rep = ref NONE, + val r'' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, Known = ref (!(#Known (unNode r)))}) - val r' = ref (Node {Rep = ref NONE, + val r' = ref (Node {Id = nodeId (), + Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r''), Known = #Known (unNode r)}) @@ -744,65 +771,6 @@ end val tabs = ref (SM.empty : (string list * string list list) SM.map) -fun ccOf hyps = - let - val cc = Cc.database () - val () = app (fn a => Cc.assert (cc, a)) hyps - - (* Take advantage of table key information *) - fun findKeys hyps = - case hyps of - [] => () - | AReln (Sql tab, [r1]) :: hyps => - (case SM.find (!tabs, tab) of - NONE => findKeys hyps - | SOME (_, []) => findKeys hyps - | SOME (_, ks) => - let - fun finder hyps = - case hyps of - [] => () - | AReln (Sql tab', [r2]) :: hyps => - (if tab' = tab andalso - List.exists (List.all (fn f => - let - val r = - Cc.check (cc, - AReln (Eq, [Proj (r1, f), - Proj (r2, f)])) - in - (*Print.prefaces "Fs" - [("tab", - Print.PD.string tab), - ("r1", - p_exp (Proj (r1, f))), - ("r2", - p_exp (Proj (r2, f))), - ("r", - Print.PD.string - (Bool.toString r))];*) - r - end)) ks then - ((*Print.prefaces "Key match" [("tab", Print.PD.string tab), - ("r1", p_exp r1), - ("r2", p_exp r2), - ("rp1", Cc.p_repOf cc r1), - ("rp2", Cc.p_repOf cc r2)];*) - Cc.assert (cc, AReln (Eq, [r1, r2]))) - else - (); - finder hyps) - | _ :: hyps => finder hyps - in - finder hyps; - findKeys hyps - end) - | _ :: hyps => findKeys hyps - in - findKeys hyps; - cc - end - fun patCon pc = case pc of PConVar n => "C" ^ Int.toString n @@ -1212,27 +1180,105 @@ end = struct val hnames = ref 1 -type hyps = int * atom list +type hyps = int * atom list * bool ref val db = Cc.database () -val path = ref ([] : (hyps * check) option ref list) -val hyps = ref (0, [] : atom list) +val path = ref ([] : ((int * atom list) * check) option ref list) +val hyps = ref (0, [] : atom list, ref false) val nvar = ref 0 -fun setHyps (h as (n', hs)) = +fun setHyps (n', hs) = let - val (n, _) = !hyps + val (n, _, _) = !hyps in if n' = n then () else - (hyps := h; + (hyps := (n', hs, ref false); Cc.clear db; app (fn a => Cc.assert (db, a)) hs) end -type stashed = int * (hyps * check) option ref list * (int * atom list) -fun stash () = (!nvar, !path, !hyps) +fun useKeys () = + let + val changed = ref false + + fun findKeys (hyps, acc) = + case hyps of + [] => acc + | (a as AReln (Sql tab, [r1])) :: hyps => + (case SM.find (!tabs, tab) of + NONE => findKeys (hyps, a :: acc) + | SOME (_, []) => findKeys (hyps, a :: acc) + | SOME (_, ks) => + let + fun finder (hyps, acc) = + case hyps of + [] => acc + | (a as AReln (Sql tab', [r2])) :: hyps => + if tab' = tab andalso + List.exists (List.all (fn f => + let + val r = + Cc.check (db, + AReln (Eq, [Proj (r1, f), + Proj (r2, f)])) + in + (*Print.prefaces "Fs" + [("tab", + Print.PD.string tab), + ("r1", + p_exp (Proj (r1, f))), + ("r2", + p_exp (Proj (r2, f))), + ("r", + Print.PD.string + (Bool.toString r))];*) + r + end)) ks then + (changed := true; + Cc.assert (db, AReln (Eq, [r1, r2])); + finder (hyps, acc)) + else + finder (hyps, a :: acc) + | a :: hyps => finder (hyps, a :: acc) + + val hyps = finder (hyps, []) + in + findKeys (hyps, acc) + end) + | a :: hyps => findKeys (hyps, a :: acc) + + fun loop hs = + let + val hs = findKeys (hs, []) + in + if !changed then + (changed := false; + loop hs) + else + () + end + + val (_, hs, _) = !hyps + in + (*print "findKeys\n";*) + loop hs + end + +fun complete () = + let + val (_, _, bf) = !hyps + in + if !bf then + () + else + (bf := true; + useKeys ()) + end + +type stashed = int * ((int * atom list) * check) option ref list * (int * atom list) +fun stash () = (!nvar, !path, (#1 (!hyps), #2 (!hyps))) fun reinstate (nv, p, h) = (nvar := nv; path := p; @@ -1249,14 +1295,14 @@ fun nextVar () = fun assert ats = let val n = !hnames - val (_, hs) = !hyps + val (_, hs, _) = !hyps in hnames := n + 1; - hyps := (n, ats @ hs); + hyps := (n, ats @ hs, ref false); app (fn a => Cc.assert (db, a)) ats end -fun addPath c = path := ref (SOME (!hyps, c)) :: !path +fun addPath c = path := ref (SOME ((#1 (!hyps), #2 (!hyps)), c)) :: !path val sendable = ref ([] : (atom list * exp list) list) @@ -1268,7 +1314,7 @@ fun checkGoals goals k = | AReln (Sql tab, [Lvar lv]) :: goals => let val saved = stash () - val (_, hyps) = !hyps + val (_, hyps, _) = !hyps fun tryAll unifs hyps = case hyps of @@ -1282,70 +1328,14 @@ fun checkGoals goals k = tryAll unifs hyps end | (g as AReln (r, es)) :: goals => - Cc.check (db, AReln (r, map (simplify unifs) es)) - andalso checkGoals goals unifs + (complete (); + Cc.check (db, AReln (r, map (simplify unifs) es)) + andalso checkGoals goals unifs) | ACond _ :: _ => false in checkGoals goals IM.empty end -fun useKeys () = - let - fun findKeys hyps = - case hyps of - [] => () - | AReln (Sql tab, [r1]) :: hyps => - (case SM.find (!tabs, tab) of - NONE => findKeys hyps - | SOME (_, []) => findKeys hyps - | SOME (_, ks) => - let - fun finder hyps = - case hyps of - [] => () - | AReln (Sql tab', [r2]) :: hyps => - (if tab' = tab andalso - List.exists (List.all (fn f => - let - val r = - Cc.check (db, - AReln (Eq, [Proj (r1, f), - Proj (r2, f)])) - in - (*Print.prefaces "Fs" - [("tab", - Print.PD.string tab), - ("r1", - p_exp (Proj (r1, f))), - ("r2", - p_exp (Proj (r2, f))), - ("r", - Print.PD.string - (Bool.toString r))];*) - r - end)) ks then - ((*Print.prefaces "Key match" [("tab", Print.PD.string tab), - ("r1", p_exp r1), - ("r2", p_exp r2), - ("rp1", Cc.p_repOf cc r1), - ("rp2", Cc.p_repOf cc r2)];*) - Cc.assert (db, AReln (Eq, [r1, r2]))) - else - (); - finder hyps) - | _ :: hyps => finder hyps - in - finder hyps; - findKeys hyps - end) - | _ :: hyps => findKeys hyps - - val (_, hs) = !hyps - in - (*print "findKeys\n";*) - findKeys hs - end - fun buildable uk (e, loc) = let fun doPols pols acc = @@ -1358,23 +1348,23 @@ fun buildable uk (e, loc) = checkGoals goals (fn unifs => doPols pols (map (simplify unifs) es @ acc)) orelse doPols pols acc in - useKeys (); if doPols (!sendable) [] then () else let - val (_, hs) = !hyps + val (_, hs, _) = !hyps in ErrorMsg.errorAt loc "The information flow policy may be violated here."; Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), - ("User learns", p_exp e), - ("E-graph", Cc.p_database db)] + ("User learns", p_exp e)(*, + ("E-graph", Cc.p_database db)*)] end end fun checkPaths () = let - val hs = !hyps + val (n, hs, _) = !hyps + val hs = (n, hs) in app (fn r => case !r of @@ -1391,6 +1381,7 @@ fun allowSend v = ((*Print.prefaces "Allow" [("goals", Print.p_list p_atom (#1 v sendable := v :: !sendable) fun send uk (e, loc) = ((*Print.preface ("Send", p_exp e);*) + complete (); checkPaths (); if isKnown e then () @@ -1401,6 +1392,7 @@ fun doable pols (loc : ErrorMsg.span) = let val pols = !pols in + complete (); if List.exists (fn goals => if checkGoals goals (fn _ => true) then ((*Print.prefaces "Match" [("goals", Print.p_list p_atom goals), @@ -1413,7 +1405,7 @@ fun doable pols (loc : ErrorMsg.span) = () else let - val (_, hs) = !hyps + val (_, hs, _) = !hyps in ErrorMsg.errorAt loc "The database update policy may be violated here."; Print.preface ("Hypotheses", Print.p_list p_atom hs) @@ -1434,7 +1426,7 @@ val delete = doable deletable fun reset () = (Cc.clear db; path := []; - hyps := (0, []); + hyps := (0, [], ref false); nvar := 0; sendable := []; insertable := []; @@ -1444,15 +1436,15 @@ fun reset () = (Cc.clear db; fun havocReln r = let val n = !hnames - val (_, hs) = !hyps + val (_, hs, _) = !hyps in hnames := n + 1; - hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs) + hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs, ref false) end fun debug () = let - val (_, hs) = !hyps + val (_, hs, _) = !hyps in Print.preface ("Hyps", Print.p_list p_atom hs) end -- cgit v1.2.3 From fafc70c0add76e6c5d9b174afd38fd99ed6ae4ef Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Apr 2010 13:56:47 -0400 Subject: Take advantage of equalities between get_cookie calls --- src/iflow.sml | 142 +++++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 110 insertions(+), 32 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index c1205876..5a5b99c9 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -272,7 +272,8 @@ datatype node = Node of {Id : int, Rep : node ref option ref, Cons : node ref SM.map ref, Variety : variety, - Known : bool ref} + Known : bool ref, + Ge : Int64.int option ref} and variety = Dt0 of string @@ -334,7 +335,14 @@ fun p_rep n = box [space, string "(complete)"] else - box []]] + box []], + if !(#Known (unNode n)) then + string " (known)" + else + box [], + case !(#Ge (unNode n)) of + NONE => box [] + | SOME n => string (" (>= " ^ Int64.toString n ^ ")")] fun p_database (db : database) = box [string "Vars:", @@ -343,12 +351,7 @@ fun p_database (db : database) = space, string "=", space, - p_rep n, - if !(#Known (unNode n)) then - box [space, - string "(known)"] - else - box []]) (IM.listItemsi (!(#Vars db)))] + p_rep n]) (IM.listItemsi (!(#Vars db)))] fun repOf (n : representative) : representative = case !(#Rep (unNode n)) of @@ -389,7 +392,10 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Prim p, - Known = ref true}) + Known = ref true, + Ge = ref (case p of + Prim.Int n => SOME n + | _ => NONE)}) in #Consts db := CM.insert (!(#Consts db), p, r); r @@ -402,7 +408,8 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref false}) + Known = ref false, + Ge = ref NONE}) in #Vars db := IM.insert (!(#Vars db), n, r); r @@ -416,7 +423,8 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Dt0 f, - Known = ref true}) + Known = ref true, + Ge = ref NONE}) in #Con0s db := SM.insert (!(#Con0s db), f, r); r @@ -434,7 +442,8 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r), - Known = ref (!(#Known (unNode r)))}) + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) in #Cons (unNode r) := SM.insert (!(#Cons (unNode r)), f, r'); r' @@ -457,13 +466,15 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = cons, Variety = Nothing, - Known = ref (!(#Known (unNode r)))}) + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = #Cons (unNode r), Variety = Dt1 (f, r'), - Known = #Known (unNode r)}) + Known = #Known (unNode r), + Ge = ref NONE}) in cons := SM.insert (!cons, f, r''); #Rep (unNode r) := SOME r''; @@ -483,7 +494,8 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref false}) + Known = ref false, + Ge = ref NONE}) in #Funcs db := ((f, rs), r) :: (!(#Funcs db)); r @@ -511,7 +523,8 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Recrd (ref xes, true), - Known = ref false}) + Known = ref false, + Ge = ref NONE}) in #Records db := (xes, r') :: (!(#Records db)); r' @@ -530,7 +543,8 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref (!(#Known (unNode r)))}) + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) in xes := SM.insert (!xes, f, r); r @@ -541,13 +555,15 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref (!(#Known (unNode r)))}) + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = #Cons (unNode r), Variety = Recrd (ref (SM.insert (SM.empty, f, r')), false), - Known = #Known (unNode r)}) + Known = #Known (unNode r), + Ge = ref NONE}) in #Rep (unNode r) := SOME r''; r' @@ -610,6 +626,13 @@ fun assert (db, a) = (); #Cons (unNode r2) := SM.unionWith #1 (!(#Cons (unNode r2)), !(#Cons (unNode r1))); + case !(#Ge (unNode r1)) of + NONE => () + | SOME n1 => + case !(#Ge (unNode r2)) of + NONE => #Ge (unNode r2) := SOME n1 + | SOME n2 => #Ge (unNode r2) := SOME (Int64.max (n1, n2)); + compactFuncs ()) and compactFuncs () = @@ -663,7 +686,8 @@ fun assert (db, a) = Rep = ref NONE, Cons = ref SM.empty, Variety = Dt0 f, - Known = ref false}) + Known = ref false, + Ge = ref NONE}) in #Rep (unNode r) := SOME r'; #Con0s db := SM.insert (!(#Con0s db), f, r') @@ -685,13 +709,15 @@ fun assert (db, a) = Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref (!(#Known (unNode r)))}) + Known = ref (!(#Known (unNode r))), + Ge = ref NONE}) val r' = ref (Node {Id = nodeId (), Rep = ref NONE, Cons = ref SM.empty, Variety = Dt1 (f, r''), - Known = #Known (unNode r)}) + Known = #Known (unNode r), + Ge = ref NONE}) in #Rep (unNode r) := SOME r' end @@ -699,6 +725,18 @@ fun assert (db, a) = end | (Eq, [e1, e2]) => markEq (representative (db, e1), representative (db, e2)) + | (Ge, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + case !(#Ge (unNode (repOf r2))) of + NONE => () + | SOME n2 => + case !(#Ge (unNode (repOf r1))) of + NONE => #Ge (unNode (repOf r1)) := SOME n2 + | SOME n1 => #Ge (unNode (repOf r1)) := SOME (Int64.max (n1, n2)) + end | _ => () end @@ -739,6 +777,15 @@ fun check (db, a) = in repOf r1 = repOf r2 end + | (Ge, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + case (!(#Ge (unNode (repOf r1))), #Variety (unNode (repOf r2))) of + (SOME n1, Prim (Prim.Int n2)) => Int64.>= (n1, n2) + | _ => false + end | _ => false fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = @@ -931,7 +978,7 @@ datatype sqexp = | SqKnown of sqexp | Inj of Mono.exp | SqFunc of string * sqexp - | Count + | Unmodeled fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) @@ -1011,6 +1058,9 @@ val funcName = altL [constK "COUNT", constK "SUM", constK "AVG"] +val unmodeled = altL [const "COUNT(*)", + const "CURRENT_TIMESTAMP"] + fun sqexp chs = log "sqexp" (altL [wrap prim SqConst, @@ -1020,7 +1070,7 @@ fun sqexp chs = wrap uw_ident Computed, wrap known SqKnown, wrap func SqFunc, - wrap (const "COUNT(*)") (fn () => Count), + wrap unmodeled (fn () => Unmodeled), wrap sqlify Inj, wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") (follow (keep (fn ch => ch <> #")")) (const ")"))))) @@ -1174,6 +1224,7 @@ structure St :> sig val update : ErrorMsg.span -> unit val havocReln : reln -> unit + val havocCookie : string -> unit val debug : unit -> unit end = struct @@ -1329,7 +1380,11 @@ fun checkGoals goals k = end | (g as AReln (r, es)) :: goals => (complete (); - Cc.check (db, AReln (r, map (simplify unifs) es)) + (if Cc.check (db, AReln (r, map (simplify unifs) es)) then + true + else + ((*Print.preface ("Fail", p_atom (AReln (r, map (simplify unifs) es)));*) + false)) andalso checkGoals goals unifs) | ACond _ :: _ => false in @@ -1355,8 +1410,8 @@ fun buildable uk (e, loc) = val (_, hs, _) = !hyps in ErrorMsg.errorAt loc "The information flow policy may be violated here."; - Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), - ("User learns", p_exp e)(*, + Print.prefaces "Situation" [("User learns", p_exp e), + ("Hypotheses", Print.p_list p_atom hs)(*, ("E-graph", Cc.p_database db)*)] end end @@ -1408,7 +1463,8 @@ fun doable pols (loc : ErrorMsg.span) = val (_, hs, _) = !hyps in ErrorMsg.errorAt loc "The database update policy may be violated here."; - Print.preface ("Hypotheses", Print.p_list p_atom hs) + Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs)(*, + ("E-graph", Cc.p_database db)*)] end end @@ -1442,6 +1498,16 @@ fun havocReln r = hyps := (n, List.filter (fn AReln (r', _) => r' <> r | _ => true) hs, ref false) end +fun havocCookie cname = + let + val cname = "cookie/" ^ cname + val n = !hnames + val (_, hs, _) = !hyps + in + hnames := n + 1; + hyps := (n, List.filter (fn AReln (Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) + end + fun debug () = let val (_, hs, _) = !hyps @@ -1517,7 +1583,7 @@ fun expIn rv env rvOf = inl e => inl (Func (Other f, [e])) | _ => default ()) - | Count => default () + | Unmodeled => default () end in expIn @@ -1610,7 +1676,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = []) | SOME e => [(true, e)]) | SqFunc (_, e) => usedFields e - | Count => [] + | Unmodeled => [] fun doUsed () = case #Where r of NONE => () @@ -1751,7 +1817,18 @@ fun evalExp env (e as (_, loc)) k = let fun doArgs es = case es of - [] => k (Recd []) + [] => + (if s = "set_cookie" then + case es of + [_, cname, _, _, _] => + (case #1 cname of + EPrim (Prim.String cname) => + St.havocCookie cname + | _ => ()) + | _ => () + else + (); + k (Recd [])) | e :: es => evalExp env e (fn e => (St.send true (e, loc); doArgs es)) in @@ -1996,8 +2073,9 @@ fun evalExp env (e as (_, loc)) k = | EUnurlify ((EFfiApp ("Basis", "get_cookie", [(EPrim (Prim.String cname), _)]), _), _, _) => let val e = Var (St.nextVar ()) + val e' = Func (Other ("cookie/" ^ cname), []) in - St.assert [AReln (Known, [e])]; + St.assert [AReln (Known, [e]), AReln (Eq, [e, e'])]; k e end -- cgit v1.2.3 From 06865640e7d3d210ba2538d0510c5d5678c5c07f Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Apr 2010 14:52:13 -0400 Subject: Better handling of DELETE and UPDATE --- src/iflow.sml | 32 +++++++++++++++++--------------- 1 file changed, 17 insertions(+), 15 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 5a5b99c9..f35e82e8 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -798,12 +798,12 @@ fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = in (uk andalso !(#Known (unNode d))) orelse List.exists (fn b => repOf b = d) bs - orelse case #Variety (unNode d) of - Dt0 _ => true - | Dt1 (_, d) => loop d - | Prim _ => true - | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) - | Nothing => false + orelse (case #Variety (unNode d) of + Dt0 _ => true + | Dt1 (_, d) => loop d + | Prim _ => true + | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) + | Nothing => false) end fun decomp e = @@ -1296,7 +1296,7 @@ fun useKeys () = val hyps = finder (hyps, []) in - findKeys (hyps, acc) + findKeys (hyps, a :: acc) end) | a :: hyps => findKeys (hyps, a :: acc) @@ -1313,7 +1313,7 @@ fun useKeys () = val (_, hs, _) = !hyps in - (*print "findKeys\n";*) + (*print "useKeys\n";*) loop hs end @@ -1411,10 +1411,10 @@ fun buildable uk (e, loc) = in ErrorMsg.errorAt loc "The information flow policy may be violated here."; Print.prefaces "Situation" [("User learns", p_exp e), - ("Hypotheses", Print.p_list p_atom hs)(*, - ("E-graph", Cc.p_database db)*)] + ("Hypotheses", Print.p_list p_atom hs), + ("E-graph", Cc.p_database db)] end - end + end fun checkPaths () = let @@ -1454,8 +1454,8 @@ fun doable pols (loc : ErrorMsg.span) = ("hyps", Print.p_list p_atom (#2 (!hyps)))];*) true) else - ((*Print.prefaces "No match" [("goals", Print.p_list p_atom goals), - ("hyps", Print.p_list p_atom (#2 (!hyps)))];*) + ((*Print.prefaces "No match" [("goals", Print.p_list p_atom goals)(*, + ("hyps", Print.p_list p_atom (#2 (!hyps)))*)];*) false)) pols then () else @@ -2005,7 +2005,8 @@ fun evalExp env (e as (_, loc)) k = val saved = St.stash () in - St.assert [AReln (Sql (tab ^ "$Old"), [Var old])]; + St.assert [AReln (Sql (tab ^ "$Old"), [Var old]), + AReln (Sql (tab), [Var old])]; decomp {Save = St.stash, Restore = St.reinstate, Add = fn a => St.assert [a]} p @@ -2049,7 +2050,8 @@ fun evalExp env (e as (_, loc)) k = val saved = St.stash () in St.assert [AReln (Sql (tab ^ "$New"), [Recd fs]), - AReln (Sql (tab ^ "$Old"), [Var old])]; + AReln (Sql (tab ^ "$Old"), [Var old]), + AReln (Sql tab, [Var old])]; decomp {Save = St.stash, Restore = St.reinstate, Add = fn a => St.assert [a]} p -- cgit v1.2.3 From b791d89df86efa83df863a9a5ac4e4e7dab0efc8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Apr 2010 15:54:37 -0400 Subject: Fix innappropriate removal of duplicate tables from DML policies --- src/iflow.sml | 121 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 62 insertions(+), 59 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index f35e82e8..1b20f0d1 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -233,7 +233,6 @@ structure Cc :> sig type database exception Contradiction - exception Undetermined val database : unit -> database val clear : database -> unit @@ -738,55 +737,56 @@ fun assert (db, a) = | SOME n1 => #Ge (unNode (repOf r1)) := SOME (Int64.max (n1, n2)) end | _ => () - end + end handle Undetermined => () fun check (db, a) = - case a of - ACond _ => false - | AReln x => - case x of - (Known, [e]) => - let - fun isKnown r = - let - val r = repOf r - in - !(#Known (unNode r)) - orelse case #Variety (unNode r) of - Dt1 (_, r) => isKnown r - | Recrd (xes, true) => List.all isKnown (SM.listItems (!xes)) - | _ => false - end + (case a of + ACond _ => false + | AReln x => + case x of + (Known, [e]) => + let + fun isKnown r = + let + val r = repOf r + in + !(#Known (unNode r)) + orelse case #Variety (unNode r) of + Dt1 (_, r) => isKnown r + | Recrd (xes, true) => List.all isKnown (SM.listItems (!xes)) + | _ => false + end - val r = representative (db, e) - in - isKnown r - end - | (PCon0 f, [e]) => - (case #Variety (unNode (representative (db, e))) of - Dt0 f' => f' = f - | _ => false) - | (PCon1 f, [e]) => - (case #Variety (unNode (representative (db, e))) of - Dt1 (f', _) => f' = f - | _ => false) - | (Eq, [e1, e2]) => - let - val r1 = representative (db, e1) - val r2 = representative (db, e2) - in - repOf r1 = repOf r2 - end - | (Ge, [e1, e2]) => - let - val r1 = representative (db, e1) - val r2 = representative (db, e2) - in - case (!(#Ge (unNode (repOf r1))), #Variety (unNode (repOf r2))) of - (SOME n1, Prim (Prim.Int n2)) => Int64.>= (n1, n2) - | _ => false - end - | _ => false + val r = representative (db, e) + in + isKnown r + end + | (PCon0 f, [e]) => + (case #Variety (unNode (representative (db, e))) of + Dt0 f' => f' = f + | _ => false) + | (PCon1 f, [e]) => + (case #Variety (unNode (representative (db, e))) of + Dt1 (f', _) => f' = f + | _ => false) + | (Eq, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + repOf r1 = repOf r2 + end + | (Ge, [e1, e2]) => + let + val r1 = representative (db, e1) + val r2 = representative (db, e2) + in + case (!(#Ge (unNode (repOf r1))), #Variety (unNode (repOf r2))) of + (SOME n1, Prim (Prim.Int n2)) => Int64.>= (n1, n2) + | _ => false + end + | _ => false) + handle Undetermined => false fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = let @@ -812,7 +812,7 @@ fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = | _ => loop (representative (db, e)) in decomp d - end + end handle Undetermined => false end @@ -1256,7 +1256,7 @@ fun useKeys () = fun findKeys (hyps, acc) = case hyps of - [] => acc + [] => rev acc | (a as AReln (Sql tab, [r1])) :: hyps => (case SM.find (!tabs, tab) of NONE => findKeys (hyps, a :: acc) @@ -1265,7 +1265,7 @@ fun useKeys () = let fun finder (hyps, acc) = case hyps of - [] => acc + [] => rev acc | (a as AReln (Sql tab', [r2])) :: hyps => if tab' = tab andalso List.exists (List.all (fn f => @@ -1411,8 +1411,8 @@ fun buildable uk (e, loc) = in ErrorMsg.errorAt loc "The information flow policy may be violated here."; Print.prefaces "Situation" [("User learns", p_exp e), - ("Hypotheses", Print.p_list p_atom hs), - ("E-graph", Cc.p_database db)] + ("Hypotheses", Print.p_list p_atom hs)(*, + ("E-graph", Cc.p_database db)*)] end end @@ -1463,8 +1463,8 @@ fun doable pols (loc : ErrorMsg.span) = val (_, hs, _) = !hyps in ErrorMsg.errorAt loc "The database update policy may be violated here."; - Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs)(*, - ("E-graph", Cc.p_database db)*)] + Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), + ("E-graph", Cc.p_database db)] end end @@ -2177,25 +2177,28 @@ fun check file = UsedExp = fn _ => (), Cont = SomeCol (fn r => k (rev (!atoms), r))} - fun untab tab = List.filter (fn AReln (Sql tab', _) => tab' <> tab - | _ => true) + fun untab (tab, nams) = List.filter (fn AReln (Sql tab', [Lvar lv]) => + tab' <> tab + orelse List.all (fn Lvar lv' => lv' <> lv + | _ => false) nams + | _ => true) in case pol of PolClient e => doQ (fn (ats, {Outs = es, ...}) => St.allowSend (ats, es)) e | PolInsert e => doQ (fn (ats, {New = SOME (tab, new), ...}) => - St.allowInsert (AReln (Sql (tab ^ "$New"), [new]) :: untab tab ats) + St.allowInsert (AReln (Sql (tab ^ "$New"), [new]) :: untab (tab, [new]) ats) | _ => raise Fail "Iflow: No New in mayInsert policy") e | PolDelete e => doQ (fn (ats, {Old = SOME (tab, old), ...}) => - St.allowDelete (AReln (Sql (tab ^ "$Old"), [old]) :: untab tab ats) + St.allowDelete (AReln (Sql (tab ^ "$Old"), [old]) :: untab (tab, [old]) ats) | _ => raise Fail "Iflow: No Old in mayDelete policy") e | PolUpdate e => doQ (fn (ats, {New = SOME (tab, new), Old = SOME (_, old), ...}) => St.allowUpdate (AReln (Sql (tab ^ "$Old"), [old]) :: AReln (Sql (tab ^ "$New"), [new]) - :: untab tab ats) + :: untab (tab, [new, old]) ats) | _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e | PolSequence e => (case #1 e of -- cgit v1.2.3 From a4b12519973682177c23c387b663d55a51dacab0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 18 Apr 2010 20:06:15 -0400 Subject: Avoid state space explosion with ECase that just writes a constant in each case --- src/iflow.sml | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 1b20f0d1..87103aeb 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1878,22 +1878,24 @@ fun evalExp env (e as (_, loc)) k = | EField (e, s) => evalExp env e (fn e => k (Proj (e, s))) | ECase (e, pes, {result = res, ...}) => evalExp env e (fn e => - let - val () = St.addPath (e, loc) - in - app (fn (p, pe) => - let - val saved = St.stash () - in - let - val env = evalPat env e p - in - evalExp env pe k; - St.reinstate saved - end - handle Cc.Contradiction => St.reinstate saved - end) pes - end) + if List.all (fn (_, (EWrite (EPrim _, _), _)) => true + | _ => false) pes then + (St.send true (e, loc); + k (Recd [])) + else + (St.addPath (e, loc); + app (fn (p, pe) => + let + val saved = St.stash () + in + let + val env = evalPat env e p + in + evalExp env pe k; + St.reinstate saved + end + handle Cc.Contradiction => St.reinstate saved + end) pes)) | EStrcat (e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => -- cgit v1.2.3 From 05f75f15e2207afeeb97fec40ef0fd10d2befef8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 29 Apr 2010 11:47:24 -0400 Subject: Complain about DValRec; optimizations for unit-valued ECase and forgetting of path conditions across ESeq --- src/iflow.sml | 58 +++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 41 insertions(+), 17 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 87103aeb..1e6d2411 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1205,6 +1205,10 @@ structure St :> sig val stash : unit -> stashed val reinstate : stashed -> unit + type stashedPath + val stashPath : unit -> stashedPath + val reinstatePath : stashedPath -> unit + val nextVar : unit -> int val assert : atom list -> unit @@ -1335,6 +1339,10 @@ fun reinstate (nv, p, h) = path := p; setHyps h) +type stashedPath = ((int * atom list) * check) option ref list +fun stashPath () = !path +fun reinstatePath p = path := p + fun nextVar () = let val n = !nvar @@ -1912,7 +1920,11 @@ fun evalExp env (e as (_, loc)) k = evalExp env e (fn e => (St.send true (e, loc); k (Recd []))) | ESeq (e1, e2) => - evalExp env e1 (fn _ => evalExp env e2 k) + let + val path = St.stashPath () + in + evalExp env e1 (fn _ => (St.reinstatePath path; evalExp env e2 k)) + end | ELet (_, _, e1, e2) => evalExp env e1 (fn e1 => evalExp (e1 :: env) e2 k) | EClosure (n, es) => @@ -1929,32 +1941,42 @@ fun evalExp env (e as (_, loc)) k = | EQuery {query = q, body = b, initial = i, state = state, ...} => evalExp env i (fn i => let - val saved = St.stash () - - val () = (k i) - handle Cc.Contradiction => () - val () = St.reinstate saved - val r = Var (St.nextVar ()) val acc = Var (St.nextVar ()) - val touched = MonoUtil.Exp.fold {typ = fn (_, touched) => touched, - exp = fn (e, touched) => + val (ts, cs) = MonoUtil.Exp.fold {typ = fn (_, st) => st, + exp = fn (e, st as (cs, ts)) => case e of EDml e => (case parse dml e of - NONE => touched + NONE => st | SOME c => case c of - Insert _ => touched + Insert _ => st | Delete (tab, _) => - SS.add (touched, tab) + (cs, SS.add (ts, tab)) | Update (tab, _, _) => - SS.add (touched, tab)) - | _ => touched} - SS.empty b + (cs, SS.add (ts, tab))) + | EFfiApp ("Basis", "set_cookie", + [_, (EPrim (Prim.String cname), _), + _, _, _]) => + (SS.add (cs, cname), ts) + | _ => st} + (SS.empty, SS.empty) b in - SS.app (St.havocReln o Sql) touched; + case (#1 state, SS.isEmpty ts, SS.isEmpty cs) of + (TRecord [], true, true) => () + | _ => + let + val saved = St.stash () + in + (k i) + handle Cc.Contradiction => (); + St.reinstate saved + end; + + SS.app (St.havocReln o Sql) ts; + SS.app St.havocCookie cs; doQuery {Env = env, NextVar = Var o St.nextVar, @@ -2110,7 +2132,7 @@ fun check file = DExport (_, _, n, _, _, _) => IS.add (exptd, n) | _ => exptd) IS.empty file - fun decl (d, _) = + fun decl (d, loc) = case d of DTable (tab, fs, pk, _) => let @@ -2159,6 +2181,8 @@ fun check file = St.reinstate saved end + | DValRec _ => ErrorMsg.errorAt loc "Iflow can't check recursive functions." + | DPolicy pol => let val rvN = ref 0 -- cgit v1.2.3 From d40bec7348942c36a597b00e146f43777fa303dc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 29 Apr 2010 17:24:42 -0400 Subject: Add rand to Basis and handle it in Iflow --- include/urweb.h | 2 ++ lib/ur/basis.urs | 2 ++ src/c/urweb.c | 5 +++++ src/iflow.sml | 19 +++++++++++++++++-- src/settings.sml | 3 ++- 5 files changed, 28 insertions(+), 3 deletions(-) (limited to 'src/iflow.sml') diff --git a/include/urweb.h b/include/urweb.h index be3a9bd1..32e9b4e1 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -280,4 +280,6 @@ uw_Basis_unit uw_Basis_debug(uw_context, uw_Basis_string); void uw_set_client_data(uw_context, void *); +uw_Basis_int uw_Basis_rand(uw_context); + #endif diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 13d52960..19983cd2 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -821,3 +821,5 @@ val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] val also : sql_policy -> sql_policy -> sql_policy val debug : string -> transaction unit + +val rand : transaction int diff --git a/src/c/urweb.c b/src/c/urweb.c index 7821a999..6815c85b 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -3404,3 +3404,8 @@ uw_Basis_unit uw_Basis_debug(uw_context ctx, uw_Basis_string s) { return uw_unit_v; } + +uw_Basis_int uw_Basis_rand(uw_context ctx) { + uw_Basis_int n = abs(rand()); + return n; +} diff --git a/src/iflow.sml b/src/iflow.sml index 1e6d2411..862ed1b9 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -972,6 +972,7 @@ datatype sqexp = SqConst of Prim.t | SqTrue | SqFalse + | SqNot of sqexp | Field of string * string | Computed of string | Binop of Rel * sqexp * sqexp @@ -1075,6 +1076,8 @@ fun sqexp chs = wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") (follow (keep (fn ch => ch <> #")")) (const ")"))))) (fn ((), (e, _)) => e), + wrap (follow (const "(NOT ") (follow sqexp (const ")"))) + (fn ((), (e, _)) => SqNot e), wrap (follow (ws (const "(")) (follow (wrap (follow sqexp @@ -1471,8 +1474,8 @@ fun doable pols (loc : ErrorMsg.span) = val (_, hs, _) = !hyps in ErrorMsg.errorAt loc "The database update policy may be violated here."; - Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs), - ("E-graph", Cc.p_database db)] + Print.prefaces "Situation" [("Hypotheses", Print.p_list p_atom hs)(*, + ("E-graph", Cc.p_database db)*)] end end @@ -1558,6 +1561,10 @@ fun expIn rv env rvOf = SqConst p => inl (Const p) | SqTrue => inl (Func (DtCon0 "Basis.bool.True", [])) | SqFalse => inl (Func (DtCon0 "Basis.bool.False", [])) + | SqNot e => + inr (case expIn e of + inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) + | inr _ => Unknown) | Field (v, f) => inl (Proj (rvOf v, f)) | Computed _ => default () | Binop (bo, e1, e2) => @@ -1674,6 +1681,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = SqConst _ => [] | SqTrue => [] | SqFalse => [] + | SqNot e => usedFields e | Field (v, f) => [(false, Proj (rvOf v, f))] | Computed _ => [] | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 @@ -1865,6 +1873,13 @@ fun evalExp env (e as (_, loc)) k = | ESome (_, e) => evalExp env e (fn e => k (Func (DtCon1 "Some", [e]))) | EFfi _ => default () + | EFfiApp ("Basis", "rand", []) => + let + val e = Var (St.nextVar ()) + in + St.assert [AReln (Known, [e])]; + k e + end | EFfiApp x => doFfi x | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [e]) diff --git a/src/settings.sml b/src/settings.sml index 3d163ca5..967efe07 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -115,7 +115,8 @@ val benignBase = basis ["get_cookie", "onDisconnect", "onServerError", "kc", - "debug"] + "debug", + "rand"] val benign = ref benignBase fun setBenignEffectful ls = benign := S.addList (benignBase, ls) -- cgit v1.2.3 From cfa74f17f0f52d49a0d14f0cf34385182730cf31 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 May 2010 09:51:46 -0400 Subject: Basic handling of recursive functions in Iflow --- src/iflow.sml | 231 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 228 insertions(+), 3 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 862ed1b9..150b9774 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1233,6 +1233,8 @@ structure St :> sig val havocReln : reln -> unit val havocCookie : string -> unit + val check : atom -> bool + val debug : unit -> unit end = struct @@ -1519,6 +1521,8 @@ fun havocCookie cname = hyps := (n, List.filter (fn AReln (Eq, [_, Func (Other f, [])]) => f <> cname | _ => true) hs, ref false) end +fun check a = Cc.check (db, a) + fun debug () = let val (_, hs, _) = !hyps @@ -1549,6 +1553,12 @@ fun deinj env e = (case deinj env e of NONE => NONE | SOME e => SOME (Proj (e, f))) + | EApp ((EFfi mf, _), e) => + if Settings.isEffectful mf orelse Settings.isBenignEffectful mf then + NONE + else (case deinj env e of + NONE => NONE + | SOME e => SOME (Func (Other (#1 mf ^ "." ^ #2 mf), [e]))) | _ => NONE fun expIn rv env rvOf = @@ -1821,6 +1831,10 @@ fun evalPat env e (pt, _) = env end +datatype arg_mode = Fixed | Decreasing | Arbitrary +type rfun = {args : arg_mode list, tables : SS.set, cookies : SS.set, body : Mono.exp} +val rfuns = ref (IM.empty : rfun IM.map) + fun evalExp env (e as (_, loc)) k = let (*val () = St.debug ()*) @@ -1883,7 +1897,62 @@ fun evalExp env (e as (_, loc)) k = | EFfiApp x => doFfi x | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [e]) - | EApp (e1, e2) => evalExp env e1 (fn _ => evalExp env e2 (fn _ => default ())) + | EApp (e1 as (EError _, _), _) => evalExp env e1 k + + | EApp (e1, e2) => + let + fun adefault () = (ErrorMsg.errorAt loc "Excessively fancy function call"; + Print.preface ("Call", MonoPrint.p_exp MonoEnv.empty e); + default ()) + + fun doArgs (e, args) = + case #1 e of + EApp (e1, e2) => doArgs (e1, e2 :: args) + | ENamed n => + (case IM.find (!rfuns, n) of + NONE => adefault () + | SOME rf => + if length (#args rf) <> length args then + adefault () + else + let + val () = (SS.app (St.havocReln o Sql) (#tables rf); + SS.app St.havocCookie (#cookies rf)) + val saved = St.stash () + + fun doArgs (args, modes, env') = + case (args, modes) of + ([], []) => (evalExp env' (#body rf) (fn _ => ()); + St.reinstate saved; + default ()) + + | (arg :: args, mode :: modes) => + evalExp env arg (fn arg => + let + val v = case mode of + Arbitrary => Var (St.nextVar ()) + | Fixed => arg + | Decreasing => + let + val v = Var (St.nextVar ()) + in + if St.check (AReln (Known, [arg])) then + St.assert [(AReln (Known, [v]))] + else + (); + v + end + in + doArgs (args, modes, v :: env') + end) + | _ => raise Fail "Iflow.doArgs: Impossible" + in + doArgs (args, #args rf, []) + end) + | _ => adefault () + in + doArgs (e, []) + end | EAbs _ => default () | EUnop (s, e1) => evalExp env e1 (fn e1 => k (Func (Other s, [e1]))) @@ -2028,6 +2097,7 @@ fun evalExp env (e as (_, loc)) k = St.assert [AReln (Sql (tab ^ "$New"), [Recd es])]; St.insert loc; St.reinstate saved; + St.assert [AReln (Sql tab, [Recd es])]; k (Recd []) end | Delete (tab, e) => @@ -2131,9 +2201,12 @@ fun evalExp env (e as (_, loc)) k = | ESpawn _ => default () end +datatype var_source = Input of int | SubInput of int | Unknown + fun check file = let - val () = St.reset () + val () = (St.reset (); + rfuns := IM.empty) val file = MonoReduce.reduce file val file = MonoOpt.optimize file @@ -2196,7 +2269,159 @@ fun check file = St.reinstate saved end - | DValRec _ => ErrorMsg.errorAt loc "Iflow can't check recursive functions." + | DValRec [(x, n, _, e, _)] => + let + val tables = ref SS.empty + val cookies = ref SS.empty + + fun deAbs (e, env, modes) = + case #1 e of + EAbs (_, _, _, e) => deAbs (e, Input (length env) :: env, ref Fixed :: modes) + | _ => (e, env, rev modes) + + val (e, env, modes) = deAbs (e, [], []) + + fun doExp env (e as (_, loc)) = + case #1 e of + EPrim _ => e + | ERel _ => e + | ENamed _ => e + | ECon (_, _, NONE) => e + | ECon (dk, pc, SOME e) => (ECon (dk, pc, SOME (doExp env e)), loc) + | ENone _ => e + | ESome (t, e) => (ESome (t, doExp env e), loc) + | EFfi _ => e + | EFfiApp (m, f, es) => + (case (m, f, es) of + ("Basis", "set_cookie", [_, (EPrim (Prim.String cname), _), _, _, _]) => + cookies := SS.add (!cookies, cname) + | _ => (); + (EFfiApp (m, f, map (doExp env) es), loc)) + + | EApp (e1, e2) => + let + fun default () = (EApp (doExp env e1, doExp env e2), loc) + + fun explore (e, args) = + case #1 e of + EApp (e1, e2) => explore (e1, e2 :: args) + | ENamed n' => + if n' = n then + let + fun doArgs (pos, args, modes) = + case (args, modes) of + ((e1, _) :: args, m1 :: modes) => + (case e1 of + ERel n => + (case List.nth (env, n) of + Input pos' => + if pos' = pos then + () + else + m1 := Arbitrary + | SubInput pos' => + if pos' = pos then + if !m1 = Arbitrary then + () + else + m1 := Decreasing + else + m1 := Arbitrary + | Unknown => m1 := Arbitrary) + | _ => m1 := Arbitrary; + doArgs (pos + 1, args, modes)) + | (_ :: _, []) => () + | ([], ms) => app (fn m => m := Arbitrary) ms + in + doArgs (0, args, modes); + (EFfi ("Basis", "?"), loc) + end + else + default () + | _ => default () + in + explore (e, []) + end + | EAbs (x, t1, t2, e) => (EAbs (x, t1, t2, doExp (Unknown :: env) e), loc) + | EUnop (uo, e1) => (EUnop (uo, doExp env e1), loc) + | EBinop (bo, e1, e2) => (EBinop (bo, doExp env e1, doExp env e2), loc) + | ERecord xets => (ERecord (map (fn (x, e, t) => (x, doExp env e, t)) xets), loc) + | EField (e1, f) => (EField (doExp env e1, f), loc) + | ECase (e, pes, ts) => + let + val source = + case #1 e of + ERel n => + (case List.nth (env, n) of + Input n => SOME n + | SubInput n => SOME n + | Unknown => NONE) + | _ => NONE + + fun doV v = + let + fun doPat (p, env) = + case #1 p of + PWild => env + | PVar _ => v :: env + | PPrim _ => env + | PCon (_, _, NONE) => env + | PCon (_, _, SOME p) => doPat (p, env) + | PRecord xpts => foldl (fn ((_, p, _), env) => doPat (p, env)) env xpts + | PNone _ => env + | PSome (_, p) => doPat (p, env) + in + (ECase (e, map (fn (p, e) => (p, doExp (doPat (p, env)) e)) pes, ts), loc) + end + in + case source of + NONE => doV Unknown + | SOME inp => doV (SubInput inp) + end + | EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc) + | EError (e1, t) => (EError (doExp env e1, t), loc) + | EReturnBlob {blob = b, mimeType = m, t} => + (EReturnBlob {blob = doExp env b, mimeType = doExp env m, t = t}, loc) + | ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc) + | EWrite e1 => (EWrite (doExp env e1), loc) + | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc) + | ELet (x, t, e1, e2) => (ELet (x, t, doExp env e1, doExp (Unknown :: env) e2), loc) + | EClosure (n, es) => (EClosure (n, map (doExp env) es), loc) + | EQuery {exps, tables, state, query, body, initial} => + (EQuery {exps = exps, tables = tables, state = state, + query = doExp env query, + body = doExp (Unknown :: Unknown :: env) body, + initial = doExp env initial}, loc) + | EDml e1 => + (case parse dml e1 of + NONE => () + | SOME c => + case c of + Insert _ => () + | Delete (tab, _) => + tables := SS.add (!tables, tab) + | Update (tab, _, _) => + tables := SS.add (!tables, tab); + (EDml (doExp env e1), loc)) + | ENextval e1 => (ENextval (doExp env e1), loc) + | ESetval (e1, e2) => (ESetval (doExp env e1, doExp env e2), loc) + | EUnurlify (e1, t, b) => (EUnurlify (doExp env e1, t, b), loc) + | EJavaScript (m, e) => (EJavaScript (m, doExp env e), loc) + | ESignalReturn _ => e + | ESignalBind _ => e + | ESignalSource _ => e + | EServerCall _ => e + | ERecv _ => e + | ESleep _ => e + | ESpawn _ => e + + val e = doExp env e + in + rfuns := IM.insert (!rfuns, n, {tables = !tables, cookies = !cookies, + args = map (fn r => !r) modes, body = e}) + end + + | DValRec _ => ErrorMsg.errorAt loc "Iflow can't check mutually-recursive functions yet." | DPolicy pol => let -- cgit v1.2.3 From e77751ae70458f5b22c3872232da30ed8b127ee1 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 1 May 2010 11:59:35 -0400 Subject: Safe unmodeled SQL expressions marked as known --- src/iflow.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 150b9774..83ab7d01 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -493,7 +493,7 @@ fun representative (db : database, e) = Rep = ref NONE, Cons = ref SM.empty, Variety = Nothing, - Known = ref false, + Known = ref (f = "allow"), Ge = ref NONE}) in #Funcs db := ((f, rs), r) :: (!(#Funcs db)); @@ -1608,7 +1608,7 @@ fun expIn rv env rvOf = inl e => inl (Func (Other f, [e])) | _ => default ()) - | Unmodeled => default () + | Unmodeled => inl (Func (Other "allow", [rv ()])) end in expIn -- cgit v1.2.3 From 8a505dfffab4e6104969dc98a0f3b07dbe661098 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 6 May 2010 12:14:00 -0400 Subject: Some Iflow improvements for gradebook --- src/iflow.sml | 81 ++++++++++++++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 37 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 83ab7d01..92e568a1 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -242,7 +242,7 @@ structure Cc :> sig val p_database : database Print.printer - val builtFrom : database * {UseKnown : bool, Base : exp list, Derived : exp} -> bool + val builtFrom : database * {Base : exp list, Derived : exp} -> bool val p_repOf : database -> exp Print.printer end = struct @@ -704,9 +704,11 @@ fun assert (db, a) = raise Contradiction | Nothing => let + val cons = ref SM.empty + val r'' = ref (Node {Id = nodeId (), Rep = ref NONE, - Cons = ref SM.empty, + Cons = cons, Variety = Nothing, Known = ref (!(#Known (unNode r))), Ge = ref NONE}) @@ -718,6 +720,7 @@ fun assert (db, a) = Known = #Known (unNode r), Ge = ref NONE}) in + cons := SM.insert (!cons, f, r'); #Rep (unNode r) := SOME r' end | _ => raise Contradiction @@ -788,7 +791,7 @@ fun check (db, a) = | _ => false) handle Undetermined => false -fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = +fun builtFrom (db, {Base = bs, Derived = d}) = let val bs = map (fn b => representative (db, b)) bs @@ -796,7 +799,7 @@ fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = let val d = repOf d in - (uk andalso !(#Known (unNode d))) + !(#Known (unNode d)) orelse List.exists (fn b => repOf b = d) bs orelse (case #Variety (unNode d) of Dt0 _ => true @@ -804,6 +807,8 @@ fun builtFrom (db, {UseKnown = uk, Base = bs, Derived = d}) = | Prim _ => true | Recrd (xes, _) => List.all loop (SM.listItems (!xes)) | Nothing => false) + orelse List.exists (fn r => List.exists (fn b => repOf b = repOf r) bs) + (SM.listItems (!(#Cons (unNode d)))) end fun decomp e = @@ -980,6 +985,7 @@ datatype sqexp = | Inj of Mono.exp | SqFunc of string * sqexp | Unmodeled + | Null fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) @@ -1067,6 +1073,7 @@ fun sqexp chs = (altL [wrap prim SqConst, wrap (const "TRUE") (fn () => SqTrue), wrap (const "FALSE") (fn () => SqFalse), + wrap (const "NULL") (fn () => Null), wrap field Field, wrap uw_ident Computed, wrap known SqKnown, @@ -1219,7 +1226,7 @@ structure St :> sig val addPath : check -> unit val allowSend : atom list * exp list -> unit - val send : bool -> check -> unit + val send : check -> unit val allowInsert : atom list -> unit val insert : ErrorMsg.span -> unit @@ -1404,14 +1411,20 @@ fun checkGoals goals k = checkGoals goals IM.empty end -fun buildable uk (e, loc) = +fun buildable (e, loc) = let fun doPols pols acc = case pols of - [] => ((*Print.prefaces "buildable" [("Base", Print.p_list p_exp acc), - ("Derived", p_exp e), - ("Hyps", Print.p_list p_atom (#2 (!hyps)))];*) - Cc.builtFrom (db, {UseKnown = uk, Base = acc, Derived = e})) + [] => + let + val b = Cc.builtFrom (db, {Base = acc, Derived = e}) + in + (*Print.prefaces "buildable" [("Base", Print.p_list p_exp acc), + ("Derived", p_exp e), + ("Hyps", Print.p_list p_atom (#2 (!hyps))), + ("Good", Print.PD.string (Bool.toString b))];*) + b + end | (goals, es) :: pols => checkGoals goals (fn unifs => doPols pols (map (simplify unifs) es @ acc)) orelse doPols pols acc @@ -1424,8 +1437,8 @@ fun buildable uk (e, loc) = in ErrorMsg.errorAt loc "The information flow policy may be violated here."; Print.prefaces "Situation" [("User learns", p_exp e), - ("Hypotheses", Print.p_list p_atom hs)(*, - ("E-graph", Cc.p_database db)*)] + ("Hypotheses", Print.p_list p_atom hs), + ("E-graph", Cc.p_database db)] end end @@ -1440,7 +1453,7 @@ fun checkPaths () = | SOME (hs, e) => (r := NONE; setHyps hs; - buildable true e)) (!path); + buildable e)) (!path); setHyps hs end @@ -1448,13 +1461,13 @@ fun allowSend v = ((*Print.prefaces "Allow" [("goals", Print.p_list p_atom (#1 v ("exps", Print.p_list p_exp (#2 v))];*) sendable := v :: !sendable) -fun send uk (e, loc) = ((*Print.preface ("Send", p_exp e);*) - complete (); - checkPaths (); - if isKnown e then - () - else - buildable uk (e, loc)) +fun send (e, loc) = ((*Print.preface ("Send[" ^ Bool.toString uk ^ "]", p_exp e);*) + complete (); + checkPaths (); + if isKnown e then + () + else + buildable (e, loc)) fun doable pols (loc : ErrorMsg.span) = let @@ -1571,6 +1584,7 @@ fun expIn rv env rvOf = SqConst p => inl (Const p) | SqTrue => inl (Func (DtCon0 "Basis.bool.True", [])) | SqFalse => inl (Func (DtCon0 "Basis.bool.False", [])) + | Null => inl (Func (DtCon0 "None", [])) | SqNot e => inr (case expIn e of inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.False", [])]) @@ -1646,7 +1660,6 @@ type 'a doQuery = { Add : atom -> unit, Save : unit -> 'a, Restore : 'a -> unit, - UsedExp : bool * exp -> unit, Cont : queryMode } @@ -1691,6 +1704,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = SqConst _ => [] | SqTrue => [] | SqFalse => [] + | Null => [] | SqNot e => usedFields e | Field (v, f) => [(false, Proj (rvOf v, f))] | Computed _ => [] @@ -1704,11 +1718,6 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = | SqFunc (_, e) => usedFields e | Unmodeled => [] - fun doUsed () = case #Where r of - NONE => () - | SOME e => - app (#UsedExp arg) (usedFields e) - fun normal' () = case #Cont arg of SomeCol k => @@ -1753,7 +1762,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = fun doWhere final = (addFrom (); case #Where r of - NONE => (doUsed (); final ()) + NONE => final () | SOME e => let val p = case expIn e of @@ -1763,7 +1772,7 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = val saved = #Save arg () in decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} - p (fn () => (doUsed (); final ()) handle Cc.Contradiction => ()); + p (fn () => final () handle Cc.Contradiction => ()); #Restore arg saved end) handle Cc.Contradiction => () @@ -1860,7 +1869,7 @@ fun evalExp env (e as (_, loc)) k = (); k (Recd [])) | e :: es => - evalExp env e (fn e => (St.send true (e, loc); doArgs es)) + evalExp env e (fn e => (St.send (e, loc); doArgs es)) in doArgs es end @@ -1972,7 +1981,7 @@ fun evalExp env (e as (_, loc)) k = evalExp env e (fn e => if List.all (fn (_, (EWrite (EPrim _, _), _)) => true | _ => false) pes then - (St.send true (e, loc); + (St.send (e, loc); k (Recd [])) else (St.addPath (e, loc); @@ -1992,16 +2001,16 @@ fun evalExp env (e as (_, loc)) k = evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other "cat", [e1, e2])))) - | EError (e, _) => evalExp env e (fn e => St.send true (e, loc)) + | EError (e, _) => evalExp env e (fn e => St.send (e, loc)) | EReturnBlob {blob = b, mimeType = m, ...} => evalExp env b (fn b => - (St.send true (b, loc); + (St.send (b, loc); evalExp env m - (fn m => St.send true (m, loc)))) + (fn m => St.send (m, loc)))) | ERedirect (e, _) => - evalExp env e (fn e => St.send true (e, loc)) + evalExp env e (fn e => St.send (e, loc)) | EWrite e => - evalExp env e (fn e => (St.send true (e, loc); + evalExp env e (fn e => (St.send (e, loc); k (Recd []))) | ESeq (e1, e2) => let @@ -2067,7 +2076,6 @@ fun evalExp env (e as (_, loc)) k = Add = fn a => St.assert [a], Save = St.stash, Restore = St.reinstate, - UsedExp = fn (b, e) => St.send b (e, loc), Cont = AllCols (fn x => (St.assert [AReln (Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q @@ -2440,7 +2448,6 @@ fun check file = Add = fn a => atoms := a :: !atoms, Save = fn () => !atoms, Restore = fn ls => atoms := ls, - UsedExp = fn _ => (), Cont = SomeCol (fn r => k (rev (!atoms), r))} fun untab (tab, nams) = List.filter (fn AReln (Sql tab', [Lvar lv]) => -- cgit v1.2.3 From 8179b6224c5d4eb3b3fbe48e6acf5d630138c3da Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 27 Jul 2010 11:42:30 -0400 Subject: Initial version of equalKnown working for secret --- lib/ur/basis.urs | 3 ++ src/iflow.sml | 85 +++++++++++++++++++++++++++++++++++++++++----------- src/mono.sml | 1 + src/mono_print.sml | 5 ++++ src/mono_shake.sml | 1 + src/mono_util.sml | 3 ++ src/monoize.sml | 9 ++++++ tests/equalKnown.ur | 24 +++++++++++++++ tests/equalKnown.urp | 1 + tests/equalKnown.urs | 1 + 10 files changed, 115 insertions(+), 18 deletions(-) create mode 100644 tests/equalKnown.ur create mode 100644 tests/equalKnown.urp create mode 100644 tests/equalKnown.urs (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index f6141bc7..7b17dd05 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -819,6 +819,9 @@ val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] => sql_query [] ([Old = fs, New = fs] ++ tables) [] -> sql_policy +val equalKnown : nm :: Name -> t ::: Type -> fs ::: {Type} -> ks ::: {{Unit}} + -> [[nm] ~ fs] => sql_table ([nm = t] ++ fs) ks -> sql_policy + val also : sql_policy -> sql_policy -> sql_policy val debug : string -> transaction unit diff --git a/src/iflow.sml b/src/iflow.sml index 92e568a1..bf75775b 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1228,6 +1228,9 @@ structure St :> sig val allowSend : atom list * exp list -> unit val send : check -> unit + val allowEqualKnown : { table : string, field : string } -> unit + val mayTest : prop -> bool + val allowInsert : atom list -> unit val insert : ErrorMsg.span -> unit @@ -1506,11 +1509,40 @@ val deletable = ref ([] : atom list list) fun allowDelete v = deletable := v :: !deletable val delete = doable deletable +val testable = ref ([] : { table : string, field : string } list) +fun allowEqualKnown v = testable := v :: !testable +fun mayTest p = + case p of + Reln (Eq, [e1, e2]) => + let + val (_, hs, _) = !hyps + + fun tableInHyps (tab, x) = List.exists (fn AReln (Sql tab', [Var x']) => tab' = tab andalso x' = x + | _ => false) hs + + fun allowed (tab, v) = + case tab of + Proj (Var tab, fd) => + List.exists (fn {table = tab', field = fd'} => + fd' = fd + andalso tableInHyps (tab', tab)) (!testable) + andalso Cc.check (db, AReln (Known, [v])) + | _ => false + in + if allowed (e1, e2) orelse allowed (e2, e1) then + (Cc.assert (db, AReln (Eq, [e1, e2])); + true) + else + false + end + | _ => false + fun reset () = (Cc.clear db; path := []; hyps := (0, [], ref false); nvar := 0; sendable := []; + testable := []; insertable := []; updatable := []; deletable := []) @@ -1660,7 +1692,8 @@ type 'a doQuery = { Add : atom -> unit, Save : unit -> 'a, Restore : 'a -> unit, - Cont : queryMode + Cont : queryMode, + Send : exp -> unit } fun doQuery (arg : 'a doQuery) (e as (_, loc)) = @@ -1699,24 +1732,24 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = val saved = #Save arg () fun addFrom () = app (fn (t, v) => #Add arg (AReln (Sql t, [rvOf v]))) (#From r) - fun usedFields e = + fun leavesE e = case e of - SqConst _ => [] - | SqTrue => [] - | SqFalse => [] - | Null => [] - | SqNot e => usedFields e - | Field (v, f) => [(false, Proj (rvOf v, f))] - | Computed _ => [] - | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 - | SqKnown _ => [] - | Inj e => - (case deinj (#Env arg) e of - NONE => (ErrorMsg.errorAt loc "Expression injected into SQL is too complicated"; - []) - | SOME e => [(true, e)]) - | SqFunc (_, e) => usedFields e - | Unmodeled => [] + Const _ => [] + | Var _ => [] + | Lvar _ => [] + | Func (_, es) => List.concat (map leavesE es) + | Recd xes => List.concat (map (leavesE o #2) xes) + | Proj _ => [e] + + fun leavesP p = + case p of + True => [] + | False => [] + | Unknown => [] + | And (p1, p2) => leavesP p1 @ leavesP p2 + | Or (p1, p2) => leavesP p1 @ leavesP p2 + | Reln (_, es) => List.concat (map leavesE es) + | Cond (e, p) => e :: leavesP p fun normal' () = case #Cont arg of @@ -1769,8 +1802,17 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p + fun getConjuncts p = + case p of + And (p1, p2) => getConjuncts p1 @ getConjuncts p2 + | _ => [p] + val saved = #Save arg () + + val conjs = getConjuncts p + val conjs = List.filter (not o St.mayTest) conjs in + app (fn p => app (#Send arg) (leavesP p)) conjs; decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} p (fn () => final () handle Cc.Contradiction => ()); #Restore arg saved @@ -2076,6 +2118,7 @@ fun evalExp env (e as (_, loc)) k = Add = fn a => St.assert [a], Save = St.stash, Restore = St.reinstate, + Send = fn e => St.send (e, loc), Cont = AllCols (fn x => (St.assert [AReln (Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q @@ -2448,6 +2491,7 @@ fun check file = Add = fn a => atoms := a :: !atoms, Save = fn () => !atoms, Restore = fn ls => atoms := ls, + Send = fn _ => (), Cont = SomeCol (fn r => k (rev (!atoms), r))} fun untab (tab, nams) = List.filter (fn AReln (Sql tab', [Lvar lv]) => @@ -2483,6 +2527,11 @@ fun check file = St.allowSend ([p], outs) end | _ => ()) + | PolEqualKnown {table = tab, field = nm} => + (case #1 tab of + EPrim (Prim.String tab) => St.allowEqualKnown {table = String.extract (tab, 3, NONE), + field = nm} + | _ => ErrorMsg.errorAt loc "Table for 'equalKnown' policy isn't fully resolved.") end | _ => () diff --git a/src/mono.sml b/src/mono.sml index 9a960cd0..2f5ab117 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -129,6 +129,7 @@ datatype policy = | PolDelete of exp | PolUpdate of exp | PolSequence of exp + | PolEqualKnown of {table : exp, field : string} datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index 25a8e9d8..693b5e3e 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -429,6 +429,11 @@ fun p_policy env pol = | PolSequence e => box [string "sendOwnIds", space, p_exp env e] + | PolEqualKnown {table = tab, field = nm} => box [string "equalKnown[", + string nm, + string "]", + space, + p_exp env tab] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 50c4b387..6a5aefae 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -67,6 +67,7 @@ fun shake file = | PolDelete e1 => e1 | PolUpdate e1 => e1 | PolSequence e1 => e1 + | PolEqualKnown {table = e1, ...} => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index 6bbbecb1..cb01a958 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -556,6 +556,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | PolSequence e => S.map2 (mfe ctx e, PolSequence) + | PolEqualKnown {table = tab, field = nm} => + S.map2 (mfe ctx tab, + fn tab => PolEqualKnown {table = tab, field = nm}) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index d43002cb..5054cc9f 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3804,6 +3804,15 @@ fun monoDecl (env, fm) (all as (d, loc)) = (e, L'.PolUpdate) | L.EFfiApp ("Basis", "sendOwnIds", [e]) => (e, L'.PolSequence) + | L.EApp ((L.ECApp + ((L.ECApp + ((L.ECApp + ((L.ECApp + ((L.EFfi ("Basis", "equalKnown"), _), nm), _), _), _), + _), _), _), _), tab) => + (case #1 nm of + L.CName nm => (tab, fn tab => L'.PolEqualKnown {table = tab, field = nm}) + | _ => (poly (); (e, L'.PolClient))) | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e diff --git a/tests/equalKnown.ur b/tests/equalKnown.ur new file mode 100644 index 00000000..4af32490 --- /dev/null +++ b/tests/equalKnown.ur @@ -0,0 +1,24 @@ +type fruit = int +table fruit : { Id : fruit, Nam : string, Weight : float, Secret : string } + PRIMARY KEY Id, + CONSTRAINT Nam UNIQUE Nam + +policy sendClient (SELECT fruit.Id, fruit.Nam + FROM fruit) + +policy sendClient (SELECT fruit.Weight + FROM fruit + WHERE known(fruit.Secret)) + +policy equalKnown[#Secret] fruit + +fun main () = + x1 <- queryX (SELECT fruit.Id, fruit.Nam, fruit.Weight + FROM fruit + WHERE fruit.Nam = "apple" + AND fruit.Secret = "tasty") + (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}, {[x.Fruit.Weight]}
    • ); + + return +
      {x1}
    +     diff --git a/tests/equalKnown.urp b/tests/equalKnown.urp new file mode 100644 index 00000000..380321fd --- /dev/null +++ b/tests/equalKnown.urp @@ -0,0 +1 @@ +equalKnown diff --git a/tests/equalKnown.urs b/tests/equalKnown.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/equalKnown.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From a5d7c214f42af261d900af8a7ac042b807c2abe2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 27 Jul 2010 12:12:08 -0400 Subject: equalAny policies --- lib/ur/basis.urs | 2 ++ src/iflow.sml | 21 +++++++++++---------- src/mono.sml | 2 +- src/mono_print.sml | 12 +++++++----- src/mono_shake.sml | 2 +- src/mono_util.sml | 4 ++-- src/monoize.sml | 11 ++++++++++- 7 files changed, 34 insertions(+), 20 deletions(-) (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 7b17dd05..8bc2b6ea 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -819,6 +819,8 @@ val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] => sql_query [] ([Old = fs, New = fs] ++ tables) [] -> sql_policy +val equalAny : nm :: Name -> t ::: Type -> fs ::: {Type} -> ks ::: {{Unit}} + -> [[nm] ~ fs] => sql_table ([nm = t] ++ fs) ks -> sql_policy val equalKnown : nm :: Name -> t ::: Type -> fs ::: {Type} -> ks ::: {{Unit}} -> [[nm] ~ fs] => sql_table ([nm = t] ++ fs) ks -> sql_policy diff --git a/src/iflow.sml b/src/iflow.sml index bf75775b..c70240a7 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1228,7 +1228,7 @@ structure St :> sig val allowSend : atom list * exp list -> unit val send : check -> unit - val allowEqualKnown : { table : string, field : string } -> unit + val allowEqual : { table : string, field : string, known : bool } -> unit val mayTest : prop -> bool val allowInsert : atom list -> unit @@ -1509,8 +1509,8 @@ val deletable = ref ([] : atom list list) fun allowDelete v = deletable := v :: !deletable val delete = doable deletable -val testable = ref ([] : { table : string, field : string } list) -fun allowEqualKnown v = testable := v :: !testable +val testable = ref ([] : { table : string, field : string, known : bool } list) +fun allowEqual v = testable := v :: !testable fun mayTest p = case p of Reln (Eq, [e1, e2]) => @@ -1523,14 +1523,14 @@ fun mayTest p = fun allowed (tab, v) = case tab of Proj (Var tab, fd) => - List.exists (fn {table = tab', field = fd'} => + List.exists (fn {table = tab', field = fd', known} => fd' = fd - andalso tableInHyps (tab', tab)) (!testable) - andalso Cc.check (db, AReln (Known, [v])) + andalso tableInHyps (tab', tab) + andalso (not known orelse Cc.check (db, AReln (Known, [v])))) (!testable) | _ => false in if allowed (e1, e2) orelse allowed (e2, e1) then - (Cc.assert (db, AReln (Eq, [e1, e2])); + (assert [AReln (Eq, [e1, e2])]; true) else false @@ -2527,10 +2527,11 @@ fun check file = St.allowSend ([p], outs) end | _ => ()) - | PolEqualKnown {table = tab, field = nm} => + | PolEqual {table = tab, field = nm, known} => (case #1 tab of - EPrim (Prim.String tab) => St.allowEqualKnown {table = String.extract (tab, 3, NONE), - field = nm} + EPrim (Prim.String tab) => St.allowEqual {table = String.extract (tab, 3, NONE), + field = nm, + known = known} | _ => ErrorMsg.errorAt loc "Table for 'equalKnown' policy isn't fully resolved.") end diff --git a/src/mono.sml b/src/mono.sml index 2f5ab117..0db9a684 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -129,7 +129,7 @@ datatype policy = | PolDelete of exp | PolUpdate of exp | PolSequence of exp - | PolEqualKnown of {table : exp, field : string} + | PolEqual of {table : exp, field : string, known : bool} datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index 693b5e3e..74467e08 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -429,11 +429,13 @@ fun p_policy env pol = | PolSequence e => box [string "sendOwnIds", space, p_exp env e] - | PolEqualKnown {table = tab, field = nm} => box [string "equalKnown[", - string nm, - string "]", - space, - p_exp env tab] + | PolEqual {table = tab, field = nm, known} => box [string "equal", + string (if known then "Known" else "Any"), + string "[", + string nm, + string "]", + space, + p_exp env tab] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 6a5aefae..581f1357 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -67,7 +67,7 @@ fun shake file = | PolDelete e1 => e1 | PolUpdate e1 => e1 | PolSequence e1 => e1 - | PolEqualKnown {table = e1, ...} => e1 + | PolEqual {table = e1, ...} => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index cb01a958..b0baa395 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -556,9 +556,9 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | PolSequence e => S.map2 (mfe ctx e, PolSequence) - | PolEqualKnown {table = tab, field = nm} => + | PolEqual {table = tab, field = nm, known = b} => S.map2 (mfe ctx tab, - fn tab => PolEqualKnown {table = tab, field = nm}) + fn tab => PolEqual {table = tab, field = nm, known = b}) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index 5054cc9f..f72c76a0 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3811,7 +3811,16 @@ fun monoDecl (env, fm) (all as (d, loc)) = ((L.EFfi ("Basis", "equalKnown"), _), nm), _), _), _), _), _), _), _), tab) => (case #1 nm of - L.CName nm => (tab, fn tab => L'.PolEqualKnown {table = tab, field = nm}) + L.CName nm => (tab, fn tab => L'.PolEqual {table = tab, field = nm, known = true}) + | _ => (poly (); (e, L'.PolClient))) + | L.EApp ((L.ECApp + ((L.ECApp + ((L.ECApp + ((L.ECApp + ((L.EFfi ("Basis", "equalAny"), _), nm), _), _), _), + _), _), _), _), tab) => + (case #1 nm of + L.CName nm => (tab, fn tab => L'.PolEqual {table = tab, field = nm, known = false}) | _ => (poly (); (e, L'.PolClient))) | _ => (poly (); (e, L'.PolClient)) -- cgit v1.2.3 From 67ed059e3b57399c7a8231f3180f35357b7aa1c9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 27 Jul 2010 14:04:09 -0400 Subject: Roll back WHERE checking --- lib/ur/basis.urs | 5 --- src/iflow.sml | 86 +++++++++++----------------------------------------- src/mono.sml | 1 - src/mono_print.sml | 7 ----- src/mono_shake.sml | 1 - src/mono_util.sml | 3 -- src/monoize.sml | 18 ----------- tests/equalKnown.ur | 24 --------------- tests/equalKnown.urp | 1 - tests/equalKnown.urs | 1 - 10 files changed, 18 insertions(+), 129 deletions(-) delete mode 100644 tests/equalKnown.ur delete mode 100644 tests/equalKnown.urp delete mode 100644 tests/equalKnown.urs (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 8bc2b6ea..f6141bc7 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -819,11 +819,6 @@ val mayUpdate : fs ::: {Type} -> tables ::: {{Type}} -> [[Old, New] ~ tables] => sql_query [] ([Old = fs, New = fs] ++ tables) [] -> sql_policy -val equalAny : nm :: Name -> t ::: Type -> fs ::: {Type} -> ks ::: {{Unit}} - -> [[nm] ~ fs] => sql_table ([nm = t] ++ fs) ks -> sql_policy -val equalKnown : nm :: Name -> t ::: Type -> fs ::: {Type} -> ks ::: {{Unit}} - -> [[nm] ~ fs] => sql_table ([nm = t] ++ fs) ks -> sql_policy - val also : sql_policy -> sql_policy -> sql_policy val debug : string -> transaction unit diff --git a/src/iflow.sml b/src/iflow.sml index c70240a7..92e568a1 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1228,9 +1228,6 @@ structure St :> sig val allowSend : atom list * exp list -> unit val send : check -> unit - val allowEqual : { table : string, field : string, known : bool } -> unit - val mayTest : prop -> bool - val allowInsert : atom list -> unit val insert : ErrorMsg.span -> unit @@ -1509,40 +1506,11 @@ val deletable = ref ([] : atom list list) fun allowDelete v = deletable := v :: !deletable val delete = doable deletable -val testable = ref ([] : { table : string, field : string, known : bool } list) -fun allowEqual v = testable := v :: !testable -fun mayTest p = - case p of - Reln (Eq, [e1, e2]) => - let - val (_, hs, _) = !hyps - - fun tableInHyps (tab, x) = List.exists (fn AReln (Sql tab', [Var x']) => tab' = tab andalso x' = x - | _ => false) hs - - fun allowed (tab, v) = - case tab of - Proj (Var tab, fd) => - List.exists (fn {table = tab', field = fd', known} => - fd' = fd - andalso tableInHyps (tab', tab) - andalso (not known orelse Cc.check (db, AReln (Known, [v])))) (!testable) - | _ => false - in - if allowed (e1, e2) orelse allowed (e2, e1) then - (assert [AReln (Eq, [e1, e2])]; - true) - else - false - end - | _ => false - fun reset () = (Cc.clear db; path := []; hyps := (0, [], ref false); nvar := 0; sendable := []; - testable := []; insertable := []; updatable := []; deletable := []) @@ -1692,8 +1660,7 @@ type 'a doQuery = { Add : atom -> unit, Save : unit -> 'a, Restore : 'a -> unit, - Cont : queryMode, - Send : exp -> unit + Cont : queryMode } fun doQuery (arg : 'a doQuery) (e as (_, loc)) = @@ -1732,24 +1699,24 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = val saved = #Save arg () fun addFrom () = app (fn (t, v) => #Add arg (AReln (Sql t, [rvOf v]))) (#From r) - fun leavesE e = + fun usedFields e = case e of - Const _ => [] - | Var _ => [] - | Lvar _ => [] - | Func (_, es) => List.concat (map leavesE es) - | Recd xes => List.concat (map (leavesE o #2) xes) - | Proj _ => [e] - - fun leavesP p = - case p of - True => [] - | False => [] - | Unknown => [] - | And (p1, p2) => leavesP p1 @ leavesP p2 - | Or (p1, p2) => leavesP p1 @ leavesP p2 - | Reln (_, es) => List.concat (map leavesE es) - | Cond (e, p) => e :: leavesP p + SqConst _ => [] + | SqTrue => [] + | SqFalse => [] + | Null => [] + | SqNot e => usedFields e + | Field (v, f) => [(false, Proj (rvOf v, f))] + | Computed _ => [] + | Binop (_, e1, e2) => usedFields e1 @ usedFields e2 + | SqKnown _ => [] + | Inj e => + (case deinj (#Env arg) e of + NONE => (ErrorMsg.errorAt loc "Expression injected into SQL is too complicated"; + []) + | SOME e => [(true, e)]) + | SqFunc (_, e) => usedFields e + | Unmodeled => [] fun normal' () = case #Cont arg of @@ -1802,17 +1769,8 @@ fun doQuery (arg : 'a doQuery) (e as (_, loc)) = inl e => Reln (Eq, [e, Func (DtCon0 "Basis.bool.True", [])]) | inr p => p - fun getConjuncts p = - case p of - And (p1, p2) => getConjuncts p1 @ getConjuncts p2 - | _ => [p] - val saved = #Save arg () - - val conjs = getConjuncts p - val conjs = List.filter (not o St.mayTest) conjs in - app (fn p => app (#Send arg) (leavesP p)) conjs; decomp {Save = #Save arg, Restore = #Restore arg, Add = #Add arg} p (fn () => final () handle Cc.Contradiction => ()); #Restore arg saved @@ -2118,7 +2076,6 @@ fun evalExp env (e as (_, loc)) k = Add = fn a => St.assert [a], Save = St.stash, Restore = St.reinstate, - Send = fn e => St.send (e, loc), Cont = AllCols (fn x => (St.assert [AReln (Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q @@ -2491,7 +2448,6 @@ fun check file = Add = fn a => atoms := a :: !atoms, Save = fn () => !atoms, Restore = fn ls => atoms := ls, - Send = fn _ => (), Cont = SomeCol (fn r => k (rev (!atoms), r))} fun untab (tab, nams) = List.filter (fn AReln (Sql tab', [Lvar lv]) => @@ -2527,12 +2483,6 @@ fun check file = St.allowSend ([p], outs) end | _ => ()) - | PolEqual {table = tab, field = nm, known} => - (case #1 tab of - EPrim (Prim.String tab) => St.allowEqual {table = String.extract (tab, 3, NONE), - field = nm, - known = known} - | _ => ErrorMsg.errorAt loc "Table for 'equalKnown' policy isn't fully resolved.") end | _ => () diff --git a/src/mono.sml b/src/mono.sml index 0db9a684..9a960cd0 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -129,7 +129,6 @@ datatype policy = | PolDelete of exp | PolUpdate of exp | PolSequence of exp - | PolEqual of {table : exp, field : string, known : bool} datatype decl' = DDatatype of (string * int * (string * int * typ option) list) list diff --git a/src/mono_print.sml b/src/mono_print.sml index 74467e08..25a8e9d8 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -429,13 +429,6 @@ fun p_policy env pol = | PolSequence e => box [string "sendOwnIds", space, p_exp env e] - | PolEqual {table = tab, field = nm, known} => box [string "equal", - string (if known then "Known" else "Any"), - string "[", - string nm, - string "]", - space, - p_exp env tab] fun p_decl env (dAll as (d, _) : decl) = case d of diff --git a/src/mono_shake.sml b/src/mono_shake.sml index 581f1357..50c4b387 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -67,7 +67,6 @@ fun shake file = | PolDelete e1 => e1 | PolUpdate e1 => e1 | PolSequence e1 => e1 - | PolEqual {table = e1, ...} => e1 in usedVars st e1 end diff --git a/src/mono_util.sml b/src/mono_util.sml index b0baa395..6bbbecb1 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -556,9 +556,6 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} = | PolSequence e => S.map2 (mfe ctx e, PolSequence) - | PolEqual {table = tab, field = nm, known = b} => - S.map2 (mfe ctx tab, - fn tab => PolEqual {table = tab, field = nm, known = b}) and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, diff --git a/src/monoize.sml b/src/monoize.sml index f72c76a0..d43002cb 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3804,24 +3804,6 @@ fun monoDecl (env, fm) (all as (d, loc)) = (e, L'.PolUpdate) | L.EFfiApp ("Basis", "sendOwnIds", [e]) => (e, L'.PolSequence) - | L.EApp ((L.ECApp - ((L.ECApp - ((L.ECApp - ((L.ECApp - ((L.EFfi ("Basis", "equalKnown"), _), nm), _), _), _), - _), _), _), _), tab) => - (case #1 nm of - L.CName nm => (tab, fn tab => L'.PolEqual {table = tab, field = nm, known = true}) - | _ => (poly (); (e, L'.PolClient))) - | L.EApp ((L.ECApp - ((L.ECApp - ((L.ECApp - ((L.ECApp - ((L.EFfi ("Basis", "equalAny"), _), nm), _), _), _), - _), _), _), _), tab) => - (case #1 nm of - L.CName nm => (tab, fn tab => L'.PolEqual {table = tab, field = nm, known = false}) - | _ => (poly (); (e, L'.PolClient))) | _ => (poly (); (e, L'.PolClient)) val (e, fm) = monoExp (env, St.empty, fm) e diff --git a/tests/equalKnown.ur b/tests/equalKnown.ur deleted file mode 100644 index 4af32490..00000000 --- a/tests/equalKnown.ur +++ /dev/null @@ -1,24 +0,0 @@ -type fruit = int -table fruit : { Id : fruit, Nam : string, Weight : float, Secret : string } - PRIMARY KEY Id, - CONSTRAINT Nam UNIQUE Nam - -policy sendClient (SELECT fruit.Id, fruit.Nam - FROM fruit) - -policy sendClient (SELECT fruit.Weight - FROM fruit - WHERE known(fruit.Secret)) - -policy equalKnown[#Secret] fruit - -fun main () = - x1 <- queryX (SELECT fruit.Id, fruit.Nam, fruit.Weight - FROM fruit - WHERE fruit.Nam = "apple" - AND fruit.Secret = "tasty") - (fn x =>
  • {[x.Fruit.Id]}: {[x.Fruit.Nam]}, {[x.Fruit.Weight]}
    • ); - - return -
      {x1}
    -     diff --git a/tests/equalKnown.urp b/tests/equalKnown.urp deleted file mode 100644 index 380321fd..00000000 --- a/tests/equalKnown.urp +++ /dev/null @@ -1 +0,0 @@ -equalKnown diff --git a/tests/equalKnown.urs b/tests/equalKnown.urs deleted file mode 100644 index 6ac44e0b..00000000 --- a/tests/equalKnown.urs +++ /dev/null @@ -1 +0,0 @@ -val main : unit -> transaction page -- cgit v1.2.3 From ee175ea1f9151123e47d9cbfee0c6329b2e5d934 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 5 Sep 2010 14:00:57 -0400 Subject: tryDml --- lib/ur/basis.urs | 2 ++ src/checknest.sml | 5 +++-- src/cjr.sml | 5 ++++- src/cjr_print.sml | 24 +++++++++++++++++------- src/cjrize.sml | 4 ++-- src/iflow.sml | 8 ++++---- src/jscomp.sml | 4 ++-- src/mono.sml | 4 +++- src/mono_print.sml | 6 +++--- src/mono_reduce.sml | 2 +- src/mono_util.sml | 4 ++-- src/monoize.sml | 48 ++++++++++++++++++++++++++++-------------------- src/mysql.sml | 23 +++++++++++++---------- src/postgres.sml | 26 ++++++++++++++------------ src/prepare.sml | 4 ++-- src/settings.sig | 6 ++++-- src/settings.sml | 6 ++++-- src/sqlite.sml | 23 +++++++++++++---------- tests/tryDml.ur | 13 +++++++++++++ tests/tryDml.urp | 4 ++++ tests/tryDml.urs | 1 + 21 files changed, 139 insertions(+), 83 deletions(-) create mode 100644 tests/tryDml.ur create mode 100644 tests/tryDml.urp create mode 100644 tests/tryDml.urs (limited to 'src/iflow.sml') diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index c06482ed..6cd9915e 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -535,6 +535,8 @@ val query : tables ::: {{Type}} -> exps ::: {Type} type dml val dml : dml -> transaction unit +val tryDml : dml -> transaction (option string) +(* Returns an error message on failure. *) val insert : fields ::: {Type} -> uniques ::: {{Unit}} -> sql_table fields uniques diff --git a/src/checknest.sml b/src/checknest.sml index a53c7083..1147d3e6 100644 --- a/src/checknest.sml +++ b/src/checknest.sml @@ -138,9 +138,10 @@ fun annotateExp globals = | SOME {id, query, ...} => SOME {id = id, query = query, nested = IS.member (expUses globals body, id)}}, loc) - | EDml {dml, prepared} => + | EDml {dml, prepared, mode} => (EDml {dml = ae dml, - prepared = prepared}, loc) + prepared = prepared, + mode = mode}, loc) | ENextval {seq, prepared} => (ENextval {seq = ae seq, diff --git a/src/cjr.sml b/src/cjr.sml index a19109d2..f34662dc 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -56,6 +56,8 @@ datatype pat' = withtype pat = pat' located +datatype failure_mode = datatype Settings.failure_mode + datatype exp' = EPrim of Prim.t | ERel of int @@ -92,7 +94,8 @@ datatype exp' = initial : exp, prepared : {id : int, query : string, nested : bool} option } | EDml of { dml : exp, - prepared : {id : int, dml : string} option } + prepared : {id : int, dml : string} option, + mode : failure_mode } | ENextval of { seq : exp, prepared : {id : int, query : string} option } | ESetval of { seq : exp, count : exp } diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 412531a6..7331196f 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1791,8 +1791,11 @@ fun p_exp' par env (e, loc) = box []] end - | EDml {dml, prepared} => - box [string "(uw_begin_region(ctx), ({", + | EDml {dml, prepared, mode} => + box [case mode of + Settings.Error => box [] + | Settings.None => string "({const char *uw_errmsg = NULL;", + string "(uw_begin_region(ctx), ({", newline, case prepared of NONE => box [string "char *dml = ", @@ -1800,7 +1803,7 @@ fun p_exp' par env (e, loc) = string ";", newline, newline, - #dml (Settings.currentDbms ()) loc] + #dml (Settings.currentDbms ()) (loc, mode)] | SOME {id, dml = dml'} => let val inputs = getPargs dml @@ -1823,16 +1826,23 @@ fun p_exp' par env (e, loc) = #dmlPrepared (Settings.currentDbms ()) {loc = loc, id = id, dml = dml', - inputs = map #2 inputs}] + inputs = map #2 inputs, + mode = mode}] end, newline, newline, - string "uw_end_region(ctx);", newline, - string "uw_unit_v;", + + case mode of + Settings.Error => string "uw_unit_v;" + | Settings.None => string "uw_errmsg ? uw_strdup(ctx, uw_errmsg) : NULL;", + newline, - string "}))"] + string "}))", + case mode of + Settings.Error => box [] + | Settings.None => string ";})"] | ENextval {seq, prepared} => box [string "({", diff --git a/src/cjrize.sml b/src/cjrize.sml index b98b3c25..22463cd4 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -455,11 +455,11 @@ fun cifyExp (eAll as (e, loc), sm) = query = query, body = body, initial = initial, prepared = NONE}, loc), sm) end - | L.EDml e => + | L.EDml (e, mode) => let val (e, sm) = cifyExp (e, sm) in - ((L'.EDml {dml = e, prepared = NONE}, loc), sm) + ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm) end | L.ENextval e => diff --git a/src/iflow.sml b/src/iflow.sml index 92e568a1..c0e92cb1 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -2040,7 +2040,7 @@ fun evalExp env (e as (_, loc)) k = val (ts, cs) = MonoUtil.Exp.fold {typ = fn (_, st) => st, exp = fn (e, st as (cs, ts)) => case e of - EDml e => + EDml (e, _) => (case parse dml e of NONE => st | SOME c => @@ -2080,7 +2080,7 @@ fun evalExp env (e as (_, loc)) k = (St.assert [AReln (Eq, [r, x])]; evalExp (acc :: r :: env) b k))} q end) - | EDml e => + | EDml (e, _) => (case parse dml e of NONE => (print ("Warning: Information flow checker can't parse DML command at " ^ ErrorMsg.spanToString loc ^ "\n"); @@ -2400,7 +2400,7 @@ fun check file = query = doExp env query, body = doExp (Unknown :: Unknown :: env) body, initial = doExp env initial}, loc) - | EDml e1 => + | EDml (e1, mode) => (case parse dml e1 of NONE => () | SOME c => @@ -2410,7 +2410,7 @@ fun check file = tables := SS.add (!tables, tab) | Update (tab, _, _) => tables := SS.add (!tables, tab); - (EDml (doExp env e1), loc)) + (EDml (doExp env e1, mode), loc)) | ENextval e1 => (ENextval (doExp env e1), loc) | ESetval (e1, e2) => (ESetval (doExp env e1, doExp env e2), loc) | EUnurlify (e1, t, b) => (EUnurlify (doExp env e1, t, b), loc) diff --git a/src/jscomp.sml b/src/jscomp.sml index f97725eb..2f7ee5ab 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -1147,11 +1147,11 @@ fun process file = ((EQuery {exps = exps, tables = tables, state = state, query = query, body = body, initial = initial}, loc), st) end - | EDml e => + | EDml (e, mode) => let val (e, st) = exp outer (e, st) in - ((EDml e, loc), st) + ((EDml (e, mode), loc), st) end | ENextval e => let diff --git a/src/mono.sml b/src/mono.sml index 9a960cd0..554b1dc5 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -66,6 +66,8 @@ datatype javascript_mode = datatype effect = datatype Export.effect datatype export_kind = datatype Export.export_kind +datatype failure_mode = datatype Settings.failure_mode + datatype exp' = EPrim of Prim.t | ERel of int @@ -104,7 +106,7 @@ datatype exp' = query : exp, body : exp, initial : exp } - | EDml of exp + | EDml of exp * failure_mode | ENextval of exp | ESetval of exp * exp diff --git a/src/mono_print.sml b/src/mono_print.sml index 25a8e9d8..c3f2866e 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -322,9 +322,9 @@ fun p_exp' par env (e, _) = string "in", space, p_exp (E.pushERel (E.pushERel env "r" dummyt NONE) "acc" dummyt NONE) body] - | EDml e => box [string "dml(", - p_exp env e, - string ")"] + | EDml (e, _) => box [string "dml(", + p_exp env e, + string ")"] | ENextval e => box [string "nextval(", p_exp env e, string ")"] diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 5e735b79..ce9f4a4e 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -465,7 +465,7 @@ fun reduce file = [ReadDb], summarize (d + 2) body] - | EDml e => summarize d e @ [WriteDb] + | EDml (e, _) => summarize d e @ [WriteDb] | ENextval e => summarize d e @ [WriteDb] | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb] | EUnurlify (e, _, _) => summarize d e diff --git a/src/mono_util.sml b/src/mono_util.sml index 6bbbecb1..8a567e83 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -332,10 +332,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} = initial = initial'}, loc))))))) - | EDml e => + | EDml (e, fm) => S.map2 (mfe ctx e, fn e' => - (EDml e', loc)) + (EDml (e', fm), loc)) | ENextval e => S.map2 (mfe ctx e, fn e' => diff --git a/src/monoize.sml b/src/monoize.sml index cde1af70..07e69834 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1748,7 +1748,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (e, fm) = monoExp (env, st, fm) e in - ((L'.EDml e, loc), + ((L'.EDml (e, L'.Error), loc), + fm) + end + + | L.EFfiApp ("Basis", "tryDml", [e]) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EDml (e, L'.None), loc), fm) end @@ -4014,13 +4022,13 @@ fun monoize env file = val e = foldl (fn ((x, v), e) => (L'.ESeq ( - (L'.EDml (L'.EStrcat ( - (L'.EPrim (Prim.String ("UPDATE uw_" - ^ tab - ^ " SET uw_" - ^ x - ^ " = NULL WHERE ")), loc), - cond (x, v)), loc), loc), + (L'.EDml ((L'.EStrcat ( + (L'.EPrim (Prim.String ("UPDATE uw_" + ^ tab + ^ " SET uw_" + ^ x + ^ " = NULL WHERE ")), loc), + cond (x, v)), loc), L'.Error), loc), e), loc)) e nullable @@ -4039,7 +4047,7 @@ fun monoize env file = ^ tab ^ " WHERE ")), loc), cond eb), loc) - ebs), loc), + ebs, L'.Error), loc), e), loc) in e @@ -4067,15 +4075,15 @@ fun monoize env file = [] => e | (x, _) :: ebs => (L'.ESeq ( - (L'.EDml (L'.EPrim (Prim.String - (foldl (fn ((x, _), s) => - s ^ ", uw_" ^ x ^ " = NULL") - ("UPDATE uw_" - ^ tab - ^ " SET uw_" - ^ x - ^ " = NULL") - ebs)), loc), loc), + (L'.EDml ((L'.EPrim (Prim.String + (foldl (fn ((x, _), s) => + s ^ ", uw_" ^ x ^ " = NULL") + ("UPDATE uw_" + ^ tab + ^ " SET uw_" + ^ x + ^ " = NULL") + ebs)), loc), L'.Error), loc), e), loc) val e = @@ -4083,8 +4091,8 @@ fun monoize env file = [] => e | eb :: ebs => (L'.ESeq ( - (L'.EDml (L'.EPrim (Prim.String ("DELETE FROM uw_" - ^ tab)), loc), loc), + (L'.EDml ((L'.EPrim (Prim.String ("DELETE FROM uw_" + ^ tab)), loc), L'.Error), loc), e), loc) in e diff --git a/src/mysql.sml b/src/mysql.sml index 12d52255..44d88c1d 100644 --- a/src/mysql.sml +++ b/src/mysql.sml @@ -1194,16 +1194,19 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = else box []] -fun dmlCommon {loc, dml} = - box [string "if (mysql_stmt_execute(stmt)) uw_error(ctx, FATAL, \"", - string (ErrorMsg.spanToString loc), - string ": Error executing DML: %s\\n%s\", ", - dml, - string ", mysql_error(conn->conn));", +fun dmlCommon {loc, dml, mode} = + box [string "if (mysql_stmt_execute(stmt)) ", + case mode of + Settings.Error => box [string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": Error executing DML: %s\\n%s\", ", + dml, + string ", mysql_error(conn->conn));"] + | Settings.None => string "uw_errmsg = mysql_error(conn->conn);", newline, newline] -fun dml loc = +fun dml (loc, mode) = box [string "uw_conn *conn = uw_get_db(ctx);", newline, string "MYSQL_STMT *stmt = mysql_stmt_init(conn->conn);", @@ -1220,12 +1223,12 @@ fun dml loc = newline, newline, - dmlCommon {loc = loc, dml = string "dml"}, + dmlCommon {loc = loc, dml = string "dml", mode = mode}, string "uw_pop_cleanup(ctx);", newline] -fun dmlPrepared {loc, id, dml, inputs} = +fun dmlPrepared {loc, id, dml, inputs, mode} = box [string "uw_conn *conn = uw_get_db(ctx);", newline, string "MYSQL_BIND in[", @@ -1471,7 +1474,7 @@ fun dmlPrepared {loc, id, dml, inputs} = dmlCommon {loc = loc, dml = box [string "\"", string (String.toCString dml), - string "\""]}] + string "\""], mode = mode}] fun nextval {loc, seqE, seqName} = box [string "uw_conn *conn = uw_get_db(ctx);", diff --git a/src/postgres.sml b/src/postgres.sml index 12e928c5..bf1e8536 100644 --- a/src/postgres.sml +++ b/src/postgres.sml @@ -708,7 +708,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = string (String.toCString query), string "\""]}] -fun dmlCommon {loc, dml} = +fun dmlCommon {loc, dml, mode} = box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", newline, newline, @@ -723,13 +723,15 @@ fun dmlCommon {loc, dml} = newline], string "}", newline, - string "PQclear(res);", - newline, - string "uw_error(ctx, FATAL, \"", - string (ErrorMsg.spanToString loc), - string ": DML failed:\\n%s\\n%s\", ", - dml, - string ", PQerrorMessage(conn));", + case mode of + Settings.Error => box [string "PQclear(res);", + newline, + string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": DML failed:\\n%s\\n%s\", ", + dml, + string ", PQerrorMessage(conn));"] + | Settings.None => string "uw_errmsg = PQerrorMessage(conn);", newline], string "}", newline, @@ -738,15 +740,15 @@ fun dmlCommon {loc, dml} = string "PQclear(res);", newline] -fun dml loc = +fun dml (loc, mode) = box [string "PGconn *conn = uw_get_db(ctx);", newline, string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);", newline, newline, - dmlCommon {loc = loc, dml = string "dml"}] + dmlCommon {loc = loc, dml = string "dml", mode = mode}] -fun dmlPrepared {loc, id, dml, inputs} = +fun dmlPrepared {loc, id, dml, inputs, mode} = box [string "PGconn *conn = uw_get_db(ctx);", newline, string "const int paramFormats[] = { ", @@ -787,7 +789,7 @@ fun dmlPrepared {loc, id, dml, inputs} = newline, dmlCommon {loc = loc, dml = box [string "\"", string (String.toCString dml), - string "\""]}] + string "\""], mode = mode}] fun nextvalCommon {loc, query} = box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");", diff --git a/src/prepare.sml b/src/prepare.sml index 2f49405b..81de2fa7 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -246,11 +246,11 @@ fun prepExp (e as (_, loc), st) = initial = initial, prepared = SOME {id = id, query = s, nested = true}}, loc), st) end - | EDml {dml, ...} => + | EDml {dml, mode, ...} => (case prepString (dml, st) of NONE => (e, st) | SOME (id, s, st) => - ((EDml {dml = dml, prepared = SOME {id = id, dml = s}}, loc), st)) + ((EDml {dml = dml, prepared = SOME {id = id, dml = s}, mode = mode}, loc), st)) | ENextval {seq, ...} => if #supportsNextval (Settings.currentDbms ()) then diff --git a/src/settings.sig b/src/settings.sig index a5f0cfa7..51d06902 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -124,6 +124,8 @@ signature SETTINGS = sig val isBlob : sql_type -> bool val isNotNull : sql_type -> bool + datatype failure_mode = Error | None + type dbms = { name : string, (* Call it this on the command line *) @@ -149,9 +151,9 @@ signature SETTINGS = sig -> Print.PD.pp_desc, nested : bool} -> Print.PD.pp_desc, - dml : ErrorMsg.span -> Print.PD.pp_desc, + dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc, dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, - inputs : sql_type list} -> Print.PD.pp_desc, + inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc, nextval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, seqName : string option} -> Print.PD.pp_desc, nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, diff --git a/src/settings.sml b/src/settings.sml index 93b022ab..af16f9ca 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -363,6 +363,8 @@ fun isBlob Blob = true fun isNotNull (Nullable _) = false | isNotNull _ = true +datatype failure_mode = Error | None + type dbms = { name : string, header : string, @@ -384,9 +386,9 @@ type dbms = { -> Print.PD.pp_desc, nested : bool} -> Print.PD.pp_desc, - dml : ErrorMsg.span -> Print.PD.pp_desc, + dml : ErrorMsg.span * failure_mode -> Print.PD.pp_desc, dmlPrepared : {loc : ErrorMsg.span, id : int, dml : string, - inputs : sql_type list} -> Print.PD.pp_desc, + inputs : sql_type list, mode : failure_mode} -> Print.PD.pp_desc, nextval : {loc : ErrorMsg.span, seqName : string option, seqE : Print.PD.pp_desc} -> Print.PD.pp_desc, nextvalPrepared : {loc : ErrorMsg.span, id : int, query : string} -> Print.PD.pp_desc, setval : {loc : ErrorMsg.span, seqE : Print.PD.pp_desc, count : Print.PD.pp_desc} -> Print.PD.pp_desc, diff --git a/src/sqlite.sml b/src/sqlite.sml index 74093f21..20afd5bc 100644 --- a/src/sqlite.sml +++ b/src/sqlite.sml @@ -688,7 +688,7 @@ fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} = box [string "uw_pop_cleanup(ctx);", newline]] -fun dmlCommon {loc, dml} = +fun dmlCommon {loc, dml, mode} = box [string "int r;", newline, @@ -701,14 +701,17 @@ fun dmlCommon {loc, dml} = newline, newline, - string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"", - string (ErrorMsg.spanToString loc), - string ": DML step failed: %s
    %s\", ", - dml, - string ", sqlite3_errmsg(conn->conn));", + string "if (r != SQLITE_DONE) ", + case mode of + Settings.Error => box [string "uw_error(ctx, FATAL, \"", + string (ErrorMsg.spanToString loc), + string ": DML step failed: %s
    %s\", ", + dml, + string ", sqlite3_errmsg(conn->conn));"] + | Settings.None => string "uw_errmsg = sqlite3_errmsg(conn->conn);", newline] -fun dml loc = +fun dml (loc, mode) = box [string "uw_conn *conn = uw_get_db(ctx);", newline, string "sqlite3_stmt *stmt;", @@ -721,12 +724,12 @@ fun dml loc = newline, newline, - dmlCommon {loc = loc, dml = string "dml"}, + dmlCommon {loc = loc, dml = string "dml", mode = mode}, string "uw_pop_cleanup(ctx);", newline] -fun dmlPrepared {loc, id, dml, inputs} = +fun dmlPrepared {loc, id, dml, inputs, mode = mode} = box [string "uw_conn *conn = uw_get_db(ctx);", newline, p_pre_inputs inputs, @@ -761,7 +764,7 @@ fun dmlPrepared {loc, id, dml, inputs} = dmlCommon {loc = loc, dml = box [string "\"", string (String.toCString dml), - string "\""]}, + string "\""], mode = mode}, string "uw_pop_cleanup(ctx);", newline, diff --git a/tests/tryDml.ur b/tests/tryDml.ur new file mode 100644 index 00000000..bfe98cdb --- /dev/null +++ b/tests/tryDml.ur @@ -0,0 +1,13 @@ +table t : {Id : int} + PRIMARY KEY Id + +fun doStuff () = + dml (INSERT INTO t (Id) VALUES (0)); + o1 <- tryDml (INSERT INTO t (Id) VALUES (0)); + dml (INSERT INTO t (Id) VALUES (1)); + o2 <- tryDml (INSERT INTO t (Id) VALUES (1)); + return {[o1]}; {[o2]} + +fun main () = return + + diff --git a/tests/tryDml.urp b/tests/tryDml.urp new file mode 100644 index 00000000..cf42105b --- /dev/null +++ b/tests/tryDml.urp @@ -0,0 +1,4 @@ +database dbname=trydml +sql trydml.sql + +tryDml diff --git a/tests/tryDml.urs b/tests/tryDml.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/tryDml.urs @@ -0,0 +1 @@ +val main : unit -> transaction page -- cgit v1.2.3 From 38d3bc508b3b882e81599bdb0e1d4a2572c23dd0 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 23 Dec 2010 17:46:40 -0500 Subject: [De]serialization of times in JavaScript; proper integer division in JavaScript; Basis.crypt; Top.mkRead'; more aggressive Mono-level inlining, for values of function-y types --- include/urweb.h | 3 +++ lib/js/urweb.js | 2 ++ lib/ur/basis.urs | 5 +++++ lib/ur/top.ur | 7 ++++++- lib/ur/top.urs | 2 ++ src/c/urweb.c | 34 ++++++++++++++++++++++++++++++++++ src/cjr_print.sml | 4 +++- src/cjrize.sml | 2 +- src/iflow.sml | 4 ++-- src/jscomp.sml | 11 ++++++----- src/mono.sml | 4 +++- src/mono_opt.sml | 2 +- src/mono_print.sml | 10 +++++----- src/mono_reduce.sml | 18 ++++++++++++++---- src/mono_util.sml | 4 ++-- src/monoize.sml | 30 +++++++++++++++--------------- src/settings.sml | 1 + src/urweb.grm | 4 +++- 18 files changed, 108 insertions(+), 39 deletions(-) (limited to 'src/iflow.sml') diff --git a/include/urweb.h b/include/urweb.h index 548e77fe..c52e1c26 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -169,6 +169,7 @@ char *uw_Basis_ensqlBool(uw_Basis_bool); char *uw_Basis_jsifyString(uw_context, uw_Basis_string); char *uw_Basis_jsifyChar(uw_context, uw_Basis_char); char *uw_Basis_jsifyChannel(uw_context, uw_Basis_channel); +char *uw_Basis_jsifyTime(uw_context, uw_Basis_time); uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int); uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float); @@ -301,4 +302,6 @@ uw_Basis_string uw_Basis_timef(uw_context, const char *fmt, uw_Basis_time); uw_Basis_time uw_Basis_stringToTimef(uw_context, const char *fmt, uw_Basis_string); uw_Basis_time uw_Basis_stringToTimef_error(uw_context, const char *fmt, uw_Basis_string); +uw_Basis_string uw_Basis_crypt(uw_context, uw_Basis_string key, uw_Basis_string salt); + #endif diff --git a/lib/js/urweb.js b/lib/js/urweb.js index f98476b7..bba58453 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -19,7 +19,9 @@ function plus(x, y) { return x + y; } function minus(x, y) { return x - y; } function times(x, y) { return x * y; } function div(x, y) { return x / y; } +function divInt(x, y) { var n = x / y; return n < 0 ? Math.ceil(n) : Math.floor(n); } function mod(x, y) { return x % y; } +function modInt(x, y) { var n = x % y; return n < 0 ? Math.ceil(n) : Math.floor(n); } function lt(x, y) { return x < y; } function le(x, y) { return x <= y; } diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 8cf516f8..95deb982 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -146,6 +146,11 @@ val minusSeconds : time -> int -> time val timef : string -> time -> string (* Uses strftime() format string *) +(** * Encryption *) + +val crypt : string -> string -> string + + (** HTTP operations *) con http_cookie :: Type -> Type diff --git a/lib/ur/top.ur b/lib/ur/top.ur index 32d06a43..19259e92 100644 --- a/lib/ur/top.ur +++ b/lib/ur/top.ur @@ -89,7 +89,7 @@ fun read_option [t ::: Type] (_ : read t) = None => None | v => Some v) -fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) = +fun txt [t] [ctx ::: {Unit}] [use ::: {Type}] (_ : show t) (v : t) : xml ctx use [] = cdata (show v) fun map0 [K] [tf :: K -> Type] (f : t :: K -> tf t) [r ::: {K}] (fl : folder r) = @@ -343,3 +343,8 @@ fun eqNullable' [tables ::: {{Type}}] [agg ::: {{Type}}] [exps ::: {Type}] case e2 of None => (SQL {e1} IS NULL) | Some _ => sql_binary sql_eq e1 (sql_inject e2) + +fun mkRead' [t ::: Type] (f : string -> option t) (name : string) : read t = + mkRead (fn s => case f s of + None => error Invalid {txt name}: {txt s} + | Some v => v) f diff --git a/lib/ur/top.urs b/lib/ur/top.urs index a18bf437..74b04ed1 100644 --- a/lib/ur/top.urs +++ b/lib/ur/top.urs @@ -231,3 +231,5 @@ val eqNullable' : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> sql_exp tables agg exps (option t) -> option t -> sql_exp tables agg exps bool + +val mkRead' : t ::: Type -> (string -> option t) -> string -> read t diff --git a/src/c/urweb.c b/src/c/urweb.c index a09978cd..efe50591 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -13,6 +13,7 @@ #include #include #include +#include #include @@ -2006,6 +2007,27 @@ uw_unit uw_Basis_htmlifyFloat_w(uw_context ctx, uw_Basis_float n) { return uw_unit_v; } +char *uw_Basis_jsifyTime(uw_context ctx, uw_Basis_time n) { + int len; + char *r; + + uw_check_heap(ctx, INTS_MAX); + r = ctx->heap.front; + sprintf(r, "%lld%n", (uw_Basis_int)n, &len); + ctx->heap.front += len+1; + return r; +} + +uw_unit uw_Basis_jsifyInt_w(uw_context ctx, uw_Basis_time n) { + int len; + + uw_check(ctx, INTS_MAX); + sprintf(ctx->page.front, "%lld%n", (uw_Basis_int)n, &len); + ctx->page.front += len; + + return uw_unit_v; +} + char *uw_Basis_htmlifyString(uw_context ctx, uw_Basis_string s) { char *r, *s2; @@ -3568,3 +3590,15 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) { return r; } + +uw_Basis_string uw_Basis_crypt(uw_context ctx, uw_Basis_string key, uw_Basis_string salt) { + struct crypt_data *data; + + if ((data = uw_get_global(ctx, "crypt")) == NULL) { + data = malloc(sizeof(struct crypt_data)); + data->initialized = 0; + uw_set_global(ctx, "crypt", data, free); + } + + return uw_strdup(ctx, crypt_r(key, salt, data)); +} diff --git a/src/cjr_print.sml b/src/cjr_print.sml index b4f75eb5..53060ab2 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -635,7 +635,9 @@ fun unurlify fromClient env (t, loc) = string (Int.toString (size x')), string "] == 0 || request[", string (Int.toString (size x')), - string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), + string "] == '/')) ? (request += ", + string (Int.toString (size x')), + string (", (*request == '/' ? ++request : NULL), __uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ")"), space, string ":", space, diff --git a/src/cjrize.sml b/src/cjrize.sml index 9c297fad..2c13e494 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -300,7 +300,7 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.EUnop (s, e1), loc), sm) end - | L.EBinop (s, e1, e2) => + | L.EBinop (_, s, e1, e2) => let val (e1, sm) = cifyExp (e1, sm) val (e2, sm) = cifyExp (e2, sm) diff --git a/src/iflow.sml b/src/iflow.sml index c0e92cb1..f6e03271 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1965,7 +1965,7 @@ fun evalExp env (e as (_, loc)) k = | EAbs _ => default () | EUnop (s, e1) => evalExp env e1 (fn e1 => k (Func (Other s, [e1]))) - | EBinop (s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2])))) + | EBinop (_, s, e1, e2) => evalExp env e1 (fn e1 => evalExp env e2 (fn e2 => k (Func (Other s, [e1, e2])))) | ERecord xets => let fun doFields (xes, acc) = @@ -2352,7 +2352,7 @@ fun check file = end | EAbs (x, t1, t2, e) => (EAbs (x, t1, t2, doExp (Unknown :: env) e), loc) | EUnop (uo, e1) => (EUnop (uo, doExp env e1), loc) - | EBinop (bo, e1, e2) => (EBinop (bo, doExp env e1, doExp env e2), loc) + | EBinop (bi, bo, e1, e2) => (EBinop (bi, bo, doExp env e1, doExp env e2), loc) | ERecord xets => (ERecord (map (fn (x, e, t) => (x, doExp env e, t)) xets), loc) | EField (e1, f) => (EField (doExp env e1, f), loc) | ECase (e, pes, ts) => diff --git a/src/jscomp.sml b/src/jscomp.sml index 992a2e30..3b859814 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -126,6 +126,7 @@ fun process file = | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st) | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st) | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st) + | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [e]), loc), st) | TFfi ("Basis", "bool") => ((ECase (e, [((PCon (Enum, PConFfi {mod = "Basis", @@ -701,7 +702,7 @@ fun process file = str ",null)}"], st) end - | EBinop (s, e1, e2) => + | EBinop (bi, s, e1, e2) => let val name = case s of "==" => "eq" @@ -709,8 +710,8 @@ fun process file = | "+" => "plus" | "-" => "minus" | "*" => "times" - | "/" => "div" - | "%" => "mod" + | "/" => (case bi of Int => "divInt" | NotInt => "div") + | "%" => (case bi of Int => "modInt" | NotInt => "mod") | "<" => "lt" | "<=" => "le" | "strcmp" => "strcmp" @@ -1039,12 +1040,12 @@ fun process file = in ((EUnop (s, e), loc), st) end - | EBinop (s, e1, e2) => + | EBinop (bi, s, e1, e2) => let val (e1, st) = exp outer (e1, st) val (e2, st) = exp outer (e2, st) in - ((EBinop (s, e1, e2), loc), st) + ((EBinop (bi, s, e1, e2), loc), st) end | ERecord xets => diff --git a/src/mono.sml b/src/mono.sml index 1d446dda..bf38c0bc 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -68,6 +68,8 @@ datatype export_kind = datatype Export.export_kind datatype failure_mode = datatype Settings.failure_mode +datatype binop_intness = Int | NotInt + datatype exp' = EPrim of Prim.t | ERel of int @@ -81,7 +83,7 @@ datatype exp' = | EAbs of string * typ * typ * exp | EUnop of string * exp - | EBinop of string * exp * exp + | EBinop of binop_intness * string * exp * exp | ERecord of (string * exp * typ) list | EField of exp * string diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 34f43143..d05e38fd 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -536,7 +536,7 @@ fun exp e = | EFfiApp ("Basis", "attrifyString_w", [(EFfiApp ("Basis", "str1", [e]), _)]) => EFfiApp ("Basis", "attrifyChar_w", [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))) | _ => e diff --git a/src/mono_print.sml b/src/mono_print.sml index 63c98f44..2d296745 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -187,11 +187,11 @@ fun p_exp' par env (e, _) = | EUnop (s, e) => parenIf true (box [string s, space, p_exp' true env e]) - | EBinop (s, e1, e2) => parenIf true (box [p_exp' true env e1, - space, - string s, - space, - p_exp' true env e2]) + | EBinop (_, s, e1, e2) => parenIf true (box [p_exp' true env e1, + space, + string s, + space, + p_exp' true env e2]) | ERecord xes => box [string "{", p_list (fn (x, e, _) => diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 59ec5a55..f8b209d5 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -92,7 +92,7 @@ fun impure (e, _) = | EApp _ => true | EUnop (_, e) => impure e - | EBinop (_, e1, e2) => impure e1 orelse impure e2 + | EBinop (_, _, e1, e2) => impure e1 orelse impure e2 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes | EField (e, _) => impure e @@ -365,11 +365,21 @@ fun reduce file = val size = U.Exp.fold {typ = fn (_, n) => n, exp = fn (_, n) => n + 1} 0 - fun mayInline (n, e) = + val functionInside' = U.Typ.exists (fn c => case c of + TFun _ => true + | _ => false) + + fun functionInside t = + case #1 t of + TFun (t1, t2) => functionInside' t1 orelse functionInside t2 + | _ => functionInside' t + + fun mayInline (n, e, t) = case IM.find (uses, n) of NONE => false | SOME count => count <= 1 orelse size e <= Settings.getMonoInline () + orelse functionInside t fun summarize d (e, _) = let @@ -426,7 +436,7 @@ fun reduce file = | EAbs _ => [] | EUnop (_, e) => summarize d e - | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 + | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2 | ERecord xets => List.concat (map (summarize d o #2) xets) | EField (e, _) => summarize d e @@ -701,7 +711,7 @@ fun reduce file = let val eo = case eo of NONE => NONE - | SOME e => if mayInline (n, e) then + | SOME e => if mayInline (n, e, t) then SOME e else NONE diff --git a/src/mono_util.sml b/src/mono_util.sml index 56472155..bb09f84d 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -200,12 +200,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mfe ctx e, fn e' => (EUnop (s, e'), loc)) - | EBinop (s, e1, e2) => + | EBinop (bi, s, e1, e2) => S.bind2 (mfe ctx e1, fn e1' => S.map2 (mfe ctx e2, fn e2' => - (EBinop (s, e1', e2'), loc))) + (EBinop (bi, s, e1', e2'), loc))) | ERecord xes => S.map2 (ListUtil.mapfold (fn (x, e, t) => diff --git a/src/monoize.sml b/src/monoize.sml index 0c0d9d2e..35c6fa83 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -895,42 +895,42 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.Int, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_float") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_bool") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_string") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "!strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_char") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.EFfi ("Basis", "eq_time") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop ("==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), + (L'.EBinop (L'.NotInt, "==", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => @@ -999,7 +999,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "int"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in numEx ((L'.TFfi ("Basis", "int"), loc), Prim.Int (Int64.fromInt 0), @@ -1019,7 +1019,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "float"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in numEx ((L'.TFfi ("Basis", "float"), loc), Prim.Float 0.0, @@ -1086,7 +1086,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.Int, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "int"), loc), intBin "<", @@ -1099,7 +1099,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "float"), loc), floatBin "<", @@ -1112,7 +1112,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "bool"), loc), boolBin "<", @@ -1125,8 +1125,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, - (L'.EBinop ("strcmp", + (L'.EBinop (L'.NotInt, s, + (L'.EBinop (L'.NotInt, "strcmp", (L'.ERel 1, loc), (L'.ERel 0, loc)), loc), (L'.EPrim (Prim.Int (Int64.fromInt 0)), loc)), loc)), loc)), loc) @@ -1142,7 +1142,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "char"), loc), charBin "<", @@ -1155,7 +1155,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EBinop (s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) + (L'.EBinop (L'.NotInt, s, (L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "time"), loc), boolBin "<", diff --git a/src/settings.sml b/src/settings.sml index 4c611336..97c39abf 100644 --- a/src/settings.sml +++ b/src/settings.sml @@ -171,6 +171,7 @@ val jsFuncsBase = basisM [("alert", "alert"), ("stringToInt_error", "pi"), ("urlifyInt", "ts"), ("urlifyFloat", "ts"), + ("urlifyTime", "ts"), ("urlifyString", "uf"), ("urlifyBool", "ub"), ("recv", "rv"), diff --git a/src/urweb.grm b/src/urweb.grm index 21c4a50c..5803f445 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1232,7 +1232,9 @@ eterm : LPAREN eexp RPAREN (#1 eexp, s (LPARENleft, RPARENright)) val e = (EApp (e, texp), loc) in if length fields <> length sqlexps then - ErrorMsg.errorAt loc "Length mismatch in INSERT field specification" + ErrorMsg.errorAt loc ("Length mismatch in INSERT field specification (" + ^ Int.toString (length fields) + ^ " vs. " ^ Int.toString (length sqlexps) ^ ")") else (); (EApp (e, (ERecord (ListPair.zip (fields, sqlexps)), loc)), loc) -- cgit v1.2.3 From 09b5839acfe26561fa87c89168133fc93c1083cc Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sat, 7 Jan 2012 15:56:22 -0500 Subject: First part of changes to avoid depending on C function call argument order of evaluation (omitting normal Ur function calls, so far) --- include/urweb.h | 8 +-- src/checknest.sml | 4 +- src/cjr.sml | 2 +- src/cjr_print.sml | 140 ++++++++++++++++++++++++++++++++-------------- src/cjrize.sml | 13 ++++- src/core.sml | 2 +- src/core_print.sml | 2 +- src/core_util.sml | 10 +++- src/corify.sml | 4 +- src/css.sml | 2 +- src/especialize.sml | 7 ++- src/iflow.sml | 18 +++--- src/jscomp.sml | 25 +++++---- src/mono.sml | 2 +- src/mono_opt.sml | 154 +++++++++++++++++++++++++-------------------------- src/mono_print.sml | 2 +- src/mono_reduce.sml | 16 +++--- src/mono_util.sml | 10 +++- src/monoize.sml | 151 +++++++++++++++++++++++++++----------------------- src/prepare.sml | 34 +++++++----- src/reduce.sml | 2 +- src/reduce_local.sml | 2 +- src/scriptcheck.sml | 8 +-- src/tag.sml | 16 +++--- 24 files changed, 369 insertions(+), 265 deletions(-) (limited to 'src/iflow.sml') diff --git a/include/urweb.h b/include/urweb.h index 53f59c5a..4230da1a 100644 --- a/include/urweb.h +++ b/include/urweb.h @@ -30,7 +30,7 @@ void uw_free(uw_context); void uw_reset(uw_context); void uw_reset_keep_request(uw_context); void uw_reset_keep_error_message(uw_context); -const char *uw_get_url_prefix(uw_context); +char *uw_get_url_prefix(uw_context); failure_kind uw_begin_init(uw_context); void uw_set_on_success(char *); @@ -75,9 +75,9 @@ uw_Basis_source uw_Basis_new_client_source(uw_context, uw_Basis_string); uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_source, uw_Basis_string); void uw_set_script_header(uw_context, const char*); -const char *uw_Basis_get_settings(uw_context, uw_unit); -const char *uw_Basis_get_script(uw_context, uw_unit); -const char *uw_get_real_script(uw_context); +char *uw_Basis_get_settings(uw_context, uw_unit); +char *uw_Basis_get_script(uw_context, uw_unit); +char *uw_get_real_script(uw_context); uw_Basis_string uw_Basis_maybe_onload(uw_context, uw_Basis_string); uw_Basis_string uw_Basis_maybe_onunload(uw_context, uw_Basis_string); diff --git a/src/checknest.sml b/src/checknest.sml index 1147d3e6..05ad8e9a 100644 --- a/src/checknest.sml +++ b/src/checknest.sml @@ -44,7 +44,7 @@ fun expUses globals = | ENone _ => IS.empty | ESome (_, e) => eu e | EFfi _ => IS.empty - | EFfiApp (_, _, es) => foldl IS.union IS.empty (map eu es) + | EFfiApp (_, _, es) => foldl IS.union IS.empty (map (eu o #1) es) | EApp (e, es) => foldl IS.union (eu e) (map eu es) | EUnop (_, e) => eu e @@ -106,7 +106,7 @@ fun annotateExp globals = | ENone _ => e | ESome (t, e) => (ESome (t, ae e), loc) | EFfi _ => e - | EFfiApp (m, f, es) => (EFfiApp (m, f, map ae es), loc) + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (ae e, t)) es), loc) | EApp (e, es) => (EApp (ae e, map ae es), loc) | EUnop (uo, e) => (EUnop (uo, ae e), loc) diff --git a/src/cjr.sml b/src/cjr.sml index 7ea665ce..c348d01a 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -66,7 +66,7 @@ datatype exp' = | ENone of typ | ESome of typ * exp | EFfi of string * string - | EFfiApp of string * string * exp list + | EFfiApp of string * string * (exp * typ) list | EApp of exp * exp list | EUnop of string * exp diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 851fa02d..e69b87f1 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -490,23 +490,23 @@ fun p_sql_type t = string (Settings.p_sql_ctype t) fun getPargs (e, _) = case e of EPrim (Prim.String _) => [] - | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2 + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => getPargs e1 @ getPargs e2 - | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)] - | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)] - | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)] - | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)] - | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)] - | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)] - | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)] - | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)] + | EFfiApp ("Basis", "sqlifyInt", [(e, _)]) => [(e, Int)] + | EFfiApp ("Basis", "sqlifyFloat", [(e, _)]) => [(e, Float)] + | EFfiApp ("Basis", "sqlifyString", [(e, _)]) => [(e, String)] + | EFfiApp ("Basis", "sqlifyBool", [(e, _)]) => [(e, Bool)] + | EFfiApp ("Basis", "sqlifyTime", [(e, _)]) => [(e, Time)] + | EFfiApp ("Basis", "sqlifyBlob", [(e, _)]) => [(e, Blob)] + | EFfiApp ("Basis", "sqlifyChannel", [(e, _)]) => [(e, Channel)] + | EFfiApp ("Basis", "sqlifyClient", [(e, _)]) => [(e, Client)] | ECase (e, [((PNone _, _), (EPrim (Prim.String "NULL"), _)), ((PSome (_, (PVar _, _)), _), - (EFfiApp (m, x, [(ERel 0, _)]), _))], - _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e)) + (EFfiApp (m, x, [((ERel 0, _), _)]), _))], + {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e)) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), @@ -1442,7 +1442,63 @@ fun potentiallyFancy (e, _) = val self = ref (NONE : int option) -fun p_exp' par tail env (e, loc) = +(* The crucial thing to do here is assign arguments to local variables, to enforce order of evaluation. + * Otherwise, we are at the mercy of C's undefined order of function argument evaluation. *) +fun pFuncall env (m, x, es, extra) = + case es of + [] => box [string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx", + case extra of + NONE => box [] + | SOME extra => box [string ",", + space, + string extra], + string ")"] + | [(e, _)] => box [string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx,", + space, + p_exp' false false env e, + case extra of + NONE => box [] + | SOME extra => box [string ",", + space, + string extra], + string ")"] + | _ => box [string "({", + newline, + p_list_sepi (box []) (fn i => fn (e, t) => + box [p_typ env t, + space, + string "arg", + string (Int.toString i), + space, + string "=", + space, + p_exp' false false env e, + string ";", + newline]) es, + string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx, ", + p_list_sepi (box [string ",", space]) (fn i => fn _ => box [string "arg", string (Int.toString i)]) es, + case extra of + NONE => box [] + | SOME extra => box [string ",", + space, + string extra], + string ");", + newline, + string "})"] + +and p_exp' par tail env (e, loc) = case e of EPrim p => Prim.p_t_GCC p | ERel n => p_rel env n @@ -1571,16 +1627,30 @@ fun p_exp' par tail env (e, loc) = string "})"] | EReturnBlob {blob, mimeType, t} => box [string "({", + newline, + string "uw_Basis_blob", + space, + string "blob", + space, + string "=", + space, + p_exp' false false env blob, + string ";", + newline, + string "uw_Basis_string", + space, + string "mimeType", + space, + string "=", + space, + p_exp' false false env mimeType, + string ";", newline, p_typ env t, space, string "tmp;", newline, - string "uw_return_blob(ctx, ", - p_exp' false false env blob, - string ", ", - p_exp' false false env mimeType, - string ");", + string "uw_return_blob(ctx, blob, mimeType);", newline, string "tmp;", newline, @@ -1604,37 +1674,23 @@ fun p_exp' par tail env (e, loc) = | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) => p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc) - | EFfiApp ("Basis", "strcat", [e1, e2]) => + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => let fun flatten e = case #1 e of - EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2 + EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2 | _ => [e] + + val es = flatten e1 @ flatten e2 + val t = (TFfi ("Basis", "string"), loc) + val es = map (fn e => (e, t)) es in - case flatten e1 @ flatten e2 of - [e1, e2] => box [string "uw_Basis_strcat(ctx, ", - p_exp' false false env e1, - string ",", - p_exp' false false env e2, - string ")"] - | es => box [string "uw_Basis_mstrcat(ctx, ", - p_list (p_exp' false false env) es, - string ", NULL)"] + case es of + [_, _] => pFuncall env ("Basis", "strcat", es, NONE) + | _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL") end - | EFfiApp (m, x, []) => box [string "uw_", - p_ident m, - string "_", - p_ident x, - string "(ctx)"] - - | EFfiApp (m, x, es) => box [string "uw_", - p_ident m, - string "_", - p_ident x, - string "(ctx, ", - p_list (p_exp' false false env) es, - string ")"] + | EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE) | EApp (f, args) => let fun default () = parenIf par (box [p_exp' true false env f, @@ -3036,7 +3092,7 @@ fun p_file env (ds, ps) = case e of ECon (_, _, SOME e) => expDb e | ESome (_, e) => expDb e - | EFfiApp (_, _, es) => List.exists expDb es + | EFfiApp (_, _, es) => List.exists (expDb o #1) es | EApp (e, es) => expDb e orelse List.exists expDb es | EUnop (_, e) => expDb e | EBinop (_, e1, e2) => expDb e1 orelse expDb e2 diff --git a/src/cjrize.sml b/src/cjrize.sml index 2b46c32d..a0ec2ece 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -277,7 +277,13 @@ fun cifyExp (eAll as (e, loc), sm) = | L.EFfi mx => ((L'.EFfi mx, loc), sm) | L.EFfiApp (m, x, es) => let - val (es, sm) = ListUtil.foldlMap cifyExp sm es + val (es, sm) = ListUtil.foldlMap (fn ((e, t), sm) => + let + val (t, sm) = cifyTyp (t, sm) + val (e, sm) = cifyExp (e, sm) + in + ((e, t), sm) + end) sm es in ((L'.EFfiApp (m, x, es), loc), sm) end @@ -384,8 +390,9 @@ fun cifyExp (eAll as (e, loc), sm) = let val (e1, sm) = cifyExp (e1, sm) val (e2, sm) = cifyExp (e2, sm) + val s = (L'.TFfi ("Basis", "string"), loc) in - ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm) + ((L'.EFfiApp ("Basis", "strcat", [(e1, s), (e2, s)]), loc), sm) end | L.EWrite e => @@ -673,7 +680,7 @@ fun cifyDecl ((d, loc), sm) = val tk = case #1 e1 of L.EFfi ("Basis", "initialize") => L'.Initialize | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves - | L.EFfiApp ("Basis", "periodic", [(L.EPrim (Prim.Int n), _)]) => L'.Periodic n + | L.EFfiApp ("Basis", "periodic", [((L.EPrim (Prim.Int n), _), _)]) => L'.Periodic n | _ => (ErrorMsg.errorAt loc "Task kind not fully determined"; L'.Initialize) val (e, sm) = cifyExp (e, sm) diff --git a/src/core.sml b/src/core.sml index 6d9e56b6..4641d1ab 100644 --- a/src/core.sml +++ b/src/core.sml @@ -92,7 +92,7 @@ datatype exp' = | ENamed of int | ECon of datatype_kind * patCon * con list * exp option | EFfi of string * string - | EFfiApp of string * string * exp list + | EFfiApp of string * string * (exp * con) list | EApp of exp * exp | EAbs of string * con * con * exp | ECApp of exp * con diff --git a/src/core_print.sml b/src/core_print.sml index 8e46db04..910ec10a 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -276,7 +276,7 @@ fun p_exp' par env (e, _) = string ".", string x, string "(", - p_list (p_exp env) es, + p_list (p_exp env o #1) es, string "))"] | EApp (e1, e2) => parenIf par (box [p_exp' true env e1, space, diff --git a/src/core_util.sml b/src/core_util.sml index e71d7276..d41dfe33 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -468,7 +468,7 @@ fun compare ((e1, _), (e2, _)) = | (EFfiApp (f1, x1, es1), EFfiApp (f2, x2, es2)) => join (String.compare (f1, f2), fn () => join (String.compare (x1, x2), - fn () => joinL compare (es1, es2))) + fn () => joinL (fn ((e1, _), (e2, _)) => compare (e1, e2))(es1, es2))) | (EFfiApp _, _) => LESS | (_, EFfiApp _) => GREATER @@ -586,6 +586,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fun mfe ctx e acc = S.bindP (mfe' ctx e acc, fe ctx) + and mfet ctx (e, t) = + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mfc ctx t, + fn t' => (e', t'))) + and mfe' ctx (eAll as (e, loc)) = case e of EPrim _ => S.return2 eAll @@ -603,7 +609,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = (ECon (dk, n, cs', SOME e'), loc))) | EFfi _ => S.return2 eAll | EFfiApp (m, x, es) => - S.map2 (ListUtil.mapfold (mfe ctx) es, + S.map2 (ListUtil.mapfold (mfet ctx) es, fn es' => (EFfiApp (m, x, es'), loc)) | EApp (e1, e2) => diff --git a/src/corify.sml b/src/corify.sml index d9e5d30c..bc14d408 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -562,8 +562,8 @@ fun corifyExp st (e, loc) = fun makeApp n = let - val (actuals, _) = foldr (fn (_, (actuals, n)) => - ((L'.ERel n, loc) :: actuals, + val (actuals, _) = foldr (fn (t, (actuals, n)) => + (((L'.ERel n, loc), t) :: actuals, n + 1)) ([], n) args in (L'.EFfiApp (m, x, actuals), loc) diff --git a/src/css.sml b/src/css.sml index 90c0b5dd..07160898 100644 --- a/src/css.sml +++ b/src/css.sml @@ -138,7 +138,7 @@ fun summarize file = | ECon (_, _, _, NONE) => ([], classes) | ECon (_, _, _, SOME e) => exp (e, classes) | EFfi _ => ([], classes) - | EFfiApp (_, _, es) => expList (es, classes) + | EFfiApp (_, _, es) => expList (map #1 es, classes) | EApp ( (EApp ( diff --git a/src/especialize.sml b/src/especialize.sml index 8720a7b1..74babe47 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -180,7 +180,12 @@ fun specialize' (funcs, specialized) file = | EFfi _ => (e, st) | EFfiApp (m, x, es) => let - val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es + val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => + let + val (e, st) = exp (env, e, st) + in + ((e, t), st) + end) st es in ((EFfiApp (m, x, es), loc), st) end diff --git a/src/iflow.sml b/src/iflow.sml index f6e03271..c65271b3 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1044,7 +1044,7 @@ fun known' chs = fun sqlify chs = case chs of - Exp (EFfiApp ("Basis", f, [e]), _) :: chs => + Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs => if String.isPrefix "sqlify" f then SOME (e, chs) else @@ -1859,7 +1859,7 @@ fun evalExp env (e as (_, loc)) k = [] => (if s = "set_cookie" then case es of - [_, cname, _, _, _] => + [_, (cname, _), _, _, _] => (case #1 cname of EPrim (Prim.String cname) => St.havocCookie cname @@ -1868,7 +1868,7 @@ fun evalExp env (e as (_, loc)) k = else (); k (Recd [])) - | e :: es => + | (e, _) :: es => evalExp env e (fn e => (St.send (e, loc); doArgs es)) in doArgs es @@ -1880,7 +1880,7 @@ fun evalExp env (e as (_, loc)) k = fun doArgs (es, acc) = case es of [] => k (Func (Other (m ^ "." ^ s), rev acc)) - | e :: es => + | (e, _) :: es => evalExp env e (fn e => doArgs (es, e :: acc)) in doArgs (es, []) @@ -1904,7 +1904,7 @@ fun evalExp env (e as (_, loc)) k = k e end | EFfiApp x => doFfi x - | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [e]) + | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [(e, (TRecord [], loc))]) | EApp (e1 as (EError _, _), _) => evalExp env e1 k @@ -2051,7 +2051,7 @@ fun evalExp env (e as (_, loc)) k = | Update (tab, _, _) => (cs, SS.add (ts, tab))) | EFfiApp ("Basis", "set_cookie", - [_, (EPrim (Prim.String cname), _), + [_, ((EPrim (Prim.String cname), _), _), _, _, _]) => (SS.add (cs, cname), ts) | _ => st} @@ -2189,7 +2189,7 @@ fun evalExp env (e as (_, loc)) k = | ENextval _ => default () | ESetval _ => default () - | EUnurlify ((EFfiApp ("Basis", "get_cookie", [(EPrim (Prim.String cname), _)]), _), _, _) => + | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String cname), _), _)]), _), _, _) => let val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) @@ -2301,10 +2301,10 @@ fun check file = | EFfi _ => e | EFfiApp (m, f, es) => (case (m, f, es) of - ("Basis", "set_cookie", [_, (EPrim (Prim.String cname), _), _, _, _]) => + ("Basis", "set_cookie", [_, ((EPrim (Prim.String cname), _), _), _, _, _]) => cookies := SS.add (!cookies, cname) | _ => (); - (EFfiApp (m, f, map (doExp env) es), loc)) + (EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc)) | EApp (e1, e2) => let diff --git a/src/jscomp.sml b/src/jscomp.sml index 57f59b12..901ea9fe 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -91,7 +91,7 @@ fun process file = fun quoteExp loc (t : typ) (e, st) = case #1 t of - TSource => ((EFfiApp ("Basis", "htmlifySource", [e]), loc), st) + TSource => ((EFfiApp ("Basis", "htmlifySource", [(e, t)]), loc), st) | TRecord [] => (str loc "null", st) | TRecord [(x, t)] => @@ -120,12 +120,12 @@ fun process file = @ [str loc "}"]), st) end - | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st) - | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [e]), loc), st) - | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st) - | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st) - | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st) - | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [e]), loc), st) + | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [(e, t)]), loc), st) + | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [(e, t)]), loc), st) + | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [(e, t)]), loc), st) + | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [(e, t)]), loc), st) + | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [(e, t)]), loc), st) + | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [(e, t)]), loc), st) | TFfi ("Basis", "bool") => ((ECase (e, [((PCon (Enum, PConFfi {mod = "Basis", @@ -511,7 +511,7 @@ fun process file = case e of EPrim (Prim.String s) => jsifyStringMulti (level, s) | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 - | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\"" + | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\"" | _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)]; raise Fail "Jscomp: deStrcat") @@ -645,7 +645,7 @@ fun process file = "ERROR") | SOME s => s - val (e, st) = foldr (fn (e, (acc, st)) => + val (e, st) = foldr (fn ((e, _), (acc, st)) => let val (e, st) = jsE inner (e, st) in @@ -1024,7 +1024,12 @@ fun process file = | EFfi _ => (e, st) | EFfiApp (m, x, es) => let - val (es, st) = ListUtil.foldlMap (exp outer) st es + val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => + let + val (e, st) = exp outer (e, st) + in + ((e, t), st) + end) st es in ((EFfiApp (m, x, es), loc), st) end diff --git a/src/mono.sml b/src/mono.sml index bf38c0bc..2c83d1bc 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -78,7 +78,7 @@ datatype exp' = | ENone of typ | ESome of typ * exp | EFfi of string * string - | EFfiApp of string * string * exp list + | EFfiApp of string * string * (exp * typ) list | EApp of exp * exp | EAbs of string * typ * typ * exp diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 5abbf900..199c807b 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -138,7 +138,7 @@ fun exp e = EPrim (Prim.String (String.implode (rev chs))) end - | EFfiApp ("Basis", "strcat", [e1, e2]) => exp (EStrcat (e1, e2)) + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) => let @@ -182,153 +182,153 @@ fun exp e = ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc), e) - | EFfiApp ("Basis", "htmlifySpecialChar", [(EPrim (Prim.Char ch), _)]) => + | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) => EPrim (Prim.String (htmlifySpecialChar ch)) | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) => EFfiApp ("Basis", "htmlifySpecialChar_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) => EPrim (Prim.String (htmlifyInt n)) - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyInt", es) - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _), - (EPrim (Prim.Int n), _)), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), + (EPrim (Prim.Int n), _)), _), _)]) => EPrim (Prim.String (htmlifyInt n)) - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _), - e), _)]) => - EFfiApp ("Basis", "htmlifyInt", [e]) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), + e), loc), _)]) => + EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))]) | EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) => EFfiApp ("Basis", "htmlifyInt_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) => EPrim (Prim.String (htmlifyFloat n)) - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyFloat", es) - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _), - (EPrim (Prim.Float n), _)), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), + (EPrim (Prim.Float n), _)), _), _)]) => EPrim (Prim.String (htmlifyFloat n)) - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _), - e), _)]) => - EFfiApp ("Basis", "htmlifyFloat", [e]) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), + e), loc), _)]) => + EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))]) | EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) => EFfiApp ("Basis", "htmlifyFloat_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", - [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", + [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) => EPrim (Prim.String "True") - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", - [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", + [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) => EPrim (Prim.String "False") - | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyBool", es) - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _), - (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), + (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) => EPrim (Prim.String "True") - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _), - (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), + (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) => EPrim (Prim.String "False") - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _), - e), _)]) => - EFfiApp ("Basis", "htmlifyBool", [e]) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), + e), loc), _)]) => + EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))]) | EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) => EFfiApp ("Basis", "htmlifyBool_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) => - EFfiApp ("Basis", "htmlifyTime", [e]) - | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) => - EFfiApp ("Basis", "htmlifyTime_w", [e]) + | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "timeToString"), _), e), loc), _)]) => + EFfiApp ("Basis", "htmlifyTime", [(e, (TFfi ("Basis", "time"), loc))]) + | EFfiApp ("Basis", "htmlifyString_w", [((EApp ((EFfi ("Basis", "timeToString"), loc), e), _), _)]) => + EFfiApp ("Basis", "htmlifyTime_w", [(e, (TFfi ("Basis", "time"), loc))]) | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => EFfiApp ("Basis", "htmlifyTime_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) => + | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]) => EPrim (Prim.String (htmlifyString s)) - | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) => + | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]), loc) => EWrite (EPrim (Prim.String (htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) => EFfiApp ("Basis", "htmlifyString_w", [e]) - | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String s), loc), _)]) => EWrite (EPrim (Prim.String (htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) => EFfiApp ("Basis", "htmlifySource_w", [e]) - | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) => + | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) => EPrim (Prim.String (attrifyInt n)) - | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) => + | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => EWrite (EPrim (Prim.String (attrifyInt n)), loc) | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) => EFfiApp ("Basis", "attrifyInt_w", [e]) - | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) => + | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) => EPrim (Prim.String (attrifyFloat n)) - | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) => + | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => EWrite (EPrim (Prim.String (attrifyFloat n)), loc) | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) => EFfiApp ("Basis", "attrifyFloat_w", [e]) - | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) => + | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]) => EPrim (Prim.String (attrifyString s)) - | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) => + | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]), loc) => EWrite (EPrim (Prim.String (attrifyString s)), loc) | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) - | EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]) => + | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) => EPrim (Prim.String (attrifyChar s)) - | EWrite (EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]), loc) => + | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) => EWrite (EPrim (Prim.String (attrifyChar s)), loc) | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) => EFfiApp ("Basis", "attrifyChar_w", [e]) - | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) => + | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]) => EPrim (Prim.String s) - | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) => + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]), loc) => EWrite (EPrim (Prim.String s), loc) | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) - | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) => + | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) => EPrim (Prim.String (urlifyInt n)) - | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) => + | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => EWrite (EPrim (Prim.String (urlifyInt n)), loc) | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) => EFfiApp ("Basis", "urlifyInt_w", [e]) - | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) => + | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) => EPrim (Prim.String (urlifyFloat n)) - | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) => + | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => EWrite (EPrim (Prim.String (urlifyFloat n)), loc) | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) => EFfiApp ("Basis", "urlifyFloat_w", [e]) - | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) => + | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]) => EPrim (Prim.String (urlifyString s)) - | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) => + | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]), loc) => EWrite (EPrim (Prim.String (urlifyString s)), loc) | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => EFfiApp ("Basis", "urlifyString_w", [e]) - | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) => + | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) => EPrim (Prim.String "1") - | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) => + | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) => EPrim (Prim.String "0") - | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) => + | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) => EWrite (EPrim (Prim.String "1"), loc) - | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) => + | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) => EWrite (EPrim (Prim.String "0"), loc) | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) => EFfiApp ("Basis", "urlifyBool_w", [e]) - | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) => + | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) => EPrim (Prim.String (sqlifyInt n)) - | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) => + | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) => EPrim (Prim.String "NULL") - | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) => + | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) => EPrim (Prim.String (sqlifyInt n)) - | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) => + | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) => EPrim (Prim.String (sqlifyFloat n)) - | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) => + | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) => optExp (ECase (b, [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), (EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)), @@ -336,9 +336,9 @@ fun exp e = (EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))], {disc = (TFfi ("Basis", "bool"), loc), result = (TFfi ("Basis", "string"), loc)}), loc) - | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) => + | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String n), _), _)]) => EPrim (Prim.String (sqlifyString n)) - | EFfiApp ("Basis", "sqlifyChar", [(EPrim (Prim.Char n), _)]) => + | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) => EPrim (Prim.String (sqlifyChar n)) | EWrite (ECase (discE, pes, {disc, ...}), loc) => @@ -418,52 +418,52 @@ fun exp e = | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) - | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) => (if checkUrl s then () else ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'"); se) - | EFfiApp ("Basis", "checkUrl", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String s), loc), _)]) => (if checkUrl s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkMime s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'"); se) - | EFfiApp ("Basis", "checkMime", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkMime s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessRequestHeader", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkRequestHeader s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'"); se) - | EFfiApp ("Basis", "checkRequestHeader", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkRequestHeader s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessResponseHeader", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkResponseHeader s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'"); se) - | EFfiApp ("Basis", "checkResponseHeader", [(se as EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkResponseHeader s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -491,7 +491,7 @@ fun exp e = EPrim (Prim.String s) end - | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) => + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String s), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -516,9 +516,9 @@ fun exp e = EPrim (Prim.String s) end - | EFfiApp ("Basis", "unAs", [(EPrim (Prim.String s), _)]) => + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String s), _), _)]) => EPrim (Prim.String (unAs s)) - | EFfiApp ("Basis", "unAs", [e']) => + | EFfiApp ("Basis", "unAs", [(e', _)]) => let fun parts (e as (_, loc)) = case #1 e of @@ -543,11 +543,11 @@ fun exp e = | NONE => e end - | EFfiApp ("Basis", "str1", [(EPrim (Prim.Char ch), _)]) => + | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) => EPrim (Prim.String (str ch)) - | EFfiApp ("Basis", "attrifyString", [(EFfiApp ("Basis", "str1", [e]), _)]) => + | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => EFfiApp ("Basis", "attrifyChar", [e]) - | EFfiApp ("Basis", "attrifyString_w", [(EFfiApp ("Basis", "str1", [e]), _)]) => + | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => EFfiApp ("Basis", "attrifyChar_w", [e]) | EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2))) diff --git a/src/mono_print.sml b/src/mono_print.sml index 2d296745..bf1b0935 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -167,7 +167,7 @@ fun p_exp' par env (e, _) = string ".", string x, string "(", - p_list (p_exp env) es, + p_list (p_exp env o #1) es, string "))"] | EApp (e1, e2) => parenIf par (box [p_exp env e1, space, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 3507480e..88628ac2 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -390,20 +390,20 @@ fun reduce file = | ENone _ => [] | ESome (_, e) => summarize d e | EFfi _ => [] - | EFfiApp ("Basis", "get_cookie", [e]) => + | EFfiApp ("Basis", "get_cookie", [(e, _)]) => summarize d e @ [ReadCookie] | EFfiApp ("Basis", "set_cookie", es) => - List.concat (map (summarize d) es) @ [WriteCookie] + List.concat (map (summarize d o #1) es) @ [WriteCookie] | EFfiApp ("Basis", "clear_cookie", es) => - List.concat (map (summarize d) es) @ [WriteCookie] + List.concat (map (summarize d o #1) es) @ [WriteCookie] | EFfiApp (m, x, es) => if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then - List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then - WritePage - else - Unsure] + List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then + WritePage + else + Unsure] else - List.concat (map (summarize d) es) + List.concat (map (summarize d o #1) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => let diff --git a/src/mono_util.sml b/src/mono_util.sml index 39305d1b..38016f85 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -156,6 +156,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = fun mfe ctx e acc = S.bindP (mfe' ctx e acc, fe ctx) + and mfet ctx (e, t) = + S.bind2 (mfe ctx e, + fn e' => + S.map2 (mft t, + fn t' => (e', t'))) + and mfe' ctx (eAll as (e, loc)) = case e of EPrim _ => S.return2 eAll @@ -178,7 +184,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} = (ESome (t', e'), loc))) | EFfi _ => S.return2 eAll | EFfiApp (m, x, es) => - S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es, + S.map2 (ListUtil.mapfold (fn e => mfet ctx e) es, fn es' => (EFfiApp (m, x, es'), loc)) | EApp (e1, e2) => @@ -479,7 +485,7 @@ fun appLoc f = | ENone _ => () | ESome (_, e) => appl e | EFfi _ => () - | EFfiApp (_, _, es) => app appl es + | EFfiApp (_, _, es) => app (appl o #1) es | EApp (e1, e2) => (appl e1; appl e2) | EAbs (_, _, _, e1) => appl e1 | EUnop (_, e1) => appl e1 diff --git a/src/monoize.sml b/src/monoize.sml index 82e0030c..d952c396 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -509,7 +509,7 @@ fun fooifyExp fk env = | _ => case t of L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm) - | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm) + | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) | L'.TRecord ((x, t) :: xts) => @@ -944,7 +944,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EFfiApp ("Basis", "eq_time", [(L'.ERel 1, loc), (L'.ERel 0, loc)]), loc)), loc)), loc), + (L'.EFfiApp ("Basis", "eq_time", [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)), + ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) => @@ -1169,7 +1170,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc), (L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc), - (L'.EFfiApp ("Basis", s, [(L'.ERel 1, loc), (L'.ERel 0, loc)]), loc)), loc)), loc) + (L'.EFfiApp ("Basis", s, [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)), + ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc) in ordEx ((L'.TFfi ("Basis", "time"), loc), boolBin "lt_time", @@ -1368,14 +1370,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.EFfiApp ("Basis", "recv", _) => poly () - | L.EFfiApp ("Basis", "float", [e]) => + | L.EFfiApp ("Basis", "float", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in - ((L'.EFfiApp ("Basis", "floatFromInt", [e]), loc), fm) + ((L'.EFfiApp ("Basis", "floatFromInt", [(e, monoType env t)]), loc), fm) end - | L.EFfiApp ("Basis", "sleep", [n]) => + | L.EFfiApp ("Basis", "sleep", [(n, _)]) => let val (n, fm) = monoExp (env, st, fm) n in @@ -1390,7 +1392,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc), (L'.EFfiApp ("Basis", "new_client_source", - [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc)]), + [((L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc), + (L'.TSource, loc))]), loc)), loc)), loc), fm) @@ -1404,9 +1407,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "set_client_source", - [(L'.ERel 2, loc), - (L'.EJavaScript (L'.Source t, - (L'.ERel 1, loc)), loc)]), + [((L'.ERel 2, loc), (L'.TSource, loc)), + ((L'.EJavaScript (L'.Source t, + (L'.ERel 1, loc)), loc), + t)]), loc)), loc)), loc)), loc), fm) end @@ -1418,7 +1422,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TRecord [], loc), t), loc), (L'.EAbs ("_", (L'.TRecord [], loc), t, (L'.EFfiApp ("Basis", "get_client_source", - [(L'.ERel 1, loc)]), + [((L'.ERel 1, loc), (L'.TSource, loc))]), loc)), loc)), loc), fm) end @@ -1430,12 +1434,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TRecord [], loc), t), loc), (L'.EAbs ("_", (L'.TRecord [], loc), t, (L'.EFfiApp ("Basis", "current", - [(L'.ERel 1, loc)]), + [((L'.ERel 1, loc), (L'.TSource, loc))]), loc)), loc)), loc), fm) end - | L.EFfiApp ("Basis", "spawn", [e]) => + | L.EFfiApp ("Basis", "spawn", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e in @@ -1480,7 +1484,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("c", s, (L'.TFun (un, s), loc), (L'.EAbs ("_", un, s, - (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc), + (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [((L'.ERel 1, loc), s)]), loc), t, true), loc)), loc)), loc), fm) @@ -1502,13 +1506,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc), (L'.EAbs ("r", rt, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, - (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String - (Settings.getUrlPrefix ())), - loc), - (L'.ERel 2, loc), - e, - fd "Expires", - fd "Secure"]) + (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String + (Settings.getUrlPrefix ())), + loc), s), + ((L'.ERel 2, loc), s), + (e, s), + (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)), + (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))]) , loc)), loc)), loc)), loc), fm) end @@ -1521,17 +1525,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.EFfiApp ("Basis", "clear_cookie", - [(L'.EPrim (Prim.String - (Settings.getUrlPrefix ())), - loc), - (L'.ERel 1, loc)]), + [((L'.EPrim (Prim.String + (Settings.getUrlPrefix ())), + loc), s), + ((L'.ERel 1, loc), s)]), loc)), loc)), loc), fm) end | L.ECApp ((L.EFfi ("Basis", "channel"), _), t) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc), - (L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "new_channel", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "send"), _), t) => let @@ -1543,8 +1547,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc), (L'.EFfiApp ("Basis", "send", - [(L'.ERel 2, loc), - e]), + [((L'.ERel 2, loc), (L'.TFfi ("Basis", "channel"), loc)), + (e, (L'.TFfi ("Basis", "string"), loc))]), loc)), loc)), loc)), loc), fm) end @@ -1763,11 +1767,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("e", string, string, (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc), (L'.EFfiApp ("Basis", "checkString", - [(L'.ERel 0, loc)]), loc)), loc)), loc), + [((L'.ERel 0, loc), string)]), loc)), loc)), loc), fm) end - | L.EFfiApp ("Basis", "dml", [e]) => + | L.EFfiApp ("Basis", "dml", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e in @@ -1775,7 +1779,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.EFfiApp ("Basis", "tryDml", [e]) => + | L.EFfiApp ("Basis", "tryDml", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e in @@ -1841,13 +1845,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = strcat [sc ("uw_" ^ x ^ " = "), (L'.EFfiApp ("Basis", "unAs", - [(L'.EField - ((L'.ERel 2, - loc), - x), loc)]), loc)]) + [((L'.EField + ((L'.ERel 2, + loc), + x), loc), + s)]), loc)]) changed), sc " WHERE ", - (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), + (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc)), loc), fm) end @@ -1869,7 +1874,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = strcat [sc "DELETE FROM ", (L'.ERel 1, loc), sc " WHERE ", - (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc), fm) end @@ -2108,43 +2113,43 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "sql_int") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyInt", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "int"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_float") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyFloat", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "float"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_bool") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyBool", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "bool"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_string") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_char") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyChar", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_time") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyTime", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_blob") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyBlob", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyBlob", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "blob"), loc))]), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) => ((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyChannel", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "channel"), loc))]), loc)), loc), fm) | L.EFfi ("Basis", "sql_client") => ((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) => ((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc), + (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) => let @@ -2430,26 +2435,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "sql_no_limit") => ((L'.EPrim (Prim.String ""), loc), fm) - | L.EFfiApp ("Basis", "sql_limit", [e]) => + | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ (L'.EPrim (Prim.String " LIMIT "), loc), - (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) + (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.EFfi ("Basis", "sql_no_offset") => ((L'.EPrim (Prim.String ""), loc), fm) - | L.EFfiApp ("Basis", "sql_offset", [e]) => + | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ (L'.EPrim (Prim.String " OFFSET "), loc), - (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc) + (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end @@ -2914,13 +2919,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.EFfiApp ("Basis", "nextval", [e]) => + | L.EFfiApp ("Basis", "nextval", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e in ((L'.ENextval e, loc), fm) end - | L.EFfiApp ("Basis", "setval", [e1, e2]) => + | L.EFfiApp ("Basis", "setval", [(e1, _), (e2, _)]) => let val (e1, fm) = monoExp (env, st, fm) e1 val (e2, fm) = monoExp (env, st, fm) e2 @@ -2930,7 +2935,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm) - | L.EFfiApp ("Basis", "classes", [s1, s2]) => + | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 @@ -2947,13 +2952,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (se, fm) = monoExp (env, st, fm) se in - ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm) + ((L'.EFfiApp ("Basis", "htmlifyString", [(se, (L'.TFfi ("Basis", "string"), loc))]), loc), fm) end | L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _), _) => ((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EFfiApp ("Basis", "htmlifySpecialChar", [(L'.ERel 0, loc)]), loc)), loc), fm) + (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm) | L.EApp ( (L.EApp ( @@ -3010,7 +3015,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun getTag (e, _) = case e of - L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, []) + L.EFfiApp ("Basis", tag, [((L.ERecord [], _), _)]) => (tag, []) | L.EApp (e, (L.ERecord [], _)) => getTag' e | _ => (E.errorAt loc "Non-constant XML tag"; Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; @@ -3297,17 +3302,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = "body" => let val onload = execify onload val onunload = execify onunload + val s = (L'.TFfi ("Basis", "string"), loc) in normal ("body", SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", - [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", - [(L'.ERecord [], loc)]), loc), - onload), loc)]), + [((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", + [((L'.ERecord [], loc), + (L'.TRecord [], loc))]), loc), + onload), loc), + s)]), loc), (L'.EFfiApp ("Basis", "maybe_onunload", - [onunload]), + [(onunload, s)]), loc)), loc), - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + SOME (L'.EFfiApp ("Basis", "get_script", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)) end | "dyn" => @@ -3645,7 +3653,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end val sigName = getSigName () - val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc) + val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc) val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String (" + | L.EFfiApp ("Basis", "url", [(e, _)]) => let val (e, fm) = monoExp (env, st, fm) e val (e, fm) = urlifyExp env fm (e, dummyTyp) @@ -3815,7 +3823,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi mx => ((L'.EFfi mx, loc), fm) | L.EFfiApp (m, x, es) => let - val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es + val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) => + let + val (e, fm) = monoExp (env, st, fm) e + in + ((e, monoType env t), fm) + end) fm es in ((L'.EFfiApp (m, x, es), loc), fm) end @@ -4054,7 +4067,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts val (e, fm) = monoExp (env, St.empty, fm) e - val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc) + val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc) in SOME (Env.pushENamed env x n t NONE s, fm, @@ -4110,7 +4123,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = let fun policies (e, fm) = case #1 e of - L.EFfiApp ("Basis", "also", [e1, e2]) => + L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) => let val (ps1, fm) = policies (e1, fm) val (ps2, fm) = policies (e2, fm) @@ -4129,7 +4142,7 @@ fun monoDecl (env, fm) (all as (d, loc)) = (e, L'.PolDelete) | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) => (e, L'.PolUpdate) - | L.EFfiApp ("Basis", "sendOwnIds", [e]) => + | L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) => (e, L'.PolSequence) | _ => (poly (); (e, L'.PolClient)) @@ -4186,7 +4199,7 @@ fun monoize env file = fun expunger () = let - val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc) + val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc) fun doTable (tab, xts, e) = case xts of diff --git a/src/prepare.sml b/src/prepare.sml index 1b7454dc..7f55959c 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -67,25 +67,25 @@ fun prepString (e, st) = case #1 e of EPrim (Prim.String s) => SOME (s :: ss, n) - | EFfiApp ("Basis", "strcat", [e1, e2]) => + | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => (case prepString' (e1, ss, n) of NONE => NONE | SOME (ss, n) => prepString' (e2, ss, n)) - | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int - | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float - | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String - | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool - | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time - | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob - | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel - | EFfiApp ("Basis", "sqlifyClient", [e]) => doOne Client + | EFfiApp ("Basis", "sqlifyInt", [_]) => doOne Int + | EFfiApp ("Basis", "sqlifyFloat", [_]) => doOne Float + | EFfiApp ("Basis", "sqlifyString", [_]) => doOne String + | EFfiApp ("Basis", "sqlifyBool", [_]) => doOne Bool + | EFfiApp ("Basis", "sqlifyTime", [_]) => doOne Time + | EFfiApp ("Basis", "sqlifyBlob", [_]) => doOne Blob + | EFfiApp ("Basis", "sqlifyChannel", [_]) => doOne Channel + | EFfiApp ("Basis", "sqlifyClient", [_]) => doOne Client | ECase (e, [((PNone _, _), (EPrim (Prim.String "NULL"), _)), ((PSome (_, (PVar _, _)), _), - (EFfiApp (m, x, [(ERel 0, _)]), _))], - _) => prepString' ((EFfiApp (m, x, [e]), #2 e), ss, n) + (EFfiApp (m, x, [((ERel 0, _), _)]), _))], + {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), @@ -130,7 +130,12 @@ fun prepExp (e as (_, loc), st) = | EFfi _ => (e, st) | EFfiApp (m, x, es) => let - val (es, st) = ListUtil.foldlMap prepExp st es + val (es, st) = ListUtil.foldlMap (fn ((e, t), st) => + let + val (e, st) = prepExp (e, st) + in + ((e, t), st) + end) st es in ((EFfiApp (m, x, es), loc), st) end @@ -260,9 +265,10 @@ fun prepExp (e as (_, loc), st) = (EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc) | _ => let - val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc) + val t = (TFfi ("Basis", "string"), loc) + val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String "')"), loc), t)]), loc) in - (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc) + (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String "SELECT NEXTVAL('"), loc), t), (s', t)]), loc) end in case prepString (s, st) of diff --git a/src/reduce.sml b/src/reduce.sml index 9371e9bd..1fbf526d 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -493,7 +493,7 @@ fun kindConAndExp (namedC, namedE) = bindType (CFfi ("Basis", "signal"), loc) loc)], loc) | EFfi _ => all - | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) (*| EApp ( (EApp diff --git a/src/reduce_local.sml b/src/reduce_local.sml index 0e87e34a..a6e4f7fc 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -256,7 +256,7 @@ fun exp env (all as (e, loc)) = | 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 (exp env) es), loc) + | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc) | EApp (e1, e2) => let diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 129f4281..6c6c5588 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -92,12 +92,12 @@ fun classify (ds, ps) = | EFfi ("Basis", x) => SS.member (basis, x) | EFfi _ => false | EFfiApp ("Basis", "maybe_onload", - [(EFfiApp ("Basis", "strcat", all as [_, (EPrim (Prim.String s), _)]), _)]) => - List.exists hasClient all + [((EFfiApp ("Basis", "strcat", all as [_, ((EPrim (Prim.String s), _), _)]), _), _)]) => + List.exists (hasClient o #1) all orelse (onload andalso size s > 0) | EFfiApp ("Basis", x, es) => SS.member (basis, x) - orelse List.exists hasClient es - | EFfiApp (_, _, es) => List.exists hasClient es + orelse List.exists (hasClient o #1) es + | EFfiApp (_, _, es) => List.exists (hasClient o #1) es | EApp (e, es) => hasClient e orelse List.exists hasClient es | EUnop (_, e) => hasClient e | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2 diff --git a/src/tag.sml b/src/tag.sml index 26c23586..6037cb17 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -170,22 +170,22 @@ fun exp env (e, s) = end | _ => (e, s)) - | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s) + | EFfiApp ("Basis", "url", [((ERel 0, _), _)]) => (e, s) - | EFfiApp ("Basis", "url", [e]) => + | EFfiApp ("Basis", "url", [(e, t)]) => let val (e, s) = tagIt (e, Link, "Url", s) in - (EFfiApp ("Basis", "url", [e]), s) + (EFfiApp ("Basis", "url", [(e, t)]), s) end - | EFfiApp ("Basis", "effectfulUrl", [(ERel 0, _)]) => (e, s) + | EFfiApp ("Basis", "effectfulUrl", [((ERel 0, _), _)]) => (e, s) - | EFfiApp ("Basis", "effectfulUrl", [e]) => + | EFfiApp ("Basis", "effectfulUrl", [(e, t)]) => let val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s) in - (EFfiApp ("Basis", "url", [e]), s) + (EFfiApp ("Basis", "url", [(e, t)]), s) end | EApp ((ENamed n, _), e') => @@ -193,11 +193,11 @@ fun exp env (e, s) = val (_, _, eo, _) = E.lookupENamed env n in case eo of - SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) => + SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) => let val (e, s) = tagIt (e', Link, "Url", s) in - (EFfiApp ("Basis", "url", [e]), s) + (EFfiApp ("Basis", "url", [(e, t)]), s) end | _ => (e, s) end -- cgit v1.2.3 From a6dc15f0ca2f44264e7794bdd4313c78c710e141 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Mon, 12 Mar 2012 12:00:23 -0700 Subject: Refactor SQL parsing code from Iflow to Sql, add querydml parser. --- src/iflow.sml | 418 +------------------------------------------------------- src/sources | 2 + src/sql.sml | 428 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 431 insertions(+), 417 deletions(-) create mode 100644 src/sql.sml (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index c65271b3..fe0be731 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -28,6 +28,7 @@ structure Iflow :> IFLOW = struct open Mono +open Sql structure IS = IntBinarySet structure IM = IntBinaryMap @@ -57,43 +58,6 @@ val writers = ["htmlifyInt_w", val writers = SS.addList (SS.empty, writers) -type lvar = int - -datatype func = - DtCon0 of string - | DtCon1 of string - | UnCon of string - | Other of string - -datatype exp = - Const of Prim.t - | Var of int - | Lvar of lvar - | Func of func * exp list - | Recd of (string * exp) list - | Proj of exp * string - -datatype reln = - Known - | Sql of string - | PCon0 of string - | PCon1 of string - | Eq - | Ne - | Lt - | Le - | Gt - | Ge - -datatype prop = - True - | False - | Unknown - | And of prop * prop - | Or of prop * prop - | Reln of reln * exp list - | Cond of exp * prop - local open Print val string = PD.string @@ -226,8 +190,6 @@ fun p_atom a = AReln x => Reln x | ACond x => Cond x) -val debug = ref false - (* Congruence closure *) structure Cc :> sig type database @@ -828,384 +790,6 @@ fun patCon pc = PConVar n => "C" ^ Int.toString n | PConFfi {mod = m, datatyp = d, con = c, ...} => m ^ "." ^ d ^ "." ^ c -datatype chunk = - String of string - | Exp of Mono.exp - -fun chunkify e = - case #1 e of - EPrim (Prim.String s) => [String s] - | EStrcat (e1, e2) => - let - val chs1 = chunkify e1 - val chs2 = chunkify e2 - in - case chs2 of - String s2 :: chs2' => - (case List.last chs1 of - String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2' - | _ => chs1 @ chs2) - | _ => chs1 @ chs2 - end - | _ => [Exp e] - -type 'a parser = chunk list -> ('a * chunk list) option - -fun always v chs = SOME (v, chs) - -fun parse p s = - case p (chunkify s) of - SOME (v, []) => SOME v - | _ => NONE - -fun const s chs = - case chs of - String s' :: chs => if String.isPrefix s s' then - SOME ((), if size s = size s' then - chs - else - String (String.extract (s', size s, NONE)) :: chs) - else - NONE - | _ => NONE - -fun follow p1 p2 chs = - case p1 chs of - NONE => NONE - | SOME (v1, chs) => - case p2 chs of - NONE => NONE - | SOME (v2, chs) => SOME ((v1, v2), chs) - -fun wrap p f chs = - case p chs of - NONE => NONE - | SOME (v, chs) => SOME (f v, chs) - -fun wrapP p f chs = - case p chs of - NONE => NONE - | SOME (v, chs) => - case f v of - NONE => NONE - | SOME r => SOME (r, chs) - -fun alt p1 p2 chs = - case p1 chs of - NONE => p2 chs - | v => v - -fun altL ps = - case rev ps of - [] => (fn _ => NONE) - | p :: ps => - foldl (fn (p1, p2) => alt p1 p2) p ps - -fun opt p chs = - case p chs of - NONE => SOME (NONE, chs) - | SOME (v, chs) => SOME (SOME v, chs) - -fun skip cp chs = - case chs of - String "" :: chs => skip cp chs - | String s :: chs' => if cp (String.sub (s, 0)) then - skip cp (String (String.extract (s, 1, NONE)) :: chs') - else - SOME ((), chs) - | _ => SOME ((), chs) - -fun keep cp chs = - case chs of - String "" :: chs => keep cp chs - | String s :: chs' => - let - val (befor, after) = Substring.splitl cp (Substring.full s) - in - if Substring.isEmpty befor then - NONE - else - SOME (Substring.string befor, - if Substring.isEmpty after then - chs' - else - String (Substring.string after) :: chs') - end - | _ => NONE - -fun ws p = wrap (follow (skip (fn ch => ch = #" ")) - (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) - -fun log name p chs = - (if !debug then - (print (name ^ ": "); - app (fn String s => print s - | _ => print "???") chs; - print "\n") - else - (); - p chs) - -fun list p chs = - altL [wrap (follow p (follow (ws (const ",")) (list p))) - (fn (v, ((), ls)) => v :: ls), - wrap (ws p) (fn v => [v]), - always []] chs - -val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_") - -val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then - SOME (String.extract (s, 2, NONE)) - else - NONE) -val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then - SOME (str (Char.toUpper (String.sub (s, 3))) - ^ String.extract (s, 4, NONE)) - else - NONE) - -val field = wrap (follow t_ident - (follow (const ".") - uw_ident)) - (fn (t, ((), f)) => (t, f)) - -datatype Rel = - Exps of exp * exp -> prop - | Props of prop * prop -> prop - -datatype sqexp = - SqConst of Prim.t - | SqTrue - | SqFalse - | SqNot of sqexp - | Field of string * string - | Computed of string - | Binop of Rel * sqexp * sqexp - | SqKnown of sqexp - | Inj of Mono.exp - | SqFunc of string * sqexp - | Unmodeled - | Null - -fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) - -val sqbrel = altL [cmp "=" Eq, - cmp "<>" Ne, - cmp "<=" Le, - cmp "<" Lt, - cmp ">=" Ge, - cmp ">" Gt, - wrap (const "AND") (fn () => Props And), - wrap (const "OR") (fn () => Props Or)] - -datatype ('a, 'b) sum = inl of 'a | inr of 'b - -fun string chs = - case chs of - String s :: chs => - if size s >= 2 andalso String.sub (s, 0) = #"'" then - let - fun loop (cs, acc) = - case cs of - [] => NONE - | c :: cs => - if c = #"'" then - SOME (String.implode (rev acc), cs) - else if c = #"\\" then - case cs of - c :: cs => loop (cs, c :: acc) - | _ => raise Fail "Iflow.string: Unmatched backslash escape" - else - loop (cs, c :: acc) - in - case loop (String.explode (String.extract (s, 1, NONE)), []) of - NONE => NONE - | SOME (s, []) => SOME (s, chs) - | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs) - end - else - NONE - | _ => NONE - -val prim = - altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) - (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y)))) - (opt (const "::float8"))) #1, - wrap (follow (wrapP (keep Char.isDigit) - (Option.map Prim.Int o Int64.fromString)) - (opt (const "::int8"))) #1, - wrap (follow (opt (const "E")) (follow string (opt (const "::text")))) - (Prim.String o #1 o #2)] - -fun known' chs = - case chs of - Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs) - | _ => NONE - -fun sqlify chs = - case chs of - Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs => - if String.isPrefix "sqlify" f then - SOME (e, chs) - else - NONE - | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), - (EPrim (Prim.String "TRUE"), _)), - ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), - (EPrim (Prim.String "FALSE"), _))], _), _) :: chs => - SOME (e, chs) - - | _ => NONE - -fun constK s = wrap (const s) (fn () => s) - -val funcName = altL [constK "COUNT", - constK "MIN", - constK "MAX", - constK "SUM", - constK "AVG"] - -val unmodeled = altL [const "COUNT(*)", - const "CURRENT_TIMESTAMP"] - -fun sqexp chs = - log "sqexp" - (altL [wrap prim SqConst, - wrap (const "TRUE") (fn () => SqTrue), - wrap (const "FALSE") (fn () => SqFalse), - wrap (const "NULL") (fn () => Null), - wrap field Field, - wrap uw_ident Computed, - wrap known SqKnown, - wrap func SqFunc, - wrap unmodeled (fn () => Unmodeled), - wrap sqlify Inj, - wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") - (follow (keep (fn ch => ch <> #")")) (const ")"))))) - (fn ((), (e, _)) => e), - wrap (follow (const "(NOT ") (follow sqexp (const ")"))) - (fn ((), (e, _)) => SqNot e), - wrap (follow (ws (const "(")) - (follow (wrap - (follow sqexp - (alt - (wrap - (follow (ws sqbrel) - (ws sqexp)) - inl) - (always (inr ())))) - (fn (e1, sm) => - case sm of - inl (bo, e2) => Binop (bo, e1, e2) - | inr () => e1)) - (const ")"))) - (fn ((), (e, ())) => e)]) - chs - -and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) - (fn ((), ((), (e, ()))) => e) chs - -and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) - (fn (f, ((), (e, ()))) => (f, e)) chs - -datatype sitem = - SqField of string * string - | SqExp of sqexp * string - -val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident)) - (fn (e, ((), s)) => SqExp (e, s))) - (wrap field SqField) - -val select = log "select" - (wrap (follow (const "SELECT ") (list sitem)) - (fn ((), ls) => ls)) - -val fitem = wrap (follow uw_ident - (follow (const " AS ") - t_ident)) - (fn (t, ((), f)) => (t, f)) - -val from = log "from" - (wrap (follow (const "FROM ") (list fitem)) - (fn ((), ls) => ls)) - -val wher = wrap (follow (ws (const "WHERE ")) sqexp) - (fn ((), ls) => ls) - -type query1 = {Select : sitem list, - From : (string * string) list, - Where : sqexp option} - -val query1 = log "query1" - (wrap (follow (follow select from) (opt wher)) - (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) - -datatype query = - Query1 of query1 - | Union of query * query - -val orderby = log "orderby" - (wrap (follow (ws (const "ORDER BY ")) - (follow (list sqexp) - (opt (ws (const "DESC"))))) - ignore) - -fun query chs = log "query" - (wrap - (follow - (alt (wrap (follow (const "((") - (follow query - (follow (const ") UNION (") - (follow query (const "))"))))) - (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) - (wrap query1 Query1)) - (opt orderby)) - #1) - chs - -datatype dml = - Insert of string * (string * sqexp) list - | Delete of string * sqexp - | Update of string * (string * sqexp) list * sqexp - -val insert = log "insert" - (wrapP (follow (const "INSERT INTO ") - (follow uw_ident - (follow (const " (") - (follow (list uw_ident) - (follow (const ") VALUES (") - (follow (list sqexp) - (const ")"))))))) - (fn ((), (tab, ((), (fs, ((), (es, ())))))) => - (SOME (tab, ListPair.zipEq (fs, es))) - handle ListPair.UnequalLengths => NONE)) - -val delete = log "delete" - (wrap (follow (const "DELETE FROM ") - (follow uw_ident - (follow (const " AS T_T WHERE ") - sqexp))) - (fn ((), (tab, ((), es))) => (tab, es))) - -val setting = log "setting" - (wrap (follow uw_ident (follow (const " = ") sqexp)) - (fn (f, ((), e)) => (f, e))) - -val update = log "update" - (wrap (follow (const "UPDATE ") - (follow uw_ident - (follow (const " AS T_T SET ") - (follow (list setting) - (follow (ws (const "WHERE ")) - sqexp))))) - (fn ((), (tab, ((), (fs, ((), e))))) => - (tab, fs, e))) - -val dml = log "dml" - (altL [wrap insert Insert, - wrap delete Delete, - wrap update Update]) - type check = exp * ErrorMsg.span structure St :> sig diff --git a/src/sources b/src/sources index aebe9de6..4011ce3b 100644 --- a/src/sources +++ b/src/sources @@ -180,6 +180,8 @@ mono_shake.sml fuse.sig fuse.sml +sql.sml + iflow.sig iflow.sml diff --git a/src/sql.sml b/src/sql.sml new file mode 100644 index 00000000..c314eb3d --- /dev/null +++ b/src/sql.sml @@ -0,0 +1,428 @@ +structure Sql = struct + +open Mono + +val debug = ref false + +type lvar = int + +datatype func = + DtCon0 of string + | DtCon1 of string + | UnCon of string + | Other of string + +datatype exp = + Const of Prim.t + | Var of int + | Lvar of lvar + | Func of func * exp list + | Recd of (string * exp) list + | Proj of exp * string + +datatype reln = + Known + | Sql of string + | PCon0 of string + | PCon1 of string + | Eq + | Ne + | Lt + | Le + | Gt + | Ge + +datatype prop = + True + | False + | Unknown + | And of prop * prop + | Or of prop * prop + | Reln of reln * exp list + | Cond of exp * prop + +datatype chunk = + String of string + | Exp of Mono.exp + +fun chunkify e = + case #1 e of + EPrim (Prim.String s) => [String s] + | EStrcat (e1, e2) => + let + val chs1 = chunkify e1 + val chs2 = chunkify e2 + in + case chs2 of + String s2 :: chs2' => + (case List.last chs1 of + String s1 => List.take (chs1, length chs1 - 1) @ String (s1 ^ s2) :: chs2' + | _ => chs1 @ chs2) + | _ => chs1 @ chs2 + end + | _ => [Exp e] + +type 'a parser = chunk list -> ('a * chunk list) option + +fun always v chs = SOME (v, chs) + +fun parse p s = + case p (chunkify s) of + SOME (v, []) => SOME v + | _ => NONE + +fun const s chs = + case chs of + String s' :: chs => if String.isPrefix s s' then + SOME ((), if size s = size s' then + chs + else + String (String.extract (s', size s, NONE)) :: chs) + else + NONE + | _ => NONE + +fun follow p1 p2 chs = + case p1 chs of + NONE => NONE + | SOME (v1, chs) => + case p2 chs of + NONE => NONE + | SOME (v2, chs) => SOME ((v1, v2), chs) + +fun wrap p f chs = + case p chs of + NONE => NONE + | SOME (v, chs) => SOME (f v, chs) + +fun wrapP p f chs = + case p chs of + NONE => NONE + | SOME (v, chs) => + case f v of + NONE => NONE + | SOME r => SOME (r, chs) + +fun alt p1 p2 chs = + case p1 chs of + NONE => p2 chs + | v => v + +fun altL ps = + case rev ps of + [] => (fn _ => NONE) + | p :: ps => + foldl (fn (p1, p2) => alt p1 p2) p ps + +fun opt p chs = + case p chs of + NONE => SOME (NONE, chs) + | SOME (v, chs) => SOME (SOME v, chs) + +fun skip cp chs = + case chs of + String "" :: chs => skip cp chs + | String s :: chs' => if cp (String.sub (s, 0)) then + skip cp (String (String.extract (s, 1, NONE)) :: chs') + else + SOME ((), chs) + | _ => SOME ((), chs) + +fun keep cp chs = + case chs of + String "" :: chs => keep cp chs + | String s :: chs' => + let + val (befor, after) = Substring.splitl cp (Substring.full s) + in + if Substring.isEmpty befor then + NONE + else + SOME (Substring.string befor, + if Substring.isEmpty after then + chs' + else + String (Substring.string after) :: chs') + end + | _ => NONE + +fun ws p = wrap (follow (skip (fn ch => ch = #" ")) + (follow p (skip (fn ch => ch = #" ")))) (#1 o #2) + +fun log name p chs = + (if !debug then + (print (name ^ ": "); + app (fn String s => print s + | _ => print "???") chs; + print "\n") + else + (); + p chs) + +fun list p chs = + altL [wrap (follow p (follow (ws (const ",")) (list p))) + (fn (v, ((), ls)) => v :: ls), + wrap (ws p) (fn v => [v]), + always []] chs + +val ident = keep (fn ch => Char.isAlphaNum ch orelse ch = #"_") + +val t_ident = wrapP ident (fn s => if String.isPrefix "T_" s then + SOME (String.extract (s, 2, NONE)) + else + NONE) +val uw_ident = wrapP ident (fn s => if String.isPrefix "uw_" s andalso size s >= 4 then + SOME (str (Char.toUpper (String.sub (s, 3))) + ^ String.extract (s, 4, NONE)) + else + NONE) + +val field = wrap (follow t_ident + (follow (const ".") + uw_ident)) + (fn (t, ((), f)) => (t, f)) + +datatype Rel = + Exps of exp * exp -> prop + | Props of prop * prop -> prop + +datatype sqexp = + SqConst of Prim.t + | SqTrue + | SqFalse + | SqNot of sqexp + | Field of string * string + | Computed of string + | Binop of Rel * sqexp * sqexp + | SqKnown of sqexp + | Inj of Mono.exp + | SqFunc of string * sqexp + | Unmodeled + | Null + +fun cmp s r = wrap (const s) (fn () => Exps (fn (e1, e2) => Reln (r, [e1, e2]))) + +val sqbrel = altL [cmp "=" Eq, + cmp "<>" Ne, + cmp "<=" Le, + cmp "<" Lt, + cmp ">=" Ge, + cmp ">" Gt, + wrap (const "AND") (fn () => Props And), + wrap (const "OR") (fn () => Props Or)] + +datatype ('a, 'b) sum = inl of 'a | inr of 'b + +fun string chs = + case chs of + String s :: chs => + if size s >= 2 andalso String.sub (s, 0) = #"'" then + let + fun loop (cs, acc) = + case cs of + [] => NONE + | c :: cs => + if c = #"'" then + SOME (String.implode (rev acc), cs) + else if c = #"\\" then + case cs of + c :: cs => loop (cs, c :: acc) + | _ => raise Fail "Iflow.string: Unmatched backslash escape" + else + loop (cs, c :: acc) + in + case loop (String.explode (String.extract (s, 1, NONE)), []) of + NONE => NONE + | SOME (s, []) => SOME (s, chs) + | SOME (s, cs) => SOME (s, String (String.implode cs) :: chs) + end + else + NONE + | _ => NONE + +val prim = + altL [wrap (follow (wrapP (follow (keep Char.isDigit) (follow (const ".") (keep Char.isDigit))) + (fn (x, ((), y)) => Option.map Prim.Float (Real64.fromString (x ^ "." ^ y)))) + (opt (const "::float8"))) #1, + wrap (follow (wrapP (keep Char.isDigit) + (Option.map Prim.Int o Int64.fromString)) + (opt (const "::int8"))) #1, + wrap (follow (opt (const "E")) (follow string (opt (const "::text")))) + (Prim.String o #1 o #2)] + +fun known' chs = + case chs of + Exp (EFfi ("Basis", "sql_known"), _) :: chs => SOME ((), chs) + | _ => NONE + +fun sqlify chs = + case chs of + Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs => + if String.isPrefix "sqlify" f then + SOME (e, chs) + else + NONE + | Exp (ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String "TRUE"), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String "FALSE"), _))], _), _) :: chs => + SOME (e, chs) + + | _ => NONE + +fun constK s = wrap (const s) (fn () => s) + +val funcName = altL [constK "COUNT", + constK "MIN", + constK "MAX", + constK "SUM", + constK "AVG"] + +val unmodeled = altL [const "COUNT(*)", + const "CURRENT_TIMESTAMP"] + +fun sqexp chs = + log "sqexp" + (altL [wrap prim SqConst, + wrap (const "TRUE") (fn () => SqTrue), + wrap (const "FALSE") (fn () => SqFalse), + wrap (const "NULL") (fn () => Null), + wrap field Field, + wrap uw_ident Computed, + wrap known SqKnown, + wrap func SqFunc, + wrap unmodeled (fn () => Unmodeled), + wrap sqlify Inj, + wrap (follow (const "COALESCE(") (follow sqexp (follow (const ",") + (follow (keep (fn ch => ch <> #")")) (const ")"))))) + (fn ((), (e, _)) => e), + wrap (follow (const "(NOT ") (follow sqexp (const ")"))) + (fn ((), (e, _)) => SqNot e), + wrap (follow (ws (const "(")) + (follow (wrap + (follow sqexp + (alt + (wrap + (follow (ws sqbrel) + (ws sqexp)) + inl) + (always (inr ())))) + (fn (e1, sm) => + case sm of + inl (bo, e2) => Binop (bo, e1, e2) + | inr () => e1)) + (const ")"))) + (fn ((), (e, ())) => e)]) + chs + +and known chs = wrap (follow known' (follow (const "(") (follow sqexp (const ")")))) + (fn ((), ((), (e, ()))) => e) chs + +and func chs = wrap (follow funcName (follow (const "(") (follow sqexp (const ")")))) + (fn (f, ((), (e, ()))) => (f, e)) chs + +datatype sitem = + SqField of string * string + | SqExp of sqexp * string + +val sitem = alt (wrap (follow sqexp (follow (const " AS ") uw_ident)) + (fn (e, ((), s)) => SqExp (e, s))) + (wrap field SqField) + +val select = log "select" + (wrap (follow (const "SELECT ") (list sitem)) + (fn ((), ls) => ls)) + +val fitem = wrap (follow uw_ident + (follow (const " AS ") + t_ident)) + (fn (t, ((), f)) => (t, f)) + +val from = log "from" + (wrap (follow (const "FROM ") (list fitem)) + (fn ((), ls) => ls)) + +val wher = wrap (follow (ws (const "WHERE ")) sqexp) + (fn ((), ls) => ls) + +type query1 = {Select : sitem list, + From : (string * string) list, + Where : sqexp option} + +val query1 = log "query1" + (wrap (follow (follow select from) (opt wher)) + (fn ((fs, ts), wher) => {Select = fs, From = ts, Where = wher})) + +datatype query = + Query1 of query1 + | Union of query * query + +val orderby = log "orderby" + (wrap (follow (ws (const "ORDER BY ")) + (follow (list sqexp) + (opt (ws (const "DESC"))))) + ignore) + +fun query chs = log "query" + (wrap + (follow + (alt (wrap (follow (const "((") + (follow query + (follow (const ") UNION (") + (follow query (const "))"))))) + (fn ((), (q1, ((), (q2, ())))) => Union (q1, q2))) + (wrap query1 Query1)) + (opt orderby)) + #1) + chs + +datatype dml = + Insert of string * (string * sqexp) list + | Delete of string * sqexp + | Update of string * (string * sqexp) list * sqexp + +val insert = log "insert" + (wrapP (follow (const "INSERT INTO ") + (follow uw_ident + (follow (const " (") + (follow (list uw_ident) + (follow (const ") VALUES (") + (follow (list sqexp) + (const ")"))))))) + (fn ((), (tab, ((), (fs, ((), (es, ())))))) => + (SOME (tab, ListPair.zipEq (fs, es))) + handle ListPair.UnequalLengths => NONE)) + +val delete = log "delete" + (wrap (follow (const "DELETE FROM ") + (follow uw_ident + (follow (const " AS T_T WHERE ") + sqexp))) + (fn ((), (tab, ((), es))) => (tab, es))) + +val setting = log "setting" + (wrap (follow uw_ident (follow (const " = ") sqexp)) + (fn (f, ((), e)) => (f, e))) + +val update = log "update" + (wrap (follow (const "UPDATE ") + (follow uw_ident + (follow (const " AS T_T SET ") + (follow (list setting) + (follow (ws (const "WHERE ")) + sqexp))))) + (fn ((), (tab, ((), (fs, ((), e))))) => + (tab, fs, e))) + +val dml = log "dml" + (altL [wrap insert Insert, + wrap delete Delete, + wrap update Update]) + +datatype querydml = + Query of query + | Dml of dml + +val querydml = log "querydml" (altL [wrap dml Dml, wrap query Query]) + +end -- cgit v1.2.3 From 3d21914a4b831ee9c727dd4296e56961c1e4ea89 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 15 Mar 2013 16:09:55 -0400 Subject: Make Scriptcheck catch more script/message-passing uses, and move the phase earlier in compilation --- src/cjr.sml | 5 +- src/cjrize.sml | 9 +++- src/compiler.sig | 4 +- src/compiler.sml | 18 ++++---- src/fuse.sml | 4 +- src/iflow.sml | 6 +-- src/jscomp.sml | 8 ++-- src/mono.sml | 7 ++- src/mono_print.sml | 2 +- src/mono_reduce.sml | 4 +- src/mono_shake.sml | 34 +++++++------- src/mono_util.sml | 55 +++++++++++----------- src/monoize.sml | 2 +- src/name_js.sml | 6 +-- src/pathcheck.sml | 2 +- src/scriptcheck.sig | 2 +- src/scriptcheck.sml | 131 +++++++++++----------------------------------------- src/untangle.sml | 4 +- 18 files changed, 119 insertions(+), 184 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/cjr.sml b/src/cjr.sml index c348d01a..3a37b26f 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -128,10 +128,7 @@ datatype decl' = withtype decl = decl' located -datatype sidedness = - ServerOnly - | ServerAndPull - | ServerAndPullAndPush +datatype sidedness = datatype Mono.sidedness datatype effect = datatype Export.effect datatype export_kind = datatype Export.export_kind diff --git a/src/cjrize.sml b/src/cjrize.sml index 9e41fda4..0f4bdb42 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -694,7 +694,7 @@ fun cifyDecl ((d, loc), sm) = | L.DPolicy _ => (NONE, NONE, sm) | L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm) -fun cjrize ds = +fun cjrize (ds, sideInfo) = let val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let @@ -722,6 +722,13 @@ fun cjrize ds = (dsF, ds, ps, Sm.clearDeclares sm) end) ([], [], [], Sm.empty) ds + + val sideInfo = foldl (fn ((n, mode), mp) => IM.insert (mp, n, mode)) IM.empty sideInfo + + val ps = map (fn (ek, s, n, ts, t, _, b) => + (ek, s, n, ts, t, + getOpt (IM.find (sideInfo, n), L'.ServerOnly), + b)) ps in (List.revAppend (dsF, rev ds), ps) diff --git a/src/compiler.sig b/src/compiler.sig index 7e4f2f6a..fcf664eb 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -116,12 +116,12 @@ signature COMPILER = sig val mono_shake : (Mono.file, Mono.file) phase val iflow : (Mono.file, Mono.file) phase val namejs : (Mono.file, Mono.file) phase + val scriptcheck : (Mono.file, Mono.file) phase val jscomp : (Mono.file, Mono.file) phase val fuse : (Mono.file, Mono.file) phase val pathcheck : (Mono.file, Mono.file) phase val sidecheck : (Mono.file, Mono.file) phase val cjrize : (Mono.file, Cjr.file) phase - val scriptcheck : (Cjr.file, Cjr.file) phase val prepare : (Cjr.file, Cjr.file) phase val checknest : (Cjr.file, Cjr.file) phase val sqlify : (Mono.file, Cjr.file) phase @@ -170,6 +170,7 @@ signature COMPILER = sig val toIflow : (string, Mono.file) transform val toNamejs : (string, Mono.file) transform val toNamejs_untangle : (string, Mono.file) transform + val toScriptcheck : (string, Mono.file) transform val toJscomp : (string, Mono.file) transform val toMono_opt3 : (string, Mono.file) transform val toFuse : (string, Mono.file) transform @@ -184,7 +185,6 @@ signature COMPILER = sig val toPathcheck : (string, Mono.file) transform val toSidecheck : (string, Mono.file) transform val toCjrize : (string, Cjr.file) transform - val toScriptcheck : (string, Cjr.file) transform val toPrepare : (string, Cjr.file) transform val toChecknest : (string, Cjr.file) transform val toSqlify : (string, Cjr.file) transform diff --git a/src/compiler.sml b/src/compiler.sml index f8dd07e2..77542811 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -1363,12 +1363,19 @@ val toNamejs = transform namejs "namejs" o toIflow val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs +val scriptcheck = { + func = ScriptCheck.classify, + print = MonoPrint.p_file MonoEnv.empty +} + +val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle + val jscomp = { func = JsComp.process, print = MonoPrint.p_file MonoEnv.empty } -val toJscomp = transform jscomp "jscomp" o toNamejs_untangle +val toJscomp = transform jscomp "jscomp" o toScriptcheck val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp @@ -1410,19 +1417,12 @@ val cjrize = { val toCjrize = transform cjrize "cjrize" o toSidecheck -val scriptcheck = { - func = ScriptCheck.classify, - print = CjrPrint.p_file CjrEnv.empty -} - -val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize - val prepare = { func = Prepare.prepare, print = CjrPrint.p_file CjrEnv.empty } -val toPrepare = transform prepare "prepare" o toScriptcheck +val toPrepare = transform prepare "prepare" o toCjrize val checknest = { func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f, diff --git a/src/fuse.sml b/src/fuse.sml index 565fc591..5193e59a 100644 --- a/src/fuse.sml +++ b/src/fuse.sml @@ -144,9 +144,9 @@ fun fuse file = (funcs, maxName)) end - val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file + val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file) in - file + (ds, #2 file) end end diff --git a/src/iflow.sml b/src/iflow.sml index fe0be731..8c933dc4 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1795,7 +1795,7 @@ fun evalExp env (e as (_, loc)) k = datatype var_source = Input of int | SubInput of int | Unknown -fun check file = +fun check (file : file) = let val () = (St.reset (); rfuns := IM.empty) @@ -1810,7 +1810,7 @@ fun check file = val exptd = foldl (fn ((d, _), exptd) => case d of DExport (_, _, n, _, _, _) => IS.add (exptd, n) - | _ => exptd) IS.empty file + | _ => exptd) IS.empty (#1 file) fun decl (d, loc) = case d of @@ -2071,7 +2071,7 @@ fun check file = | _ => () in - app decl file + app decl (#1 file) end val check = fn file => diff --git a/src/jscomp.sml b/src/jscomp.sml index ea34a3b5..ffb68ab2 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -61,7 +61,7 @@ exception CantEmbed of typ fun inString {needle, haystack} = String.isSubstring needle haystack -fun process file = +fun process (file : file) = let val (someTs, nameds) = foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e)) @@ -77,7 +77,7 @@ fun process file = someTs) someTs dts, nameds) | (_, state) => state) - (IM.empty, IM.empty) file + (IM.empty, IM.empty) (#1 file) fun str loc s = (EPrim (Prim.String s), loc) @@ -1304,7 +1304,7 @@ fun process file = listInjectors = TM.empty, decoders = IM.empty, maxName = U.File.maxName file + 1} - file + (#1 file) val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"}) fun lines acc = @@ -1334,7 +1334,7 @@ fun process file = "" in TextIO.closeIn inf; - (DJavaScript script, ErrorMsg.dummySpan) :: ds + ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file) end end diff --git a/src/mono.sml b/src/mono.sml index 4a0278fd..f269c52d 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -157,6 +157,11 @@ datatype decl' = withtype decl = decl' located -type file = decl list +datatype sidedness = + ServerOnly + | ServerAndPull + | ServerAndPullAndPush + +type file = decl list * (int * sidedness) list end diff --git a/src/mono_print.sml b/src/mono_print.sml index e5ef4cf8..12b36f2a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -530,7 +530,7 @@ fun p_decl env (dAll as (d, _) : decl) = p_policy env p] | DOnError _ => string "ONERROR" -fun p_file env file = +fun p_file env (file, _) = let val (pds, _) = ListUtil.foldlMap (fn (d, env) => (p_decl env d, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 71c87095..e7fac5ed 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -308,7 +308,7 @@ val freeInAbs = U.Exp.existsB {typ = fn _ => false, U.Exp.RelE _ => n + 1 | _ => n} 0 -fun reduce file = +fun reduce (file : file) = let val (timpures, impures, absCounts) = foldl (fn ((d, _), (timpures, impures, absCounts)) => @@ -366,7 +366,7 @@ fun reduce file = absCounts vis) | _ => (timpures, impures, absCounts) end) - (IS.empty, IS.empty, IM.empty) file + (IS.empty, IS.empty, IM.empty) (#1 file) val uses = U.File.fold {typ = fn (_, m) => m, exp = fn (e, m) => diff --git a/src/mono_shake.sml b/src/mono_shake.sml index b6de9410..5818fea0 100644 --- a/src/mono_shake.sml +++ b/src/mono_shake.sml @@ -41,7 +41,7 @@ type free = { exp : IS.set } -fun shake file = +fun shake (file : file) = let val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef) @@ -60,7 +60,7 @@ fun shake file = | ((DTask _, _), acc) => acc | ((DPolicy _, _), acc) => acc | ((DOnError _, _), acc) => acc) - (IM.empty, IM.empty) file + (IM.empty, IM.empty) (#1 file) fun typ (c, s) = case c of @@ -130,7 +130,7 @@ fun shake file = usedVars st e1 end | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) - | (_, st) => st) (IS.empty, IS.empty) file + | (_, st) => st) (IS.empty, IS.empty) (#1 file) val s = {con = page_cs, exp = page_es} @@ -145,20 +145,20 @@ fun shake file = NONE => raise Fail "MonoShake: Couldn't find 'val'" | SOME (t, e) => shakeExp s e) s page_es in - List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts - | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) - | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis - | (DExport _, _) => true - | (DTable _, _) => true - | (DSequence _, _) => true - | (DView _, _) => true - | (DDatabase _, _) => true - | (DJavaScript _, _) => true - | (DCookie _, _) => true - | (DStyle _, _) => true - | (DTask _, _) => true - | (DPolicy _, _) => true - | (DOnError _, _) => true) file + (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts + | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) + | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis + | (DExport _, _) => true + | (DTable _, _) => true + | (DSequence _, _) => true + | (DView _, _) => true + | (DDatabase _, _) => true + | (DJavaScript _, _) => true + | (DCookie _, _) => true + | (DStyle _, _) => true + | (DTask _, _) => true + | (DPolicy _, _) => true + | (DOnError _, _) => true) (#1 file), #2 file) end end diff --git a/src/mono_util.sml b/src/mono_util.sml index 58498996..61638858 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -664,9 +664,9 @@ fun mapfoldB (all as {bind, ...}) = let val mfd = Decl.mapfoldB all - fun mff ctx ds = + fun mff ctx (ds, ps) = case ds of - nil => S.return2 nil + nil => S.return2 (nil, ps) | d :: ds' => S.bind2 (mfd ctx d, fn d' => @@ -705,9 +705,9 @@ fun mapfoldB (all as {bind, ...}) = | DPolicy _ => ctx | DOnError _ => ctx in - S.map2 (mff ctx' ds', - fn ds' => - d' :: ds') + S.map2 (mff ctx' (ds', ps), + fn (ds', _) => + (d' :: ds', ps)) end) in mff @@ -741,27 +741,28 @@ fun fold {typ, exp, decl} s d = S.Continue (_, s) => s | S.Return _ => raise Fail "MonoUtil.File.fold: Impossible" -val maxName = foldl (fn ((d, _) : decl, count) => - case d of - DDatatype dts => - foldl (fn ((_, n, ns), count) => - foldl (fn ((_, n', _), m) => Int.max (n', m)) - (Int.max (n, count)) ns) count dts - | DVal (_, n, _, _, _) => Int.max (n, count) - | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis - | DExport _ => count - | DTable _ => count - | DSequence _ => count - | DView _ => count - | DDatabase _ => count - | DJavaScript _ => count - | DCookie _ => count - | DStyle _ => count - | DTask _ => count - | DPolicy _ => count - | DOnError _ => count) 0 - -fun appLoc f = +fun maxName (f : file) = + foldl (fn ((d, _) : decl, count) => + case d of + DDatatype dts => + foldl (fn ((_, n, ns), count) => + foldl (fn ((_, n', _), m) => Int.max (n', m)) + (Int.max (n, count)) ns) count dts + | DVal (_, n, _, _, _) => Int.max (n, count) + | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis + | DExport _ => count + | DTable _ => count + | DSequence _ => count + | DView _ => count + | DDatabase _ => count + | DJavaScript _ => count + | DCookie _ => count + | DStyle _ => count + | DTask _ => count + | DPolicy _ => count + | DOnError _ => count) 0 (#1 f) + +fun appLoc f (fl : file) = let val eal = Exp.appLoc f @@ -790,7 +791,7 @@ fun appLoc f = | PolUpdate e1 => eal e1 | PolSequence e1 => eal e1 in - app appl + app appl (#1 fl) end end diff --git a/src/monoize.sml b/src/monoize.sml index e07c0c90..ce7bfbe9 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4656,7 +4656,7 @@ fun monoize env file = pvars := RM.empty; pvarDefs := []; pvarOldDefs := []; - rev ds + (rev ds, []) end end diff --git a/src/name_js.sml b/src/name_js.sml index 70ac000c..53abd7a3 100644 --- a/src/name_js.sml +++ b/src/name_js.sml @@ -72,7 +72,7 @@ fun squish vs = U.Exp.mapB {typ = fn x => x, fun rewrite file = let - val (file, _) = ListUtil.foldlMapConcat (fn (d, nextName) => + val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) => let val (d, (nextName, newDs)) = U.Decl.foldMapB {typ = fn x => x, @@ -143,9 +143,9 @@ fun rewrite file = DValRec vis => [(DValRec (vis @ newDs), #2 d)] | _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]), nextName) - end) (U.File.maxName file + 1) file + end) (U.File.maxName file + 1) (#1 file) in - file + (ds, #2 file) end end diff --git a/src/pathcheck.sml b/src/pathcheck.sml index 15405db7..c1bb667b 100644 --- a/src/pathcheck.sml +++ b/src/pathcheck.sml @@ -110,6 +110,6 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) = | _ => (funcs, rels, cookies, styles) end -fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) +fun check (ds, _) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds) end diff --git a/src/scriptcheck.sig b/src/scriptcheck.sig index bc9b6377..afb557b7 100644 --- a/src/scriptcheck.sig +++ b/src/scriptcheck.sig @@ -27,6 +27,6 @@ signature SCRIPT_CHECK = sig - val classify : Cjr.file -> Cjr.file + val classify : Mono.file -> Mono.file end diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml index 6c6c5588..e5db476a 100644 --- a/src/scriptcheck.sml +++ b/src/scriptcheck.sml @@ -27,7 +27,7 @@ structure ScriptCheck :> SCRIPT_CHECK = struct -open Cjr +open Mono structure SS = BinarySetFn(struct type ord_key = string @@ -35,98 +35,31 @@ structure SS = BinarySetFn(struct end) structure IS = IntBinarySet -val pullBasis = SS.addList (SS.empty, - ["new_client_source", - "get_client_source", - "set_client_source"]) - val pushBasis = SS.addList (SS.empty, ["new_channel", "self"]) -val events = ["abort", - "blur", - "change", - "click", - "dblclick", - "error", - "focus", - "keydown", - "keypress", - "keyup", - "load", - "mousedown", - "mousemove", - "mouseout", - "mouseover", - "mouseup", - "reset", - "resize", - "select", - "submit", - "unload"] - -val scriptWords = " " on" ^ s ^ "='") events - -val pushWords = ["rv("] - fun classify (ds, ps) = let val proto = Settings.currentProtocol () fun inString {needle, haystack} = String.isSubstring needle haystack - fun hasClient {basis, words, onload} csids = - let - fun hasClient e = - case #1 e of - EPrim (Prim.String s) => List.exists (fn n => inString {needle = n, haystack = s}) words - | EPrim _ => false - | ERel _ => false - | ENamed n => IS.member (csids, n) - | ECon (_, _, NONE) => false - | ECon (_, _, SOME e) => hasClient e - | ENone _ => false - | ESome (_, e) => hasClient e - | EFfi ("Basis", x) => SS.member (basis, x) - | EFfi _ => false - | EFfiApp ("Basis", "maybe_onload", - [((EFfiApp ("Basis", "strcat", all as [_, ((EPrim (Prim.String s), _), _)]), _), _)]) => - List.exists (hasClient o #1) all - orelse (onload andalso size s > 0) - | EFfiApp ("Basis", x, es) => SS.member (basis, x) - orelse List.exists (hasClient o #1) es - | EFfiApp (_, _, es) => List.exists (hasClient o #1) es - | EApp (e, es) => hasClient e orelse List.exists hasClient es - | EUnop (_, e) => hasClient e - | EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2 - | ERecord (_, xes) => List.exists (hasClient o #2) xes - | EField (e, _) => hasClient e - | ECase (e, pes, _) => hasClient e orelse List.exists (hasClient o #2) pes - | EError (e, _) => hasClient e - | EReturnBlob {blob = e1, mimeType = e2, ...} => hasClient e1 orelse hasClient e2 - | ERedirect (e, _) => hasClient e - | EWrite e => hasClient e - | ESeq (e1, e2) => hasClient e1 orelse hasClient e2 - | ELet (_, _, e1, e2) => hasClient e1 orelse hasClient e2 - | EQuery {query, body, initial, ...} => hasClient query orelse hasClient body - orelse hasClient initial - | EDml {dml, ...} => hasClient dml - | ENextval {seq, ...} => hasClient seq - | ESetval {seq, count, ...} => hasClient seq orelse hasClient count - | EUnurlify (e, _, _) => hasClient e - in - hasClient - end + fun hasClient {basis, funcs, push} = + MonoUtil.Exp.exists {typ = fn _ => false, + exp = fn ERecv _ => push + | EFfiApp ("Basis", x, _) => SS.member (basis, x) + | EJavaScript _ => not push + | ENamed n => IS.member (funcs, n) + | _ => false} fun decl ((d, _), (pull_ids, push_ids)) = let - val hasClientPull = hasClient {basis = pullBasis, words = scriptWords, onload = true} pull_ids - val hasClientPush = hasClient {basis = pushBasis, words = pushWords, onload = false} push_ids + val hasClientPull = hasClient {basis = SS.empty, funcs = pull_ids, push = false} + val hasClientPush = hasClient {basis = pushBasis, funcs = push_ids, push = true} in case d of - DVal (_, n, _, e) => (if hasClientPull e then + DVal (_, n, _, e, _) => (if hasClientPull e then IS.add (pull_ids, n) else pull_ids, @@ -134,20 +67,12 @@ fun classify (ds, ps) = IS.add (push_ids, n) else push_ids) - | DFun (_, n, _, _, e) => (if hasClientPull e then - IS.add (pull_ids, n) - else - pull_ids, - if hasClientPush e then - IS.add (push_ids, n) - else - push_ids) - | DFunRec xes => (if List.exists (fn (_, _, _, _, e) => hasClientPull e) xes then + | DValRec xes => (if List.exists (fn (_, _, _, e, _) => hasClientPull e) xes then foldl (fn ((_, n, _, _, _), pull_ids) => IS.add (pull_ids, n)) pull_ids xes else pull_ids, - if List.exists (fn (_, _, _, _, e) => hasClientPush e) xes then + if List.exists (fn (_, _, _, e, _) => hasClientPush e) xes then foldl (fn ((_, n, _, _, _), push_ids) => IS.add (push_ids, n)) push_ids xes else @@ -159,21 +84,21 @@ fun classify (ds, ps) = val foundBad = ref false - val ps = map (fn (ek, x, n, ts, t, _, b) => - (ek, x, n, ts, t, - if IS.member (push_ids, n) then - (if not (#persistent proto) andalso not (!foundBad) then - (foundBad := true; - ErrorMsg.error ("This program needs server push, but the current protocol (" - ^ #name proto ^ ") doesn't support that.")) - else - (); - ServerAndPullAndPush) - else if IS.member (pull_ids, n) then - ServerAndPull - else - ServerOnly, - b)) ps + val all_ids = IS.union (pull_ids, push_ids) + + val ps = map (fn n => + (n, if IS.member (push_ids, n) then + (if not (#persistent proto) andalso not (!foundBad) then + (foundBad := true; + ErrorMsg.error ("This program needs server push, but the current protocol (" + ^ #name proto ^ ") doesn't support that.")) + else + (); + ServerAndPullAndPush) + else if IS.member (pull_ids, n) then + ServerAndPull + else + ServerOnly)) (IS.listItems all_ids) in (ds, ps) end diff --git a/src/untangle.sml b/src/untangle.sml index 373cfe18..bcb90ed6 100644 --- a/src/untangle.sml +++ b/src/untangle.sml @@ -43,7 +43,7 @@ fun exp (e, s) = | _ => s -fun untangle file = +fun untangle (file : file) = let fun decl (dAll as (d, loc)) = case d of @@ -208,7 +208,7 @@ fun untangle file = end | _ => [dAll] in - ListUtil.mapConcat decl file + (ListUtil.mapConcat decl (#1 file), #2 file) end end -- cgit v1.2.3 From 52a39c41846b52cd9b93bf53fb709eea75704cca Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 21 Apr 2013 13:03:20 -0400 Subject: Get Iflow working again --- src/iflow.sml | 95 +++++++++++++++++++++++++++++++++++++++++++++++++++-- src/mono_reduce.sig | 4 ++- src/mono_reduce.sml | 36 ++++++++++---------- 3 files changed, 115 insertions(+), 20 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/iflow.sml b/src/iflow.sml index 8c933dc4..0c94cd47 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2010, Adam Chlipala +(* Copyright (c) 2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -1249,7 +1249,8 @@ type 'a doQuery = { fun doQuery (arg : 'a doQuery) (e as (_, loc)) = let - fun default () = ErrorMsg.errorAt loc "Information flow checker can't parse SQL query" + fun default () = (ErrorMsg.errorAt loc "Information flow checker can't parse SQL query"; + Print.preface ("Query", MonoPrint.p_exp MonoEnv.empty e)) in case parse query e of NONE => default () @@ -1795,16 +1796,103 @@ fun evalExp env (e as (_, loc)) k = datatype var_source = Input of int | SubInput of int | Unknown +structure U = MonoUtil + +fun mliftExpInExp by = + U.Exp.mapB {typ = fn t => t, + exp = fn bound => fn e => + case e of + ERel xn => + if xn < bound then + e + else + ERel (xn + by) + | _ => e, + bind = fn (bound, U.Exp.RelE _) => bound + 1 + | (bound, _) => bound} + +fun nameSubexps k (e : Mono.exp) = + let + fun numParams (e : Mono.exp) = + case #1 e of + EStrcat (e1, e2) => numParams e1 + numParams e2 + | EPrim (Prim.String _) => 0 + | _ => 1 + + val nps = numParams e + + fun getParams (e : Mono.exp) x = + case #1 e of + EStrcat (e1, e2) => + let + val (ps1, e1') = getParams e1 x + val (ps2, e2') = getParams e2 (x - length ps1) + in + (ps2 @ ps1, (EStrcat (e1', e2'), #2 e)) + end + | EPrim (Prim.String _) => ([], e) + | _ => + let + val (e', k) = + case #1 e of + EFfiApp (m, f, [(e', t)]) => + if Settings.isEffectful (m, f) orelse Settings.isBenignEffectful (m, f) then + (e, fn x => x) + else + (e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e)) + | ECase (e', ps as + [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), + (EPrim (Prim.String "TRUE"), _)), + ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), + (EPrim (Prim.String "FALSE"), _))], q) => + (e', fn e' => (ECase (e', ps, q), #2 e)) + | _ => (e, fn x => x) + in + ([e'], k (ERel x, #2 e)) + end + + val (ps, e') = getParams e (nps - 1) + + val string = (TFfi ("Basis", "string"), #2 e) + + val (e', _) = foldl (fn (p, (e', liftBy)) => + ((ELet ("p" ^ Int.toString liftBy, + string, + mliftExpInExp liftBy 0 p, + e'), #2 e), liftBy - 1)) (k (nps, e'), nps - 1) ps + in + #1 e' + end + +val namer = MonoUtil.File.map {typ = fn t => t, + exp = fn e => + case e of + EDml (e, fm) => + nameSubexps (fn (_, e') => (EDml (e', fm), #2 e)) e + | EQuery {exps, tables, state, query, body, initial} => + nameSubexps (fn (liftBy, e') => + (EQuery {exps = exps, + tables = tables, + state = state, + query = e', + body = mliftExpInExp liftBy 2 body, + initial = mliftExpInExp liftBy 0 initial}, + #2 query)) query + | _ => e, + decl = fn d => d} + fun check (file : file) = let val () = (St.reset (); rfuns := IM.empty) + (*val () = Print.preface ("FilePre", MonoPrint.p_file MonoEnv.empty file)*) val file = MonoReduce.reduce file val file = MonoOpt.optimize file val file = Fuse.fuse file val file = MonoOpt.optimize file val file = MonoShake.shake file + val file = namer file (*val () = Print.preface ("File", MonoPrint.p_file MonoEnv.empty file)*) val exptd = foldl (fn ((d, _), exptd) => @@ -2077,13 +2165,16 @@ fun check (file : file) = val check = fn file => let val oldInline = Settings.getMonoInline () + val oldFull = !MonoReduce.fullMode in (Settings.setMonoInline (case Int.maxInt of NONE => 1000000 | SOME n => n); + MonoReduce.fullMode := true; check file; Settings.setMonoInline oldInline) handle ex => (Settings.setMonoInline oldInline; + MonoReduce.fullMode := oldFull; raise ex) end diff --git a/src/mono_reduce.sig b/src/mono_reduce.sig index a6b6cc81..8990b21d 100644 --- a/src/mono_reduce.sig +++ b/src/mono_reduce.sig @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -35,4 +35,6 @@ signature MONO_REDUCE = sig val impure : Mono.exp -> bool + val fullMode : bool ref + end diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 73adafa3..5bac235c 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -31,6 +31,8 @@ structure MonoReduce :> MONO_REDUCE = struct open Mono +val fullMode = ref false + structure E = MonoEnv structure U = MonoUtil @@ -531,27 +533,27 @@ fun reduce (file : file) = simpleImpure (timpures, impures) env e andalso impure e andalso not (List.null (summarize ~1 e)) + fun passive (e : exp) = + case #1 e of + EPrim _ => true + | ERel _ => true + | ENamed _ => true + | ECon (_, _, NONE) => true + | ECon (_, _, SOME e) => passive e + | ENone _ => true + | ESome (_, e) => passive e + | EFfi _ => true + | EAbs _ => true + | ERecord xets => List.all (passive o #2) xets + | EField (e, _) => passive e + | _ => false + fun exp env e = let (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) fun doLet (x, t, e', b) = let - fun passive (e : exp) = - case #1 e of - EPrim _ => true - | ERel _ => true - | ENamed _ => true - | ECon (_, _, NONE) => true - | ECon (_, _, SOME e) => passive e - | ENone _ => true - | ESome (_, e) => passive e - | EFfi _ => true - | EAbs _ => true - | ERecord xets => List.all (passive o #2) xets - | EField (e, _) => passive e - | _ => false - fun doSub () = let val r = subExpInExp (0, e') b @@ -630,7 +632,7 @@ fun reduce (file : file) = else e end - else if countFree 0 0 b > 1 andalso not (passive e') then + else if countFree 0 0 b > 1 andalso not (!fullMode) andalso not (passive e') then e else trySub () @@ -653,7 +655,7 @@ fun reduce (file : file) = ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), ("e2", MonoPrint.p_exp env e2), ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) - if impure env e2 orelse countFree 0 0 e1 > 1 then + if impure env e2 orelse (not (!fullMode) andalso countFree 0 0 e1 > 1) then #1 (reduceExp env (ELet (x, t, e2, e1), loc)) else #1 (reduceExp env (subExpInExp (0, e2) e1))) -- cgit v1.2.3 From d7c4817af0c7f4ea2ed30b4a34408f2f92e9e979 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Wed, 11 Dec 2013 18:22:10 -0500 Subject: Change handling of returned text blobs, to activate the normal EWrite optimizations --- include/urweb/urweb_cpp.h | 2 ++ src/c/urweb.c | 34 ++++++++++++++++++++++++++++++++++ src/checknest.sml | 6 ++++-- src/cjr.sml | 2 +- src/cjr_print.sml | 26 ++++++++++++++++++++++++-- src/cjrize.sml | 11 +++++++++-- src/iflow.sml | 9 ++++++--- src/jscomp.sml | 10 ++++++++-- src/mono.sml | 2 +- src/mono_print.sml | 36 ++++++++++++++++++++++++------------ src/mono_reduce.sml | 6 ++++-- src/mono_util.sml | 13 ++++++++++--- src/monoize.sml | 20 +++++++++++++++++++- src/prepare.sml | 9 ++++++++- 14 files changed, 154 insertions(+), 32 deletions(-) (limited to 'src/iflow.sml') diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h index fb3c83a2..d1fb4d37 100644 --- a/include/urweb/urweb_cpp.h +++ b/include/urweb/urweb_cpp.h @@ -209,6 +209,7 @@ uw_Basis_string uw_Basis_requestHeader(struct uw_context *, uw_Basis_string); void uw_write_header(struct uw_context *, uw_Basis_string); void uw_clear_headers(struct uw_context *); +void uw_Basis_clear_page(struct uw_context *); uw_Basis_string uw_Basis_get_cookie(struct uw_context *, uw_Basis_string c); uw_unit uw_Basis_set_cookie(struct uw_context *, uw_Basis_string prefix, uw_Basis_string c, uw_Basis_string v, uw_Basis_time *expires, uw_Basis_bool secure); @@ -255,6 +256,7 @@ uw_Basis_postBody uw_getPostBody(struct uw_context *); void uw_mayReturnIndirectly(struct uw_context *); __attribute__((noreturn)) void uw_return_blob(struct uw_context *, uw_Basis_blob, uw_Basis_string mimeType); +__attribute__((noreturn)) void uw_return_blob_from_page(struct uw_context *, uw_Basis_string mimeType); __attribute__((noreturn)) void uw_redirect(struct uw_context *, uw_Basis_string url); uw_Basis_time uw_Basis_now(struct uw_context *); diff --git a/src/c/urweb.c b/src/c/urweb.c index cd724cbf..1201b09b 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -1351,6 +1351,10 @@ void uw_clear_headers(uw_context ctx) { uw_buffer_reset(&ctx->outHeaders); } +void uw_Basis_clear_page(uw_context ctx) { + uw_buffer_reset(&ctx->page); +} + static void uw_check_script(uw_context ctx, size_t extra) { ctx_uw_buffer_check(ctx, "script", &ctx->script, extra); } @@ -3736,6 +3740,36 @@ __attribute__((noreturn)) void uw_return_blob(uw_context ctx, uw_Basis_blob b, u longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); } +__attribute__((noreturn)) void uw_return_blob_from_page(uw_context ctx, uw_Basis_string mimeType) { + cleanup *cl; + int len; + char *oldh; + + if (!ctx->allowed_to_return_indirectly) + uw_error(ctx, FATAL, "Tried to return a blob from an RPC"); + + ctx->returning_indirectly = 1; + oldh = old_headers(ctx); + uw_buffer_reset(&ctx->outHeaders); + + uw_write_header(ctx, on_success); + uw_write_header(ctx, "Content-Type: "); + uw_write_header(ctx, mimeType); + uw_write_header(ctx, "\r\nContent-Length: "); + ctx_uw_buffer_check(ctx, "headers", &ctx->outHeaders, INTS_MAX); + sprintf(ctx->outHeaders.front, "%lu%n", (unsigned long)uw_buffer_used(&ctx->page), &len); + ctx->outHeaders.front += len; + uw_write_header(ctx, "\r\n"); + if (oldh) uw_write_header(ctx, oldh); + + for (cl = ctx->cleanup; cl < ctx->cleanup_front; ++cl) + cl->func(cl->arg); + + ctx->cleanup_front = ctx->cleanup; + + longjmp(ctx->jmp_buf, RETURN_INDIRECTLY); +} + __attribute__((noreturn)) void uw_redirect(uw_context ctx, uw_Basis_string url) { cleanup *cl; char *s; diff --git a/src/checknest.sml b/src/checknest.sml index 05ad8e9a..fa418d89 100644 --- a/src/checknest.sml +++ b/src/checknest.sml @@ -56,7 +56,8 @@ fun expUses globals = | ECase (e, pes, _) => foldl (fn ((_, e), s) => IS.union (eu e, s)) (eu e) pes | EError (e, _) => eu e - | EReturnBlob {blob, mimeType, ...} => IS.union (eu blob, eu mimeType) + | EReturnBlob {blob = NONE, mimeType, ...} => eu mimeType + | EReturnBlob {blob = SOME blob, mimeType, ...} => IS.union (eu blob, eu mimeType) | ERedirect (e, _) => eu e | EWrite e => eu e @@ -118,7 +119,8 @@ fun annotateExp globals = | ECase (e, pes, ts) => (ECase (ae e, map (fn (p, e) => (p, ae e)) pes, ts), loc) | EError (e, t) => (EError (ae e, t), loc) - | EReturnBlob {blob, mimeType, t} => (EReturnBlob {blob = ae blob, mimeType = ae mimeType, t = t}, loc) + | EReturnBlob {blob = NONE, mimeType, t} => (EReturnBlob {blob = NONE, mimeType = ae mimeType, t = t}, loc) + | EReturnBlob {blob = SOME blob, mimeType, t} => (EReturnBlob {blob = SOME (ae blob), mimeType = ae mimeType, t = t}, loc) | ERedirect (e, t) => (ERedirect (ae e, t), loc) | EWrite e => (EWrite (ae e), loc) diff --git a/src/cjr.sml b/src/cjr.sml index 3a37b26f..8cbabdcc 100644 --- a/src/cjr.sml +++ b/src/cjr.sml @@ -78,7 +78,7 @@ datatype exp' = | ECase of exp * (pat * exp) list * { disc : typ, result : typ } | EError of exp * typ - | EReturnBlob of {blob : exp, mimeType : exp, t : typ} + | EReturnBlob of {blob : exp option, mimeType : exp, t : typ} | ERedirect of exp * typ | EWrite of exp diff --git a/src/cjr_print.sml b/src/cjr_print.sml index e98918e6..dec21eb3 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -1628,7 +1628,7 @@ and p_exp' par tail env (e, loc) = string "tmp;", newline, string "})"] - | EReturnBlob {blob, mimeType, t} => + | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "({", newline, string "uw_Basis_blob", @@ -1658,6 +1658,27 @@ and p_exp' par tail env (e, loc) = string "tmp;", newline, string "})"] + | EReturnBlob {blob = NONE, mimeType, t} => + box [string "({", + newline, + string "uw_Basis_string", + space, + string "mimeType", + space, + string "=", + space, + p_exp' false false env mimeType, + string ";", + newline, + p_typ env t, + space, + string "tmp;", + newline, + string "uw_return_blob_from_page(ctx, mimeType);", + newline, + string "tmp;", + newline, + string "})"] | ERedirect (e, t) => box [string "({", newline, @@ -3180,7 +3201,8 @@ fun p_file env (ds, ps) = | EField (e, _) => expDb e | ECase (e, pes, _) => expDb e orelse List.exists (expDb o #2) pes | EError (e, _) => expDb e - | EReturnBlob {blob = e1, mimeType = e2, ...} => expDb e1 orelse expDb e2 + | EReturnBlob {blob = NONE, mimeType = e2, ...} => expDb e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => expDb e1 orelse expDb e2 | ERedirect (e, _) => expDb e | EWrite e => expDb e | ESeq (e1, e2) => expDb e1 orelse expDb e2 diff --git a/src/cjrize.sml b/src/cjrize.sml index 0f4bdb42..d153feff 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -372,13 +372,20 @@ fun cifyExp (eAll as (e, loc), sm) = in ((L'.EError (e, t), loc), sm) end - | L.EReturnBlob {blob, mimeType, t} => + | L.EReturnBlob {blob = NONE, mimeType, t} => + let + val (mimeType, sm) = cifyExp (mimeType, sm) + val (t, sm) = cifyTyp (t, sm) + in + ((L'.EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), sm) + end + | L.EReturnBlob {blob = SOME blob, mimeType, t} => let val (blob, sm) = cifyExp (blob, sm) val (mimeType, sm) = cifyExp (mimeType, sm) val (t, sm) = cifyTyp (t, sm) in - ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm) + ((L'.EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), sm) end | L.ERedirect (e, t) => let diff --git a/src/iflow.sml b/src/iflow.sml index 0c94cd47..461dc956 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1587,7 +1587,8 @@ fun evalExp env (e as (_, loc)) k = evalExp env e2 (fn e2 => k (Func (Other "cat", [e1, e2])))) | EError (e, _) => evalExp env e (fn e => St.send (e, loc)) - | EReturnBlob {blob = b, mimeType = m, ...} => + | EReturnBlob {blob = NONE, ...} => raise Fail "Iflow doesn't support blob optimization" + | EReturnBlob {blob = SOME b, mimeType = m, ...} => evalExp env b (fn b => (St.send (b, loc); evalExp env m @@ -2060,8 +2061,10 @@ fun check (file : file) = end | EStrcat (e1, e2) => (EStrcat (doExp env e1, doExp env e2), loc) | EError (e1, t) => (EError (doExp env e1, t), loc) - | EReturnBlob {blob = b, mimeType = m, t} => - (EReturnBlob {blob = doExp env b, mimeType = doExp env m, t = t}, loc) + | EReturnBlob {blob = NONE, mimeType = m, t} => + (EReturnBlob {blob = NONE, mimeType = doExp env m, t = t}, loc) + | EReturnBlob {blob = SOME b, mimeType = m, t} => + (EReturnBlob {blob = SOME (doExp env b), mimeType = doExp env m, t = t}, loc) | ERedirect (e1, t) => (ERedirect (doExp env e1, t), loc) | EWrite e1 => (EWrite (doExp env e1), loc) | ESeq (e1, e2) => (ESeq (doExp env e1, doExp env e2), loc) diff --git a/src/jscomp.sml b/src/jscomp.sml index e0d87a8e..4a2c0365 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -1118,12 +1118,18 @@ fun process (file : file) = in ((EError (e, t), loc), st) end - | EReturnBlob {blob, mimeType, t} => + | EReturnBlob {blob = NONE, mimeType, t} => + let + val (mimeType, st) = exp outer (mimeType, st) + in + ((EReturnBlob {blob = NONE, mimeType = mimeType, t = t}, loc), st) + end + | EReturnBlob {blob = SOME blob, mimeType, t} => let val (blob, st) = exp outer (blob, st) val (mimeType, st) = exp outer (mimeType, st) in - ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) + ((EReturnBlob {blob = SOME blob, mimeType = mimeType, t = t}, loc), st) end | ERedirect (e, t) => let diff --git a/src/mono.sml b/src/mono.sml index f5260419..78740d70 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -93,7 +93,7 @@ datatype exp' = | EStrcat of exp * exp | EError of exp * typ - | EReturnBlob of {blob : exp, mimeType : exp, t : typ} + | EReturnBlob of {blob : exp option, mimeType : exp, t : typ} | ERedirect of exp * typ | EWrite of exp diff --git a/src/mono_print.sml b/src/mono_print.sml index a5156aca..c81b362a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -235,18 +235,30 @@ fun p_exp' par env (e, _) = space, p_typ env t, string ")"] - | EReturnBlob {blob, mimeType, t} => box [string "(blob", - space, - p_exp env blob, - space, - string "in", - space, - p_exp env mimeType, - space, - string ":", - space, - p_typ env t, - string ")"] + | EReturnBlob {blob = SOME blob, mimeType, t} => box [string "(blob", + space, + p_exp env blob, + space, + string "in", + space, + p_exp env mimeType, + space, + string ":", + space, + p_typ env t, + string ")"] + | EReturnBlob {blob = NONE, mimeType, t} => box [string "(blob", + space, + string "", + space, + string "in", + space, + p_exp env mimeType, + space, + string ":", + space, + p_typ env t, + string ")"] | ERedirect (e, t) => box [string "(redirect", space, p_exp env e, diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 0dfb7558..e96a0e8f 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -101,7 +101,8 @@ fun impure (e, _) = | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes | EError _ => true - | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2 + | EReturnBlob {blob = NONE, mimeType = e2, ...} => impure e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => impure e1 orelse impure e2 | ERedirect (e, _) => impure e | EStrcat (e1, e2) => impure e1 orelse impure e2 @@ -492,7 +493,8 @@ fun reduce (file : file) = | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 | EError (e, _) => summarize d e @ [Abort] - | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] + | EReturnBlob {blob = NONE, mimeType = e2, ...} => summarize d e2 @ [Abort] + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] | ERedirect (e, _) => summarize d e @ [Abort] | EWrite e => summarize d e @ [WritePage] diff --git a/src/mono_util.sml b/src/mono_util.sml index cb871891..cc531625 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -261,14 +261,20 @@ fun mapfoldB {typ = fc, exp = fe, bind} = S.map2 (mft t, fn t' => (EError (e', t'), loc))) - | EReturnBlob {blob, mimeType, t} => + | EReturnBlob {blob = NONE, mimeType, t} => + S.bind2 (mfe ctx mimeType, + fn mimeType' => + S.map2 (mft t, + fn t' => + (EReturnBlob {blob = NONE, mimeType = mimeType', t = t'}, loc))) + | EReturnBlob {blob = SOME blob, mimeType, t} => S.bind2 (mfe ctx blob, fn blob' => S.bind2 (mfe ctx mimeType, fn mimeType' => S.map2 (mft t, fn t' => - (EReturnBlob {blob = blob', mimeType = mimeType', t = t'}, loc)))) + (EReturnBlob {blob = SOME blob', mimeType = mimeType', t = t'}, loc)))) | ERedirect (e, t) => S.bind2 (mfe ctx e, fn e' => @@ -495,7 +501,8 @@ fun appLoc f = | ECase (e1, pes, _) => (appl e1; app (appl o #2) pes) | EStrcat (e1, e2) => (appl e1; appl e2) | EError (e1, _) => appl e1 - | EReturnBlob {blob = e1, mimeType = e2, ...} => (appl e1; appl e2) + | EReturnBlob {blob = NONE, mimeType = e2, ...} => appl e2 + | EReturnBlob {blob = SOME e1, mimeType = e2, ...} => (appl e1; appl e2) | ERedirect (e1, _) => appl e1 | EWrite e1 => appl e1 | ESeq (e1, e2) => (appl e1; appl e2) diff --git a/src/monoize.sml b/src/monoize.sml index 2b604325..b1166734 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -4053,6 +4053,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EError ((L'.ERel 0, loc), t), loc)), loc), fm) end + | L.EApp ( + (L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t), _), + (L.EFfiApp ("Basis", "textBlob", [(e, _)]), _)) => + let + val t = monoType env t + val un = (L'.TRecord [], loc) + val (e, fm) = monoExp (env, st, fm) e + in + ((L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc), + (L'.EAbs ("_", un, t, + (L'.ESeq ((L'.EFfiApp ("Basis", "clear_page", []), loc), + (L'.ESeq ((L'.EWrite (liftExpInExp 0 (liftExpInExp 0 e)), loc), + (L'.EReturnBlob {blob = NONE, + mimeType = (L'.ERel 1, loc), + t = t}, loc)), loc)), loc)), loc)), + loc), + fm) + end | L.ECApp ((L.EFfi ("Basis", "returnBlob"), _), t) => let val t = monoType env t @@ -4062,7 +4080,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.TFun ((L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc)), loc), (L'.EAbs ("mt", (L'.TFfi ("Basis", "string"), loc), (L'.TFun (un, t), loc), (L'.EAbs ("_", un, t, - (L'.EReturnBlob {blob = (L'.ERel 2, loc), + (L'.EReturnBlob {blob = SOME (L'.ERel 2, loc), mimeType = (L'.ERel 1, loc), t = t}, loc)), loc)), loc)), loc), fm) diff --git a/src/prepare.sml b/src/prepare.sml index 7f55959c..89cd1b43 100644 --- a/src/prepare.sml +++ b/src/prepare.sml @@ -201,7 +201,14 @@ fun prepExp (e as (_, loc), st) = | EReturnBlob {blob, mimeType, t} => let - val (blob, st) = prepExp (blob, st) + val (blob, st) = case blob of + NONE => (blob, st) + | SOME blob => + let + val (b, st) = prepExp (blob, st) + in + (SOME b, st) + end val (mimeType, st) = prepExp (mimeType, st) in ((EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), st) -- cgit v1.2.3 From b6d4f55981faff6ca7fa8b890c22ff4f33302ef2 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Fri, 1 Aug 2014 15:44:17 -0400 Subject: Differentiate between HTML and normal string literals --- src/cjr_print.sml | 16 +- src/cjrize.sml | 10 +- src/iflow.sml | 18 +- src/jscomp.sml | 18 +- src/mono_opt.sml | 186 +++++++------- src/mono_reduce.sml | 10 +- src/monoize.sml | 707 +++++++++++++++++++++++++--------------------------- src/pathcheck.sml | 2 +- src/prepare.sml | 16 +- src/prim.sig | 6 +- src/prim.sml | 16 +- src/shake.sml | 2 +- src/sql.sml | 8 +- src/urweb.grm | 36 +-- 14 files changed, 516 insertions(+), 535 deletions(-) (limited to 'src/iflow.sml') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index 9046acc8..a4cc8c54 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -203,10 +203,10 @@ fun p_patMatch (env, disc) (p, loc) = Prim.p_t_GCC (Prim.Int n), string ")"] | PPrim (Prim.String s) => box [string ("!strcmp(" ^ disc), - string ",", - space, - Prim.p_t_GCC (Prim.String s), - string ")"] + string ",", + space, + Prim.p_t_GCC (Prim.String s), + string ")"] | PPrim (Prim.Char ch) => box [string ("(" ^ disc), space, string "==", @@ -503,16 +503,16 @@ fun getPargs (e, _) = | ECase (e, [((PNone _, _), - (EPrim (Prim.String "NULL"), _)), + (EPrim (Prim.String (_, "NULL")), _)), ((PSome (_, (PVar _, _)), _), (EFfiApp (m, x, [((ERel 0, _), _)]), _))], {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e)) | ECase (e, [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _), - (EPrim (Prim.String "TRUE"), _)), + (EPrim (Prim.String (_, "TRUE")), _)), ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, _), _), - (EPrim (Prim.String "FALSE"), _))], + (EPrim (Prim.String (_, "FALSE")), _))], _) => [(e, Bool)] | _ => raise Fail "CjrPrint: getPargs" @@ -2218,7 +2218,7 @@ and p_exp' par tail env (e, loc) = NONE => #nextval (Settings.currentDbms ()) {loc = loc, seqE = p_exp' false false env seq, seqName = case #1 seq of - EPrim (Prim.String s) => SOME s + EPrim (Prim.String (_, s)) => SOME s | _ => NONE} | SOME {id, query} => #nextvalPrepared (Settings.currentDbms ()) {loc = loc, id = id, diff --git a/src/cjrize.sml b/src/cjrize.sml index d153feff..6dc0299c 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -242,7 +242,7 @@ fun cifyExp (eAll as (e, loc), sm) = let fun fail msg = (ErrorMsg.errorAt loc msg; - ((L'.EPrim (Prim.String ""), loc), sm)) + ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), sm)) in case e of L.EPrim p => ((L'.EPrim p, loc), sm) @@ -632,7 +632,7 @@ fun cifyDecl ((d, loc), sm) = fun flatten e = case #1 e of L.ERecord [] => [] - | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)] | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; Print.prefaces "Undetermined constraint" @@ -640,7 +640,7 @@ fun cifyDecl ((d, loc), sm) = []) val pe = case #1 pe of - L.EPrim (Prim.String s) => s + L.EPrim (Prim.String (_, s)) => s | _ => (ErrorMsg.errorAt loc "Primary key has not been fully determined"; Print.prefaces "Undetermined constraint" [("e", MonoPrint.p_exp MonoEnv.empty pe)]; @@ -662,7 +662,7 @@ fun cifyDecl ((d, loc), sm) = fun flatten e = case #1 e of L.ERecord [] => [] - | L.ERecord [(x, (L.EPrim (Prim.String v), _), _)] => [(x, v)] + | L.ERecord [(x, (L.EPrim (Prim.String (_, v)), _), _)] => [(x, v)] | L.EStrcat (e1, e2) => flatten e1 @ flatten e2 | _ => (ErrorMsg.errorAt loc "Constraint has not been fully determined"; Print.prefaces "Undetermined constraint" @@ -670,7 +670,7 @@ fun cifyDecl ((d, loc), sm) = []) val e = case #1 e of - L.EPrim (Prim.String s) => s + L.EPrim (Prim.String (_, s)) => s | _ => (ErrorMsg.errorAt loc "VIEW query has not been fully determined"; Print.prefaces "Undetermined VIEW query" [("e", MonoPrint.p_exp MonoEnv.empty e)]; diff --git a/src/iflow.sml b/src/iflow.sml index 461dc956..40cf8993 100644 --- a/src/iflow.sml +++ b/src/iflow.sml @@ -1446,7 +1446,7 @@ fun evalExp env (e as (_, loc)) k = case es of [_, (cname, _), _, _, _] => (case #1 cname of - EPrim (Prim.String cname) => + EPrim (Prim.String (_, cname)) => St.havocCookie cname | _ => ()) | _ => () @@ -1637,7 +1637,7 @@ fun evalExp env (e as (_, loc)) k = | Update (tab, _, _) => (cs, SS.add (ts, tab))) | EFfiApp ("Basis", "set_cookie", - [_, ((EPrim (Prim.String cname), _), _), + [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) => (SS.add (cs, cname), ts) | _ => st} @@ -1765,7 +1765,7 @@ fun evalExp env (e as (_, loc)) k = handle Cc.Contradiction => ()) end) - | ENextval (EPrim (Prim.String seq), _) => + | ENextval (EPrim (Prim.String (_, seq)), _) => let val nv = St.nextVar () in @@ -1775,7 +1775,7 @@ fun evalExp env (e as (_, loc)) k = | ENextval _ => default () | ESetval _ => default () - | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String cname), _), _)]), _), _, _) => + | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String (_, cname)), _), _)]), _), _, _) => let val e = Var (St.nextVar ()) val e' = Func (Other ("cookie/" ^ cname), []) @@ -1843,9 +1843,9 @@ fun nameSubexps k (e : Mono.exp) = (e', fn e' => (EFfiApp (m, f, [(e', t)]), #2 e)) | ECase (e', ps as [((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE), _), - (EPrim (Prim.String "TRUE"), _)), + (EPrim (Prim.String (_, "TRUE")), _)), ((PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE), _), - (EPrim (Prim.String "FALSE"), _))], q) => + (EPrim (Prim.String (_, "FALSE")), _))], q) => (e', fn e' => (ECase (e', ps, q), #2 e)) | _ => (e, fn x => x) in @@ -1907,7 +1907,7 @@ fun check (file : file) = let val ks = case #1 pk of - EPrim (Prim.String s) => + EPrim (Prim.String (_, s)) => (case String.tokens (fn ch => ch = #"," orelse ch = #" ") s of [] => [] | pk => [pk]) @@ -1974,7 +1974,7 @@ fun check (file : file) = | EFfi _ => e | EFfiApp (m, f, es) => (case (m, f, es) of - ("Basis", "set_cookie", [_, ((EPrim (Prim.String cname), _), _), _, _, _]) => + ("Basis", "set_cookie", [_, ((EPrim (Prim.String (_, cname)), _), _), _, _, _]) => cookies := SS.add (!cookies, cname) | _ => (); (EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc)) @@ -2150,7 +2150,7 @@ fun check (file : file) = | _ => raise Fail "Iflow: No New or Old in mayUpdate policy") e | PolSequence e => (case #1 e of - EPrim (Prim.String seq) => + EPrim (Prim.String (_, seq)) => let val p = AReln (Sql (String.extract (seq, 3, NONE)), [Lvar 0]) val outs = [Lvar 0] diff --git a/src/jscomp.sml b/src/jscomp.sml index bcabed0b..1a476739 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -55,7 +55,7 @@ type state = { fun strcat loc es = case es of - [] => (EPrim (Prim.String ""), loc) + [] => (EPrim (Prim.String (Prim.Normal, "")), loc) | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) @@ -81,7 +81,7 @@ fun process (file : file) = | (_, state) => state) (IM.empty, IM.empty) (#1 file) - fun str loc s = (EPrim (Prim.String s), loc) + fun str loc s = (EPrim (Prim.String (Prim.Normal, s)), loc) fun isNullable (t, _) = case t of @@ -149,7 +149,7 @@ fun process (file : file) = val (e', st) = quoteExp loc t ((ERel 0, loc), st) in (case #1 e' of - EPrim (Prim.String "ERROR") => raise Fail "UHOH" + EPrim (Prim.String (_, "ERROR")) => raise Fail "UHOH" | _ => (ECase (e, [((PNone t, loc), @@ -450,7 +450,7 @@ fun process (file : file) = 3) in case p of - Prim.String s => + Prim.String (_, s) => str ("\"" ^ String.translate jsChar s ^ "\"") | Prim.Char ch => str ("\"" ^ jsChar ch ^ "\"") | _ => str (Prim.toString p) @@ -519,7 +519,7 @@ fun process (file : file) = fun deStrcat level (all as (e, loc)) = case e of - EPrim (Prim.String s) => jsifyStringMulti (level, s) + EPrim (Prim.String (_, s)) => jsifyStringMulti (level, s) | EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2 | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\"" | _ => (ErrorMsg.errorAt loc "Unexpected non-constant JavaScript code"; @@ -1021,10 +1021,10 @@ fun process (file : file) = case #1 e of EPrim p => (case p of - Prim.String s => if inString {needle = " if inString {needle = " (); (e, st)) | ERel _ => (e, st) diff --git a/src/mono_opt.sml b/src/mono_opt.sml index ae306e68..d1e5ce55 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -145,7 +145,7 @@ fun checkProperty s = size s > 0 fun exp e = case e of - EPrim (Prim.String s) => + EPrim (Prim.String (Prim.Html, s)) => if CharVector.exists Char.isSpace s then let val (_, chs) = @@ -160,14 +160,14 @@ fun exp e = end) (false, []) s in - EPrim (Prim.String (String.implode (rev chs))) + EPrim (Prim.String (Prim.Html, String.implode (rev chs))) end else e | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2)) - - | EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) => + + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EPrim (Prim.String (Prim.Html, s2)), _)) => let val s = if size s1 > 0 andalso size s2 > 0 @@ -177,10 +177,13 @@ fun exp e = else s1 ^ s2 in - EPrim (Prim.String s) + EPrim (Prim.String (Prim.Html, s)) end + + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EPrim (Prim.String (_, s2)), _)) => + EPrim (Prim.String (Prim.Normal, s1 ^ s2)) - | EStrcat ((EPrim (Prim.String s1), loc), (EStrcat ((EPrim (Prim.String s2), _), rest), _)) => + | EStrcat ((EPrim (Prim.String (Prim.Html, s1)), loc), (EStrcat ((EPrim (Prim.String (Prim.Html, s2)), _), rest), _)) => let val s = if size s1 > 0 andalso size s2 > 0 @@ -190,9 +193,12 @@ fun exp e = else s1 ^ s2 in - EStrcat ((EPrim (Prim.String s), loc), rest) + EStrcat ((EPrim (Prim.String (Prim.Html, s)), loc), rest) end + | EStrcat ((EPrim (Prim.String (_, s1)), loc), (EStrcat ((EPrim (Prim.String (_, s2)), _), rest), _)) => + EStrcat ((EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), rest) + | EStrcat ((EStrcat (e1, e2), loc), e3) => optExp (EStrcat (e1, (EStrcat (e2, e3), loc)), loc) @@ -200,27 +206,27 @@ fun exp e = ESeq ((optExp (EWrite e1, loc), loc), (optExp (EWrite e2, loc), loc)) - | ESeq ((EWrite (EPrim (Prim.String s1), _), loc), - (EWrite (EPrim (Prim.String s2), _), _)) => - EWrite (EPrim (Prim.String (s1 ^ s2)), loc) - | ESeq ((EWrite (EPrim (Prim.String s1), _), loc), - (ESeq ((EWrite (EPrim (Prim.String s2), _), _), + | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), + (EWrite (EPrim (Prim.String (_, s2)), _), _)) => + EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc) + | ESeq ((EWrite (EPrim (Prim.String (_, s1)), _), loc), + (ESeq ((EWrite (EPrim (Prim.String (_, s2)), _), _), e), _)) => - ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc), + ESeq ((EWrite (EPrim (Prim.String (Prim.Normal, s1 ^ s2)), loc), loc), e) | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) => - EPrim (Prim.String (htmlifySpecialChar ch)) + EPrim (Prim.String (Prim.Html, htmlifySpecialChar ch)) | EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) => EFfiApp ("Basis", "htmlifySpecialChar_w", [e]) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) => - EPrim (Prim.String (htmlifyInt n)) + EPrim (Prim.String (Prim.Html, htmlifyInt n)) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyInt", es) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), (EPrim (Prim.Int n), _)), _), _)]) => - EPrim (Prim.String (htmlifyInt n)) + EPrim (Prim.String (Prim.Html, htmlifyInt n)) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _), e), loc), _)]) => EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))]) @@ -228,12 +234,12 @@ fun exp e = EFfiApp ("Basis", "htmlifyInt_w", [e]) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) => - EPrim (Prim.String (htmlifyFloat n)) + EPrim (Prim.String (Prim.Html, htmlifyFloat n)) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyFloat", es) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), (EPrim (Prim.Float n), _)), _), _)]) => - EPrim (Prim.String (htmlifyFloat n)) + EPrim (Prim.String (Prim.Html, htmlifyFloat n)) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _), e), loc), _)]) => EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))]) @@ -242,18 +248,18 @@ fun exp e = | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) => - EPrim (Prim.String "True") + EPrim (Prim.String (Prim.Html, "True")) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) => - EPrim (Prim.String "False") + EPrim (Prim.String (Prim.Html, "False")) | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) => EFfiApp ("Basis", "htmlifyBool", es) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) => - EPrim (Prim.String "True") + EPrim (Prim.String (Prim.Html, "True")) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) => - EPrim (Prim.String "False") + EPrim (Prim.String (Prim.Html, "False")) | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _), e), loc), _)]) => EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))]) @@ -267,106 +273,106 @@ fun exp e = | EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) => EFfiApp ("Basis", "htmlifyTime_w", [e]) - | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (htmlifyString s)) - | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String (htmlifyString s)), loc) + | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, htmlifyString s)) + | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) => EFfiApp ("Basis", "htmlifyString_w", [e]) - | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String s), loc), _)]) => - EWrite (EPrim (Prim.String (htmlifyString s)), loc) + | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String (_, s)), loc), _)]) => + EWrite (EPrim (Prim.String (Prim.Html, htmlifyString s)), loc) | EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) => EFfiApp ("Basis", "htmlifySource_w", [e]) | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) => - EPrim (Prim.String (attrifyInt n)) + EPrim (Prim.String (Prim.Html, attrifyInt n)) | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyInt n)), loc) + EWrite (EPrim (Prim.String (Prim.Html, attrifyInt n)), loc) | EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) => EFfiApp ("Basis", "attrifyInt_w", [e]) | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) => - EPrim (Prim.String (attrifyFloat n)) + EPrim (Prim.String (Prim.Html, attrifyFloat n)) | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyFloat n)), loc) + EWrite (EPrim (Prim.String (Prim.Html, attrifyFloat n)), loc) | EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) => EFfiApp ("Basis", "attrifyFloat_w", [e]) - | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (attrifyString s)) - | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyString s)), loc) + | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, attrifyString s)) + | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, attrifyString s)), loc) | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) => - EPrim (Prim.String (attrifyChar s)) + EPrim (Prim.String (Prim.Html, attrifyChar s)) | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) => - EWrite (EPrim (Prim.String (attrifyChar s)), loc) + EWrite (EPrim (Prim.String (Prim.Html, attrifyChar s)), loc) | EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) => EFfiApp ("Basis", "attrifyChar_w", [e]) - | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String s) - | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String s), loc) + | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Html, s)) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String (_, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Html, s)), loc) | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) => - EPrim (Prim.String (urlifyInt n)) + EPrim (Prim.String (Prim.Normal, urlifyInt n)) | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) => - EWrite (EPrim (Prim.String (urlifyInt n)), loc) + EWrite (EPrim (Prim.String (Prim.Normal, urlifyInt n)), loc) | EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) => EFfiApp ("Basis", "urlifyInt_w", [e]) | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) => - EPrim (Prim.String (urlifyFloat n)) + EPrim (Prim.String (Prim.Normal, urlifyFloat n)) | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) => - EWrite (EPrim (Prim.String (urlifyFloat n)), loc) + EWrite (EPrim (Prim.String (Prim.Normal, urlifyFloat n)), loc) | EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) => EFfiApp ("Basis", "urlifyFloat_w", [e]) - | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (urlifyString s)) - | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]), loc) => - EWrite (EPrim (Prim.String (urlifyString s)), loc) + | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Normal, urlifyString s)) + | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String (Prim.Normal, s)), _), _)]), loc) => + EWrite (EPrim (Prim.String (Prim.Normal, urlifyString s)), loc) | EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) => EFfiApp ("Basis", "urlifyString_w", [e]) | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) => - EPrim (Prim.String "1") + EPrim (Prim.String (Prim.Normal, "1")) | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) => - EPrim (Prim.String "0") + EPrim (Prim.String (Prim.Normal, "0")) | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) => - EWrite (EPrim (Prim.String "1"), loc) + EWrite (EPrim (Prim.String (Prim.Normal, "1")), loc) | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) => - EWrite (EPrim (Prim.String "0"), loc) + EWrite (EPrim (Prim.String (Prim.Normal, "0")), loc) | EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) => EFfiApp ("Basis", "urlifyBool_w", [e]) | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) => - EPrim (Prim.String (sqlifyInt n)) + EPrim (Prim.String (Prim.Normal, sqlifyInt n)) | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) => - EPrim (Prim.String "NULL") + EPrim (Prim.String (Prim.Normal, "NULL")) | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) => - EPrim (Prim.String (sqlifyInt n)) + EPrim (Prim.String (Prim.Normal, sqlifyInt n)) | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) => - EPrim (Prim.String (sqlifyFloat n)) + EPrim (Prim.String (Prim.Normal, sqlifyFloat n)) | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) => optExp (ECase (b, [((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), - (EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)), + (EPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc)), ((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), - (EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))], + (EPrim (Prim.String (Prim.Normal, #falseString (Settings.currentDbms ()))), loc))], {disc = (TFfi ("Basis", "bool"), loc), result = (TFfi ("Basis", "string"), loc)}), loc) - | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String n), _), _)]) => - EPrim (Prim.String (sqlifyString n)) + | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String (_, n)), _), _)]) => + EPrim (Prim.String (Prim.Normal, sqlifyString n)) | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) => - EPrim (Prim.String (sqlifyChar n)) + EPrim (Prim.String (Prim.Normal, sqlifyChar n)) | EWrite (ECase (discE, pes, {disc, ...}), loc) => optExp (ECase (discE, @@ -388,11 +394,11 @@ fun exp e = end | EWrite (EQuery {exps, tables, state, query, - initial = (EPrim (Prim.String ""), _), - body = (EStrcat ((EPrim (Prim.String s), _), + initial = (EPrim (Prim.String (k, "")), _), + body = (EStrcat ((EPrim (Prim.String (_, s)), _), (EStrcat ((ERel 0, _), e'), _)), _)}, loc) => - if CharVector.all Char.isSpace s then + if (case k of Prim.Normal => s = "" | Prim.Html => CharVector.all Char.isSpace s) then EQuery {exps = exps, tables = tables, query = query, state = (TRecord [], loc), initial = (ERecord [], loc), @@ -401,7 +407,7 @@ fun exp e = e | EWrite (EQuery {exps, tables, state, query, - initial = (EPrim (Prim.String ""), _), + initial = (EPrim (Prim.String (_, "")), _), body}, loc) => let fun passLets (depth, (e', _), lets) = @@ -439,94 +445,94 @@ fun exp e = | EWrite (ELet (x, t, e1, e2), loc) => optExp (ELet (x, t, e1, (EWrite e2, loc)), loc) - | EWrite (EPrim (Prim.String ""), loc) => + | EWrite (EPrim (Prim.String (_, "")), loc) => ERecord [] | ESignalBind ((ESignalReturn e1, loc), e2) => optExp (EApp (e2, e1), loc) - | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkData s then () else ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s); se) - | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkUrl s then () else ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'"); se) - | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkUrl s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkMime s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'"); se) - | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkMime s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkAtom s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'"); se) - | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkCssUrl s then () else ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'"); se) - | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if checkProperty s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'"); se) - | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkRequestHeader s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'"); se) - | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkRequestHeader s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkResponseHeader s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'"); se) - | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkResponseHeader s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "blessEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkEnvVar s then () else ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessEnvVar'"); se) - | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkEnvVar", [((se as EPrim (Prim.String (_, s)), loc), _)]) => (if Settings.checkEnvVar s then ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) - | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -551,10 +557,10 @@ fun exp e = #"_" :: cs => uwify (cs, ["uw_"]) | cs => uwify (cs, []) in - EPrim (Prim.String s) + EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String s), loc), _)]) => + | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String (_, s)), loc), _)]) => let fun uwify (cs, acc) = case cs of @@ -576,11 +582,11 @@ fun exp e = val s = uwify (String.explode s, []) in - EPrim (Prim.String s) + EPrim (Prim.String (Prim.Normal, s)) end - | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String s), _), _)]) => - EPrim (Prim.String (unAs s)) + | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String (_, s)), _), _)]) => + EPrim (Prim.String (Prim.Normal, unAs s)) | EFfiApp ("Basis", "unAs", [(e', _)]) => let fun parts (e as (_, loc)) = @@ -589,7 +595,7 @@ fun exp e = (case (parts s1, parts s2) of (SOME p1, SOME p2) => SOME (p1 @ p2) | _ => NONE) - | EPrim (Prim.String s) => SOME [(EPrim (Prim.String (unAs s)), loc)] + | EPrim (Prim.String (_, s)) => SOME [(EPrim (Prim.String (Prim.Normal, unAs s)), loc)] | EFfiApp ("Basis", f, [_]) => if String.isPrefix "sqlify" f then SOME [e] @@ -607,7 +613,7 @@ fun exp e = end | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) => - EPrim (Prim.String (str ch)) + EPrim (Prim.String (Prim.Normal, str ch)) | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => EFfiApp ("Basis", "attrifyChar", [e]) | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) => diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index 98e81185..f1a6758d 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -190,13 +190,13 @@ fun match (env, p : pat, e : exp) = (PWild, _) => Yes env | (PVar (x, t), _) => Yes ((x, t, e) :: env) - | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => + | (PPrim (Prim.String (_, s)), EStrcat ((EPrim (Prim.String (_, s')), _), _)) => if String.isPrefix s' s then Maybe else No - | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) => + | (PPrim (Prim.String (_, s)), EStrcat (_, (EPrim (Prim.String (_, s')), _))) => if String.isSuffix s' s then Maybe else @@ -756,8 +756,10 @@ fun reduce (file : file) = | ELet (x, t, e', b) => doLet (x, t, e', b) - | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => - EPrim (Prim.String (s1 ^ s2)) + | EStrcat ((EPrim (Prim.String (k1, s1)), _), (EPrim (Prim.String (k2, s2)), _)) => + EPrim (Prim.String ((case (k1, k2) of + (Prim.Html, Prim.Html) => Prim.Html + | _ => Prim.Normal), s1 ^ s2)) | ESignalBind ((ESignalReturn e1, loc), e2) => #1 (reduceExp env (EApp (e2, e1), loc)) diff --git a/src/monoize.sml b/src/monoize.sml index 9182c077..a1f97184 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -515,7 +515,7 @@ fun fooifyExp fk env = let val (_, _, _, s) = Env.lookupENamed env fnam in - ((L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) + ((L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) end | L'.EClosure (fnam, args) => let @@ -531,21 +531,21 @@ fun fooifyExp fk env = in attrify (args, ft, (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), arg'), loc)), loc), fm) end | _ => (E.errorAt loc "Type mismatch encoding attribute"; (e, fm)) in - attrify (args, ft, (L'.EPrim (Prim.String (Settings.getUrlPrefix () ^ s)), loc), fm) + attrify (args, ft, (L'.EPrim (Prim.String (Prim.Normal, Settings.getUrlPrefix () ^ s)), loc), fm) end | _ => case t of - L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm) + L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm) - | L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm) + | L'.TRecord [] => ((L'.EPrim (Prim.String (Prim.Normal, "")), loc), fm) | L'.TRecord ((x, t) :: xts) => let val (se, fm) = fooify fm ((L'.EField (e, x), loc), t) @@ -555,7 +555,7 @@ fun fooifyExp fk env = val (se', fm) = fooify fm ((L'.EField (e, x), loc), t) in ((L'.EStrcat (se, - (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "/")), loc), se'), loc)), loc), fm) end) (se, fm) xts @@ -585,14 +585,14 @@ fun fooifyExp fk env = case to of NONE => (((L'.PCon (dk, L'.PConVar n, NONE), loc), - (L'.EPrim (Prim.String x), loc)), + (L'.EPrim (Prim.String (Prim.Normal, x)), loc)), fm) | SOME t => let val (arg, fm) = fooify fm ((L'.ERel 0, loc), t) in (((L'.PCon (dk, L'.PConVar n, SOME (L'.PVar ("a", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String (x ^ "/")), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, x ^ "/")), loc), arg), loc)), fm) end) @@ -626,10 +626,10 @@ fun fooifyExp fk env = in ((L'.ECase (e, [((L'.PNone t, loc), - (L'.EPrim (Prim.String "None"), loc)), + (L'.EPrim (Prim.String (Prim.Normal, "None")), loc)), ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "Some/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Some/")), loc), body), loc))], {disc = tAll, result = (L'.TFfi ("Basis", "string"), loc)}), loc), @@ -644,9 +644,9 @@ fun fooifyExp fk env = val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt) val branches = [((L'.PNone rt, loc), - (L'.EPrim (Prim.String "Nil"), loc)), + (L'.EPrim (Prim.String (Prim.Normal, "Nil")), loc)), ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc), + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, "Cons/")), loc), arg), loc))] val dom = tAll @@ -742,7 +742,7 @@ fun monoPat env (all as (p, loc)) = fun strcat loc es = case es of - [] => (L'.EPrim (Prim.String ""), loc) + [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc) | [e] => e | _ => let @@ -757,7 +757,7 @@ fun strcat loc es = fun strcatComma loc es = case es of - [] => (L'.EPrim (Prim.String ""), loc) + [] => (L'.EPrim (Prim.String (Prim.Normal, "")), loc) | [e] => e | _ => let @@ -766,11 +766,11 @@ fun strcatComma loc es = in foldr (fn (e, e') => case (e, e') of - ((L'.EPrim (Prim.String ""), _), _) => e' - | (_, (L'.EPrim (Prim.String ""), _)) => e + ((L'.EPrim (Prim.String (_, "")), _), _) => e' + | (_, (L'.EPrim (Prim.String (_, "")), _)) => e | _ => (L'.EStrcat (e, - (L'.EStrcat ((L'.EPrim (Prim.String ", "), loc), e'), loc)), loc)) + (L'.EStrcat ((L'.EPrim (Prim.String (Prim.Normal, ", ")), loc), e'), loc)), loc)) e1 es end @@ -788,7 +788,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val strcat = strcat loc val strcatComma = strcatComma loc - fun str s = (L'.EPrim (Prim.String s), loc) + fun str s = (L'.EPrim (Prim.String (Prim.Normal, s)), loc) + fun strH s = (L'.EPrim (Prim.String (Prim.Html, s)), loc) fun poly () = (E.errorAt loc "Unsupported expression"; @@ -1564,9 +1565,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc), (L'.EAbs ("r", rt, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, - (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String - (Settings.getUrlPrefix ())), - loc), s), + (L'.EFfiApp ("Basis", "set_cookie", [(str (Settings.getUrlPrefix ()), s), ((L'.ERel 2, loc), s), (e, s), (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)), @@ -1583,9 +1582,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("c", s, (L'.TFun (un, un), loc), (L'.EAbs ("_", un, un, (L'.EFfiApp ("Basis", "clear_cookie", - [((L'.EPrim (Prim.String - (Settings.getUrlPrefix ())), - loc), s), + [(str (Settings.getUrlPrefix ()), s), ((L'.ERel 1, loc), s)]), loc)), loc)), loc), fm) @@ -1612,8 +1609,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.EFfi ("Basis", "no_primary_key"), _), _) => - ((L'.EPrim (Prim.String ""), loc), - fm) + (str "", fm) | L.ECApp ( (L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "primary_key"), _), _), _), t), _), nm), _), @@ -1623,16 +1619,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val witnesses = (L'.TRecord (map (fn (nm, _) => (monoName env nm, (L'.TRecord [], loc))) unique), loc) in ((L'.EAbs ("_", witnesses, (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String - (String.concatWith ", " - (map (fn (x, _) => - Settings.mangleSql (monoNameLc env x) - ^ (if #textKeysNeedLengths (Settings.currentDbms ()) - andalso isBlobby t then - "(767)" - else - "")) unique))), - loc)), loc), + (str + (String.concatWith ", " + (map (fn (x, _) => + Settings.mangleSql (monoNameLc env x) + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique)))), + loc), fm) end @@ -1668,15 +1664,15 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val unique = (nm, t) :: unique in - ((L'.EPrim (Prim.String ("UNIQUE (" - ^ String.concatWith ", " - (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) - ^ (if #textKeysNeedLengths (Settings.currentDbms ()) - andalso isBlobby t then - "(767)" - else - "")) unique) - ^ ")")), loc), + (str ("UNIQUE (" + ^ String.concatWith ", " + (map (fn (x, t) => Settings.mangleSql (monoNameLc env x) + ^ (if #textKeysNeedLengths (Settings.currentDbms ()) + andalso isBlobby t then + "(767)" + else + "")) unique) + ^ ")"), fm) end @@ -1690,7 +1686,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EFfi ("Basis", "mat_nil") => let val string = (L'.TFfi ("Basis", "string"), loc) - val stringE = (L'.EPrim (Prim.String ""), loc) + val stringE = str "" in ((L'.ERecord [("1", stringE, string), ("2", stringE, string)], loc), fm) @@ -1715,21 +1711,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (mat, mat), loc), (L'.EAbs ("m", mat, mat, (L'.ECase ((L'.EField ((L'.ERel 0, loc), "1"), loc), - [((L'.PPrim (Prim.String ""), loc), - (L'.ERecord [("1", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1))), - loc), string), - ("2", (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2))), - loc), string)], loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + (L'.ERecord [("1", str (Settings.mangleSql (lowercaseFirst nm1)), + string), + ("2", str (Settings.mangleSql (lowercaseFirst nm2)), + string)], loc)), ((L'.PWild, loc), (L'.ERecord [("1", (L'.EStrcat ( - (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm1) - ^ ", ")), - loc), + str (Settings.mangleSql (lowercaseFirst nm1) + ^ ", "), (L'.EField ((L'.ERel 0, loc), "1"), loc)), loc), string), ("2", (L'.EStrcat ( - (L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm2) - ^ ", ")), loc), + str (Settings.mangleSql (lowercaseFirst nm2) + ^ ", "), (L'.EField ((L'.ERel 0, loc), "2"), loc)), loc), string)], loc))], @@ -1738,10 +1733,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => ((L'.EPrim (Prim.String "RESTRICT"), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => ((L'.EPrim (Prim.String "CASCADE"), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => ((L'.EPrim (Prim.String "NO ACTION"), loc), fm) - | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => ((L'.EPrim (Prim.String "SET NULL"), loc), fm) + | L.ECApp ((L.EFfi ("Basis", "restrict"), _), _) => (str "RESTRICT", fm) + | L.ECApp ((L.EFfi ("Basis", "cascade"), _), _) => (str "CASCADE", fm) + | L.ECApp ((L.EFfi ("Basis", "no_action"), _), _) => (str "NO ACTION", fm) + | L.ECApp ((L.EFfi ("Basis", "set_null"), _), _) => (str "SET NULL", fm) | L.ECApp ( (L.ECApp ( @@ -1773,10 +1768,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun prop (fd, kw) = (L'.ECase ((L'.EField ((L'.ERel 0, loc), fd), loc), - [((L'.PPrim (Prim.String "NO ACTION"), loc), - (L'.EPrim (Prim.String ""), loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "NO ACTION")), loc), + str ""), ((L'.PWild, loc), - strcat [(L'.EPrim (Prim.String (" ON " ^ kw ^ " ")), loc), + strcat [str (" ON " ^ kw ^ " "), (L'.EField ((L'.ERel 0, loc), fd), loc)])], {disc = string, result = string}), loc) @@ -1784,13 +1779,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.EAbs ("m", mat, (L'.TFun (string, (L'.TFun (recd, string), loc)), loc), (L'.EAbs ("tab", string, (L'.TFun (recd, string), loc), (L'.EAbs ("pr", recd, string, - strcat [(L'.EPrim (Prim.String "FOREIGN KEY ("), loc), + strcat [str "FOREIGN KEY (", (L'.EField ((L'.ERel 2, loc), "1"), loc), - (L'.EPrim (Prim.String ") REFERENCES "), loc), + str ") REFERENCES ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ("), loc), + str " (", (L'.EField ((L'.ERel 2, loc), "2"), loc), - (L'.EPrim (Prim.String ")"), loc), + str ")", prop ("OnDelete", "DELETE"), prop ("OnUpdate", "UPDATE")]), loc)), loc)), loc), fm) @@ -1823,7 +1818,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val string = (L'.TFfi ("Basis", "string"), loc) in ((L'.EAbs ("e", string, string, - (L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc), + (L'.EStrcat (str "CHECK ", (L'.EFfiApp ("Basis", "checkString", [((L'.ERel 0, loc), string)]), loc)), loc)), loc), fm) @@ -1852,19 +1847,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) val fields = map (fn (x, _) => (x, s)) fields val rt = (L'.TRecord fields, loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("tab", s, (L'.TFun (rt, s), loc), (L'.EAbs ("fs", rt, s, - strcat [sc "INSERT INTO ", + strcat [str "INSERT INTO ", (L'.ERel 1, loc), - sc " (", - strcatComma (map (fn (x, _) => sc (Settings.mangleSql x)) fields), - sc ") VALUES (", + str " (", + strcatComma (map (fn (x, _) => str (Settings.mangleSql x)) fields), + str ") VALUES (", strcatComma (map (fn (x, _) => (L'.EField ((L'.ERel 0, loc), x), loc)) fields), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end | _ => poly ()) @@ -1876,31 +1870,30 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val s = (L'.TFfi ("Basis", "string"), loc) val changed = map (fn (x, _) => (x, s)) changed val rt = (L'.TRecord changed, loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("fs", rt, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, if #supportsUpdateAs (Settings.currentDbms ()) then - strcat [sc "UPDATE ", + strcat [str "UPDATE ", (L'.ERel 1, loc), - sc " AS T_T SET ", + str " AS T_T SET ", strcatComma (map (fn (x, _) => - strcat [sc (Settings.mangleSql x + strcat [str (Settings.mangleSql x ^ " = "), (L'.EField ((L'.ERel 2, loc), x), loc)]) changed), - sc " WHERE ", + str " WHERE ", (L'.ERel 0, loc)] else - strcat [sc "UPDATE ", + strcat [str "UPDATE ", (L'.ERel 1, loc), - sc " SET ", + str " SET ", strcatComma (map (fn (x, _) => - strcat [sc (Settings.mangleSql x + strcat [str (Settings.mangleSql x ^ " = "), (L'.EFfiApp ("Basis", "unAs", [((L'.EField @@ -1909,7 +1902,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = x), loc), s)]), loc)]) changed), - sc " WHERE ", + str " WHERE ", (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc)), loc), fm) @@ -1919,19 +1912,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "delete"), _), _), _), _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("tab", s, (L'.TFun (s, s), loc), (L'.EAbs ("e", s, s, if #supportsDeleteAs (Settings.currentDbms ()) then - strcat [sc "DELETE FROM ", + strcat [str "DELETE FROM ", (L'.ERel 1, loc), - sc " AS T_T WHERE ", + str " AS T_T WHERE ", (L'.ERel 0, loc)] else - strcat [sc "DELETE FROM ", + strcat [str "DELETE FROM ", (L'.ERel 1, loc), - sc " WHERE ", + str " WHERE ", (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc), fm) end @@ -1991,7 +1983,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_query"), _), _), _), _), _), _), _), _), _), _) => let - fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) fun gf s = (L'.EField ((L'.ERel 0, loc), s), loc) in @@ -2000,9 +1991,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = s, strcat [gf "Rows", (L'.ECase (gf "OrderBy", - [((L'.PPrim (Prim.String ""), loc), sc ""), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), ((L'.PWild, loc), - strcat [sc " ORDER BY ", + strcat [str " ORDER BY ", gf "OrderBy"])], {disc = s, result = s}), loc), gf "Limit", @@ -2025,7 +2016,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = sexps), _), _) => let - fun sc s = (L'.EPrim (Prim.String s), loc) val s = (L'.TFfi ("Basis", "string"), loc) val b = (L'.TFfi ("Basis", "bool"), loc) val un = (L'.TRecord [], loc) @@ -2072,7 +2062,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ("SelectExps", (L'.TRecord (map (fn (x, _) => (x, s)) sexps), loc))], loc), s, - strcat [sc "SELECT ", + strcat [str "SELECT ", (L'.ECase (gf "Distinct", [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", @@ -2080,41 +2070,41 @@ fun monoExp (env, st, fm) (all as (e, loc)) = con = "True", arg = NONE}, NONE), loc), - (L'.EPrim (Prim.String "DISTINCT "), loc)), + str "DISTINCT "), ((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "False", arg = NONE}, NONE), loc), - (L'.EPrim (Prim.String ""), loc))], + str "")], {disc = b, result = s}), loc), strcatComma (map (fn (x, t) => strcat [ (L'.EField (gf "SelectExps", x), loc), - sc (" AS " ^ Settings.mangleSql x) + str (" AS " ^ Settings.mangleSql x) ]) sexps @ map (fn (x, xts) => strcatComma (map (fn (x', _) => - sc ("T_" ^ x + str ("T_" ^ x ^ "." ^ Settings.mangleSql x')) xts)) stables), (L'.ECase (gf "From", - [((L'.PPrim (Prim.String ""), loc), - sc ""), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), ((L'.PVar ("x", s), loc), - strcat [sc " FROM ", + strcat [str " FROM ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc), (L'.ECase (gf "Where", - [((L'.PPrim (Prim.String (#trueString (Settings.currentDbms ()))), + [((L'.PPrim (Prim.String (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), - sc ""), + str ""), ((L'.PWild, loc), - strcat [sc " WHERE ", gf "Where"])], + strcat [str " WHERE ", gf "Where"])], {disc = s, result = s}), loc), @@ -2125,14 +2115,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = List.all (fn (x, _) => List.exists (fn (x', _) => x' = x) xts') xts) tables then - sc "" + str "" else strcat [ - sc " GROUP BY ", + str " GROUP BY ", strcatComma (map (fn (x, xts) => strcatComma (map (fn (x', _) => - sc ("T_" ^ x + str ("T_" ^ x ^ "." ^ Settings.mangleSql x')) xts)) grouped) @@ -2140,10 +2130,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.ECase (gf "Having", [((L'.PPrim (Prim.String - (#trueString (Settings.currentDbms ()))), loc), - sc ""), + (Prim.Normal, #trueString (Settings.currentDbms ()))), loc), + str ""), ((L'.PWild, loc), - strcat [sc " HAVING ", gf "Having"])], + strcat [str " HAVING ", gf "Having"])], {disc = s, result = s}), loc) ]), loc), @@ -2234,7 +2224,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = s, (L'.ECase ((L'.ERel 0, loc), [((L'.PNone t, loc), - (L'.EPrim (Prim.String "NULL"), loc)), + str "NULL"), ((L'.PSome (t, (L'.PVar ("y", t), loc)), loc), (L'.EApp ((L'.ERel 2, loc), (L'.ERel 0, loc)), loc))], {disc = (L'.TOption t, loc), @@ -2270,7 +2260,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ERecord [], loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_from_nil"), _), _) => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.ECApp ((L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_table"), _), _), _), _), _), _), _), _), _), (L.CName name, _)) => @@ -2279,7 +2269,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EAbs ("tab", s, s, strcat [(L'.ERel 0, loc), - (L'.EPrim (Prim.String (" AS T_" ^ name)), loc)]), loc), + str (" AS T_" ^ name)]), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_query"), _), _), @@ -2287,12 +2277,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.CName name, _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("q", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 0, loc), - sc (") AS T_" ^ name)]), loc), + str (") AS T_" ^ name)]), loc), fm) end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_from_comma"), _), _), _), _), _), _) => @@ -2303,13 +2292,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("tab2", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 1, loc), s), ("2", (L'.ERel 0, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 0, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), ((L'.PWild, loc), strcat [(L'.ERel 1, loc), - (L'.EPrim (Prim.String ", "), loc), + str ", ", (L'.ERel 0, loc)])], {disc = (L'.TRecord [("1", s), ("2", s)], loc), result = s}), loc)), loc)), loc), @@ -2324,24 +2313,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), loc), s)], loc), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), loc), s)], loc), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " JOIN "), loc), + str " JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2360,27 +2349,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " LEFT JOIN "), - loc), + str " LEFT JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2399,27 +2387,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " RIGHT JOIN "), - loc), + str " RIGHT JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2438,27 +2425,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L'.EAbs ("on", s, s, (L'.ECase ((L'.ERecord [("1", (L'.ERel 2, loc), s), ("2", (L'.ERel 1, loc), s)], loc), - [((L'.PRecord [("1", (L'.PPrim (Prim.String ""), + [((L'.PRecord [("1", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 1, loc)), - ((L'.PRecord [("2", (L'.PPrim (Prim.String ""), + ((L'.PRecord [("2", (L'.PPrim (Prim.String (Prim.Normal, "")), loc), s)], loc), (L'.ERel 2, loc)), ((L'.PWild, loc), strcat ((if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String "("), loc)] + [str "("] else []) @ [(L'.ERel 2, loc), - (L'.EPrim (Prim.String " FULL JOIN "), - loc), + str " FULL JOIN ", (L'.ERel 1, loc), - (L'.EPrim (Prim.String " ON "), loc), + str " ON ", (L'.ERel 0, loc)] @ (if #nestedRelops (Settings.currentDbms ()) then - [(L'.EPrim (Prim.String ")"), loc)] + [str ")"] else [])))], {disc = (L'.TRecord [("1", s), ("2", s)], loc), @@ -2467,9 +2453,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_Nil"), _), _), _), _) => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_order_by_random"), _), _), _), _) => - ((L'.EPrim (Prim.String (#randomFunction (Settings.currentDbms ()) ^ "()")), loc), fm) + (str (#randomFunction (Settings.currentDbms ()) ^ "()"), fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2481,81 +2467,80 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("d", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, (L'.ECase ((L'.ERel 0, loc), - [((L'.PPrim (Prim.String ""), loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc)]), ((L'.PWild, loc), strcat [(L'.ERel 2, loc), (L'.ERel 1, loc), - sc ", ", + str ", ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc)), loc)), loc)), loc)), loc), fm) end | L.EFfi ("Basis", "sql_no_limit") => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ - (L'.EPrim (Prim.String " LIMIT "), loc), + str " LIMIT ", (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.EFfi ("Basis", "sql_no_offset") => - ((L'.EPrim (Prim.String ""), loc), fm) + (str "", fm) | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) => let val (e, fm) = monoExp (env, st, fm) e in (strcat [ - (L'.EPrim (Prim.String " OFFSET "), loc), + str " OFFSET ", (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc) ], fm) end | L.ECApp ((L.EFfi ("Basis", "sql_eq"), _), _) => - ((L'.EPrim (Prim.String "="), loc), fm) + (str "=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_ne"), _), _) => - ((L'.EPrim (Prim.String "<>"), loc), fm) + (str "<>", fm) | L.ECApp ((L.EFfi ("Basis", "sql_lt"), _), _) => - ((L'.EPrim (Prim.String "<"), loc), fm) + (str "<", fm) | L.ECApp ((L.EFfi ("Basis", "sql_le"), _), _) => - ((L'.EPrim (Prim.String "<="), loc), fm) + (str "<=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_gt"), _), _) => - ((L'.EPrim (Prim.String ">"), loc), fm) + (str ">", fm) | L.ECApp ((L.EFfi ("Basis", "sql_ge"), _), _) => - ((L'.EPrim (Prim.String ">="), loc), fm) + (str ">=", fm) | L.ECApp ((L.EFfi ("Basis", "sql_plus"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "+"), loc)), loc), fm) + str "+"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_minus"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "-"), loc)), loc), fm) + str "-"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_times"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "*"), loc)), loc), fm) + str "*"), loc), fm) | L.ECApp ((L.EFfi ("Basis", "sql_div"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "/"), loc)), loc), fm) + str "/"), loc), fm) | L.EFfi ("Basis", "sql_mod") => - ((L'.EPrim (Prim.String "%"), loc), fm) + (str "%", fm) | L.EFfi ("Basis", "sql_like") => - ((L'.EPrim (Prim.String "LIKE"), loc), fm) + (str "LIKE", fm) | L.ECApp ( (L.ECApp ( @@ -2570,21 +2555,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), - strcat [sc "(", + strcat [str "(", (L'.ERel 1, loc), - sc " ", + str " ", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end - | L.EFfi ("Basis", "sql_not") => ((L'.EPrim (Prim.String "NOT"), loc), fm) + | L.EFfi ("Basis", "sql_not") => (str "NOT", fm) | L.ECApp ((L.EFfi ("Basis", "sql_neg"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "-"), loc)), loc), fm) + str "-"), loc), fm) | L.ECApp ( (L.ECApp ( @@ -2601,22 +2585,21 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 1, loc), - sc " ", + str " ", (L'.ERel 2, loc), - sc " ", + str " ", (L'.ERel 0, loc), - sc ")"]), loc)), loc)), loc), + str ")"]), loc)), loc)), loc), fm) end - | L.EFfi ("Basis", "sql_and") => ((L'.EPrim (Prim.String "AND"), loc), fm) - | L.EFfi ("Basis", "sql_or") => ((L'.EPrim (Prim.String "OR"), loc), fm) + | L.EFfi ("Basis", "sql_and") => (str "AND", fm) + | L.EFfi ("Basis", "sql_or") => (str "OR", fm) | L.ECApp ( (L.ECApp ( @@ -2632,7 +2615,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), (L.CName tab, _)), _), - (L.CName field, _)) => ((L'.EPrim (Prim.String ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field))), loc), fm) + (L.CName field, _)) => (str ("T_" ^ tab ^ "." ^ Settings.mangleSql (lowercaseFirst field)), fm) | L.ECApp ( (L.ECApp ( @@ -2644,7 +2627,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _), _), _), _), _), - (L.CName nm, _)) => ((L'.EPrim (Prim.String (Settings.mangleSql (lowercaseFirst nm))), loc), fm) + (L.CName nm, _)) => (str (Settings.mangleSql (lowercaseFirst nm)), fm) | L.ECApp ( (L.ECApp ( @@ -2661,49 +2644,48 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in (if #nestedRelops (Settings.currentDbms ()) then (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, - strcat [sc "((", + strcat [str "((", (L'.ERel 1, loc), - sc ") ", + str ") ", (L'.ERel 3, loc), (L'.ECase ((L'.ERel 2, loc), [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), - sc " ALL"), + str " ALL"), ((L'.PWild, loc), - sc "")], + str "")], {disc = (L'.TFfi ("Basis", "bool"), loc), result = s}), loc), - sc " (", + str " (", (L'.ERel 0, loc), - sc "))"]), loc)), loc)), loc)), loc) + str "))"]), loc)), loc)), loc)), loc) else (L'.EAbs ("c", s, (L'.TFun ((L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc)), loc), (L'.EAbs ("all", (L'.TFfi ("Basis", "bool"), loc), (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), (L'.EAbs ("e2", s, s, strcat [(L'.ERel 1, loc), - sc " ", + str " ", (L'.ERel 3, loc), (L'.ECase ((L'.ERel 2, loc), [((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc), - sc " ALL"), + str " ALL"), ((L'.PWild, loc), - sc "")], + str "")], {disc = (L'.TFfi ("Basis", "bool"), loc), result = s}), loc), - sc " ", + str " ", (L'.ERel 0, loc)]), loc)), loc)), loc)), loc), fm) end @@ -2720,25 +2702,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("x", s, s, (L'.ERel 0, loc)), loc), fm) end - | L.EFfi ("Basis", "sql_union") => ((L'.EPrim (Prim.String "UNION"), loc), fm) + | L.EFfi ("Basis", "sql_union") => (str "UNION", fm) | L.EFfi ("Basis", "sql_intersect") => (if #onlyUnion (Settings.currentDbms ()) then ErrorMsg.errorAt loc "The DBMS you've selected doesn't support INTERSECT." else (); - ((L'.EPrim (Prim.String "INTERSECT"), loc), fm)) + (str "INTERSECT", fm)) | L.EFfi ("Basis", "sql_except") => (if #onlyUnion (Settings.currentDbms ()) then ErrorMsg.errorAt loc "The DBMS you've selected doesn't support EXCEPT." else (); - ((L'.EPrim (Prim.String "EXCEPT"), loc), fm)) + (str "EXCEPT", fm)) | L.ECApp ( (L.ECApp ( @@ -2746,8 +2727,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_count"), _), _), _), _), _), - _) => ((L'.EPrim (Prim.String "COUNT(*)"), loc), - fm) + _) => (str "COUNT(*)", fm) | L.ECApp ( (L.ECApp ( @@ -2762,12 +2742,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = t) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) val main = strcat [(L'.ERel 1, loc), - sc "(", + str "(", (L'.ERel 0, loc), - sc ")"] + str ")"] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, (L'.TFun (s, s), loc), main), loc)), loc), @@ -2775,8 +2754,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.EFfi ("Basis", "sql_count_col"), _), _) => - ((L'.EPrim (Prim.String "COUNT"), loc), - fm) + (str "COUNT", fm) | L.EFfi ("Basis", "sql_summable_int") => ((L'.ERecord [], loc), fm) | L.EFfi ("Basis", "sql_summable_float") => ((L'.ERecord [], loc), fm) @@ -2786,12 +2764,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) | L.ECApp ((L.EFfi ("Basis", "sql_avg"), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "AVG"), loc)), loc), + str "AVG"), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_sum"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "SUM"), loc)), loc)), loc), + str "SUM"), loc)), loc), fm) | L.EFfi ("Basis", "sql_arith_int") => ((L'.ERecord [], loc), fm) @@ -2811,16 +2789,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_max"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MAX"), loc)), loc)), loc), + str "MAX"), loc)), loc), fm) | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_min"), _), _), _), _) => ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc)), loc), (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "string"), loc), - (L'.EPrim (Prim.String "MIN"), loc)), loc)), loc), + str "MIN"), loc)), loc), fm) - | L.EFfi ("Basis", "sql_asc") => ((L'.EPrim (Prim.String ""), loc), fm) - | L.EFfi ("Basis", "sql_desc") => ((L'.EPrim (Prim.String " DESC"), loc), fm) + | L.EFfi ("Basis", "sql_asc") => (str "", fm) + | L.EFfi ("Basis", "sql_desc") => (str " DESC", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2832,7 +2810,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("s", s, s, (L'.ERel 0, loc)), loc), fm) @@ -2860,7 +2837,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end - | L.EFfi ("Basis", "sql_current_timestamp") => ((L'.EPrim (Prim.String "CURRENT_TIMESTAMP"), loc), fm) + | L.EFfi ("Basis", "sql_current_timestamp") => (str "CURRENT_TIMESTAMP", fm) | L.ECApp ( (L.ECApp ( @@ -2875,25 +2852,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("f", s, (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, strcat [(L'.ERel 1, loc), - sc "(", + str "(", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end | L.EFfi ("Basis", "sql_octet_length") => - ((L'.EPrim (Prim.String (if #supportsOctetLength (Settings.currentDbms ()) then - "octet_length" - else - "length")), loc), fm) + (str (if #supportsOctetLength (Settings.currentDbms ()) then + "octet_length" + else + "length"), fm) | L.EFfi ("Basis", "sql_lower") => - ((L'.EPrim (Prim.String "lower"), loc), fm) + (str "lower", fm) | L.EFfi ("Basis", "sql_upper") => - ((L'.EPrim (Prim.String "upper"), loc), fm) + (str "upper", fm) | L.ECApp ((L.EFfi ("Basis", "sql_known"), _), _) => ((L'.EFfi ("Basis", "sql_known"), loc), fm) @@ -2907,12 +2883,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("s", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 0, loc), - sc " IS NULL)"]), loc), + str " IS NULL)"]), loc), fm) end @@ -2926,15 +2901,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("x1", s, (L'.TFun (s, s), loc), (L'.EAbs ("x1", s, s, - strcat [sc "COALESCE(", + strcat [str "COALESCE(", (L'.ERel 1, loc), - sc ",", + str ",", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end @@ -2948,18 +2922,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _), _)) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("if", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("then", s, (L'.TFun (s, s), loc), (L'.EAbs ("else", s, s, - strcat [sc "(CASE WHEN (", + strcat [str "(CASE WHEN (", (L'.ERel 2, loc), - sc ") THEN (", + str ") THEN (", (L'.ERel 1, loc), - sc ") ELSE (", + str ") ELSE (", (L'.ERel 0, loc), - sc ") END)"]), loc)), loc)), loc), + str ") END)"]), loc)), loc)), loc), fm) end @@ -2974,7 +2947,6 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("u", (L'.TRecord [], loc), (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, @@ -2997,13 +2969,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) in ((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFun (s, s), loc), (L'.EAbs ("x", s, s, - strcat [sc "(", + strcat [str "(", (L'.ERel 0, loc), - sc ")"]), loc)), loc), + str ")"]), loc)), loc), fm) end @@ -3013,7 +2984,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.EFfi ("Basis", "sql_no_partition"), _), _), _), _), _), - _) => ((L'.EPrim (Prim.String ""), loc), fm) + _) => (str "", fm) | L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -3026,7 +2997,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val s = (L'.TFfi ("Basis", "string"), loc) in - ((L'.EAbs ("e", s, s, strcat [(L'.EPrim (Prim.String "PARTITION BY "), loc), (L'.ERel 0, loc)]), loc), + ((L'.EAbs ("e", s, s, strcat [str "PARTITION BY ", (L'.ERel 0, loc)]), loc), fm) end @@ -3046,20 +3017,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ErrorMsg.errorAt loc "The DBMS you've selected doesn't support window functions." val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) val main = strcat [(L'.ERel 2, loc), - sc " OVER (", + str " OVER (", (L'.ERel 1, loc), (L'.ECase ((L'.ERel 0, loc), - [((L'.PPrim (Prim.String ""), loc), - sc ""), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + str ""), ((L'.PWild, loc), - strcat [sc " ORDER BY ", + strcat [str " ORDER BY ", (L'.ERel 0, loc)])], {disc = s, result = s}), loc), - sc ")"] + str ")"] in ((L'.EAbs ("w", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("p", s, (L'.TFun (s, s), loc), @@ -3081,12 +3051,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) = _) => let val s = (L'.TFfi ("Basis", "string"), loc) - fun sc s = (L'.EPrim (Prim.String s), loc) val main = strcat [(L'.ERel 1, loc), - sc "(", + str "(", (L'.ERel 0, loc), - sc ")"] + str ")"] in ((L'.EAbs ("c", s, (L'.TFun (s, (L'.TFun (s, s), loc)), loc), (L'.EAbs ("e1", s, s, main), loc)), loc), @@ -3094,9 +3063,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = end | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_window_count"), _), _), _), _), _), _) => - ((L'.EPrim (Prim.String "COUNT(*)"), loc), fm) + (str "COUNT(*)", fm) | L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "sql_rank"), _), _), _), _), _), _) => - ((L'.EPrim (Prim.String "RANK()"), loc), fm) + (str "RANK()", fm) | L.EFfiApp ("Basis", "nextval", [(e, _)]) => let @@ -3112,19 +3081,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ESetval (e1, e2), loc), fm) end - | L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm) + | L.EFfi ("Basis", "null") => (str "", fm) | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end - | L.EFfi ("Basis", "data_kind") => ((L'.EPrim (Prim.String "data-"), loc), fm) - | L.EFfi ("Basis", "aria_kind") => ((L'.EPrim (Prim.String "aria-"), loc), fm) + | L.EFfi ("Basis", "data_kind") => (str "data-", fm) + | L.EFfi ("Basis", "aria_kind") => (str "aria-", fm) | L.EFfiApp ("Basis", "data_attr", [(sk, _), (s1, _), (s2, _)]) => let @@ -3134,9 +3103,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat (sk, (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc), + (L'.EStrcat (str "=\"", (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EPrim (Prim.String "\""), loc)), loc)), + str "\""), loc)), loc)), loc)), loc), fm) end @@ -3146,7 +3115,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end @@ -3154,9 +3123,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = let val (s, fm) = monoExp (env, st, fm) s in - ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc), + ((L'.EStrcat (str "url(", (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EPrim (Prim.String ")"), loc)), loc)), loc), + str ")"), loc)), loc), fm) end @@ -3165,7 +3134,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s, fm) = monoExp (env, st, fm) s in ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), - (L'.EPrim (Prim.String ":"), loc)), loc), + str ":"), loc), fm) end | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) => @@ -3173,17 +3142,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (str " ", s2), loc)), loc), fm) end - | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm) + | L.EFfi ("Basis", "noStyle") => (str "", fm) | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) => let val (s1, fm) = monoExp (env, st, fm) s1 val (s2, fm) = monoExp (env, st, fm) s2 in - ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc), + ((L'.EStrcat (s1, (L'.EStrcat (s2, str ";"), loc)), loc), fm) end @@ -3332,28 +3301,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun tagStart tag' = let val t = (L'.TFfi ("Basis", "string"), loc) - val s = (L'.EPrim (Prim.String (String.concat ["<", tag'])), loc) + val s = strH (String.concat ["<", tag']) val s = (L'.EStrcat (s, (L'.ECase (class, - [((L'.PPrim (Prim.String ""), loc), - (L'.EPrim (Prim.String ""), loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strH ""), ((L'.PVar ("x", t), loc), - (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat (strH " class=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), + strH "\""), loc)), loc))], {disc = t, result = t}), loc)), loc) val s = (L'.EStrcat (s, (L'.ECase (style, - [((L'.PPrim (Prim.String ""), loc), - (L'.EPrim (Prim.String ""), loc)), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), + strH ""), ((L'.PVar ("x", t), loc), - (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), + (L'.EStrcat (strH " style=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\""), loc)), + strH "\""), loc)), loc))], {disc = t, result = t}), loc)), loc) @@ -3363,7 +3332,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | (("Data", e, _), (s, fm)) => ((L'.EStrcat (s, (L'.EStrcat ( - (L'.EPrim (Prim.String " "), loc), + strH " ", e), loc)), loc), fm) | ((x, e, t), (s, fm)) => @@ -3380,7 +3349,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = arg = NONE}, NONE), loc), (L'.EStrcat (s, - (L'.EPrim (Prim.String s'), loc)), loc)), + strH s'), loc)), ((L'.PCon (L'.Enum, L'.PConFfi {mod = "Basis", datatyp = "bool", @@ -3409,10 +3378,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in ((L'.EStrcat (s, (L'.EStrcat ( - (L'.EPrim (Prim.String s'), loc), + strH s', (L'.EStrcat ( (L'.EJavaScript (L'.Attribute, e), loc), - (L'.EPrim (Prim.String ");return false'"), loc)), loc)), + strH ");return false'"), loc)), loc)), loc), fm) end @@ -3438,14 +3407,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (e, fm) = fooify env fm (e, t) val e = case (tag, x) of - ("coption", "Value") => (L'.EStrcat ((L'.EPrim (Prim.String "x"), loc), e), loc) + ("coption", "Value") => (L'.EStrcat (strH "x", e), loc) | _ => e in ((L'.EStrcat (s, - (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), + (L'.EStrcat (strH xp, (L'.EStrcat (e, - (L'.EPrim (Prim.String "\""), - loc)), + strH "\""), loc)), loc)), loc), fm) @@ -3454,7 +3422,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = in (if tag = "coption" andalso List.all (fn ("Value", _, _) => false | _ => true) attrs then (L'.EStrcat (s, - (L'.EPrim (Prim.String " value=\"\""), loc)), loc) + strH " value=\"\""), loc) else s, fm) @@ -3467,8 +3435,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val (ts, fm) = tagStart "input" in ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), - loc)), loc), fm) + strH (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\" />")), loc), fm) end | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to input tag") @@ -3488,10 +3455,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = NONE => xml | SOME extra => (L'.EStrcat (extra, xml), loc) in - ((L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), + ((L'.EStrcat ((L'.EStrcat (tagStart, strH ">"), loc), (L'.EStrcat (xml, - (L'.EPrim (Prim.String (String.concat [""])), - loc)), loc)), + strH (String.concat [""])), loc)), loc), fm) end @@ -3511,9 +3477,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), _), _), - (L.EPrim (Prim.String s), _)), _), NONE) => + (L.EPrim (Prim.String (_, s)), _)), _), NONE) => if CharVector.all Char.isSpace s andalso isSingleton () then - ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String " />"), loc)), loc), fm) + ((L'.EStrcat (tagStart, strH " />"), loc), fm) else normal () | _ => normal () @@ -3521,7 +3487,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun setAttrs jexp = let - val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) + val s = strH (String.concat ["<", tag]) val assgns = List.mapPartial (fn ("Source", _, _) => NONE @@ -3570,12 +3536,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) = val t = (L'.TFfi ("Basis", "string"), loc) val setClass = (L'.ECase (class, - [((L'.PPrim (Prim.String ""), loc), + [((L'.PPrim (Prim.String (Prim.Normal, "")), loc), str ""), ((L'.PVar ("x", t), loc), - (L'.EStrcat ((L'.EPrim (Prim.String "d.className=\""), loc), + (L'.EStrcat (strH "d.className=\"", (L'.EStrcat ((L'.ERel 0, loc), - (L'.EPrim (Prim.String "\";"), loc)), loc)), + strH "\";"), loc)), loc))], {disc = (L'.TOption t, loc), result = t}), loc) @@ -3594,14 +3560,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fun execify e = case e of - NONE => (L'.EPrim (Prim.String ""), loc) + NONE => strH "" | SOME e => let val e = (L'.EApp (e, (L'.ERecord [], loc)), loc) in - (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), + (L'.EStrcat (strH "exec(", (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), - (L'.EPrim (Prim.String ")"), loc)), loc)), loc) + strH ")"), loc)), loc) end fun inTag tag' = case ctxOuter of @@ -3643,10 +3609,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = case attrs of [("Signal", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ("")), loc)), loc)), loc), + strH ("))")), loc)), loc), fm) | _ => raise Fail "Monoize: Bad attributes" end @@ -3655,9 +3621,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (case attrs of [("Code", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ("")), loc)), loc)), loc), + strH "))"), loc)), loc), fm) | _ => raise Fail "Monoize: Bad attributes") @@ -3665,9 +3631,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (case attrs of [("Code", e, _)] => ((L'.EStrcat - ((L'.EPrim (Prim.String ("")), loc)), loc)), loc), + strH "))"), loc)), loc), fm) | _ => raise Fail "Monoize: Bad