Mercurial > urweb

annotate src/postgres.sml @ 870:7fa9a37a34b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Move all DBMS initialization to #init
author Adam Chlipala <adamc@hcoop.net>
date Tue, 30 Jun 2009 15:45:10 -0400
parents 64ba57fa20bf
children 3ae6b655ced0
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@870 34 val ident = String.translate (fn #"'" => "PRIME"
adamc@870 35 | ch => str ch)
adamc@870 36
adamc@870 37 fun p_sql_type_base t =
adamc@870 38 case t of
adamc@870 39 Int => "int8"
adamc@870 40 | Float => "float8"
adamc@870 41 | String => "text"
adamc@870 42 | Bool => "bool"
adamc@870 43 | Time => "timestamp"
adamc@870 44 | Blob => "bytea"
adamc@870 45 | Channel => "int8"
adamc@870 46 | Client => "int4"
adamc@870 47 | Nullable t => p_sql_type_base t
adamc@870 48
adamc@870 49 fun init {dbstring, prepared = ss, tables, sequences} =
adamc@866 50 box [if #persistent (currentProtocol ()) then
adamc@870 51 box [string "static void uw_db_validate(uw_context ctx) {",
adamc@870 52 newline,
adamc@870 53 string "PGconn *conn = uw_get_db(ctx);",
adamc@870 54 newline,
adamc@870 55 string "PGresult *res;",
adamc@870 56 newline,
adamc@870 57 newline,
adamc@870 58 p_list_sep newline
adamc@870 59 (fn (s, xts) =>
adamc@870 60 let
adamc@870 61 val sl = CharVector.map Char.toLower s
adamc@870 62
adamc@870 63 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
adamc@870 64 ^ sl ^ "'"
adamc@870 65
adamc@870 66 val q' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
adamc@870 67 sl,
adamc@870 68 "') AND (",
adamc@870 69 String.concatWith " OR "
adamc@870 70 (map (fn (x, t) =>
adamc@870 71 String.concat ["(attname = 'uw_",
adamc@870 72 CharVector.map
adamc@870 73 Char.toLower (ident x),
adamc@870 74 "' AND atttypid = (SELECT oid FROM pg_type",
adamc@870 75 " WHERE typname = '",
adamc@870 76 p_sql_type_base t,
adamc@870 77 "') AND attnotnull = ",
adamc@870 78 if isNotNull t then
adamc@870 79 "TRUE"
adamc@870 80 else
adamc@870 81 "FALSE",
adamc@870 82 ")"]) xts),
adamc@870 83 ")"]
adamc@870 84
adamc@870 85 val q'' = String.concat ["SELECT COUNT(*) FROM pg_attribute WHERE attrelid = (SELECT oid FROM pg_class WHERE relname = '",
adamc@870 86 sl,
adamc@870 87 "') AND attname LIKE 'uw_%'"]
adamc@870 88 in
adamc@870 89 box [string "res = PQexec(conn, \"",
adamc@870 90 string q,
adamc@870 91 string "\");",
adamc@870 92 newline,
adamc@870 93 newline,
adamc@870 94 string "if (res == NULL) {",
adamc@870 95 newline,
adamc@870 96 box [string "PQfinish(conn);",
adamc@870 97 newline,
adamc@870 98 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@870 99 newline],
adamc@870 100 string "}",
adamc@870 101 newline,
adamc@870 102 newline,
adamc@870 103 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@870 104 newline,
adamc@870 105 box [string "char msg[1024];",
adamc@870 106 newline,
adamc@870 107 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@870 108 newline,
adamc@870 109 string "msg[1023] = 0;",
adamc@870 110 newline,
adamc@870 111 string "PQclear(res);",
adamc@870 112 newline,
adamc@870 113 string "PQfinish(conn);",
adamc@870 114 newline,
adamc@870 115 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@870 116 string q,
adamc@870 117 string "\\n%s\", msg);",
adamc@870 118 newline],
adamc@870 119 string "}",
adamc@870 120 newline,
adamc@870 121 newline,
adamc@870 122 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
adamc@870 123 newline,
adamc@870 124 box [string "PQclear(res);",
adamc@870 125 newline,
adamc@870 126 string "PQfinish(conn);",
adamc@870 127 newline,
adamc@870 128 string "uw_error(ctx, FATAL, \"Table '",
adamc@870 129 string s,
adamc@870 130 string "' does not exist.\");",
adamc@870 131 newline],
adamc@870 132 string "}",
adamc@870 133 newline,
adamc@870 134 newline,
adamc@870 135 string "PQclear(res);",
adamc@870 136 newline,
adamc@870 137
adamc@870 138 string "res = PQexec(conn, \"",
adamc@870 139 string q',
adamc@870 140 string "\");",
adamc@870 141 newline,
adamc@870 142 newline,
adamc@870 143 string "if (res == NULL) {",
adamc@870 144 newline,
adamc@870 145 box [string "PQfinish(conn);",
adamc@870 146 newline,
adamc@870 147 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@870 148 newline],
adamc@870 149 string "}",
adamc@870 150 newline,
adamc@870 151 newline,
adamc@870 152 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@870 153 newline,
adamc@870 154 box [string "char msg[1024];",
adamc@870 155 newline,
adamc@870 156 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@870 157 newline,
adamc@870 158 string "msg[1023] = 0;",
adamc@870 159 newline,
adamc@870 160 string "PQclear(res);",
adamc@870 161 newline,
adamc@870 162 string "PQfinish(conn);",
adamc@870 163 newline,
adamc@870 164 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@870 165 string q',
adamc@870 166 string "\\n%s\", msg);",
adamc@870 167 newline],
adamc@870 168 string "}",
adamc@870 169 newline,
adamc@870 170 newline,
adamc@870 171 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@870 172 string (Int.toString (length xts)),
adamc@870 173 string "\")) {",
adamc@870 174 newline,
adamc@870 175 box [string "PQclear(res);",
adamc@870 176 newline,
adamc@870 177 string "PQfinish(conn);",
adamc@870 178 newline,
adamc@870 179 string "uw_error(ctx, FATAL, \"Table '",
adamc@870 180 string s,
adamc@870 181 string "' has the wrong column types.\");",
adamc@870 182 newline],
adamc@870 183 string "}",
adamc@870 184 newline,
adamc@870 185 newline,
adamc@870 186 string "PQclear(res);",
adamc@870 187 newline,
adamc@870 188 newline,
adamc@870 189
adamc@870 190 string "res = PQexec(conn, \"",
adamc@870 191 string q'',
adamc@870 192 string "\");",
adamc@870 193 newline,
adamc@870 194 newline,
adamc@870 195 string "if (res == NULL) {",
adamc@870 196 newline,
adamc@870 197 box [string "PQfinish(conn);",
adamc@870 198 newline,
adamc@870 199 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@870 200 newline],
adamc@870 201 string "}",
adamc@870 202 newline,
adamc@870 203 newline,
adamc@870 204 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@870 205 newline,
adamc@870 206 box [string "char msg[1024];",
adamc@870 207 newline,
adamc@870 208 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@870 209 newline,
adamc@870 210 string "msg[1023] = 0;",
adamc@870 211 newline,
adamc@870 212 string "PQclear(res);",
adamc@870 213 newline,
adamc@870 214 string "PQfinish(conn);",
adamc@870 215 newline,
adamc@870 216 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@870 217 string q'',
adamc@870 218 string "\\n%s\", msg);",
adamc@870 219 newline],
adamc@870 220 string "}",
adamc@870 221 newline,
adamc@870 222 newline,
adamc@870 223 string "if (strcmp(PQgetvalue(res, 0, 0), \"",
adamc@870 224 string (Int.toString (length xts)),
adamc@870 225 string "\")) {",
adamc@870 226 newline,
adamc@870 227 box [string "PQclear(res);",
adamc@870 228 newline,
adamc@870 229 string "PQfinish(conn);",
adamc@870 230 newline,
adamc@870 231 string "uw_error(ctx, FATAL, \"Table '",
adamc@870 232 string s,
adamc@870 233 string "' has extra columns.\");",
adamc@870 234 newline],
adamc@870 235 string "}",
adamc@870 236 newline,
adamc@870 237 newline,
adamc@870 238 string "PQclear(res);",
adamc@870 239 newline]
adamc@870 240 end) tables,
adamc@870 241
adamc@870 242 p_list_sep newline
adamc@870 243 (fn s =>
adamc@870 244 let
adamc@870 245 val sl = CharVector.map Char.toLower s
adamc@870 246
adamc@870 247 val q = "SELECT COUNT(*) FROM pg_class WHERE relname = '"
adamc@870 248 ^ sl ^ "' AND relkind = 'S'"
adamc@870 249 in
adamc@870 250 box [string "res = PQexec(conn, \"",
adamc@870 251 string q,
adamc@870 252 string "\");",
adamc@870 253 newline,
adamc@870 254 newline,
adamc@870 255 string "if (res == NULL) {",
adamc@870 256 newline,
adamc@870 257 box [string "PQfinish(conn);",
adamc@870 258 newline,
adamc@870 259 string "uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@870 260 newline],
adamc@870 261 string "}",
adamc@870 262 newline,
adamc@870 263 newline,
adamc@870 264 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@870 265 newline,
adamc@870 266 box [string "char msg[1024];",
adamc@870 267 newline,
adamc@870 268 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@870 269 newline,
adamc@870 270 string "msg[1023] = 0;",
adamc@870 271 newline,
adamc@870 272 string "PQclear(res);",
adamc@870 273 newline,
adamc@870 274 string "PQfinish(conn);",
adamc@870 275 newline,
adamc@870 276 string "uw_error(ctx, FATAL, \"Query failed:\\n",
adamc@870 277 string q,
adamc@870 278 string "\\n%s\", msg);",
adamc@870 279 newline],
adamc@870 280 string "}",
adamc@870 281 newline,
adamc@870 282 newline,
adamc@870 283 string "if (strcmp(PQgetvalue(res, 0, 0), \"1\")) {",
adamc@870 284 newline,
adamc@870 285 box [string "PQclear(res);",
adamc@870 286 newline,
adamc@870 287 string "PQfinish(conn);",
adamc@870 288 newline,
adamc@870 289 string "uw_error(ctx, FATAL, \"Sequence '",
adamc@870 290 string s,
adamc@870 291 string "' does not exist.\");",
adamc@870 292 newline],
adamc@870 293 string "}",
adamc@870 294 newline,
adamc@870 295 newline,
adamc@870 296 string "PQclear(res);",
adamc@870 297 newline]
adamc@870 298 end) sequences,
adamc@870 299
adamc@870 300 string "}",
adamc@870 301
adamc@870 302 string "static void uw_db_prepare(uw_context ctx) {",
adamc@866 303 newline,
adamc@866 304 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 305 newline,
adamc@866 306 string "PGresult *res;",
adamc@866 307 newline,
adamc@866 308 newline,
adamc@866 309
adamc@866 310 p_list_sepi newline (fn i => fn (s, n) =>
adamc@866 311 box [string "res = PQprepare(conn, \"uw",
adamc@866 312 string (Int.toString i),
adamc@866 313 string "\", \"",
adamc@866 314 string (String.toString s),
adamc@866 315 string "\", ",
adamc@866 316 string (Int.toString n),
adamc@866 317 string ", NULL);",
adamc@866 318 newline,
adamc@866 319 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 320 newline,
adamc@866 321 box [string "char msg[1024];",
adamc@866 322 newline,
adamc@866 323 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@866 324 newline,
adamc@866 325 string "msg[1023] = 0;",
adamc@866 326 newline,
adamc@866 327 string "PQclear(res);",
adamc@866 328 newline,
adamc@866 329 string "PQfinish(conn);",
adamc@866 330 newline,
adamc@866 331 string "uw_error(ctx, FATAL, \"Unable to create prepared statement:\\n",
adamc@866 332 string (String.toString s),
adamc@866 333 string "\\n%s\", msg);",
adamc@866 334 newline],
adamc@866 335 string "}",
adamc@866 336 newline,
adamc@866 337 string "PQclear(res);",
adamc@866 338 newline])
adamc@866 339 ss,
adamc@866 340
adamc@866 341 string "}",
adamc@866 342 newline,
adamc@866 343 newline,
adamc@866 344
adamc@866 345 string "void uw_db_close(uw_context ctx) {",
adamc@866 346 newline,
adamc@866 347 string "PQfinish(uw_get_db(ctx));",
adamc@866 348 newline,
adamc@866 349 string "}",
adamc@866 350 newline,
adamc@866 351 newline,
adamc@866 352
adamc@866 353 string "int uw_db_begin(uw_context ctx) {",
adamc@866 354 newline,
adamc@866 355 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 356 newline,
adamc@866 357 string "PGresult *res = PQexec(conn, \"BEGIN ISOLATION LEVEL SERIALIZABLE\");",
adamc@866 358 newline,
adamc@866 359 newline,
adamc@866 360 string "if (res == NULL) return 1;",
adamc@866 361 newline,
adamc@866 362 newline,
adamc@866 363 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 364 box [string "PQclear(res);",
adamc@866 365 newline,
adamc@866 366 string "return 1;",
adamc@866 367 newline],
adamc@866 368 string "}",
adamc@866 369 newline,
adamc@866 370 string "return 0;",
adamc@866 371 newline,
adamc@866 372 string "}",
adamc@866 373 newline,
adamc@866 374 newline,
adamc@866 375
adamc@866 376 string "int uw_db_commit(uw_context ctx) {",
adamc@866 377 newline,
adamc@866 378 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 379 newline,
adamc@866 380 string "PGresult *res = PQexec(conn, \"COMMIT\");",
adamc@866 381 newline,
adamc@866 382 newline,
adamc@866 383 string "if (res == NULL) return 1;",
adamc@866 384 newline,
adamc@866 385 newline,
adamc@866 386 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 387 box [string "PQclear(res);",
adamc@866 388 newline,
adamc@866 389 string "return 1;",
adamc@866 390 newline],
adamc@866 391 string "}",
adamc@866 392 newline,
adamc@866 393 string "return 0;",
adamc@866 394 newline,
adamc@866 395 string "}",
adamc@866 396 newline,
adamc@866 397 newline,
adamc@866 398
adamc@866 399 string "int uw_db_rollback(uw_context ctx) {",
adamc@866 400 newline,
adamc@866 401 string "PGconn *conn = uw_get_db(ctx);",
adamc@866 402 newline,
adamc@866 403 string "PGresult *res = PQexec(conn, \"ROLLBACK\");",
adamc@866 404 newline,
adamc@866 405 newline,
adamc@866 406 string "if (res == NULL) return 1;",
adamc@866 407 newline,
adamc@866 408 newline,
adamc@866 409 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@866 410 box [string "PQclear(res);",
adamc@866 411 newline,
adamc@866 412 string "return 1;",
adamc@866 413 newline],
adamc@866 414 string "}",
adamc@866 415 newline,
adamc@866 416 string "return 0;",
adamc@866 417 newline,
adamc@866 418 string "}",
adamc@866 419 newline,
adamc@866 420 newline]
adamc@866 421 else
adamc@870 422 box [string "static void uw_db_validate(uw_context ctx) { }",
adamc@870 423 newline,
adamc@870 424 string "static void uw_db_prepare(uw_context ctx) { }"],
adamc@870 425
adamc@866 426 newline,
adamc@866 427 newline,
adamc@866 428
adamc@866 429 string "void uw_db_init(uw_context ctx) {",
adamc@866 430 newline,
adamc@866 431 string "PGconn *conn = PQconnectdb(\"",
adamc@866 432 string (String.toString dbstring),
adamc@866 433 string "\");",
adamc@866 434 newline,
adamc@866 435 string "if (conn == NULL) uw_error(ctx, FATAL, ",
adamc@866 436 string "\"libpq can't allocate a connection.\");",
adamc@866 437 newline,
adamc@866 438 string "if (PQstatus(conn) != CONNECTION_OK) {",
adamc@866 439 newline,
adamc@866 440 box [string "char msg[1024];",
adamc@866 441 newline,
adamc@866 442 string "strncpy(msg, PQerrorMessage(conn), 1024);",
adamc@866 443 newline,
adamc@866 444 string "msg[1023] = 0;",
adamc@866 445 newline,
adamc@866 446 string "PQfinish(conn);",
adamc@866 447 newline,
adamc@866 448 string "uw_error(ctx, BOUNDED_RETRY, ",
adamc@866 449 string "\"Connection to Postgres server failed: %s\", msg);"],
adamc@866 450 newline,
adamc@866 451 string "}",
adamc@866 452 newline,
adamc@866 453 string "uw_set_db(ctx, conn);",
adamc@866 454 newline,
adamc@866 455 string "uw_db_validate(ctx);",
adamc@866 456 newline,
adamc@866 457 string "uw_db_prepare(ctx);",
adamc@866 458 newline,
adamc@866 459 string "}"]
adamc@866 460
adamc@867 461 fun p_getcol {wontLeakStrings, col = i, typ = t} =
adamc@867 462 let
adamc@867 463 fun p_unsql t e eLen =
adamc@867 464 case t of
adamc@867 465 Int => box [string "uw_Basis_stringToInt_error(ctx, ", e, string ")"]
adamc@867 466 | Float => box [string "uw_Basis_stringToFloat_error(ctx, ", e, string ")"]
adamc@867 467 | String =>
adamc@867 468 if wontLeakStrings then
adamc@867 469 e
adamc@867 470 else
adamc@867 471 box [string "uw_strdup(ctx, ", e, string ")"]
adamc@867 472 | Bool => box [string "uw_Basis_stringToBool_error(ctx, ", e, string ")"]
adamc@867 473 | Time => box [string "uw_Basis_stringToTime_error(ctx, ", e, string ")"]
adamc@867 474 | Blob => box [string "uw_Basis_stringToBlob_error(ctx, ",
adamc@867 475 e,
adamc@867 476 string ", ",
adamc@867 477 eLen,
adamc@867 478 string ")"]
adamc@867 479 | Channel => box [string "uw_Basis_stringToChannel_error(ctx, ", e, string ")"]
adamc@867 480 | Client => box [string "uw_Basis_stringToClient_error(ctx, ", e, string ")"]
adamc@867 481
adamc@867 482 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
adamc@867 483
adamc@867 484 fun getter t =
adamc@867 485 case t of
adamc@867 486 Nullable t =>
adamc@867 487 box [string "(PQgetisnull(res, i, ",
adamc@867 488 string (Int.toString i),
adamc@867 489 string ") ? NULL : ",
adamc@867 490 case t of
adamc@867 491 String => getter t
adamc@867 492 | _ => box [string "({",
adamc@867 493 newline,
adamc@870 494 string (p_sql_type t),
adamc@867 495 space,
adamc@867 496 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@870 497 string (p_sql_type t),
adamc@867 498 string "));",
adamc@867 499 newline,
adamc@867 500 string "*tmp = ",
adamc@867 501 getter t,
adamc@867 502 string ";",
adamc@867 503 newline,
adamc@867 504 string "tmp;",
adamc@867 505 newline,
adamc@867 506 string "})"],
adamc@867 507 string ")"]
adamc@867 508 | _ =>
adamc@867 509 box [string "(PQgetisnull(res, i, ",
adamc@867 510 string (Int.toString i),
adamc@867 511 string ") ? ",
adamc@867 512 box [string "({",
adamc@870 513 string (p_sql_type t),
adamc@867 514 space,
adamc@867 515 string "tmp;",
adamc@867 516 newline,
adamc@867 517 string "uw_error(ctx, FATAL, \"Unexpectedly NULL field #",
adamc@867 518 string (Int.toString i),
adamc@867 519 string "\");",
adamc@867 520 newline,
adamc@867 521 string "tmp;",
adamc@867 522 newline,
adamc@867 523 string "})"],
adamc@867 524 string " : ",
adamc@867 525 p_unsql t
adamc@867 526 (box [string "PQgetvalue(res, i, ",
adamc@867 527 string (Int.toString i),
adamc@867 528 string ")"])
adamc@867 529 (box [string "PQgetlength(res, i, ",
adamc@867 530 string (Int.toString i),
adamc@867 531 string ")"]),
adamc@867 532 string ")"]
adamc@867 533 in
adamc@867 534 getter t
adamc@867 535 end
adamc@867 536
adamc@867 537 fun queryCommon {loc, query, numCols, doCols} =
adamc@867 538 box [string "int n, i;",
adamc@867 539 newline,
adamc@867 540 newline,
adamc@867 541
adamc@867 542 string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating query result.\");",
adamc@867 543 newline,
adamc@867 544 newline,
adamc@867 545
adamc@867 546 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@867 547 newline,
adamc@867 548 box [string "PQclear(res);",
adamc@867 549 newline,
adamc@867 550 string "uw_error(ctx, FATAL, \"",
adamc@867 551 string (ErrorMsg.spanToString loc),
adamc@867 552 string ": Query failed:\\n%s\\n%s\", ",
adamc@867 553 query,
adamc@867 554 string ", PQerrorMessage(conn));",
adamc@867 555 newline],
adamc@867 556 string "}",
adamc@867 557 newline,
adamc@867 558 newline,
adamc@867 559
adamc@867 560 string "if (PQnfields(res) != ",
adamc@867 561 string (Int.toString numCols),
adamc@867 562 string ") {",
adamc@867 563 newline,
adamc@867 564 box [string "int nf = PQnfields(res);",
adamc@867 565 newline,
adamc@867 566 string "PQclear(res);",
adamc@867 567 newline,
adamc@867 568 string "uw_error(ctx, FATAL, \"",
adamc@867 569 string (ErrorMsg.spanToString loc),
adamc@867 570 string ": Query returned %d columns instead of ",
adamc@867 571 string (Int.toString numCols),
adamc@867 572 string ":\\n%s\\n%s\", nf, ",
adamc@867 573 query,
adamc@867 574 string ", PQerrorMessage(conn));",
adamc@867 575 newline],
adamc@867 576 string "}",
adamc@867 577 newline,
adamc@867 578 newline,
adamc@867 579
adamc@867 580 string "uw_end_region(ctx);",
adamc@867 581 newline,
adamc@867 582 string "uw_push_cleanup(ctx, (void (*)(void *))PQclear, res);",
adamc@867 583 newline,
adamc@867 584 string "n = PQntuples(res);",
adamc@867 585 newline,
adamc@867 586 string "for (i = 0; i < n; ++i) {",
adamc@867 587 newline,
adamc@867 588 doCols p_getcol,
adamc@867 589 string "}",
adamc@867 590 newline,
adamc@867 591 newline,
adamc@867 592 string "uw_pop_cleanup(ctx);",
adamc@867 593 newline]
adamc@867 594
adamc@867 595 fun query {loc, numCols, doCols} =
adamc@867 596 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867 597 newline,
adamc@867 598 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
adamc@867 599 newline,
adamc@867 600 newline,
adamc@867 601 queryCommon {loc = loc, numCols = numCols, doCols = doCols, query = string "query"}]
adamc@867 602
adamc@867 603 fun p_ensql t e =
adamc@867 604 case t of
adamc@867 605 Int => box [string "uw_Basis_attrifyInt(ctx, ", e, string ")"]
adamc@867 606 | Float => box [string "uw_Basis_attrifyFloat(ctx, ", e, string ")"]
adamc@867 607 | String => e
adamc@867 608 | Bool => box [string "(", e, string " ? \"TRUE\" : \"FALSE\")"]
adamc@867 609 | Time => box [string "uw_Basis_attrifyTime(ctx, ", e, string ")"]
adamc@867 610 | Blob => box [e, string ".data"]
adamc@867 611 | Channel => box [string "uw_Basis_attrifyChannel(ctx, ", e, string ")"]
adamc@867 612 | Client => box [string "uw_Basis_attrifyClient(ctx, ", e, string ")"]
adamc@867 613 | Nullable String => e
adamc@867 614 | Nullable t => box [string "(",
adamc@867 615 e,
adamc@867 616 string " == NULL ? NULL : ",
adamc@867 617 p_ensql t (box [string "(*", e, string ")"]),
adamc@867 618 string ")"]
adamc@867 619
adamc@867 620 fun queryPrepared {loc, id, query, inputs, numCols, doCols} =
adamc@867 621 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@867 622 newline,
adamc@867 623 string "const int paramFormats[] = { ",
adamc@867 624 p_list_sep (box [string ",", space])
adamc@867 625 (fn t => if isBlob t then string "1" else string "0") inputs,
adamc@867 626 string " };",
adamc@867 627 newline,
adamc@867 628 string "const int paramLengths[] = { ",
adamc@867 629 p_list_sepi (box [string ",", space])
adamc@867 630 (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adamc@867 631 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adamc@867 632 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adamc@867 633 | _ => string "0") inputs,
adamc@867 634 string " };",
adamc@867 635 newline,
adamc@867 636 string "const char *paramValues[] = { ",
adamc@867 637 p_list_sepi (box [string ",", space])
adamc@867 638 (fn i => fn t => p_ensql t (box [string "arg",
adamc@867 639 string (Int.toString (i + 1))]))
adamc@867 640 inputs,
adamc@867 641 string " };",
adamc@867 642 newline,
adamc@867 643 newline,
adamc@867 644 string "PGresult *res = ",
adamc@867 645 if #persistent (Settings.currentProtocol ()) then
adamc@867 646 box [string "PQexecPrepared(conn, \"uw",
adamc@867 647 string (Int.toString id),
adamc@867 648 string "\", ",
adamc@867 649 string (Int.toString (length inputs)),
adamc@867 650 string ", paramValues, paramLengths, paramFormats, 0);"]
adamc@867 651 else
adamc@867 652 box [string "PQexecParams(conn, \"",
adamc@867 653 string (String.toString query),
adamc@867 654 string "\", ",
adamc@867 655 string (Int.toString (length inputs)),
adamc@867 656 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
adamc@867 657 newline,
adamc@867 658 newline,
adamc@867 659 queryCommon {loc = loc, numCols = numCols, doCols = doCols, query = box [string "\"",
adamc@867 660 string (String.toString query),
adamc@867 661 string "\""]}]
adamc@867 662
adamc@868 663 fun dmlCommon {loc, dml} =
adamc@868 664 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating DML result.\");",
adamc@868 665 newline,
adamc@868 666 newline,
adamc@868 667
adamc@868 668 string "if (PQresultStatus(res) != PGRES_COMMAND_OK) {",
adamc@868 669 newline,
adamc@868 670 box [string "if (!strcmp(PQresultErrorField(res, PG_DIAG_SQLSTATE), \"40001\")) {",
adamc@868 671 box [newline,
adamc@868 672 string "PQclear(res);",
adamc@868 673 newline,
adamc@868 674 string "uw_error(ctx, UNLIMITED_RETRY, \"Serialization failure\");",
adamc@868 675 newline],
adamc@868 676 string "}",
adamc@868 677 newline,
adamc@868 678 string "PQclear(res);",
adamc@868 679 newline,
adamc@868 680 string "uw_error(ctx, FATAL, \"",
adamc@868 681 string (ErrorMsg.spanToString loc),
adamc@868 682 string ": DML failed:\\n%s\\n%s\", ",
adamc@868 683 dml,
adamc@868 684 string ", PQerrorMessage(conn));",
adamc@868 685 newline],
adamc@868 686 string "}",
adamc@868 687 newline,
adamc@868 688 newline,
adamc@868 689
adamc@868 690 string "PQclear(res);",
adamc@868 691 newline]
adamc@868 692
adamc@868 693 fun dml loc =
adamc@868 694 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868 695 newline,
adamc@868 696 string "PGresult *res = PQexecParams(conn, dml, 0, NULL, NULL, NULL, NULL, 0);",
adamc@868 697 newline,
adamc@868 698 newline,
adamc@868 699 dmlCommon {loc = loc, dml = string "dml"}]
adamc@868 700
adamc@868 701 fun dmlPrepared {loc, id, dml, inputs} =
adamc@868 702 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@868 703 newline,
adamc@868 704 string "const int paramFormats[] = { ",
adamc@868 705 p_list_sep (box [string ",", space])
adamc@868 706 (fn t => if isBlob t then string "1" else string "0") inputs,
adamc@868 707 string " };",
adamc@868 708 newline,
adamc@868 709 string "const int paramLengths[] = { ",
adamc@868 710 p_list_sepi (box [string ",", space])
adamc@868 711 (fn i => fn Blob => string ("arg" ^ Int.toString (i + 1) ^ ".size")
adamc@868 712 | Nullable Blob => string ("arg" ^ Int.toString (i + 1)
adamc@868 713 ^ "?arg" ^ Int.toString (i + 1) ^ "->size:0")
adamc@868 714 | _ => string "0") inputs,
adamc@868 715 string " };",
adamc@868 716 newline,
adamc@868 717 string "const char *paramValues[] = { ",
adamc@868 718 p_list_sepi (box [string ",", space])
adamc@868 719 (fn i => fn t => p_ensql t (box [string "arg",
adamc@868 720 string (Int.toString (i + 1))]))
adamc@868 721 inputs,
adamc@868 722 string " };",
adamc@868 723 newline,
adamc@868 724 newline,
adamc@868 725 string "PGresult *res = ",
adamc@868 726 if #persistent (Settings.currentProtocol ()) then
adamc@868 727 box [string "PQexecPrepared(conn, \"uw",
adamc@868 728 string (Int.toString id),
adamc@868 729 string "\", ",
adamc@868 730 string (Int.toString (length inputs)),
adamc@868 731 string ", paramValues, paramLengths, paramFormats, 0);"]
adamc@868 732 else
adamc@868 733 box [string "PQexecParams(conn, \"",
adamc@868 734 string (String.toString dml),
adamc@868 735 string "\", ",
adamc@868 736 string (Int.toString (length inputs)),
adamc@868 737 string ", NULL, paramValues, paramLengths, paramFormats, 0);"],
adamc@868 738 newline,
adamc@868 739 newline,
adamc@868 740 dmlCommon {loc = loc, dml = box [string "\"",
adamc@868 741 string (String.toString dml),
adamc@868 742 string "\""]}]
adamc@868 743
adamc@869 744 fun nextvalCommon {loc, query} =
adamc@869 745 box [string "if (res == NULL) uw_error(ctx, FATAL, \"Out of memory allocating nextval result.\");",
adamc@869 746 newline,
adamc@869 747 newline,
adamc@869 748
adamc@869 749 string "if (PQresultStatus(res) != PGRES_TUPLES_OK) {",
adamc@869 750 newline,
adamc@869 751 box [string "PQclear(res);",
adamc@869 752 newline,
adamc@869 753 string "uw_error(ctx, FATAL, \"",
adamc@869 754 string (ErrorMsg.spanToString loc),
adamc@869 755 string ": Query failed:\\n%s\\n%s\", ",
adamc@869 756 query,
adamc@869 757 string ", PQerrorMessage(conn));",
adamc@869 758 newline],
adamc@869 759 string "}",
adamc@869 760 newline,
adamc@869 761 newline,
adamc@869 762
adamc@869 763 string "uw_end_region(ctx);",
adamc@869 764 newline,
adamc@869 765 string "n = PQntuples(res);",
adamc@869 766 newline,
adamc@869 767 string "if (n != 1) {",
adamc@869 768 newline,
adamc@869 769 box [string "PQclear(res);",
adamc@869 770 newline,
adamc@869 771 string "uw_error(ctx, FATAL, \"",
adamc@869 772 string (ErrorMsg.spanToString loc),
adamc@869 773 string ": Wrong number of result rows:\\n%s\\n%s\", ",
adamc@869 774 query,
adamc@869 775 string ", PQerrorMessage(conn));",
adamc@869 776 newline],
adamc@869 777 string "}",
adamc@869 778 newline,
adamc@869 779 newline,
adamc@869 780
adamc@869 781 string "n = uw_Basis_stringToInt_error(ctx, PQgetvalue(res, 0, 0));",
adamc@869 782 newline,
adamc@869 783 string "PQclear(res);",
adamc@869 784 newline]
adamc@869 785
adamc@869 786 fun nextval loc =
adamc@869 787 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@869 788 newline,
adamc@869 789 string "PGresult *res = PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);",
adamc@869 790 newline,
adamc@869 791 newline,
adamc@869 792 nextvalCommon {loc = loc, query = string "query"}]
adamc@869 793
adamc@869 794 fun nextvalPrepared {loc, id, query} =
adamc@869 795 box [string "PGconn *conn = uw_get_db(ctx);",
adamc@869 796 newline,
adamc@869 797 newline,
adamc@869 798 string "PGresult *res = ",
adamc@869 799 if #persistent (Settings.currentProtocol ()) then
adamc@869 800 box [string "PQexecPrepared(conn, \"uw",
adamc@869 801 string (Int.toString id),
adamc@869 802 string "\", 0, NULL, NULL, NULL, 0);"]
adamc@869 803 else
adamc@869 804 box [string "PQexecParams(conn, \"",
adamc@869 805 string (String.toString query),
adamc@869 806 string "\", 0, NULL, NULL, NULL, NULL, 0);"],
adamc@869 807 newline,
adamc@869 808 newline,
adamc@869 809 nextvalCommon {loc = loc, query = box [string "\"",
adamc@869 810 string (String.toString query),
adamc@869 811 string "\""]}]
adamc@869 812
adamc@866 813 val () = addDbms {name = "postgres",
adamc@866 814 header = "postgresql/libpq-fe.h",
adamc@866 815 link = "-lpq",
adamc@866 816 global_init = box [string "void uw_client_init() { }",
adamc@866 817 newline],
adamc@867 818 init = init,
adamc@867 819 query = query,
adamc@868 820 queryPrepared = queryPrepared,
adamc@868 821 dml = dml,
adamc@869 822 dmlPrepared = dmlPrepared,
adamc@869 823 nextval = nextval,
adamc@869 824 nextvalPrepared = nextvalPrepared}
adamc@866 825 val () = setDbms "postgres"
adamc@866 826
adamc@866 827 end