Mercurial > urweb

annotate src/postgres.sml @ 1034:a779402841f6

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