Mercurial > urweb

annotate src/postgres.sml @ 868:06497beb265b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Moved dml code into Settings
author Adam Chlipala <adamc@hcoop.net>
date Sun, 28 Jun 2009 16:22:17 -0400
parents e7f80d78075b
children 64ba57fa20bf
rev   line source
adamc@866 1 (* Copyright (c) 2008-2009, Adam Chlipala
adamc@866 2 * All rights reserved.
adamc@866 3 *
adamc@866 4 * Redistribution and use in source and binary forms, with or without
adamc@866 5 * modification, are permitted provided that the following conditions are met:
adamc@866 6 *
adamc@866 7 * - Redistributions of source code must retain the above copyright notice,
adamc@866 8 * this list of conditions and the following disclaimer.
adamc@866 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@866 10 * this list of conditions and the following disclaimer in the documentation
adamc@866 11 * and/or other materials provided with the distribution.
adamc@866 12 * - The names of contributors may not be used to endorse or promote products
adamc@866 13 * derived from this software without specific prior written permission.
adamc@866 14 *
adamc@866 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@866 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@866 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@866 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@866 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@866 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@866 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@866 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@866 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@866 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@866 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@866 26 *)
adamc@866 27
adamc@866 28 structure Postgres :> POSTGRES = struct
adamc@866 29
adamc@866 30 open Settings
adamc@866 31 open Print.PD
adamc@866 32 open Print
adamc@866 33
adamc@866 34 fun init (dbstring, ss) =
adamc@866 35 box [if #persistent (currentProtocol ()) then
adamc@866 36 box [string "static void uw_db_prepare(uw_context ctx) {",
adamc@866 37 newline,
adamc@866 38 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 39 newline,
adamc@866 40 string "PGresult *res;",
adamc@866 41 newline,
adamc@866 42 newline,
adamc@866 43
adamc@866 44 p_list_sepi newline (fn i => fn (s, n) =>
adamc@866 45 box [string "res = PQprepare(conn, \"uw",
adamc@866 46 string (Int.toString i),
adamc@866 47 string "\", \"",
adamc@866 48 string (String.toString s),
adamc@866 49 string "\", ",
adamc@866 50 string (Int.toString n),
adamc@866 51 string ", NULL);",
adamc@866 52 newline,
adamc@866 53 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 54 newline,
adamc@866 55 box [string "char msg[1024];",
adamc@866 56 newline,
adamc@866 57 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@866 58 newline,
adamc@866 59 string "msg[1023] = 0;",
adamc@866 60 newline,
adamc@866 61 string "PQclear(res);",
adamc@866 62 newline,
adamc@866 63 string "PQfinish(conn);",
adamc@866 64 newline,
adamc@866 65 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
adamc@866 66 string (String.toString s),
adamc@866 67 string "\\n%s\", msg);",
adamc@866 68 newline],
adamc@866 69 string "}",
adamc@866 70 newline,
adamc@866 71 string "PQclear(res);",
adamc@866 72 newline])
adamc@866 73 ss,
adamc@866 74
adamc@866 75 string "}",
adamc@866 76 newline,
adamc@866 77 newline,
adamc@866 78
adamc@866 79 string "void uw_db_close(uw_context ctx) {",
adamc@866 80 newline,
adamc@866 81 string "PQfinish(uw_get_db(ctx));",
adamc@866 82 newline,
adamc@866 83 string "}",
adamc@866 84 newline,
adamc@866 85 newline,
adamc@866 86
adamc@866 87 string "int uw_db_begin(uw_context ctx) {",
adamc@866 88 newline,
adamc@866 89 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 90 newline,
adamc@866 91 string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
adamc@866 92 newline,
adamc@866 93 newline,
adamc@866 94 string "if (res == NULL) return 1;",
adamc@866 95 newline,
adamc@866 96 newline,
adamc@866 97 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 98 box [string "PQclear(res);",
adamc@866 99 newline,
adamc@866 100 string "return 1;",
adamc@866 101 newline],
adamc@866 102 string "}",
adamc@866 103 newline,
adamc@866 104 string "return 0;",
adamc@866 105 newline,
adamc@866 106 string "}",
adamc@866 107 newline,
adamc@866 108 newline,
adamc@866 109
adamc@866 110 string "int uw_db_commit(uw_context ctx) {",
adamc@866 111 newline,
adamc@866 112 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 113 newline,
adamc@866 114 string "PGresult *res = PQexec(conn, \"COMMIT\");",
adamc@866 115 newline,
adamc@866 116 newline,
adamc@866 117 string "if (res == NULL) return 1;",
adamc@866 118 newline,
adamc@866 119 newline,
adamc@866 120 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 121 box [string "PQclear(res);",
adamc@866 122 newline,
adamc@866 123 string "return 1;",
adamc@866 124 newline],
adamc@866 125 string "}",
adamc@866 126 newline,
adamc@866 127 string "return 0;",
adamc@866 128 newline,
adamc@866 129 string "}",
adamc@866 130 newline,
adamc@866 131 newline,
adamc@866 132
adamc@866 133 string "int uw_db_rollback(uw_context ctx) {",
adamc@866 134 newline,
adamc@866 135 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 136 newline,
adamc@866 137 string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
adamc@866 138 newline,
adamc@866 139 newline,
adamc@866 140 string "if (res == NULL) return 1;",
adamc@866 141 newline,
adamc@866 142 newline,
adamc@866 143 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 144 box [string "PQclear(res);",
adamc@866 145 newline,
adamc@866 146 string "return 1;",
adamc@866 147 newline],
adamc@866 148 string "}",
adamc@866 149 newline,
adamc@866 150 string "return 0;",
adamc@866 151 newline,
adamc@866 152 string "}",
adamc@866 153 newline,
adamc@866 154 newline]
adamc@866 155 else
adamc@866 156 string "static void uw_db_prepare(uw_context ctx) { }",
adamc@866 157 newline,
adamc@866 158 newline,
adamc@866 159
adamc@866 160 string "void uw_db_init(uw_context ctx) {",
adamc@866 161 newline,
adamc@866 162 string "PGconn *conn = PQconnectdb(\"",
adamc@866 163 string (String.toString dbstring),
adamc@866 164 string "\");",
adamc@866 165 newline,
adamc@866 166 string "if (conn == NULL) uw_error(ctx, FATAL, ",
adamc@866 167 string "\"libpq can't allocate a connection.\");",
adamc@866 168 newline,
adamc@866 169 string "if (PQstatus(conn) != CONNECTION_OK) {",
adamc@866 170 newline,
adamc@866 171 box [string "char msg[1024];",
adamc@866 172 newline,
adamc@866 173 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@866 174 newline,
adamc@866 175 string "msg[1023] = 0;",
adamc@866 176 newline,
adamc@866 177 string "PQfinish(conn);",
adamc@866 178 newline,
adamc@866 179 string "uw_error(ctx, BOUNDED_RETRY, ",
adamc@866 180 string "\"Connection to Postgres server failed: %s\", msg);"],
adamc@866 181 newline,
adamc@866 182 string "}",
adamc@866 183 newline,
adamc@866 184 string "uw_set_db(ctx, conn);",
adamc@866 185 newline,
adamc@866 186 string "uw_db_validate(ctx);",
adamc@866 187 newline,
adamc@866 188 string "uw_db_prepare(ctx);",
adamc@866 189 newline,
adamc@866 190 string "}"]
adamc@866 191
adamc@867 192 fun p_getcol {wontLeakStrings, col = i, typ = t} =
adamc@867 193 let
adamc@867 194 fun p_unsql t e eLen =
adamc@867 195 case t of
adamc@867 196 Int => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
adamc@867 197 | Float => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
adamc@867 198 | String =>
adamc@867 199 if wontLeakStrings then
adamc@867 200 e
adamc@867 201 else
adamc@867 202 box [string "uw_strdup(ctx, ", e, string ")"]
adamc@867 203 | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
adamc@867 204 | Time => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
adamc@867 205 | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ",
adamc@867 206 e,
adamc@867 207 string ", ",
adamc@867 208 eLen,
adamc@867 209 string ")"]
adamc@867 210 | Channel => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
adamc@867 211 | Client => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
adamc@867 212
adamc@867 213 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
adamc@867 214
adamc@867 215 fun getter t =
adamc@867 216 case t of
adamc@867 217 Nullable t =>
adamc@867 218 box [string "(PQgetisnull(res, i, ",
adamc@867 219 string (Int.toString i),
adamc@867 220 string ") ? NULL : ",
adamc@867 221 case t of
adamc@867 222 String => getter t
adamc@867 223 | _ => box [string "({",
adamc@867 224 newline,
adamc@867 225 p_sql_type t,
adamc@867 226 space,
adamc@867 227 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@867 228 p_sql_type t,
adamc@867 229 string "));",
adamc@867 230 newline,
adamc@867 231 string "*tmp = ",
adamc@867 232 getter t,
adamc@867 233 string ";",
adamc@867 234 newline,
adamc@867 235 string "tmp;",
adamc@867 236 newline,
adamc@867 237 string "})"],
adamc@867 238 string ")"]
adamc@867 239 | _ =>
adamc@867 240 box [string "(PQgetisnull(res, i, ",
adamc@867 241 string (Int.toString i),
adamc@867 242 string ") ? ",
adamc@867 243 box [string "({",
adamc@867 244 p_sql_type t,
adamc@867 245 space,
adamc@867 246 string "tmp;",
adamc@867 247 newline,
adamc@867 248 string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
adamc@867 249 string (Int.toString i),
adamc@867 250 string "\");",
adamc@867 251 newline,
adamc@867 252 string "tmp;",
adamc@867 253 newline,
adamc@867 254 string "})"],
adamc@867 255 string " : ",
adamc@867 256 p_unsql t
adamc@867 257 (box [string "PQgetvalue(res, i, ",
adamc@867 258 string (Int.toString i),
adamc@867 259 string ")"])
adamc@867 260 (box [string "PQgetlength(res, i, ",
adamc@867 261 string (Int.toString i),
adamc@867 262 string ")"]),
adamc@867 263 string ")"]
adamc@867 264 in
adamc@867 265 getter t
adamc@867 266 end
adamc@867 267
adamc@867 268 fun queryCommon {loc, query, numCols, doCols} =
adamc@867 269 box [string "int n, i;",
adamc@867 270 newline,
adamc@867 271 newline,
adamc@867 272
adamc@867 273 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@867 274 newline,
adamc@867 275 newline,
adamc@867 276
adamc@867 277 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@867 278 newline,
adamc@867 279 box [string "PQclear(res);",
adamc@867 280 newline,
adamc@867 281 string "uw_error(ctx, FATAL, \"",
adamc@867 282 string (ErrorMsg.spanToString loc),
adamc@867 283 string ": Query failed:\\n%s\\n%s\", ",
adamc@867 284 query,
adamc@867 285 string ", PQerrorMessage(conn));",
adamc@867 286 newline],
adamc@867 287 string "}",
adamc@867 288 newline,
adamc@867 289 newline,
adamc@867 290
adamc@867 291 string "if (PQnfields(res) != ",
adamc@867 292 string (Int.toString numCols),
adamc@867 293 string ") {",
adamc@867 294 newline,
adamc@867 295 box [string "int nf = PQnfields(res);",
adamc@867 296 newline,
adamc@867 297 string "PQclear(res);",
adamc@867 298 newline,
adamc@867 299 string "uw_error(ctx, FATAL, \"",
adamc@867 300 string (ErrorMsg.spanToString loc),
adamc@867 301 string ": Query returned %d columns instead of ",
adamc@867 302 string (Int.toString numCols),
adamc@867 303 string ":\\n%s\\n%s\", nf, ",
adamc@867 304 query,
adamc@867 305 string ", PQerrorMessage(conn));",
adamc@867 306 newline],
adamc@867 307 string "}",
adamc@867 308 newline,
adamc@867 309 newline,
adamc@867 310
adamc@867 311 string "uw_end_region(ctx);",
adamc@867 312 newline,
adamc@867 313 string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);",
adamc@867 314 newline,
adamc@867 315 string "n = PQntuples(res);",
adamc@867 316 newline,
adamc@867 317 string "for (i = 0; i < n; ++i) {",
adamc@867 318 newline,
adamc@867 319 doCols p_getcol,
adamc@867 320 string "}",
adamc@867 321 newline,
adamc@867 322 newline,
adamc@867 323 string "uw_pop_cleanup(ctx);",
adamc@867 324 newline]
adamc@867 325
adamc@867 326 fun query {loc, numCols, doCols} =
adamc@867 327 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867 328 newline,
adamc@867 329 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
adamc@867 330 newline,
adamc@867 331 newline,
adamc@867 332 queryCommon {loc = loc, numCols = numCols, doCols = doCols, query = string "query"}]
adamc@867 333
adamc@867 334 fun p_ensql t e =
adamc@867 335 case t of
adamc@867 336 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
adamc@867 337 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
adamc@867 338 | String => e
adamc@867 339 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
adamc@867 340 | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
adamc@867 341 | Blob => box [e, string ".data"]
adamc@867 342 | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
adamc@867 343 | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
adamc@867 344 | Nullable String => e
adamc@867 345 | Nullable t => box [string "(",
adamc@867 346 e,
adamc@867 347 string " == NULL ? NULL : ",
adamc@867 348 p_ensql t (box [string "(*", e, string ")"]),
adamc@867 349 string ")"]
adamc@867 350
adamc@867 351 fun queryPrepared {loc, id, query, inputs, numCols, doCols} =
adamc@867 352 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867 353 newline,
adamc@867 354 string "const int paramFormats[] = { ",
adamc@867 355 p_list_sep (box [string ",", space])
adamc@867 356 (fn t => if isBlob t then string "1" else string "0") inputs,
adamc@867 357 string " };",
adamc@867 358 newline,
adamc@867 359 string "const int paramLengths[] = { ",
adamc@867 360 p_list_sepi (box [string ",", space])
adamc@867 361 (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adamc@867 362 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adamc@867 363 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adamc@867 364 | _ => string "0") inputs,
adamc@867 365 string " };",
adamc@867 366 newline,
adamc@867 367 string "const char *paramValues[] = { ",
adamc@867 368 p_list_sepi (box [string ",", space])
adamc@867 369 (fn i => fn t => p_ensql t (box [string "arg",
adamc@867 370 string (Int.toString (i + 1))]))
adamc@867 371 inputs,
adamc@867 372 string " };",
adamc@867 373 newline,
adamc@867 374 newline,
adamc@867 375 string "PGresult *res = ",
adamc@867 376 if #persistent (Settings.currentProtocol ()) then
adamc@867 377 box [string "PQexecPrepared(conn, \"uw",
adamc@867 378 string (Int.toString id),
adamc@867 379 string "\", ",
adamc@867 380 string (Int.toString (length inputs)),
adamc@867 381 string ", paramValues, paramLengths, paramFormats, 0);"]
adamc@867 382 else
adamc@867 383 box [string "PQexecParams(conn, \"",
adamc@867 384 string (String.toString query),
adamc@867 385 string "\", ",
adamc@867 386 string (Int.toString (length inputs)),
adamc@867 387 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
adamc@867 388 newline,
adamc@867 389 newline,
adamc@867 390 queryCommon {loc = loc, numCols = numCols, doCols = doCols, query = box [string "\"",
adamc@867 391 string (String.toString query),
adamc@867 392 string "\""]}]
adamc@867 393
adamc@868 394 fun dmlCommon {loc, dml} =
adamc@868 395 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
adamc@868 396 newline,
adamc@868 397 newline,
adamc@868 398
adamc@868 399 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@868 400 newline,
adamc@868 401 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
adamc@868 402 box [newline,
adamc@868 403 string "PQclear(res);",
adamc@868 404 newline,
adamc@868 405 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
adamc@868 406 newline],
adamc@868 407 string "}",
adamc@868 408 newline,
adamc@868 409 string "PQclear(res);",
adamc@868 410 newline,
adamc@868 411 string "uw_error(ctx, FATAL, \"",
adamc@868 412 string (ErrorMsg.spanToString loc),
adamc@868 413 string ": DML failed:\\n%s\\n%s\", ",
adamc@868 414 dml,
adamc@868 415 string ", PQerrorMessage(conn));",
adamc@868 416 newline],
adamc@868 417 string "}",
adamc@868 418 newline,
adamc@868 419 newline,
adamc@868 420
adamc@868 421 string "PQclear(res);",
adamc@868 422 newline]
adamc@868 423
adamc@868 424 fun dml loc =
adamc@868 425 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868 426 newline,
adamc@868 427 string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
adamc@868 428 newline,
adamc@868 429 newline,
adamc@868 430 dmlCommon {loc = loc, dml = string "dml"}]
adamc@868 431
adamc@868 432 fun dmlPrepared {loc, id, dml, inputs} =
adamc@868 433 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868 434 newline,
adamc@868 435 string "const int paramFormats[] = { ",
adamc@868 436 p_list_sep (box [string ",", space])
adamc@868 437 (fn t => if isBlob t then string "1" else string "0") inputs,
adamc@868 438 string " };",
adamc@868 439 newline,
adamc@868 440 string "const int paramLengths[] = { ",
adamc@868 441 p_list_sepi (box [string ",", space])
adamc@868 442 (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adamc@868 443 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adamc@868 444 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adamc@868 445 | _ => string "0") inputs,
adamc@868 446 string " };",
adamc@868 447 newline,
adamc@868 448 string "const char *paramValues[] = { ",
adamc@868 449 p_list_sepi (box [string ",", space])
adamc@868 450 (fn i => fn t => p_ensql t (box [string "arg",
adamc@868 451 string (Int.toString (i + 1))]))
adamc@868 452 inputs,
adamc@868 453 string " };",
adamc@868 454 newline,
adamc@868 455 newline,
adamc@868 456 string "PGresult *res = ",
adamc@868 457 if #persistent (Settings.currentProtocol ()) then
adamc@868 458 box [string "PQexecPrepared(conn, \"uw",
adamc@868 459 string (Int.toString id),
adamc@868 460 string "\", ",
adamc@868 461 string (Int.toString (length inputs)),
adamc@868 462 string ", paramValues, paramLengths, paramFormats, 0);"]
adamc@868 463 else
adamc@868 464 box [string "PQexecParams(conn, \"",
adamc@868 465 string (String.toString dml),
adamc@868 466 string "\", ",
adamc@868 467 string (Int.toString (length inputs)),
adamc@868 468 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
adamc@868 469 newline,
adamc@868 470 newline,
adamc@868 471 dmlCommon {loc = loc, dml = box [string "\"",
adamc@868 472 string (String.toString dml),
adamc@868 473 string "\""]}]
adamc@868 474
adamc@866 475 val () = addDbms {name = "postgres",
adamc@866 476 header = "postgresql/libpq-fe.h",
adamc@866 477 link = "-lpq",
adamc@866 478 global_init = box [string "void uw_client_init() { }",
adamc@866 479 newline],
adamc@867 480 init = init,
adamc@867 481 query = query,
adamc@868 482 queryPrepared = queryPrepared,
adamc@868 483 dml = dml,
adamc@868 484 dmlPrepared = dmlPrepared}
adamc@866 485 val () = setDbms "postgres"
adamc@866 486
adamc@866 487 end