summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/c/urweb.c4
-rw-r--r--src/cjr_print.sml162
-rw-r--r--src/compiler.sig4
-rw-r--r--src/compiler.sml18
-rw-r--r--src/demo.sml4
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/mysql.sig30
-rw-r--r--src/mysql.sml273
-rw-r--r--src/postgres.sig30
-rw-r--r--src/postgres.sml200
-rw-r--r--src/settings.sig25
-rw-r--r--src/settings.sml22
-rw-r--r--src/sources6
13 files changed, 615 insertions, 166 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 221ac039..f088e74d 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -286,10 +286,14 @@ static void client_send(client *c, buf *msg) {
// Global entry points
+extern void uw_client_init();
+
void uw_global_init() {
srand(time(NULL) ^ getpid());
clients = malloc(0);
+
+ uw_client_init();
}
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 14721edd..d3f1b469 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2039,6 +2039,8 @@ fun p_fun env (fx, n, args, ran, e) =
string "}"]
end
+val prepped = ref ([] : (string * int) list)
+
fun p_decl env (dAll as (d, _) : decl) =
case d of
DStruct (n, xts) =>
@@ -2196,115 +2198,8 @@ fun p_decl env (dAll as (d, _) : decl) =
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_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,
+ #init (Settings.currentDbms ()) (name, !prepped),
string "void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
newline,
@@ -2323,54 +2218,9 @@ fun p_decl env (dAll as (d, _) : decl) =
string "}",
newline]
- | DPreparedStatements [] =>
- box [string "static void uw_db_prepare(uw_context ctx) {",
- newline,
- string "}"]
| DPreparedStatements ss =>
- if #persistent (Settings.currentProtocol ()) then
- box [string "static void uw_db_prepare(uw_context ctx) {",
- newline,
- string "PGconn *conn = uw_get_db(ctx);",
- newline,
- string "PGresult *res;",
- newline,
- newline,
-
- p_list_sepi newline (fn i => fn (s, n) =>
- box [string "res = PQprepare(conn, \"uw",
- string (Int.toString i),
- string "\", \"",
- string (String.toString s),
- string "\", ",
- string (Int.toString n),
- string ", NULL);",
- newline,
- string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
- newline,
- box [string "char msg[1024];",
- newline,
- string "strncpy(msg, PQerrorMessage(conn), 1024);",
- newline,
- string "msg[1023] = 0;",
- newline,
- string "PQclear(res);",
- newline,
- string "PQfinish(conn);",
- newline,
- string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
- string (String.toString s),
- string "\\n%s\", msg);",
- newline],
- string "}",
- newline,
- string "PQclear(res);",
- newline])
- ss,
-
- string "}"]
- else
- string "static void uw_db_prepare(uw_context ctx) { }"
+ (prepped := ss;
+ box [])
| DJavaScript s => box [string "static char jslib[] = \"",
string (String.toString s),
@@ -3268,7 +3118,7 @@ fun p_file env (ds, ps) =
string "#include <math.h>",
newline,
if hasDb then
- box [string "#include <postgresql/libpq-fe.h>",
+ box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"),
newline]
else
box [],
diff --git a/src/compiler.sig b/src/compiler.sig
index 2f062622..f7727771 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -49,7 +49,9 @@ signature COMPILER = sig
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
- filterMime : Settings.rule list
+ filterMime : Settings.rule list,
+ protocol : string option,
+ dbms : string option
}
val compile : string -> unit
val compileC : {cname : string, oname : string, ename : string, libs : string,
diff --git a/src/compiler.sml b/src/compiler.sml
index 2a53bf08..9cf874c7 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -53,7 +53,9 @@ type job = {
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
- filterMime : Settings.rule list
+ filterMime : Settings.rule list,
+ protocol : string option,
+ dbms : string option
}
type ('src, 'dst) phase = {
@@ -349,6 +351,8 @@ fun parseUrp' fname =
val url = ref []
val mime = ref []
val libs = ref []
+ val protocol = ref NONE
+ val dbms = ref NONE
fun finish sources =
let
@@ -373,7 +377,9 @@ fun parseUrp' fname =
rewrites = rev (!rewrites),
filterUrl = rev (!url),
filterMime = rev (!mime),
- sources = sources
+ sources = sources,
+ protocol = !protocol,
+ dbms = !dbms
}
fun mergeO f (old, new) =
@@ -410,7 +416,9 @@ fun parseUrp' fname =
rewrites = #rewrites old @ #rewrites new,
filterUrl = #filterUrl old @ #filterUrl new,
filterMime = #filterMime old @ #filterMime new,
- sources = #sources new @ #sources old
+ sources = #sources new @ #sources old,
+ protocol = mergeO #2 (#protocol old, #protocol new),
+ dbms = mergeO #2 (#dbms old, #dbms new)
}
in
foldr (fn (fname, job) => merge (job, pu fname)) job (!libs)
@@ -570,6 +578,8 @@ fun parseUrp' fname =
Settings.setRewriteRules (#rewrites job);
Settings.setUrlRules (#filterUrl job);
Settings.setMimeRules (#filterMime job);
+ Option.app Settings.setProtocol (#protocol job);
+ Option.app Settings.setDbms (#dbms job);
job
end
in
@@ -949,7 +959,7 @@ fun compile job =
val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file)
val libs =
if hasDb then
- "-lpq"
+ #link (Settings.currentDbms ())
else
""
in
diff --git a/src/demo.sml b/src/demo.sml
index 21242d73..b8323993 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -106,7 +106,9 @@ fun make {prefix, dirname, guided} =
jsFuncs = [],
rewrites = #rewrites combined @ #rewrites urp,
filterUrl = #filterUrl combined @ #filterUrl urp,
- filterMime = #filterMime combined @ #filterMime urp
+ filterMime = #filterMime combined @ #filterMime urp,
+ protocol = mergeWith #2 (#protocol combined, #protocol urp),
+ dbms = mergeWith #2 (#dbms combined, #dbms urp)
}
val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index 62fb6509..7498bb5e 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -41,6 +41,9 @@ fun doArgs args =
| "-protocol" :: name :: rest =>
(Settings.setProtocol name;
doArgs rest)
+ | "-dbms" :: name :: rest =>
+ (Settings.setDbms name;
+ doArgs rest)
| "-debug" :: rest =>
(Settings.setDebug true;
doArgs rest)
diff --git a/src/mysql.sig b/src/mysql.sig
new file mode 100644
index 00000000..fa254ae3
--- /dev/null
+++ b/src/mysql.sig
@@ -0,0 +1,30 @@
+(* Copyright (c) 2008-2009, 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.
+ *)
+
+signature MYSQL = sig
+
+end
diff --git a/src/mysql.sml b/src/mysql.sml
new file mode 100644
index 00000000..b791a93c
--- /dev/null
+++ b/src/mysql.sml
@@ -0,0 +1,273 @@
+(* Copyright (c) 2008-2009, 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 MySQL :> MYSQL = struct
+
+open Settings
+open Print.PD
+open Print
+
+fun init (dbstring, ss) =
+ let
+ val host = ref NONE
+ val user = ref NONE
+ val passwd = ref NONE
+ val db = ref NONE
+ val port = ref NONE
+ val unix_socket = ref NONE
+
+ fun stringOf r = case !r of
+ NONE => string "NULL"
+ | SOME s => box [string "\"",
+ string (String.toString s),
+ string "\""]
+ in
+ app (fn s =>
+ case String.fields (fn ch => ch = #"=") s of
+ [name, value] =>
+ (case name of
+ "host" =>
+ if size value > 0 andalso String.sub (value, 0) = #"/" then
+ unix_socket := SOME value
+ else
+ host := SOME value
+ | "hostaddr" => host := SOME value
+ | "port" => port := Int.fromString value
+ | "dbname" => db := SOME value
+ | "user" => user := SOME value
+ | "password" => passwd := SOME value
+ | _ => ())
+ | _ => ()) (String.tokens Char.isSpace dbstring);
+
+ box [string "typedef struct {",
+ newline,
+ box [string "MYSQL *conn;",
+ newline,
+ p_list_sepi (box [])
+ (fn i => fn _ =>
+ box [string "MYSQL_STMT *p",
+ string (Int.toString i),
+ string ";",
+ newline])
+ ss],
+ string "} uw_conn;",
+ newline,
+ newline,
+
+ if #persistent (currentProtocol ()) then
+ box [string "static void uw_db_prepare(uw_context ctx) {",
+ newline,
+ string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ string "MYSQL_STMT *stmt;",
+ newline,
+ newline,
+
+ p_list_sepi newline (fn i => fn (s, n) =>
+ let
+ fun uhoh this s args =
+ box [p_list_sepi (box [])
+ (fn j => fn () =>
+ box [string
+ "mysql_stmt_close(conn->p",
+ string (Int.toString j),
+ string ");",
+ newline])
+ (List.tabulate (i, fn _ => ())),
+ box (if this then
+ [string
+ "mysql_stmt_close(conn->p",
+ string (Int.toString i),
+ string ");",
+ newline]
+ else
+ []),
+ string "mysql_close(conn->conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"",
+ string s,
+ string "\"",
+ p_list_sep (box []) (fn s => box [string ", ",
+ string s]) args,
+ string ");",
+ newline]
+ in
+ box [string "stmt = mysql_stmt_init(conn->conn);",
+ newline,
+ string "if (stmt == NULL) {",
+ newline,
+ uhoh false "Out of memory allocating prepared statement" [],
+ string "}",
+ newline,
+
+ string "if (mysql_stmt_prepare(stmt, \"",
+ string (String.toString s),
+ string "\", ",
+ string (Int.toString (size s)),
+ string ")) {",
+ newline,
+ box [string "char msg[1024];",
+ newline,
+ string "strncpy(msg, mysql_stmt_error(stmt), 1024);",
+ newline,
+ string "msg[1023] = 0;",
+ newline,
+ uhoh true "Error preparing statement: %s" ["msg"]],
+ string "}",
+ newline]
+ end)
+ ss,
+
+ string "}"]
+ else
+ string "static void uw_db_prepare(uw_context ctx) { }",
+ newline,
+ newline,
+
+ string "void uw_db_init(uw_context ctx) {",
+ newline,
+ string "MYSQL *mysql = mysql_init(NULL);",
+ newline,
+ string "uw_conn *conn;",
+ newline,
+ string "if (mysql == NULL) uw_error(ctx, FATAL, ",
+ string "\"libmysqlclient can't allocate a connection.\");",
+ newline,
+ string "if (mysql_real_connect(mysql, ",
+ stringOf host,
+ string ", ",
+ stringOf user,
+ string ", ",
+ stringOf passwd,
+ string ", ",
+ stringOf db,
+ string ", ",
+ case !port of
+ NONE => string "0"
+ | SOME n => string (Int.toString n),
+ string ", ",
+ stringOf unix_socket,
+ string ", 0)) {",
+ newline,
+ box [string "char msg[1024];",
+ newline,
+ string "strncpy(msg, mysql_error(mysql), 1024);",
+ newline,
+ string "msg[1023] = 0;",
+ newline,
+ string "mysql_close(mysql);",
+ newline,
+ string "uw_error(ctx, BOUNDED_RETRY, ",
+ string "\"Connection to MySQL server failed: %s\", msg);"],
+ newline,
+ string "}",
+ newline,
+ string "conn = malloc(sizeof(conn));",
+ newline,
+ string "conn->conn = mysql;",
+ 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 "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ p_list_sepi (box [])
+ (fn i => fn _ =>
+ box [string "if (conn->p",
+ string (Int.toString i),
+ string ") mysql_stmt_close(conn->p",
+ string (Int.toString i),
+ string ");",
+ newline])
+ ss,
+ string "mysql_close(conn->conn);",
+ newline,
+ string "}",
+ newline,
+ newline,
+
+ string "int uw_db_begin(uw_context ctx) {",
+ newline,
+ string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ newline,
+ string "return mysql_query(conn->conn, \"SET TRANSACTION ISOLATION LEVEL SERIALIZABLE\")",
+ newline,
+ string " || mysql_query(conn->conn, \"BEGIN\");",
+ newline,
+ string "}",
+ newline,
+ newline,
+
+ string "int uw_db_commit(uw_context ctx) {",
+ newline,
+ string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ string "return mysql_commit(conn->conn);",
+ newline,
+ string "}",
+ newline,
+ newline,
+
+ string "int uw_db_rollback(uw_context ctx) {",
+ newline,
+ string "uw_conn *conn = uw_get_db(ctx);",
+ newline,
+ string "return mysql_rollback(conn->conn);",
+ newline,
+ string "}",
+ newline,
+ newline]
+ end
+
+val () = addDbms {name = "mysql",
+ header = "mysql/mysql.h",
+ link = "-lmysqlclient",
+ global_init = box [string "void uw_client_init() {",
+ newline,
+ box [string "if (mysql_library_init(0, NULL, NULL)) {",
+ newline,
+ box [string "fprintf(stderr, \"Could not initialize MySQL library\\n\");",
+ newline,
+ string "exit(1);",
+ newline],
+ string "}",
+ newline],
+ string "}",
+ newline],
+ init = init}
+
+end
diff --git a/src/postgres.sig b/src/postgres.sig
new file mode 100644
index 00000000..54117f07
--- /dev/null
+++ b/src/postgres.sig
@@ -0,0 +1,30 @@
+(* Copyright (c) 2008-2009, 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.
+ *)
+
+signature POSTGRES = sig
+
+end
diff --git a/src/postgres.sml b/src/postgres.sml
new file mode 100644
index 00000000..43db90e7
--- /dev/null
+++ b/src/postgres.sml
@@ -0,0 +1,200 @@
+(* Copyright (c) 2008-2009, 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 Postgres :> POSTGRES = struct
+
+open Settings
+open Print.PD
+open Print
+
+fun init (dbstring, ss) =
+ box [if #persistent (currentProtocol ()) then
+ box [string "static void uw_db_prepare(uw_context ctx) {",
+ newline,
+ string "PGconn *conn = uw_get_db(ctx);",
+ newline,
+ string "PGresult *res;",
+ newline,
+ newline,
+
+ p_list_sepi newline (fn i => fn (s, n) =>
+ box [string "res = PQprepare(conn, \"uw",
+ string (Int.toString i),
+ string "\", \"",
+ string (String.toString s),
+ string "\", ",
+ string (Int.toString n),
+ string ", NULL);",
+ newline,
+ string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
+ newline,
+ box [string "char msg[1024];",
+ newline,
+ string "strncpy(msg, PQerrorMessage(conn), 1024);",
+ newline,
+ string "msg[1023] = 0;",
+ newline,
+ string "PQclear(res);",
+ newline,
+ string "PQfinish(conn);",
+ newline,
+ string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
+ string (String.toString s),
+ string "\\n%s\", msg);",
+ newline],
+ string "}",
+ newline,
+ string "PQclear(res);",
+ newline])
+ ss,
+
+ 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_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]
+ else
+ string "static void uw_db_prepare(uw_context ctx) { }",
+ newline,
+ newline,
+
+ string "void uw_db_init(uw_context ctx) {",
+ newline,
+ string "PGconn *conn = PQconnectdb(\"",
+ string (String.toString dbstring),
+ string "\");",
+ newline,
+ string "if (conn == NULL) uw_error(ctx, FATAL, ",
+ 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 "}"]
+
+val () = addDbms {name = "postgres",
+ header = "postgresql/libpq-fe.h",
+ link = "-lpq",
+ global_init = box [string "void uw_client_init() { }",
+ newline],
+ init = init}
+val () = setDbms "postgres"
+
+end
diff --git a/src/settings.sig b/src/settings.sig
index 8259e519..215839a1 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -27,6 +27,11 @@
signature SETTINGS = sig
+ val setDebug : bool -> unit
+ val getDebug : unit -> bool
+
+ val clibFile : string -> string
+
(* How do all application URLs begin? *)
val setUrlPrefix : string -> unit
val getUrlPrefix : unit -> string
@@ -92,13 +97,25 @@ signature SETTINGS = sig
persistent : bool (* Multiple requests per process? *)
}
val addProtocol : protocol -> unit
- val getProtocol : string -> protocol option
val setProtocol : string -> unit
val currentProtocol : unit -> protocol
- val setDebug : bool -> unit
- val getDebug : unit -> bool
+ (* Different DBMSes *)
+ type dbms = {
+ name : string,
+ (* Call it this on the command line *)
+ header : string,
+ (* Include this C header file *)
+ link : string,
+ (* Pass these linker arguments *)
+ global_init : Print.PD.pp_desc,
+ (* Define uw_client_init() *)
+ init : string * (string * int) list -> Print.PD.pp_desc
+ (* Define uw_db_init() from dbstring and prepared statements *)
+ }
- val clibFile : string -> string
+ val addDbms : dbms -> unit
+ val setDbms : string -> unit
+ val currentDbms : unit -> dbms
end
diff --git a/src/settings.sml b/src/settings.sml
index 845683a7..ed3d1f14 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -274,4 +274,26 @@ val debug = ref false
fun setDebug b = debug := b
fun getDebug () = !debug
+type dbms = {
+ name : string,
+ header : string,
+ link : string,
+ global_init : Print.PD.pp_desc,
+ init : string * (string * int) list -> Print.PD.pp_desc
+}
+
+val dbmses = ref ([] : dbms list)
+val curDb = ref ({name = "",
+ header = "",
+ link = "",
+ global_init = Print.box [],
+ init = fn _ => Print.box []} : dbms)
+
+fun addDbms v = dbmses := v :: !dbmses
+fun setDbms s =
+ case List.find (fn db => #name db = s) (!dbmses) of
+ NONE => raise Fail ("Unknown DBMS " ^ s)
+ | SOME db => curDb := db
+fun currentDbms () = !curDb
+
end
diff --git a/src/sources b/src/sources
index 0ed28654..7ba0b999 100644
--- a/src/sources
+++ b/src/sources
@@ -25,6 +25,12 @@ cgi.sml
fastcgi.sig
fastcgi.sml
+postgres.sig
+postgres.sml
+
+mysql.sig
+mysql.sml
+
print.sig
print.sml
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-13 08:13:56 +0000