adamc@866: (* Copyright (c) 2008-2009, 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@866: fun init (dbstring, ss) =
adamc@866:     box [if #persistent (currentProtocol ()) then
adamc@866:              box [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 "\", \"",
adamc@866:                                                        string (String.toString 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",
adamc@866:                                                             string (String.toString 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: 
adamc@866:                   string "void uw_db_close(uw_context ctx) {",
adamc@866:                   newline,
adamc@866:                   string "PQfinish(uw_get_db(ctx));",
adamc@866:                   newline,
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866: 
adamc@866:                   string "int uw_db_begin(uw_context ctx) {",
adamc@866:                   newline,
adamc@866:                   string "PGconn *conn = uw_get_db(ctx);",
adamc@866:                   newline,
adamc@866:                   string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866:                   string "if (res == NULL) return 1;",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866:                   string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866:                   box [string "PQclear(res);",
adamc@866:                        newline,
adamc@866:                        string "return 1;",
adamc@866:                        newline],
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   string "return 0;",
adamc@866:                   newline,
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866: 
adamc@866:                   string "int uw_db_commit(uw_context ctx) {",
adamc@866:                   newline,
adamc@866:                   string "PGconn *conn = uw_get_db(ctx);",
adamc@866:                   newline,
adamc@866:                   string "PGresult *res = PQexec(conn, \"COMMIT\");",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866:                   string "if (res == NULL) return 1;",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866:                   string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866:                   box [string "PQclear(res);",
adamc@866:                        newline,
adamc@866:                        string "return 1;",
adamc@866:                        newline],
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   string "return 0;",
adamc@866:                   newline,
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866: 
adamc@866:                   string "int uw_db_rollback(uw_context ctx) {",
adamc@866:                   newline,
adamc@866:                   string "PGconn *conn = uw_get_db(ctx);",
adamc@866:                   newline,
adamc@866:                   string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866:                   string "if (res == NULL) return 1;",
adamc@866:                   newline,
adamc@866:                   newline,
adamc@866:                   string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866:                   box [string "PQclear(res);",
adamc@866:                        newline,
adamc@866:                        string "return 1;",
adamc@866:                        newline],
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   string "return 0;",
adamc@866:                   newline,
adamc@866:                   string "}",
adamc@866:                   newline,
adamc@866:                   newline]
adamc@866:          else
adamc@866:              string "static void uw_db_prepare(uw_context ctx) { }",
adamc@866:          newline,
adamc@866:          newline,
adamc@866: 
adamc@866:          string "void uw_db_init(uw_context ctx) {",
adamc@866:          newline,
adamc@866:          string "PGconn *conn = PQconnectdb(\"",
adamc@866:          string (String.toString 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@867: fun p_getcol {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@867:               | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
adamc@867:               | Time => box [string "uw_Basis_stringToTime_error(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@867:                                    p_sql_type t,
adamc@867:                                    space,
adamc@867:                                    string "*tmp = uw_malloc(ctx, sizeof(",
adamc@867:                                    p_sql_type 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@867:                           p_sql_type t,
adamc@867:                           space,
adamc@867:                           string "tmp;",
adamc@867:                           newline,
adamc@867:                           string "uw_error(ctx, FATAL, \"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@867: fun queryCommon {loc, query, numCols, 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@867:          string (Int.toString numCols),
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@867:               string (Int.toString numCols),
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@867: fun query {loc, numCols, 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@867:          queryCommon {loc = loc, numCols = numCols, 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@867:       | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
adamc@867:       | Time => box [string "uw_Basis_attrifyTime(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: 
adamc@867: fun queryPrepared {loc, id, query, inputs, numCols, doCols} =
adamc@867:     box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867:          newline,
adamc@867:          string "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,
adamc@867:          string "const int paramLengths[] = { ",
adamc@867:          p_list_sepi (box [string ",", space])
adamc@867:                      (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adamc@867:                                | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adamc@867:                                                           ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adamc@867:                                | _ => string "0") inputs,
adamc@867:          string " };",
adamc@867:          newline,
adamc@867:          string "const char *paramValues[] = { ",
adamc@867:          p_list_sepi (box [string ",", space])
adamc@867:                      (fn i => fn t => p_ensql t (box [string "arg",
adamc@867:                                                       string (Int.toString (i + 1))]))
adamc@867:                      inputs,
adamc@867:          string " };",
adamc@867:          newline,
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, \"",
adamc@867:                   string (String.toString 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@867:          queryCommon {loc = loc, numCols = numCols, doCols = doCols, query = box [string "\"",
adamc@867:                                                                                   string (String.toString query),
adamc@867:                                                                                   string "\""]}]
adamc@867: 
adamc@868: fun dmlCommon {loc, dml} =
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,
adamc@868:               string "PQclear(res);",
adamc@868:               newline,
adamc@868:               string "uw_error(ctx, FATAL, \"",
adamc@868:               string (ErrorMsg.spanToString loc),
adamc@868:               string ": DML failed:\\n%s\\n%s\", ",
adamc@868:               dml,
adamc@868:               string ", PQerrorMessage(conn));",
adamc@868:               newline],
adamc@868:          string "}",
adamc@868:          newline,
adamc@868:          newline,
adamc@868: 
adamc@868:          string "PQclear(res);",
adamc@868:          newline]
adamc@868: 
adamc@868: fun dml loc =
adamc@868:     box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868:          newline,
adamc@868:          string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
adamc@868:          newline,
adamc@868:          newline,
adamc@868:          dmlCommon {loc = loc, dml = string "dml"}]
adamc@868: 
adamc@868: fun dmlPrepared {loc, id, dml, inputs} =
adamc@868:     box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868:          newline,
adamc@868:          string "const int paramFormats[] = { ",
adamc@868:          p_list_sep (box [string ",", space])
adamc@868:                     (fn t => if isBlob t then string "1" else string "0") inputs,
adamc@868:          string " };",
adamc@868:          newline,
adamc@868:          string "const int paramLengths[] = { ",
adamc@868:          p_list_sepi (box [string ",", space])
adamc@868:                      (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adamc@868:                                | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adamc@868:                                                           ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adamc@868:                                | _ => string "0") inputs,
adamc@868:          string " };",
adamc@868:          newline,
adamc@868:          string "const char *paramValues[] = { ",
adamc@868:          p_list_sepi (box [string ",", space])
adamc@868:                      (fn i => fn t => p_ensql t (box [string "arg",
adamc@868:                                                       string (Int.toString (i + 1))]))
adamc@868:                      inputs,
adamc@868:          string " };",
adamc@868:          newline,
adamc@868:          newline,
adamc@868:          string "PGresult *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, \"",
adamc@868:                   string (String.toString 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 "\"",
adamc@868:                                           string (String.toString dml),
adamc@868:                                           string "\""]}]
adamc@868: 
adamc@866: val () = addDbms {name = "postgres",
adamc@866:                   header = "postgresql/libpq-fe.h",
adamc@866:                   link = "-lpq",
adamc@866:                   global_init = box [string "void uw_client_init() { }",
adamc@866:                                      newline],
adamc@867:                   init = init,
adamc@867:                   query = query,
adamc@868:                   queryPrepared = queryPrepared,
adamc@868:                   dml = dml,
adamc@868:                   dmlPrepared = dmlPrepared}
adamc@866: val () = setDbms "postgres"
adamc@866: 
adamc@866: end