summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/urweb.h3
-rw-r--r--src/c/driver.c19
-rw-r--r--src/c/urweb.c26
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml248
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml17
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/monoize.sml112
9 files changed, 267 insertions, 164 deletions
diff --git a/include/urweb.h b/include/urweb.h
index e3d3f71f..aa574ff3 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -10,8 +10,9 @@ void uw_global_init(void);
void uw_client_connect(unsigned id, int pass, int sock);
void uw_prune_clients(uw_context);
+failure_kind uw_initialize(uw_context);
-uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, size_t heap_len);
+uw_context uw_init(void);
void uw_set_db(uw_context, void*);
void *uw_get_db(uw_context);
void uw_free(uw_context);
diff --git a/src/c/driver.c b/src/c/driver.c
index 14d08b57..52999da3 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -69,7 +69,7 @@ static int try_rollback(uw_context ctx) {
static void *worker(void *data) {
int me = *(int *)data, retries_left = MAX_RETRIES;
- uw_context ctx = uw_init(0, 0, 1024, 0);
+ uw_context ctx = uw_init();
while (1) {
failure_kind fk = uw_begin_init(ctx);
@@ -278,7 +278,7 @@ static void *worker(void *data) {
}
static void *client_pruner(void *data) {
- uw_context ctx = uw_init(0, 0, 0, 0);
+ uw_context ctx = uw_init();
uw_db_init(ctx);
while (1) {
@@ -296,6 +296,19 @@ static void sigint(int signum) {
exit(0);
}
+static void initialize() {
+ uw_context ctx = uw_init();
+
+ uw_db_init(ctx);
+ if (uw_initialize(ctx) != SUCCESS) {
+ printf("Failed to initialize database!\n");
+ uw_db_rollback(ctx);
+ exit(1);
+ }
+
+ uw_free(ctx);
+}
+
int main(int argc, char *argv[]) {
// The skeleton for this function comes from Beej's sockets tutorial.
int sockfd; // listen on sock_fd
@@ -342,6 +355,8 @@ int main(int argc, char *argv[]) {
}
}
+ initialize();
+
names = calloc(nthreads, sizeof(int));
sockfd = socket(PF_INET, SOCK_STREAM, 0); // do some error checking!
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 62d5be1b..1165c5d1 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -308,15 +308,15 @@ struct uw_context {
extern int uw_inputs_len, uw_timeout;
-uw_context uw_init(size_t outHeaders_len, size_t script_len, size_t page_len, size_t heap_len) {
+uw_context uw_init() {
uw_context ctx = malloc(sizeof(struct uw_context));
ctx->headers = ctx->headers_end = NULL;
- buf_init(&ctx->outHeaders, outHeaders_len);
- buf_init(&ctx->page, page_len);
- buf_init(&ctx->heap, heap_len);
- buf_init(&ctx->script, script_len);
+ buf_init(&ctx->outHeaders, 0);
+ buf_init(&ctx->page, 0);
+ buf_init(&ctx->heap, 0);
+ buf_init(&ctx->script, 0);
ctx->script.start[0] = 0;
ctx->inputs = calloc(uw_inputs_len, sizeof(char *));
@@ -1931,3 +1931,19 @@ void uw_prune_clients(uw_context ctx) {
pthread_mutex_unlock(&clients_mutex);
}
+
+void uw_initializer(uw_context ctx);
+
+failure_kind uw_initialize(uw_context ctx) {
+ int r = setjmp(ctx->jmp_buf);
+
+ if (r == 0) {
+ if (uw_db_begin(ctx))
+ uw_error(ctx, FATAL, "Error running SQL BEGIN");
+ uw_initializer(ctx);
+ if (uw_db_commit(ctx))
+ uw_error(ctx, FATAL, "Error running SQL COMMIT");
+ }
+
+ return r;
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 948b345f..41bb6a4c 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -106,7 +106,7 @@ datatype decl' =
| DTable of string * (string * typ) list
| DSequence of string
- | DDatabase of string * int
+ | DDatabase of {name : string, expunge : int, initialize : int}
| DPreparedStatements of (string * int) list
| DJavaScript of string
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 3b1705af..96f60887 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1937,128 +1937,138 @@ fun p_decl env (dAll as (d, _) : decl) =
string x,
string " */",
newline]
- | DDatabase (s, n) => box [string "static void uw_db_validate(uw_context);",
- newline,
- string "static void uw_db_prepare(uw_context);",
- newline,
- newline,
- string "void uw_db_init(uw_context ctx) {",
- newline,
- string "PGconn *conn = PQconnectdb(\"",
- string (String.toString s),
- string "\");",
- newline,
- string "if (conn == NULL) uw_error(ctx, BOUNDED_RETRY, ",
- string "\"libpq can't allocate a connection.\");",
- newline,
- string "if (PQstatus(conn) != CONNECTION_OK) {",
- newline,
- box [string "char msg[1024];",
- newline,
- string "strncpy(msg, PQerrorMessage(conn), 1024);",
- newline,
- string "msg[1023] = 0;",
- newline,
- string "PQfinish(conn);",
- newline,
- string "uw_error(ctx, BOUNDED_RETRY, ",
- string "\"Connection to Postgres server failed: %s\", msg);"],
- newline,
- string "}",
- newline,
- string "uw_set_db(ctx, conn);",
- newline,
- string "uw_db_validate(ctx);",
- newline,
- string "uw_db_prepare(ctx);",
- newline,
- string "}",
- newline,
- newline,
- string "void uw_db_close(uw_context ctx) {",
- newline,
- string "PQfinish(uw_get_db(ctx));",
- newline,
- string "}",
- newline,
- newline,
+ | DDatabase {name, expunge, initialize} =>
+ box [string "static void uw_db_validate(uw_context);",
+ newline,
+ string "static void uw_db_prepare(uw_context);",
+ newline,
+ newline,
+ string "void uw_db_init(uw_context ctx) {",
+ newline,
+ string "PGconn *conn = PQconnectdb(\"",
+ string (String.toString name),
+ string "\");",
+ newline,
+ string "if (conn == NULL) uw_error(ctx, BOUNDED_RETRY, ",
+ string "\"libpq can't allocate a connection.\");",
+ newline,
+ string "if (PQstatus(conn) != CONNECTION_OK) {",
+ newline,
+ box [string "char msg[1024];",
+ newline,
+ string "strncpy(msg, PQerrorMessage(conn), 1024);",
+ newline,
+ string "msg[1023] = 0;",
+ newline,
+ string "PQfinish(conn);",
+ newline,
+ string "uw_error(ctx, BOUNDED_RETRY, ",
+ string "\"Connection to Postgres server failed: %s\", msg);"],
+ newline,
+ string "}",
+ newline,
+ string "uw_set_db(ctx, conn);",
+ newline,
+ string "uw_db_validate(ctx);",
+ newline,
+ string "uw_db_prepare(ctx);",
+ newline,
+ string "}",
+ newline,
+ newline,
+ string "void uw_db_close(uw_context ctx) {",
+ newline,
+ string "PQfinish(uw_get_db(ctx));",
+ newline,
+ string "}",
+ newline,
+ newline,
- string "int uw_db_begin(uw_context ctx) {",
- newline,
- string "PGconn *conn = uw_get_db(ctx);",
- newline,
- string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
- newline,
- newline,
- string "if (res == NULL) return 1;",
- newline,
- newline,
- string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
- box [string "PQclear(res);",
- newline,
- string "return 1;",
- newline],
- string "}",
- newline,
- string "return 0;",
- newline,
- string "}",
- newline,
- newline,
+ string "int uw_db_begin(uw_context ctx) {",
+ newline,
+ string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
+ newline,
+ newline,
+ string "if (res == NULL) return 1;",
+ newline,
+ newline,
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ box [string "PQclear(res);",
+ newline,
+ string "return 1;",
+ newline],
+ string "}",
+ newline,
+ string "return 0;",
+ newline,
+ string "}",
+ newline,
+ newline,
- string "int uw_db_commit(uw_context ctx) {",
- newline,
- string "PGconn *conn = uw_get_db(ctx);",
- newline,
- string "PGresult *res = PQexec(conn, \"COMMIT\");",
- newline,
- newline,
- string "if (res == NULL) return 1;",
- newline,
- newline,
- string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
- box [string "PQclear(res);",
- newline,
- string "return 1;",
- newline],
- string "}",
- newline,
- string "return 0;",
- newline,
- string "}",
- newline,
- newline,
+ string "int uw_db_commit(uw_context ctx) {",
+ newline,
+ string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res = PQexec(conn, \"COMMIT\");",
+ newline,
+ newline,
+ string "if (res == NULL) return 1;",
+ newline,
+ newline,
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ box [string "PQclear(res);",
+ newline,
+ string "return 1;",
+ newline],
+ string "}",
+ newline,
+ string "return 0;",
+ newline,
+ string "}",
+ newline,
+ newline,
- string "int uw_db_rollback(uw_context ctx) {",
- newline,
- string "PGconn *conn = uw_get_db(ctx);",
- newline,
- string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
- newline,
- newline,
- string "if (res == NULL) return 1;",
- newline,
- newline,
- string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
- box [string "PQclear(res);",
- newline,
- string "return 1;",
- newline],
- string "}",
- newline,
- string "return 0;",
- newline,
- string "}",
- newline,
- newline,
+ string "int uw_db_rollback(uw_context ctx) {",
+ newline,
+ string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
+ newline,
+ newline,
+ string "if (res == NULL) return 1;",
+ newline,
+ newline,
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ box [string "PQclear(res);",
+ newline,
+ string "return 1;",
+ newline],
+ string "}",
+ newline,
+ string "return 0;",
+ newline,
+ string "}",
+ newline,
+ newline,
- string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
- newline,
- box [p_enamed env n,
- string "(ctx, cli);",
- newline],
- string "}",
- newline]
+ string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
+ newline,
+ box [p_enamed env expunge,
+ string "(ctx, cli);",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "void uw_initializer(uw_context ctx) {",
+ newline,
+ box [p_enamed env initialize,
+ string "(ctx, uw_unit_v);",
+ newline],
+ string "}",
+ newline]
| DPreparedStatements [] =>
box [string "static void uw_db_prepare(uw_context ctx) {",
@@ -2762,6 +2772,8 @@ fun p_file env (ds, ps) =
string "int uw_db_rollback(uw_context ctx) { return 0; };",
newline,
string "void uw_expunger(uw_context ctx, uw_Basis_client cli) { };",
+ newline,
+ string "void uw_initializer(uw_context ctx) { };",
newline]]
end
diff --git a/src/mono.sml b/src/mono.sml
index 95c65fc9..f4bbc868 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -122,7 +122,7 @@ datatype decl' =
| DTable of string * (string * typ) list
| DSequence of string
- | DDatabase of string * int
+ | DDatabase of {name : string, expunge : int, initialize : int}
| DJavaScript of string
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 23b32a72..b30fa4e8 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -413,13 +413,16 @@ fun p_decl env (dAll as (d, _) : decl) =
| DSequence s => box [string "(* SQL sequence ",
string s,
string "*)"]
- | DDatabase (s, n) => box [string "database",
- space,
- string s,
- space,
- string "(",
- p_enamed env n,
- string ")"]
+ | DDatabase {name, expunge, initialize} => box [string "database",
+ space,
+ string name,
+ space,
+ string "(",
+ p_enamed env expunge,
+ string ",",
+ space,
+ p_enamed env initialize,
+ string ")"]
| DJavaScript s => box [string "JavaScript(",
string s,
string ")"]
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 475c4895..343ec728 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -45,7 +45,7 @@ fun shake file =
let
val page_es = List.foldl
(fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es
- | ((DDatabase (_, n), _), page_es) => n :: page_es
+ | ((DDatabase {expunge = n1, initialize = n2, ...}, _), page_es) => n1 :: n2 :: page_es
| (_, page_es) => page_es) [] file
val (cdef, edef) = foldl (fn ((DDatatype (_, n, xncs), _), (cdef, edef)) =>
diff --git a/src/monoize.sml b/src/monoize.sml
index 361986d2..71672785 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2474,6 +2474,25 @@ fun monoize env file =
val loc = E.dummySpan
val client = (L'.TFfi ("Basis", "client"), loc)
val unit = (L'.TRecord [], loc)
+
+ fun calcClientish xts =
+ foldl (fn ((x : L.con, t : L.con), st as (nullable, notNullable)) =>
+ case #1 x of
+ L.CName x =>
+ (case #1 t of
+ L.CFfi ("Basis", "client") =>
+ (nullable, (x, Client) :: notNullable)
+ | L.CApp ((L.CFfi ("Basis", "option"), _),
+ (L.CFfi ("Basis", "client"), _)) =>
+ ((x, Client) :: nullable, notNullable)
+ | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
+ (nullable, (x, Channel) :: notNullable)
+ | L.CApp ((L.CFfi ("Basis", "option"), _),
+ (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
+ ((x, Channel) :: nullable, notNullable)
+ | _ => st)
+ | _ => st) ([], []) xts
+
fun expunger () =
let
val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
@@ -2482,23 +2501,7 @@ fun monoize env file =
case xts of
L.CRecord (_, xts) =>
let
- val (nullable, notNullable) =
- foldl (fn ((x, t), st as (nullable, notNullable)) =>
- case #1 x of
- L.CName x =>
- (case #1 t of
- L.CFfi ("Basis", "client") =>
- (nullable, (x, Client) :: notNullable)
- | L.CApp ((L.CFfi ("Basis", "option"), _),
- (L.CFfi ("Basis", "client"), _)) =>
- ((x, Client) :: nullable, notNullable)
- | L.CApp ((L.CFfi ("Basis", "channel"), _), _) =>
- (nullable, (x, Channel) :: notNullable)
- | L.CApp ((L.CFfi ("Basis", "option"), _),
- (L.CApp ((L.CFfi ("Basis", "channel"), _), _), _)) =>
- ((x, Channel) :: nullable, notNullable)
- | _ => st)
- | _ => st) ([], []) xts
+ val (nullable, notNullable) = calcClientish xts
fun cond (x, v) =
(L'.EStrcat ((L'.EPrim (Prim.String ("uw_" ^ x
@@ -2529,7 +2532,7 @@ fun monoize env file =
(L'.EDml (foldl
(fn (eb, s) =>
(L'.EStrcat (s,
- (L'.EStrcat ((L'.EPrim (Prim.String " AND "),
+ (L'.EStrcat ((L'.EPrim (Prim.String " OR "),
loc),
cond eb), loc)), loc))
(L'.EStrcat ((L'.EPrim (Prim.String ("DELETE FROM uw_"
@@ -2551,21 +2554,74 @@ fun monoize env file =
| _ => e) e file
end
+ fun initializer () =
+ let
+ fun doTable (tab, xts, e) =
+ case xts of
+ L.CRecord (_, xts) =>
+ let
+ val (nullable, notNullable) = calcClientish xts
+
+ val e =
+ case nullable of
+ [] => 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),
+ e), loc)
+
+ val e =
+ case notNullable of
+ [] => e
+ | eb :: ebs =>
+ (L'.ESeq (
+ (L'.EDml (L'.EPrim (Prim.String ("DELETE FROM uw_"
+ ^ tab)), loc), loc),
+ e), loc)
+ in
+ e
+ end
+ | _ => e
+
+ val e = (L'.ERecord [], loc)
+ in
+ foldl (fn ((d, _), e) =>
+ case d of
+ L.DTable (_, _, xts, tab) => doTable (tab, #1 xts, e)
+ | _ => e) e file
+ end
+
val (_, _, ds) = List.foldl (fn (d, (env, fm, ds)) =>
case #1 d of
L.DDatabase s =>
let
- val (n, fm) = Fm.freshName fm
-
-
- val d = L'.DVal ("expunger",
- n,
- (L'.TFun (client, unit), loc),
- (L'.EAbs ("cli", client, unit, expunger ()), loc),
- "expunger")
+ val (nExp, fm) = Fm.freshName fm
+ val (nIni, fm) = Fm.freshName fm
+
+ val dExp = L'.DVal ("expunger",
+ nExp,
+ (L'.TFun (client, unit), loc),
+ (L'.EAbs ("cli", client, unit, expunger ()), loc),
+ "expunger")
+ val dIni = L'.DVal ("initializer",
+ nIni,
+ (L'.TFun (unit, unit), loc),
+ (L'.EAbs ("_", unit, unit, initializer ()), loc),
+ "initializer")
in
- (env, Fm.enter fm, (L'.DDatabase (s, n), loc)
- :: (d, loc)
+ (env, Fm.enter fm, (L'.DDatabase {name = s,
+ expunge = nExp,
+ initialize = nIni}, loc)
+ :: (dExp, loc)
+ :: (dIni, loc)
:: ds)
end
| _ =>
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-02 01:42:37 +0000