Mercurial > urweb
changeset 1293:acabf3935060
tryDml
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 05 Sep 2010 14:00:57 -0400 |
| parents | a671c986f517 |
| children | b4480a56cab7 |
| files | lib/ur/basis.urs src/checknest.sml src/cjr.sml src/cjr_print.sml src/cjrize.sml src/iflow.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/mysql.sml src/postgres.sml src/prepare.sml src/settings.sig src/settings.sml src/sqlite.sml tests/tryDml.ur tests/tryDml.urp tests/tryDml.urs |
| diffstat | 21 files changed, 139 insertions(+), 83 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/basis.urs Sun Sep 05 12:50:06 2010 -0400 +++ b/lib/ur/basis.urs Sun Sep 05 14:00:57 2010 -0400 @@ -535,6 +535,8 @@ 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
--- a/src/checknest.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/checknest.sml Sun Sep 05 14:00:57 2010 -0400 @@ -138,9 +138,10 @@ | 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,
--- a/src/cjr.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/cjr.sml Sun Sep 05 14:00:57 2010 -0400 @@ -56,6 +56,8 @@ withtype pat = pat' located +datatype failure_mode = datatype Settings.failure_mode + datatype exp' = EPrim of Prim.t | ERel of int @@ -92,7 +94,8 @@ 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 }
--- a/src/cjr_print.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/cjr_print.sml Sun Sep 05 14:00:57 2010 -0400 @@ -1791,8 +1791,11 @@ 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 @@ 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 @@ #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 "({",
--- a/src/cjrize.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/cjrize.sml Sun Sep 05 14:00:57 2010 -0400 @@ -455,11 +455,11 @@ 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 =>
--- a/src/iflow.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/iflow.sml Sun Sep 05 14:00:57 2010 -0400 @@ -2040,7 +2040,7 @@ 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 @@ (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 @@ 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 @@ 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)
--- a/src/jscomp.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/jscomp.sml Sun Sep 05 14:00:57 2010 -0400 @@ -1147,11 +1147,11 @@ ((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
--- a/src/mono.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/mono.sml Sun Sep 05 14:00:57 2010 -0400 @@ -66,6 +66,8 @@ 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 @@ query : exp, body : exp, initial : exp } - | EDml of exp + | EDml of exp * failure_mode | ENextval of exp | ESetval of exp * exp
--- a/src/mono_print.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/mono_print.sml Sun Sep 05 14:00:57 2010 -0400 @@ -322,9 +322,9 @@ 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 ")"]
--- a/src/mono_reduce.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/mono_reduce.sml Sun Sep 05 14:00:57 2010 -0400 @@ -465,7 +465,7 @@ [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
--- a/src/mono_util.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/mono_util.sml Sun Sep 05 14:00:57 2010 -0400 @@ -332,10 +332,10 @@ 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' =>
--- a/src/monoize.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/monoize.sml Sun Sep 05 14:00:57 2010 -0400 @@ -1748,7 +1748,15 @@ 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 @@ 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 @@ ^ tab ^ " WHERE ")), loc), cond eb), loc) - ebs), loc), + ebs, L'.Error), loc), e), loc) in e @@ -4067,15 +4075,15 @@ [] => 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 @@ [] => 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
--- a/src/mysql.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/mysql.sml Sun Sep 05 14:00:57 2010 -0400 @@ -1194,16 +1194,19 @@ 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 @@ 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 @@ 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);",
--- a/src/postgres.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/postgres.sml Sun Sep 05 14:00:57 2010 -0400 @@ -708,7 +708,7 @@ 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 @@ 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 @@ 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 @@ 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.\");",
--- a/src/prepare.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/prepare.sml Sun Sep 05 14:00:57 2010 -0400 @@ -246,11 +246,11 @@ 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
--- a/src/settings.sig Sun Sep 05 12:50:06 2010 -0400 +++ b/src/settings.sig Sun Sep 05 14:00:57 2010 -0400 @@ -124,6 +124,8 @@ 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 @@ -> 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,
--- a/src/settings.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/settings.sml Sun Sep 05 14:00:57 2010 -0400 @@ -363,6 +363,8 @@ fun isNotNull (Nullable _) = false | isNotNull _ = true +datatype failure_mode = Error | None + type dbms = { name : string, header : string, @@ -384,9 +386,9 @@ -> 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,
--- a/src/sqlite.sml Sun Sep 05 12:50:06 2010 -0400 +++ b/src/sqlite.sml Sun Sep 05 14:00:57 2010 -0400 @@ -688,7 +688,7 @@ 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 @@ newline, newline, - string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"", - string (ErrorMsg.spanToString loc), - string ": DML step failed: %s<br />%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<br />%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 @@ 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 @@ dmlCommon {loc = loc, dml = box [string "\"", string (String.toCString dml), - string "\""]}, + string "\""], mode = mode}, string "uw_pop_cleanup(ctx);", newline,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/tryDml.ur Sun Sep 05 14:00:57 2010 -0400 @@ -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 <xml>{[o1]}; {[o2]}</xml> + +fun main () = return <xml><body> + <form> <submit action={doStuff}/> </form> +</body></xml>