Mercurial > urweb
changeset 866:03e7f111fe99
Start of multi-DBMS support
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 28 Jun 2009 13:49:32 -0400 |
| parents | ebefb0609ac3 |
| children | e7f80d78075b |
| files | src/c/urweb.c src/cjr_print.sml src/compiler.sig src/compiler.sml src/demo.sml src/main.mlton.sml src/mysql.sig src/mysql.sml src/postgres.sig src/postgres.sml src/settings.sig src/settings.sml src/sources |
| diffstat | 13 files changed, 615 insertions(+), 166 deletions(-) [+] |
line wrap: on
line diff
--- a/src/c/urweb.c Sun Jun 28 11:49:04 2009 -0400 +++ b/src/c/urweb.c Sun Jun 28 13:49:32 2009 -0400 @@ -286,10 +286,14 @@ // Global entry points +extern void uw_client_init(); + void uw_global_init() { srand(time(NULL) ^ getpid()); clients = malloc(0); + + uw_client_init(); }
--- a/src/cjr_print.sml Sun Jun 28 11:49:04 2009 -0400 +++ b/src/cjr_print.sml Sun Jun 28 13:49:32 2009 -0400 @@ -2039,6 +2039,8 @@ 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 @@ 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 @@ 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 @@ string "#include <math.h>", newline, if hasDb then - box [string "#include <postgresql/libpq-fe.h>", + box [string ("#include <" ^ #header (Settings.currentDbms ()) ^ ">"), newline] else box [],
--- a/src/compiler.sig Sun Jun 28 11:49:04 2009 -0400 +++ b/src/compiler.sig Sun Jun 28 13:49:32 2009 -0400 @@ -49,7 +49,9 @@ 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,
--- a/src/compiler.sml Sun Jun 28 11:49:04 2009 -0400 +++ b/src/compiler.sml Sun Jun 28 13:49:32 2009 -0400 @@ -53,7 +53,9 @@ 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 @@ 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 @@ 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 @@ 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 @@ 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 @@ val hasDb = List.exists (fn (Cjr.DDatabase _, _) => true | _ => false) (#1 file) val libs = if hasDb then - "-lpq" + #link (Settings.currentDbms ()) else "" in
--- a/src/demo.sml Sun Jun 28 11:49:04 2009 -0400 +++ b/src/demo.sml Sun Jun 28 13:49:32 2009 -0400 @@ -106,7 +106,9 @@ 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")
--- a/src/main.mlton.sml Sun Jun 28 11:49:04 2009 -0400 +++ b/src/main.mlton.sml Sun Jun 28 13:49:32 2009 -0400 @@ -41,6 +41,9 @@ | "-protocol" :: name :: rest => (Settings.setProtocol name; doArgs rest) + | "-dbms" :: name :: rest => + (Settings.setDbms name; + doArgs rest) | "-debug" :: rest => (Settings.setDebug true; doArgs rest)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mysql.sig Sun Jun 28 13:49:32 2009 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/mysql.sml Sun Jun 28 13:49:32 2009 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/postgres.sig Sun Jun 28 13:49:32 2009 -0400 @@ -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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/postgres.sml Sun Jun 28 13:49:32 2009 -0400 @@ -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
--- a/src/settings.sig Sun Jun 28 11:49:04 2009 -0400 +++ b/src/settings.sig Sun Jun 28 13:49:32 2009 -0400 @@ -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 @@ 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
--- a/src/settings.sml Sun Jun 28 11:49:04 2009 -0400 +++ b/src/settings.sml Sun Jun 28 13:49:32 2009 -0400 @@ -274,4 +274,26 @@ 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