summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb/types_cpp.h2
-rw-r--r--include/urweb/urweb_cpp.h1
-rw-r--r--src/c/cgi.c3
-rw-r--r--src/c/fastcgi.c3
-rw-r--r--src/c/http.c3
-rw-r--r--src/c/urweb.c21
-rw-r--r--src/cjr_print.sml13
-rw-r--r--src/corify.sml2
-rw-r--r--src/effectize.sml10
-rw-r--r--src/export.sig2
-rw-r--r--src/export.sml4
-rw-r--r--src/mysql.sml2
-rw-r--r--src/postgres.sml4
-rw-r--r--src/sqlite.sml2
-rw-r--r--src/tag.sml6
15 files changed, 46 insertions, 32 deletions
diff --git a/include/urweb/types_cpp.h b/include/urweb/types_cpp.h
index 330f7755..789aecb1 100644
--- a/include/urweb/types_cpp.h
+++ b/include/urweb/types_cpp.h
@@ -82,7 +82,7 @@ typedef struct {
void (*expunger)(struct uw_context *, uw_Basis_client);
void (*db_init)(struct uw_context *);
- int (*db_begin)(struct uw_context *);
+ int (*db_begin)(struct uw_context *, int could_write);
int (*db_commit)(struct uw_context *);
int (*db_rollback)(struct uw_context *);
void (*db_close)(struct uw_context *);
diff --git a/include/urweb/urweb_cpp.h b/include/urweb/urweb_cpp.h
index cf046e83..8dfffdf9 100644
--- a/include/urweb/urweb_cpp.h
+++ b/include/urweb/urweb_cpp.h
@@ -86,6 +86,7 @@ uw_Basis_string uw_Basis_maybe_onunload(struct uw_context *, uw_Basis_string);
void uw_set_needs_push(struct uw_context *, int);
void uw_set_needs_sig(struct uw_context *, int);
+void uw_set_could_write_db(struct uw_context *, int);
char *uw_Basis_htmlifyInt(struct uw_context *, uw_Basis_int);
char *uw_Basis_htmlifyFloat(struct uw_context *, uw_Basis_float);
diff --git a/src/c/cgi.c b/src/c/cgi.c
index 52c0ca2e..c9ec744a 100644
--- a/src/c/cgi.c
+++ b/src/c/cgi.c
@@ -134,8 +134,7 @@ void uw_copy_client_data(void *dst, void *src) {
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
- if (uw_get_app(ctx)->db_begin(ctx))
- uw_error(ctx, FATAL, "Error running SQL BEGIN");
+ uw_ensure_transaction(ctx);
uw_get_app(ctx)->expunger(ctx, cli);
uw_commit(ctx);
}
diff --git a/src/c/fastcgi.c b/src/c/fastcgi.c
index 9e3c8d7e..d6d2391d 100644
--- a/src/c/fastcgi.c
+++ b/src/c/fastcgi.c
@@ -632,8 +632,7 @@ void uw_copy_client_data(void *dst, void *src) {
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
- if (uw_get_app(ctx)->db_begin(ctx))
- uw_error(ctx, FATAL, "Error running SQL BEGIN");
+ uw_ensure_transaction(ctx);
uw_get_app(ctx)->expunger(ctx, cli);
uw_commit(ctx);
}
diff --git a/src/c/http.c b/src/c/http.c
index ebe50bea..230d07f0 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -438,8 +438,7 @@ void uw_copy_client_data(void *dst, void *src) {
}
void uw_do_expunge(uw_context ctx, uw_Basis_client cli, void *data) {
- if (uw_get_app(ctx)->db_begin(ctx))
- uw_error(ctx, FATAL, "Error running SQL BEGIN");
+ uw_ensure_transaction(ctx);
uw_get_app(ctx)->expunger(ctx, cli);
uw_commit(ctx);
}
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 9641333c..3082f110 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -441,7 +441,7 @@ struct uw_context {
const char *script_header;
- int needs_push, needs_sig;
+ int needs_push, needs_sig, could_write_db;
size_t n_deltas, used_deltas;
delta *deltas;
@@ -517,6 +517,7 @@ uw_context uw_init(int id, void *logger_data, uw_logger log_debug) {
ctx->script_header = "";
ctx->needs_push = 0;
ctx->needs_sig = 0;
+ ctx->could_write_db = 1;
ctx->source_count = 0;
@@ -777,7 +778,7 @@ failure_kind uw_begin(uw_context ctx, char *path) {
void uw_ensure_transaction(uw_context ctx) {
if (!ctx->transaction_started) {
- if (ctx->app->db_begin(ctx))
+ if (ctx->app->db_begin(ctx, ctx->could_write_db))
uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
ctx->transaction_started = 1;
}
@@ -1191,6 +1192,10 @@ void uw_set_needs_sig(uw_context ctx, int n) {
ctx->needs_sig = n;
}
+void uw_set_could_write_db(uw_context ctx, int n) {
+ ctx->could_write_db = n;
+}
+
static void uw_buffer_check_ctx(uw_context ctx, const char *kind, uw_buffer *b, size_t extra, const char *desc) {
if (b->back - b->front < extra) {
@@ -3466,9 +3471,7 @@ failure_kind uw_initialize(uw_context ctx) {
int r = setjmp(ctx->jmp_buf);
if (r == 0) {
- if (ctx->app->db_begin(ctx))
- uw_error(ctx, FATAL, "Error running SQL BEGIN");
- ctx->transaction_started = 1;
+ uw_ensure_transaction(ctx);
ctx->app->initializer(ctx);
if (ctx->app->db_commit(ctx))
uw_error(ctx, FATAL, "Error running SQL COMMIT");
@@ -4085,9 +4088,7 @@ failure_kind uw_runCallback(uw_context ctx, void (*callback)(uw_context)) {
int r = setjmp(ctx->jmp_buf);
if (r == 0) {
- if (ctx->app->db_begin(ctx))
- uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
- ctx->transaction_started = 1;
+ uw_ensure_transaction(ctx);
callback(ctx);
}
@@ -4134,9 +4135,7 @@ failure_kind uw_begin_onError(uw_context ctx, char *msg) {
if (ctx->app->on_error) {
if (r == 0) {
- if (ctx->app->db_begin(ctx))
- uw_error(ctx, BOUNDED_RETRY, "Error running SQL BEGIN");
- ctx->transaction_started = 1;
+ uw_ensure_transaction(ctx);
uw_buffer_reset(&ctx->outHeaders);
if (on_success[0])
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 798492d6..5d697eac 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -3001,11 +3001,18 @@ fun p_file env (ds, ps) =
fun couldWrite ek =
case ek of
- Link => false
+ Link _ => false
| Action ef => ef = ReadCookieWrite
| Rpc ef => ef = ReadCookieWrite
| Extern _ => false
+ fun couldWriteDb ek =
+ case ek of
+ Link ef => ef <> ReadOnly
+ | Action ef => ef <> ReadOnly
+ | Rpc ef => ef <> ReadOnly
+ | Extern ef => ef <> ReadOnly
+
val s =
case Settings.getUrlPrefix () of
"" => s
@@ -3091,6 +3098,10 @@ fun p_file env (ds, ps) =
end,
string "\");",
newline]),
+ string "uw_set_could_write_db(ctx, ",
+ string (if couldWriteDb ek then "1" else "0"),
+ string ");",
+ newline,
string "uw_set_needs_push(ctx, ",
string (case side of
ServerAndPullAndPush => "1"
diff --git a/src/corify.sml b/src/corify.sml
index c06d62ca..c1c60045 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -1046,7 +1046,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) =
| _ => false) args then
L'.Extern L'.ReadCookieWrite
else
- L'.Link
+ L'.Link L'.ReadCookieWrite
in
((L.DVal ("wrap_" ^ s, 0, tf, e), loc) :: wds,
(fn st =>
diff --git a/src/effectize.sml b/src/effectize.sml
index 6ced952b..d711e620 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -153,7 +153,7 @@ fun effectize file =
in
(d, loop (writers, readers, pushers))
end
- | DExport (Link, n, t) =>
+ | DExport (Link _, n, t) =>
(case IM.find (writers, n) of
NONE => ()
| SOME (loc, s) =>
@@ -162,7 +162,13 @@ fun effectize file =
else
ErrorMsg.errorAt loc ("A handler (URI prefix \"" ^ s
^ "\") accessible via GET could cause side effects; try accessing it only via forms, removing it from the signature of the main program module, or whitelisting it with the 'safeGet' .urp directive");
- ((DExport (Link, n, IM.inDomain (pushers, n)), #2 d), evs))
+ ((DExport (Link (if IM.inDomain (writers, n) then
+ if IM.inDomain (readers, n) then
+ ReadCookieWrite
+ else
+ ReadWrite
+ else
+ ReadOnly), n, IM.inDomain (pushers, n)), #2 d), evs))
| DExport (Action _, n, _) =>
((DExport (Action (if IM.inDomain (writers, n) then
if IM.inDomain (readers, n) then
diff --git a/src/export.sig b/src/export.sig
index 9bcfa0d4..881459c5 100644
--- a/src/export.sig
+++ b/src/export.sig
@@ -33,7 +33,7 @@ datatype effect =
| ReadWrite
datatype export_kind =
- Link
+ Link of effect
| Action of effect
| Rpc of effect
| Extern of effect
diff --git a/src/export.sml b/src/export.sml
index 5d200894..a99d0b70 100644
--- a/src/export.sml
+++ b/src/export.sml
@@ -36,7 +36,7 @@ datatype effect =
| ReadWrite
datatype export_kind =
- Link
+ Link of effect
| Action of effect
| Rpc of effect
| Extern of effect
@@ -49,7 +49,7 @@ fun p_effect ef =
fun p_export_kind ck =
case ck of
- Link => string "link"
+ Link ef => box [string "link(", p_effect ef, string ")"]
| Action ef => box [string "action(", p_effect ef, string ")"]
| Rpc ef => box [string "rpc(", p_effect ef, string ")"]
| Extern ef => box [string "extern(", p_effect ef, string ")"]
diff --git a/src/mysql.sml b/src/mysql.sml
index c70a1cdd..884cde36 100644
--- a/src/mysql.sml
+++ b/src/mysql.sml
@@ -577,7 +577,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
- string "static int uw_db_begin(uw_context ctx) {",
+ string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
diff --git a/src/postgres.sml b/src/postgres.sml
index 41529173..272097e7 100644
--- a/src/postgres.sml
+++ b/src/postgres.sml
@@ -402,11 +402,11 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
- string "static int uw_db_begin(uw_context ctx) {",
+ string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "PGconn *conn = uw_get_db(ctx);",
newline,
- string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
+ string "PGresult *res = PQexec(conn, could_write ? \"BEGIN ISOLATION LEVEL SERIALIZABLE\" : \"BEGIN ISOLATION LEVEL SERIALIZABLE, READ ONLY\");",
newline,
newline,
string "if (res == NULL) return 1;",
diff --git a/src/sqlite.sml b/src/sqlite.sml
index 09c4c683..c138415b 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -344,7 +344,7 @@ fun init {dbstring, prepared = ss, tables, views, sequences} =
newline,
newline,
- string "static int uw_db_begin(uw_context ctx) {",
+ string "static int uw_db_begin(uw_context ctx, int could_write) {",
newline,
string "uw_conn *conn = uw_get_db(ctx);",
newline,
diff --git a/src/tag.sml b/src/tag.sml
index 9c4807c6..865e7f53 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -145,7 +145,7 @@ fun exp env (e, s) =
end
in
case x of
- (CName "Link", _) => tagIt' (Link, "Link")
+ (CName "Link", _) => tagIt' (Link ReadWrite, "Link")
| (CName "Action", _) => tagIt' (Action ReadWrite, "Action")
| _ => ((x, e, t), s)
end)
@@ -180,7 +180,7 @@ fun exp env (e, s) =
| EFfiApp ("Basis", "url", [(e, t)]) =>
let
- val (e, s) = tagIt (e, Link, "Url", s)
+ val (e, s) = tagIt (e, Link ReadWrite, "Url", s)
in
(EFfiApp ("Basis", "url", [(e, t)]), s)
end
@@ -201,7 +201,7 @@ fun exp env (e, s) =
case eo of
SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
let
- val (e, s) = tagIt (e', Link, "Url", s)
+ val (e, s) = tagIt (e', Link ReadWrite, "Url", s)
in
(EFfiApp ("Basis", "url", [(e, t)]), s)
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 05:46:26 +0000