summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/ur/basis.urs2
-rw-r--r--src/checknest.sml5
-rw-r--r--src/cjr.sml5
-rw-r--r--src/cjr_print.sml24
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/iflow.sml8
-rw-r--r--src/jscomp.sml4
-rw-r--r--src/mono.sml4
-rw-r--r--src/mono_print.sml6
-rw-r--r--src/mono_reduce.sml2
-rw-r--r--src/mono_util.sml4
-rw-r--r--src/monoize.sml48
-rw-r--r--src/mysql.sml23
-rw-r--r--src/postgres.sml26
-rw-r--r--src/prepare.sml4
-rw-r--r--src/settings.sig6
-rw-r--r--src/settings.sml6
-rw-r--r--src/sqlite.sml23
-rw-r--r--tests/tryDml.ur13
-rw-r--r--tests/tryDml.urp4
-rw-r--r--tests/tryDml.urs1
21 files changed, 139 insertions, 83 deletions
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<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 @@ 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 <xml>{[o1]}; {[o2]}</xml>
+
+fun main () = return <xml><body>
+ <form> <submit action={doStuff}/> </form>
+</body></xml>
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 11:18:49 +0000