adam@1295: (* Copyright (c) 2008-2010, Adam Chlipala adamc@866: * All rights reserved. adamc@866: * adamc@866: * Redistribution and use in source and binary forms, with or without adamc@866: * modification, are permitted provided that the following conditions are met: adamc@866: * adamc@866: * - Redistributions of source code must retain the above copyright notice, adamc@866: * this list of conditions and the following disclaimer. adamc@866: * - Redistributions in binary form must reproduce the above copyright notice, adamc@866: * this list of conditions and the following disclaimer in the documentation adamc@866: * and/or other materials provided with the distribution. adamc@866: * - The names of contributors may not be used to endorse or promote products adamc@866: * derived from this software without specific prior written permission. adamc@866: * adamc@866: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@866: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@866: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@866: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@866: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@866: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@866: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@866: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@866: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@866: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@866: * POSSIBILITY OF SUCH DAMAGE. adamc@866: *) adamc@866: adamc@866: structure Postgres :> POSTGRES = struct adamc@866: adamc@866: open Settings adamc@866: open Print.PD adamc@866: open Print adamc@866: adamc@870: val ident = String.translate (fn #"'" => "PRIME" adamc@870: | ch => str ch) adamc@870: adamc@873: fun p_sql_type t = adamc@873: case t of adamc@873: Int => "int8" adamc@873: | Float => "float8" adamc@873: | String => "text" adamc@1011: | Char => "char" adamc@873: | Bool => "bool" adamc@873: | Time => "timestamp" adamc@873: | Blob => "bytea" adamc@873: | Channel => "int8" adamc@873: | Client => "int4" adamc@873: | Nullable t => p_sql_type t adamc@873: adamc@870: fun p_sql_type_base t = adamc@870: case t of adamc@871: Int => "bigint" adamc@871: | Float => "double precision" adamc@870: | String => "text" adamc@1011: | Char => "character" adamc@871: | Bool => "boolean" adamc@871: | Time => "timestamp without time zone" adamc@870: | Blob => "bytea" adamc@871: | Channel => "bigint" adamc@871: | Client => "integer" adamc@870: | Nullable t => p_sql_type_base t adamc@870: adamc@872: fun checkRel (table, checkNullable) (s, xts) = adamc@871: let adamc@871: val sl = CharVector.map Char.toLower s adamc@871: adamc@872: val q = "SELECT COUNT(*) FROM information_schema." ^ table ^ " WHERE table_name = '" adamc@871: ^ sl ^ "'" adamc@871: adamc@871: val q' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '", adamc@871: sl, adamc@871: "' AND (", adamc@871: String.concatWith " OR " adamc@871: (map (fn (x, t) => adamc@871: String.concat ["(column_name = 'uw_", adamc@871: CharVector.map adamc@871: Char.toLower (ident x), adam@1428: (case p_sql_type_base t of adam@1428: "bigint" => adam@1428: "' AND data_type IN ('bigint', 'numeric')" adam@1428: | t => adam@1428: String.concat ["' AND data_type = '", adam@1428: t, adam@1428: "'"]), adamc@872: if checkNullable then adamc@872: (" AND is_nullable = '" adamc@872: ^ (if isNotNull t then adamc@872: "NO" adamc@872: else adamc@872: "YES") adamc@872: ^ "'") adamc@871: else adamc@872: "", adamc@872: ")"]) xts), adamc@871: ")"] adamc@871: adamc@871: val q'' = String.concat ["SELECT COUNT(*) FROM information_schema.columns WHERE table_name = '", adamc@871: sl, adamc@871: "' AND column_name LIKE 'uw_%'"] adamc@871: in adamc@871: box [string "res = PQexec(conn, \"", adamc@871: string q, adamc@871: string "\");", adamc@871: newline, adamc@871: newline, adamc@871: string "if (res == NULL) {", adamc@871: newline, adamc@871: box [string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@871: newline, adamc@871: box [string "char msg[1024];", adamc@871: newline, adamc@871: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@871: newline, adamc@871: string "msg[1023] = 0;", adamc@871: newline, adamc@871: string "PQclear(res);", adamc@871: newline, adamc@871: string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@871: string q, adamc@871: string "\\n%s\", msg);", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", adamc@871: newline, adamc@871: box [string "PQclear(res);", adamc@871: newline, adamc@871: string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Table '", adamc@871: string s, adamc@871: string "' does not exist.\");", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "PQclear(res);", adamc@871: newline, adamc@871: adamc@871: string "res = PQexec(conn, \"", adamc@871: string q', adamc@871: string "\");", adamc@871: newline, adamc@871: newline, adamc@871: string "if (res == NULL) {", adamc@871: newline, adamc@871: box [string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@871: newline, adamc@871: box [string "char msg[1024];", adamc@871: newline, adamc@871: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@871: newline, adamc@871: string "msg[1023] = 0;", adamc@871: newline, adamc@871: string "PQclear(res);", adamc@871: newline, adamc@871: string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@871: string q', adamc@871: string "\\n%s\", msg);", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "if (strcmp(PQgetvalue(res, 0, 0), \"", adamc@871: string (Int.toString (length xts)), adamc@871: string "\")) {", adamc@871: newline, adamc@871: box [string "PQclear(res);", adamc@871: newline, adamc@871: string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Table '", adamc@871: string s, adamc@871: string "' has the wrong column types.\");", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "PQclear(res);", adamc@871: newline, adamc@871: newline, adamc@871: adamc@871: string "res = PQexec(conn, \"", adamc@871: string q'', adamc@871: string "\");", adamc@871: newline, adamc@871: newline, adamc@871: string "if (res == NULL) {", adamc@871: newline, adamc@871: box [string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@871: newline, adamc@871: box [string "char msg[1024];", adamc@871: newline, adamc@871: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@871: newline, adamc@871: string "msg[1023] = 0;", adamc@871: newline, adamc@871: string "PQclear(res);", adamc@871: newline, adamc@871: string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@871: string q'', adamc@871: string "\\n%s\", msg);", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "if (strcmp(PQgetvalue(res, 0, 0), \"", adamc@871: string (Int.toString (length xts)), adamc@871: string "\")) {", adamc@871: newline, adamc@871: box [string "PQclear(res);", adamc@871: newline, adamc@871: string "PQfinish(conn);", adamc@871: newline, adamc@871: string "uw_error(ctx, FATAL, \"Table '", adamc@871: string s, adamc@871: string "' has extra columns.\");", adamc@871: newline], adamc@871: string "}", adamc@871: newline, adamc@871: newline, adamc@871: string "PQclear(res);", adamc@871: newline] adamc@871: end adamc@871: adamc@872: fun init {dbstring, prepared = ss, tables, views, sequences} = adamc@866: box [if #persistent (currentProtocol ()) then adamc@1094: box [string "static void uw_db_validate(uw_context ctx) {", adamc@870: newline, adamc@870: string "PGconn *conn = uw_get_db(ctx);", adamc@870: newline, adamc@870: string "PGresult *res;", adamc@870: newline, adamc@870: newline, adamc@872: p_list_sep newline (checkRel ("tables", true)) tables, adamc@872: p_list_sep newline (checkRel ("views", false)) views, adamc@870: adamc@870: p_list_sep newline adamc@870: (fn s => adamc@870: let adamc@870: val sl = CharVector.map Char.toLower s adamc@870: adamc@870: val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '" adamc@870: ^ sl ^ "' AND relkind = 'S'" adamc@870: in adamc@870: box [string "res = PQexec(conn, \"", adamc@870: string q, adamc@870: string "\");", adamc@870: newline, adamc@870: newline, adamc@870: string "if (res == NULL) {", adamc@870: newline, adamc@870: box [string "PQfinish(conn);", adamc@870: newline, adamc@870: string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@870: newline], adamc@870: string "}", adamc@870: newline, adamc@870: newline, adamc@870: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@870: newline, adamc@870: box [string "char msg[1024];", adamc@870: newline, adamc@870: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@870: newline, adamc@870: string "msg[1023] = 0;", adamc@870: newline, adamc@870: string "PQclear(res);", adamc@870: newline, adamc@870: string "PQfinish(conn);", adamc@870: newline, adamc@870: string "uw_error(ctx, FATAL, \"Query failed:\\n", adamc@870: string q, adamc@870: string "\\n%s\", msg);", adamc@870: newline], adamc@870: string "}", adamc@870: newline, adamc@870: newline, adamc@870: string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {", adamc@870: newline, adamc@870: box [string "PQclear(res);", adamc@870: newline, adamc@870: string "PQfinish(conn);", adamc@870: newline, adamc@870: string "uw_error(ctx, FATAL, \"Sequence '", adamc@870: string s, adamc@870: string "' does not exist.\");", adamc@870: newline], adamc@870: string "}", adamc@870: newline, adamc@870: newline, adamc@870: string "PQclear(res);", adamc@870: newline] adamc@870: end) sequences, adamc@870: adamc@870: string "}", adamc@870: adamc@870: string "static void uw_db_prepare(uw_context ctx) {", adamc@866: newline, adamc@866: string "PGconn *conn = uw_get_db(ctx);", adamc@866: newline, adamc@866: string "PGresult *res;", adamc@866: newline, adamc@866: newline, adamc@866: adamc@866: p_list_sepi newline (fn i => fn (s, n) => adamc@866: box [string "res = PQprepare(conn, \"uw", adamc@866: string (Int.toString i), adamc@866: string "\", \"", adam@1285: string (String.toCString s), adamc@866: string "\", ", adamc@866: string (Int.toString n), adamc@866: string ", NULL);", adamc@866: newline, adamc@866: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@866: newline, adamc@866: box [string "char msg[1024];", adamc@866: newline, adamc@866: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@866: newline, adamc@866: string "msg[1023] = 0;", adamc@866: newline, adamc@866: string "PQclear(res);", adamc@866: newline, adamc@866: string "PQfinish(conn);", adamc@866: newline, adamc@866: string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n", adam@1285: string (String.toCString s), adamc@866: string "\\n%s\", msg);", adamc@866: newline], adamc@866: string "}", adamc@866: newline, adamc@866: string "PQclear(res);", adamc@866: newline]) adamc@866: ss, adamc@866: adamc@866: string "}", adamc@866: newline, adamc@866: newline] adamc@866: else adamc@870: box [string "static void uw_db_validate(uw_context ctx) { }", adamc@870: newline, adamc@870: string "static void uw_db_prepare(uw_context ctx) { }"], adamc@870: adamc@1094: string "static void uw_client_init(void) {", adamc@1094: newline, adamc@1094: box [string "uw_sqlfmtInt = \"%lld::int8%n\";", adamc@1094: newline, adamc@1094: string "uw_sqlfmtFloat = \"%g::float8%n\";", adamc@1094: newline, adamc@1094: string "uw_Estrings = 1;", adamc@1094: newline, adamc@1094: string "uw_sqlsuffixString = \"::text\";", adamc@1094: newline, adamc@1094: string "uw_sqlsuffixChar = \"::char\";", adamc@1094: newline, adamc@1094: string "uw_sqlsuffixBlob = \"::bytea\";", adamc@1094: newline, adamc@1094: string "uw_sqlfmtUint4 = \"%u::int4%n\";", adamc@1094: newline], adamc@1094: string "}", adamc@866: newline, adamc@866: newline, adamc@866: adamc@1094: string "static void uw_db_close(uw_context ctx) {", adamc@1094: newline, adamc@1094: string "PQfinish(uw_get_db(ctx));", adamc@1094: newline, adamc@1094: string "}", adamc@1094: newline, adamc@1094: newline, adamc@1094: adamc@1094: string "static int uw_db_begin(uw_context ctx) {", adamc@1094: newline, adamc@1094: string "PGconn *conn = uw_get_db(ctx);", adamc@1094: newline, adamc@1094: string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");", adamc@1094: newline, adamc@1094: newline, adamc@1094: string "if (res == NULL) return 1;", adamc@1094: newline, adamc@1094: newline, adamc@1094: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@1094: box [string "PQclear(res);", adamc@1094: newline, adamc@1094: string "return 1;", adamc@1094: newline], adamc@1094: string "}", adamc@1094: newline, adamc@1144: string "PQclear(res);", adamc@1144: newline, adamc@1094: string "return 0;", adamc@1094: newline, adamc@1094: string "}", adamc@1094: newline, adamc@1094: newline, adamc@1094: adamc@1094: string "static int uw_db_commit(uw_context ctx) {", adamc@1094: newline, adamc@1094: string "PGconn *conn = uw_get_db(ctx);", adamc@1094: newline, adamc@1094: string "PGresult *res = PQexec(conn, \"COMMIT\");", adamc@1094: newline, adamc@1094: newline, adamc@1094: string "if (res == NULL) return 1;", adamc@1094: newline, adamc@1094: newline, adamc@1094: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@1094: box [string "PQclear(res);", adamc@1094: newline, adamc@1094: string "return 1;", adamc@1094: newline], adamc@1094: string "}", adamc@1094: newline, adamc@1144: string "PQclear(res);", adamc@1144: newline, adamc@1094: string "return 0;", adamc@1094: newline, adamc@1094: string "}", adamc@1094: newline, adamc@1094: newline, adamc@1094: adamc@1094: string "static int uw_db_rollback(uw_context ctx) {", adamc@1094: newline, adamc@1094: string "PGconn *conn = uw_get_db(ctx);", adamc@1094: newline, adamc@1094: string "PGresult *res = PQexec(conn, \"ROLLBACK\");", adamc@1094: newline, adamc@1094: newline, adamc@1094: string "if (res == NULL) return 1;", adamc@1094: newline, adamc@1094: newline, adamc@1094: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@1094: box [string "PQclear(res);", adamc@1094: newline, adamc@1094: string "return 1;", adamc@1094: newline], adamc@1094: string "}", adamc@1094: newline, adamc@1144: string "PQclear(res);", adamc@1144: newline, adamc@1094: string "return 0;", adamc@1094: newline, adamc@1094: string "}", adamc@1094: adamc@1094: newline, adamc@1094: newline, adamc@1094: adamc@1094: string "static void uw_db_init(uw_context ctx) {", adamc@866: newline, adamc@866: string "PGconn *conn = PQconnectdb(\"", adam@1285: string (String.toCString dbstring), adamc@866: string "\");", adamc@866: newline, adamc@866: string "if (conn == NULL) uw_error(ctx, FATAL, ", adamc@866: string "\"libpq can't allocate a connection.\");", adamc@866: newline, adamc@866: string "if (PQstatus(conn) != CONNECTION_OK) {", adamc@866: newline, adamc@866: box [string "char msg[1024];", adamc@866: newline, adamc@866: string "strncpy(msg, PQerrorMessage(conn), 1024);", adamc@866: newline, adamc@866: string "msg[1023] = 0;", adamc@866: newline, adamc@866: string "PQfinish(conn);", adamc@866: newline, adamc@866: string "uw_error(ctx, BOUNDED_RETRY, ", adamc@866: string "\"Connection to Postgres server failed: %s\", msg);"], adamc@866: newline, adamc@866: string "}", adamc@866: newline, adamc@866: string "uw_set_db(ctx, conn);", adamc@866: newline, adamc@866: string "uw_db_validate(ctx);", adamc@866: newline, adamc@866: string "uw_db_prepare(ctx);", adamc@866: newline, adamc@866: string "}"] adamc@866: adamc@880: fun p_getcol {loc, wontLeakStrings, col = i, typ = t} = adamc@867: let adamc@867: fun p_unsql t e eLen = adamc@867: case t of adamc@867: Int => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"] adamc@867: | Float => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"] adamc@867: | String => adamc@867: if wontLeakStrings then adamc@867: e adamc@867: else adamc@867: box [string "uw_strdup(ctx, ", e, string ")"] adamc@1011: | Char => box [e, string "[0]"] adamc@867: | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"] adamc@939: | Time => box [string "uw_Basis_unsqlTime(ctx, ", e, string ")"] adamc@867: | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ", adamc@867: e, adamc@867: string ", ", adamc@867: eLen, adamc@867: string ")"] adamc@867: | Channel => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"] adamc@867: | Client => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"] adamc@867: adamc@867: | Nullable _ => raise Fail "Postgres: Recursive Nullable" adamc@867: adamc@867: fun getter t = adamc@867: case t of adamc@867: Nullable t => adamc@867: box [string "(PQgetisnull(res, i, ", adamc@867: string (Int.toString i), adamc@867: string ") ? NULL : ", adamc@867: case t of adamc@867: String => getter t adamc@867: | _ => box [string "({", adamc@867: newline, adamc@874: string (p_sql_ctype t), adamc@867: space, adamc@867: string "*tmp = uw_malloc(ctx, sizeof(", adamc@874: string (p_sql_ctype t), adamc@867: string "));", adamc@867: newline, adamc@867: string "*tmp = ", adamc@867: getter t, adamc@867: string ";", adamc@867: newline, adamc@867: string "tmp;", adamc@867: newline, adamc@867: string "})"], adamc@867: string ")"] adamc@867: | _ => adamc@867: box [string "(PQgetisnull(res, i, ", adamc@867: string (Int.toString i), adamc@867: string ") ? ", adamc@867: box [string "({", adamc@874: string (p_sql_ctype t), adamc@867: space, adamc@867: string "tmp;", adamc@867: newline, adamc@880: string "uw_error(ctx, FATAL, \"", adamc@880: string (ErrorMsg.spanToString loc), adamc@880: string ": Unexpectedly NULL field #", adamc@867: string (Int.toString i), adamc@867: string "\");", adamc@867: newline, adamc@867: string "tmp;", adamc@867: newline, adamc@867: string "})"], adamc@867: string " : ", adamc@867: p_unsql t adamc@867: (box [string "PQgetvalue(res, i, ", adamc@867: string (Int.toString i), adamc@867: string ")"]) adamc@867: (box [string "PQgetlength(res, i, ", adamc@867: string (Int.toString i), adamc@867: string ")"]), adamc@867: string ")"] adamc@867: in adamc@867: getter t adamc@867: end adamc@867: adamc@873: fun queryCommon {loc, query, cols, doCols} = adamc@867: box [string "int n, i;", adamc@867: newline, adamc@867: newline, adamc@867: adamc@867: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");", adamc@867: newline, adamc@867: newline, adamc@867: adamc@867: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@867: newline, adamc@867: box [string "PQclear(res);", adamc@867: newline, adamc@867: string "uw_error(ctx, FATAL, \"", adamc@867: string (ErrorMsg.spanToString loc), adamc@867: string ": Query failed:\\n%s\\n%s\", ", adamc@867: query, adamc@867: string ", PQerrorMessage(conn));", adamc@867: newline], adamc@867: string "}", adamc@867: newline, adamc@867: newline, adamc@867: adamc@867: string "if (PQnfields(res) != ", adamc@873: string (Int.toString (length cols)), adamc@867: string ") {", adamc@867: newline, adamc@867: box [string "int nf = PQnfields(res);", adamc@867: newline, adamc@867: string "PQclear(res);", adamc@867: newline, adamc@867: string "uw_error(ctx, FATAL, \"", adamc@867: string (ErrorMsg.spanToString loc), adamc@867: string ": Query returned %d columns instead of ", adamc@873: string (Int.toString (length cols)), adamc@867: string ":\\n%s\\n%s\", nf, ", adamc@867: query, adamc@867: string ", PQerrorMessage(conn));", adamc@867: newline], adamc@867: string "}", adamc@867: newline, adamc@867: newline, adamc@867: adamc@867: string "uw_end_region(ctx);", adamc@867: newline, adamc@867: string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);", adamc@867: newline, adamc@867: string "n = PQntuples(res);", adamc@867: newline, adamc@867: string "for (i = 0; i < n; ++i) {", adamc@867: newline, adamc@867: doCols p_getcol, adamc@867: string "}", adamc@867: newline, adamc@867: newline, adamc@867: string "uw_pop_cleanup(ctx);", adamc@867: newline] adamc@867: adamc@873: fun query {loc, cols, doCols} = adamc@867: box [string "PGconn *conn = uw_get_db(ctx);", adamc@867: newline, adamc@867: string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", adamc@867: newline, adamc@867: newline, adamc@873: queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"}] adamc@867: adamc@867: fun p_ensql t e = adamc@867: case t of adamc@867: Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"] adamc@867: | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"] adamc@867: | String => e adamc@1011: | Char => box [string "uw_Basis_attrifyChar(ctx, ", e, string ")"] adamc@867: | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"] adam@1364: | Time => box [string "uw_Basis_ensqlTime(ctx, ", e, string ")"] adamc@867: | Blob => box [e, string ".data"] adamc@867: | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"] adamc@867: | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"] adamc@867: | Nullable String => e adamc@867: | Nullable t => box [string "(", adamc@867: e, adamc@867: string " == NULL ? NULL : ", adamc@867: p_ensql t (box [string "(*", e, string ")"]), adamc@867: string ")"] adamc@867: adam@1431: fun makeParams inputs = adam@1431: box [string "static const int paramFormats[] = { ", adamc@867: p_list_sep (box [string ",", space]) adamc@867: (fn t => if isBlob t then string "1" else string "0") inputs, adamc@867: string " };", adamc@867: newline, adam@1431: if List.exists isBlob inputs then adam@1431: box [string "const int *paramLengths = uw_malloc(ctx, ", adam@1431: string (Int.toString (length inputs)), adam@1431: string " * sizeof(int));", adam@1431: newline, adam@1431: p_list_sepi (box []) adam@1431: (fn i => fn t => adam@1431: box [string "paramLengths[", adam@1431: string (Int.toString i), adam@1431: string "] = ", adam@1431: case t of adam@1431: Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size") adam@1431: | Nullable Blob => string ("arg" ^ Int.toString (i + 1) adam@1431: ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0") adam@1431: | _ => string "0", adam@1431: string ";", adam@1431: newline]) inputs, adam@1431: string " };", adam@1431: newline] adam@1431: else adam@1431: box [string "const int *paramLengths = paramFormats;", adam@1431: newline], adam@1431: adam@1431: string "const char **paramValues = uw_malloc(ctx, ", adam@1431: string (Int.toString (length inputs)), adam@1431: string " * sizeof(char*));", adamc@867: newline, adam@1431: p_list_sepi (box []) adam@1431: (fn i => fn t => box [string "paramValues[", adam@1431: string (Int.toString i), adam@1431: string "] = ", adam@1431: p_ensql t (box [string "arg", adam@1431: string (Int.toString (i + 1))]), adam@1431: string ";", adam@1431: newline]) adamc@867: inputs, adam@1431: newline] adam@1431: adam@1431: fun queryPrepared {loc, id, query, inputs, cols, doCols, nested = _} = adam@1431: box [string "PGconn *conn = uw_get_db(ctx);", adamc@867: newline, adam@1431: adam@1431: makeParams inputs, adam@1431: adamc@867: newline, adamc@867: string "PGresult *res = ", adamc@867: if #persistent (Settings.currentProtocol ()) then adamc@867: box [string "PQexecPrepared(conn, \"uw", adamc@867: string (Int.toString id), adamc@867: string "\", ", adamc@867: string (Int.toString (length inputs)), adamc@867: string ", paramValues, paramLengths, paramFormats, 0);"] adamc@867: else adamc@867: box [string "PQexecParams(conn, \"", adam@1285: string (String.toCString query), adamc@867: string "\", ", adamc@867: string (Int.toString (length inputs)), adamc@867: string ", NULL, paramValues, paramLengths, paramFormats, 0);"], adamc@867: newline, adamc@867: newline, adamc@873: queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"", adam@1285: string (String.toCString query), adamc@873: string "\""]}] adamc@867: adam@1293: fun dmlCommon {loc, dml, mode} = adamc@868: box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", adamc@868: newline, adamc@868: newline, adamc@868: adamc@868: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adamc@868: newline, adamc@868: box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {", adamc@868: box [newline, adamc@868: string "PQclear(res);", adamc@868: newline, adamc@868: string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");", adamc@868: newline], adamc@868: string "}", adamc@868: newline, adam@1550: string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40P01\")) {", adam@1550: box [newline, adam@1550: string "PQclear(res);", adam@1550: newline, adam@1550: string "uw_error(ctx, UNLIMITED_RETRY, \"Deadlock detected\");", adam@1550: newline], adam@1550: string "}", adam@1550: newline, adam@1293: case mode of adam@1293: Settings.Error => box [string "PQclear(res);", adam@1293: newline, adam@1293: string "uw_error(ctx, FATAL, \"", adam@1293: string (ErrorMsg.spanToString loc), adam@1293: string ": DML failed:\\n%s\\n%s\", ", adam@1293: dml, adam@1293: string ", PQerrorMessage(conn));"] adam@1295: | Settings.None => box [string "uw_set_error_message(ctx, PQerrorMessage(conn));", adam@1295: newline, adam@1295: newline, adam@1295: adam@1295: string "res = PQexec(conn, \"ROLLBACK TO s\");", adam@1295: newline, adam@1295: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", adam@1295: newline, adam@1295: newline, adam@1295: adam@1295: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adam@1295: newline, adam@1295: box [string "PQclear(res);", adam@1295: newline, adam@1295: string "uw_error(ctx, FATAL, \"", adam@1295: string (ErrorMsg.spanToString loc), adam@1295: string ": ROLLBACK TO failed:\\n%s\\n%s\", ", adam@1295: dml, adam@1295: string ", PQerrorMessage(conn));", adam@1295: newline, adam@1295: string "}"], adam@1295: newline, adam@1295: adam@1295: string "PQclear(res);", adam@1295: newline], adamc@868: newline], adamc@868: string "}", adamc@868: adam@1295: case mode of adam@1295: Error => box [newline, adam@1295: newline, adam@1295: string "PQclear(res);", adam@1295: newline] adam@1295: | None => box[string " else {", adam@1295: newline, adam@1295: box [string "PQclear(res);", adam@1295: newline, adam@1295: string "res = PQexec(conn, \"RELEASE s\");", adam@1295: newline, adam@1295: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", adam@1295: newline, adam@1295: newline, adam@1295: adam@1295: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adam@1295: newline, adam@1295: box [string "PQclear(res);", adam@1295: newline, adam@1295: string "uw_error(ctx, FATAL, \"", adam@1295: string (ErrorMsg.spanToString loc), adam@1295: string ": RELEASE failed:\\n%s\\n%s\", ", adam@1295: dml, adam@1295: string ", PQerrorMessage(conn));", adam@1295: newline], adam@1295: string "}", adam@1295: newline, adam@1295: string "PQclear(res);", adam@1295: newline], adam@1295: string "}", adam@1295: newline]] adam@1295: adam@1295: fun makeSavepoint mode = adam@1295: case mode of adam@1295: Error => box [] adam@1295: | None => box [string "res = PQexec(conn, \"SAVEPOINT s\");", adam@1295: newline, adam@1295: string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");", adam@1295: newline, adam@1295: newline, adam@1295: string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {", adam@1295: box [newline, adam@1295: string "PQclear(res);", adam@1295: newline, adam@1295: string "uw_error(ctx, FATAL, \"Error creating SAVEPOINT\");", adam@1295: newline], adam@1295: string "}", adam@1295: newline, adam@1295: string "PQclear(res);", adam@1295: newline, adam@1295: newline] adamc@868: adam@1293: fun dml (loc, mode) = adamc@868: box [string "PGconn *conn = uw_get_db(ctx);", adamc@868: newline, adam@1295: string "PGresult *res;", adam@1295: newline, adam@1295: adam@1295: makeSavepoint mode, adam@1295: adam@1295: string "res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);", adamc@868: newline, adamc@868: newline, adam@1293: dmlCommon {loc = loc, dml = string "dml", mode = mode}] adamc@868: adam@1293: fun dmlPrepared {loc, id, dml, inputs, mode} = adamc@868: box [string "PGconn *conn = uw_get_db(ctx);", adamc@868: newline, adam@1431: adam@1431: makeParams inputs, adam@1431: adamc@868: newline, adam@1295: string "PGresult *res;", adam@1295: newline, adam@1295: newline, adam@1295: adam@1295: makeSavepoint mode, adam@1295: adam@1295: string "res = ", adamc@868: if #persistent (Settings.currentProtocol ()) then adamc@868: box [string "PQexecPrepared(conn, \"uw", adamc@868: string (Int.toString id), adamc@868: string "\", ", adamc@868: string (Int.toString (length inputs)), adamc@868: string ", paramValues, paramLengths, paramFormats, 0);"] adamc@868: else adamc@868: box [string "PQexecParams(conn, \"", adam@1285: string (String.toCString dml), adamc@868: string "\", ", adamc@868: string (Int.toString (length inputs)), adamc@868: string ", NULL, paramValues, paramLengths, paramFormats, 0);"], adamc@868: newline, adamc@868: newline, adamc@868: dmlCommon {loc = loc, dml = box [string "\"", adam@1285: string (String.toCString dml), adam@1293: string "\""], mode = mode}] adamc@868: adamc@869: fun nextvalCommon {loc, query} = adamc@869: box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");", adamc@869: newline, adamc@869: newline, adamc@869: adamc@869: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@869: newline, adamc@869: box [string "PQclear(res);", adamc@869: newline, adamc@869: string "uw_error(ctx, FATAL, \"", adamc@869: string (ErrorMsg.spanToString loc), adamc@869: string ": Query failed:\\n%s\\n%s\", ", adamc@869: query, adamc@869: string ", PQerrorMessage(conn));", adamc@869: newline], adamc@869: string "}", adamc@869: newline, adamc@869: newline, adamc@869: adamc@869: string "n = PQntuples(res);", adamc@869: newline, adamc@869: string "if (n != 1) {", adamc@869: newline, adamc@869: box [string "PQclear(res);", adamc@869: newline, adamc@869: string "uw_error(ctx, FATAL, \"", adamc@869: string (ErrorMsg.spanToString loc), adamc@869: string ": Wrong number of result rows:\\n%s\\n%s\", ", adamc@869: query, adamc@869: string ", PQerrorMessage(conn));", adamc@869: newline], adamc@869: string "}", adamc@869: newline, adamc@869: newline, adamc@869: adamc@869: string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));", adamc@869: newline, adamc@869: string "PQclear(res);", adamc@869: newline] adamc@869: adamc@878: open Cjr adamc@878: adamc@878: fun nextval {loc, seqE, seqName} = adamc@878: let adamc@878: val query = case seqName of adamc@878: SOME s => adamc@879: string ("\"SELECT NEXTVAL('" ^ s ^ "')\"") adamc@878: | _ => box [string "uw_Basis_strcat(ctx, \"SELECT NEXTVAL('\", uw_Basis_strcat(ctx, ", adamc@878: seqE, adamc@878: string ", \"')\"))"] adamc@878: in adamc@878: box [string "char *query = ", adamc@878: query, adamc@878: string ";", adamc@878: newline, adamc@878: string "PGconn *conn = uw_get_db(ctx);", adamc@878: newline, adamc@878: string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", adamc@878: newline, adamc@878: newline, adamc@878: nextvalCommon {loc = loc, query = string "query"}] adamc@878: end adamc@869: adamc@869: fun nextvalPrepared {loc, id, query} = adamc@869: box [string "PGconn *conn = uw_get_db(ctx);", adamc@869: newline, adamc@869: newline, adamc@869: string "PGresult *res = ", adamc@869: if #persistent (Settings.currentProtocol ()) then adamc@869: box [string "PQexecPrepared(conn, \"uw", adamc@869: string (Int.toString id), adamc@869: string "\", 0, NULL, NULL, NULL, 0);"] adamc@869: else adamc@869: box [string "PQexecParams(conn, \"", adam@1285: string (String.toCString query), adamc@869: string "\", 0, NULL, NULL, NULL, NULL, 0);"], adamc@869: newline, adamc@869: newline, adamc@869: nextvalCommon {loc = loc, query = box [string "\"", adam@1285: string (String.toCString query), adamc@869: string "\""]}] adamc@869: adamc@1073: fun setvalCommon {loc, query} = adamc@1073: box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating setval result.\");", adamc@1073: newline, adamc@1073: newline, adamc@1073: adamc@1073: string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {", adamc@1073: newline, adamc@1073: box [string "PQclear(res);", adamc@1073: newline, adamc@1073: string "uw_error(ctx, FATAL, \"", adamc@1073: string (ErrorMsg.spanToString loc), adamc@1073: string ": Query failed:\\n%s\\n%s\", ", adamc@1073: query, adamc@1073: string ", PQerrorMessage(conn));", adamc@1073: newline], adamc@1073: string "}", adamc@1073: newline, adamc@1073: newline, adamc@1073: adamc@1073: string "PQclear(res);", adamc@1073: newline] adamc@1073: adamc@1073: fun setval {loc, seqE, count} = adamc@1073: let adamc@1073: val query = box [string "uw_Basis_strcat(ctx, \"SELECT SETVAL('\", uw_Basis_strcat(ctx, ", adamc@1073: seqE, adamc@1073: string ", uw_Basis_strcat(ctx, \"', \", uw_Basis_strcat(ctx, uw_Basis_sqlifyInt(ctx, ", adamc@1073: count, adamc@1073: string "), \")\"))))"] adamc@1073: in adamc@1073: box [string "char *query = ", adamc@1073: query, adamc@1073: string ";", adamc@1073: newline, adamc@1073: string "PGconn *conn = uw_get_db(ctx);", adamc@1073: newline, adamc@1073: string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);", adamc@1073: newline, adamc@1073: newline, adamc@1073: setvalCommon {loc = loc, query = string "query"}] adamc@1073: end adamc@1073: adamc@874: fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" adamc@874: | #"\\" => "\\\\" adamc@874: | ch => adamc@874: if Char.isPrint ch then adamc@874: str ch adamc@874: else adamc@874: "\\" ^ StringCvt.padLeft #"0" 3 adamc@874: (Int.fmt StringCvt.OCT (ord ch))) adam@1285: (String.toCString s) ^ "'::text" adamc@874: adamc@874: fun p_cast (s, t) = s ^ "::" ^ p_sql_type t adamc@874: adamc@874: fun p_blank (n, t) = p_cast ("$" ^ Int.toString n, t) adamc@874: adamc@866: val () = addDbms {name = "postgres", adam@1464: header = Config.pgheader, adamc@866: link = "-lpq", adamc@873: p_sql_type = p_sql_type, adamc@867: init = init, adamc@867: query = query, adamc@868: queryPrepared = queryPrepared, adamc@868: dml = dml, adamc@869: dmlPrepared = dmlPrepared, adamc@869: nextval = nextval, adamc@874: nextvalPrepared = nextvalPrepared, adamc@1073: setval = setval, adamc@874: sqlifyString = sqlifyString, adamc@874: p_cast = p_cast, adamc@874: p_blank = p_blank, adamc@877: supportsDeleteAs = true, adamc@886: supportsUpdateAs = true, adamc@877: createSequence = fn s => "CREATE SEQUENCE " ^ s, adamc@878: textKeysNeedLengths = false, adamc@879: supportsNextval = true, adamc@882: supportsNestedPrepared = true, adamc@890: sqlPrefix = "", adamc@1014: supportsOctetLength = true, adamc@1014: trueString = "TRUE", adamc@1196: falseString = "FALSE", adamc@1196: onlyUnion = false, adamc@1196: nestedRelops = true} adamc@874: adamc@866: val () = setDbms "postgres" adamc@866: adamc@866: end