Mercurial > urweb

annotate src/sqlite.sml @ 2258:b1ba35ce2613

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fix bug where pure caching didn't treat FFI applications as effectful.
author Ziv Scully <ziv@mit.edu>
date Sun, 27 Sep 2015 17:02:14 -0400
parents 661b531f55bd
children
rev   line source
adam@1656 1 (* Copyright (c) 2009-2010, Adam Chlipala
adamc@885 2 * All rights reserved.
adamc@885 3 *
adamc@885 4 * Redistribution and use in source and binary forms, with or without
adamc@885 5 * modification, are permitted provided that the following conditions are met:
adamc@885 6 *
adamc@885 7 * - Redistributions of source code must retain the above copyright notice,
adamc@885 8 * this list of conditions and the following disclaimer.
adamc@885 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@885 10 * this list of conditions and the following disclaimer in the documentation
adamc@885 11 * and/or other materials provided with the distribution.
adamc@885 12 * - The names of contributors may not be used to endorse or promote products
adamc@885 13 * derived from this software without specific prior written permission.
adamc@885 14 *
adamc@885 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@885 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@885 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@885 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adam@1682 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@885 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@885 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@885 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@885 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@885 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@885 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@885 26 *)
adamc@885 27
adamc@885 28 structure SQLite :> SQLITE = struct
adamc@885 29
adamc@885 30 open Settings
adamc@885 31 open Print.PD
adamc@885 32 open Print
adamc@885 33
adamc@885 34 fun p_sql_type t =
adamc@885 35 case t of
adamc@885 36 Int => "integer"
adamc@885 37 | Float => "real"
adamc@885 38 | String => "text"
adamc@1014 39 | Char => "text"
adamc@885 40 | Bool => "integer"
adamc@887 41 | Time => "text"
adamc@885 42 | Blob => "blob"
adamc@885 43 | Channel => "integer"
adamc@885 44 | Client => "integer"
adamc@885 45 | Nullable t => p_sql_type t
adamc@885 46
adamc@885 47 val ident = String.translate (fn #"'" => "PRIME"
adamc@885 48 | ch => str ch)
adamc@885 49
adamc@885 50 fun checkRel (table, checkNullable) (s, xts) =
adamc@885 51 let
adamc@885 52 val q = "SELECT COUNT(*) FROM sqlite_master WHERE type = '" ^ table ^ "' AND name = '"
adamc@885 53 ^ s ^ "'"
adamc@885 54 in
adamc@885 55 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adamc@885 56 string q,
adamc@885 57 string "\", -1, &stmt, NULL) != SQLITE_OK) {",
adamc@885 58 newline,
adamc@885 59 box [string "sqlite3_close(conn->conn);",
adamc@885 60 newline,
adamc@1266 61 string "uw_error(ctx, FATAL, \"Query preparation failed:<br />",
adamc@885 62 string q,
adamc@885 63 string "\");",
adamc@885 64 newline],
adamc@885 65 string "}",
adamc@885 66 newline,
adamc@885 67 newline,
adamc@885 68
adamc@885 69 string "while ((res = sqlite3_step(stmt)) == SQLITE_BUSY)",
adamc@885 70 newline,
adamc@885 71 box [string "sleep(1);",
adamc@885 72 newline],
adamc@885 73 newline,
adamc@885 74 string "if (res == SQLITE_DONE) {",
adamc@885 75 newline,
adamc@885 76 box [string "sqlite3_finalize(stmt);",
adamc@885 77 newline,
adamc@885 78 string "sqlite3_close(conn->conn);",
adamc@885 79 newline,
adamc@1266 80 string "uw_error(ctx, FATAL, \"No row returned:<br />",
adamc@885 81 string q,
adamc@885 82 string "\");",
adamc@885 83 newline],
adamc@885 84 string "}",
adamc@885 85 newline,
adamc@885 86 newline,
adamc@885 87 string "if (res != SQLITE_ROW) {",
adamc@885 88 newline,
adamc@885 89 box [string "sqlite3_finalize(stmt);",
adamc@885 90 newline,
adamc@885 91 string "sqlite3_close(conn->conn);",
adamc@885 92 newline,
adamc@1266 93 string "uw_error(ctx, FATAL, \"Error getting row:<br />",
adamc@885 94 string q,
adamc@885 95 string "\");",
adamc@885 96 newline],
adamc@885 97 string "}",
adamc@885 98 newline,
adamc@885 99 newline,
adamc@885 100
adamc@885 101 string "if (sqlite3_column_count(stmt) != 1) {",
adamc@885 102 newline,
adamc@885 103 box [string "sqlite3_finalize(stmt);",
adamc@885 104 newline,
adamc@885 105 string "sqlite3_close(conn->conn);",
adamc@885 106 newline,
adamc@1266 107 string "uw_error(ctx, FATAL, \"Bad column count:<br />",
adamc@885 108 string q,
adamc@885 109 string "\");",
adamc@885 110 newline],
adamc@885 111 string "}",
adamc@885 112 newline,
adamc@885 113 newline,
adamc@885 114
adamc@885 115 string "if (sqlite3_column_int(stmt, 0) != 1) {",
adamc@885 116 newline,
adamc@885 117 box [string "sqlite3_finalize(stmt);",
adamc@885 118 newline,
adamc@885 119 string "sqlite3_close(conn->conn);",
adamc@885 120 newline,
adamc@885 121 string "uw_error(ctx, FATAL, \"Table '",
adamc@885 122 string s,
adamc@885 123 string "' does not exist.\");",
adamc@885 124 newline],
adamc@885 125 string "}",
adamc@885 126 newline,
adamc@885 127 newline,
adamc@885 128 string "sqlite3_finalize(stmt);",
adamc@885 129 newline]
adamc@885 130 end
adamc@885 131
adamc@885 132 fun init {dbstring, prepared = ss, tables, views, sequences} =
adamc@885 133 let
adamc@885 134 val db = ref dbstring
adamc@885 135 in
adamc@885 136 app (fn s =>
adamc@885 137 case String.fields (fn ch => ch = #"=") s of
adamc@885 138 [name, value] =>
adamc@885 139 (case name of
adamc@885 140 "dbname" => db := value
adamc@885 141 | _ => ())
adamc@885 142 | _ => ()) (String.tokens Char.isSpace dbstring);
adamc@885 143
adamc@885 144 box [string "typedef struct {",
adamc@885 145 newline,
adamc@885 146 box [string "sqlite3 *conn;",
adamc@885 147 newline,
adamc@885 148 p_list_sepi (box [])
adamc@885 149 (fn i => fn _ =>
adamc@885 150 box [string "sqlite3_stmt *p",
adamc@885 151 string (Int.toString i),
adamc@885 152 string ";",
adamc@885 153 newline])
adamc@885 154 ss],
adamc@885 155 string "} uw_conn;",
adamc@885 156 newline,
adamc@885 157 newline,
adamc@885 158
adamc@1094 159 string "static void uw_client_init(void) {",
adamc@885 160 newline,
adamc@885 161 box [string "uw_sqlfmtInt = \"%lld%n\";",
adamc@885 162 newline,
adam@1920 163 string "uw_sqlfmtFloat = \"%.16g%n\";",
adamc@885 164 newline,
adamc@885 165 string "uw_Estrings = 0;",
adamc@885 166 newline,
adam@1834 167 string "uw_sql_type_annotations = 0;",
adam@1834 168 newline,
adamc@885 169 string "uw_sqlsuffixString = \"\";",
adamc@885 170 newline,
adamc@1011 171 string "uw_sqlsuffixChar = \"\";",
adamc@1011 172 newline,
adamc@885 173 string "uw_sqlsuffixBlob = \"\";",
adamc@885 174 newline,
adamc@885 175 string "uw_sqlfmtUint4 = \"%u%n\";",
adamc@885 176 newline],
adamc@885 177 string "}",
adamc@885 178 newline,
adamc@885 179 newline,
adamc@885 180
adamc@885 181 if #persistent (currentProtocol ()) then
adamc@885 182 box [string "static void uw_db_validate(uw_context ctx) {",
adamc@885 183 newline,
adamc@885 184 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 185 newline,
adamc@885 186 string "sqlite3_stmt *stmt;",
adamc@885 187 newline,
adamc@885 188 string "int res;",
adamc@885 189 newline,
adamc@885 190 newline,
adamc@885 191 p_list_sep newline (checkRel ("table", true)) tables,
adamc@885 192 p_list_sep newline (fn name => checkRel ("table", true)
adamc@885 193 (name, [("id", Settings.Client)])) sequences,
adamc@885 194 p_list_sep newline (checkRel ("view", false)) views,
adamc@885 195 string "}",
adamc@885 196 newline,
adamc@885 197 newline,
adamc@885 198
adamc@885 199 string "static void uw_db_prepare(uw_context ctx) {",
adamc@885 200 newline,
adamc@885 201 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 202 newline,
adamc@885 203 newline,
adamc@885 204
adam@2103 205 p_list_sepi newline (fn i => fn (s, _) =>
adamc@885 206 let
adamc@885 207 fun uhoh this s args =
adamc@885 208 box [p_list_sepi (box [])
adamc@885 209 (fn j => fn () =>
adamc@885 210 box [string
adamc@885 211 "sqlite3_finalize(conn->p",
adamc@885 212 string (Int.toString j),
adamc@885 213 string ");",
adamc@885 214 newline])
adamc@885 215 (List.tabulate (i, fn _ => ())),
adamc@885 216 box (if this then
adamc@885 217 [string
adamc@885 218 "sqlite3_finalize(conn->p",
adamc@885 219 string (Int.toString i),
adamc@885 220 string ");",
adamc@885 221 newline]
adamc@885 222 else
adamc@885 223 []),
adamc@885 224 string "sqlite3_close(conn->conn);",
adamc@885 225 newline,
adamc@885 226 string "uw_error(ctx, FATAL, \"",
adamc@885 227 string s,
adamc@885 228 string "\"",
adamc@885 229 p_list_sep (box []) (fn s => box [string ", ",
adamc@885 230 string s]) args,
adamc@885 231 string ");",
adamc@885 232 newline]
adamc@885 233 in
adamc@885 234 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adam@1656 235 string (Prim.toCString s),
adamc@885 236 string "\", -1, &conn->p",
adamc@885 237 string (Int.toString i),
adamc@885 238 string ", NULL) != SQLITE_OK) {",
adamc@885 239 newline,
adamc@886 240 box [string "char msg[1024];",
adamc@886 241 newline,
adamc@886 242 string "strncpy(msg, sqlite3_errmsg(conn->conn), 1024);",
adamc@886 243 newline,
adamc@886 244 string "msg[1023] = 0;",
adamc@886 245 newline,
adamc@886 246 uhoh false ("Error preparing statement: "
adam@1656 247 ^ Prim.toCString s ^ "<br />%s") ["msg"]],
adamc@885 248 string "}",
adamc@885 249 newline]
adamc@885 250 end)
adamc@885 251 ss,
adamc@885 252
adamc@885 253 string "}"]
adamc@885 254 else
adamc@885 255 box [string "static void uw_db_prepare(uw_context ctx) { }",
adamc@885 256 newline,
adamc@885 257 string "static void uw_db_validate(uw_context ctx) { }"],
adamc@885 258 newline,
adamc@885 259 newline,
adam@1682 260
adamc@1094 261 string "static void uw_db_init(uw_context ctx) {",
adamc@885 262 newline,
adamc@885 263 string "sqlite3 *sqlite;",
adamc@885 264 newline,
adamc@1115 265 string "sqlite3_stmt *stmt;",
adamc@1115 266 newline,
adamc@885 267 string "uw_conn *conn;",
adamc@885 268 newline,
adamc@885 269 newline,
adamc@885 270 string "if (sqlite3_open(\"",
adamc@885 271 string (!db),
adamc@885 272 string "\", &sqlite) != SQLITE_OK) uw_error(ctx, FATAL, ",
adamc@885 273 string "\"Can't open SQLite database.\");",
adamc@885 274 newline,
adamc@885 275 newline,
adamc@1115 276 string "if (uw_database_max < SIZE_MAX) {",
adamc@1115 277 newline,
adamc@1115 278 box [string "char buf[100];",
adamc@1115 279 newline,
adamc@1115 280 newline,
adamc@1115 281
adamc@1115 282 string "sprintf(buf, \"PRAGMA max_page_count = %llu\", (unsigned long long)(uw_database_max / 1024));",
adamc@1115 283 newline,
adamc@1115 284 newline,
adamc@1115 285
adamc@1115 286 string "if (sqlite3_prepare_v2(sqlite, buf, -1, &stmt, NULL) != SQLITE_OK) {",
adamc@1115 287 newline,
adamc@1115 288 box [string "sqlite3_close(sqlite);",
adamc@1115 289 newline,
adamc@1115 290 string "uw_error(ctx, FATAL, \"Can't prepare max_page_count query for SQLite database\");",
adamc@1115 291 newline],
adamc@1115 292 string "}",
adamc@1115 293 newline,
adamc@1115 294 newline,
adamc@1115 295
adamc@1115 296 string "if (sqlite3_step(stmt) != SQLITE_ROW) {",
adamc@1115 297 newline,
adamc@1115 298 box [string "sqlite3_finalize(stmt);",
adamc@1115 299 newline,
adamc@1115 300 string "sqlite3_close(sqlite);",
adamc@1115 301 newline,
adamc@1115 302 string "uw_error(ctx, FATAL, \"Can't set max_page_count parameter for SQLite database\");",
adamc@1115 303 newline],
adamc@1115 304 string "}",
adamc@1115 305 newline,
adamc@1115 306 newline,
adamc@1115 307
adamc@1115 308 string "sqlite3_finalize(stmt);",
adamc@1115 309 newline],
adamc@1115 310 string "}",
adamc@1115 311 newline,
adamc@1115 312 newline,
adam@1682 313
adamc@885 314 string "conn = calloc(1, sizeof(uw_conn));",
adamc@885 315 newline,
adamc@885 316 string "conn->conn = sqlite;",
adamc@885 317 newline,
adamc@885 318 string "uw_set_db(ctx, conn);",
adamc@885 319 newline,
adamc@885 320 string "uw_db_validate(ctx);",
adamc@885 321 newline,
adamc@885 322 string "uw_db_prepare(ctx);",
adamc@885 323 newline,
adamc@885 324 string "}",
adamc@885 325 newline,
adamc@885 326 newline,
adamc@885 327
adamc@1094 328 string "static void uw_db_close(uw_context ctx) {",
adamc@885 329 newline,
adamc@885 330 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 331 newline,
adamc@885 332 p_list_sepi (box [])
adamc@885 333 (fn i => fn _ =>
adamc@885 334 box [string "if (conn->p",
adamc@885 335 string (Int.toString i),
adamc@885 336 string ") sqlite3_finalize(conn->p",
adamc@885 337 string (Int.toString i),
adamc@885 338 string ");",
adamc@885 339 newline])
adamc@885 340 ss,
adamc@885 341 string "sqlite3_close(conn->conn);",
adamc@885 342 newline,
adamc@885 343 string "}",
adamc@885 344 newline,
adamc@885 345 newline,
adamc@885 346
adam@1936 347 string "static int uw_db_begin(uw_context ctx, int could_write) {",
adamc@885 348 newline,
adamc@885 349 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 350 newline,
adamc@885 351 newline,
adamc@885 352 string "if (sqlite3_exec(conn->conn, \"BEGIN\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 353 newline,
adamc@885 354 box [string "return 0;",
adamc@885 355 newline],
adamc@885 356 string "else {",
adamc@885 357 newline,
adamc@1266 358 box [string "fprintf(stderr, \"Begin error: %s<br />\", sqlite3_errmsg(conn->conn));",
adamc@885 359 newline,
adamc@885 360 string "return 1;",
adamc@885 361 newline],
adamc@885 362 string "}",
adamc@885 363 newline,
adamc@885 364 string "}",
adamc@885 365 newline,
adamc@1094 366 string "static int uw_db_commit(uw_context ctx) {",
adamc@885 367 newline,
adamc@885 368 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 369 newline,
adamc@885 370 string "if (sqlite3_exec(conn->conn, \"COMMIT\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 371 newline,
adamc@885 372 box [string "return 0;",
adamc@885 373 newline],
adamc@885 374 string "else {",
adamc@885 375 newline,
adamc@1266 376 box [string "fprintf(stderr, \"Commit error: %s<br />\", sqlite3_errmsg(conn->conn));",
adamc@885 377 newline,
adamc@885 378 string "return 1;",
adamc@885 379 newline],
adamc@885 380 string "}",
adamc@885 381 newline,
adamc@885 382 string "}",
adamc@885 383 newline,
adamc@885 384 newline,
adamc@885 385
adamc@1094 386 string "static int uw_db_rollback(uw_context ctx) {",
adamc@885 387 newline,
adamc@885 388 string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 389 newline,
adamc@885 390 string "if (sqlite3_exec(conn->conn, \"ROLLBACK\", NULL, NULL, NULL) == SQLITE_OK)",
adamc@885 391 newline,
adamc@885 392 box [string "return 0;",
adamc@885 393 newline],
adamc@885 394 string "else {",
adamc@885 395 newline,
adamc@1266 396 box [string "fprintf(stderr, \"Rollback error: %s<br />\", sqlite3_errmsg(conn->conn));",
adamc@885 397 newline,
adamc@885 398 string "return 1;",
adamc@885 399 newline],
adamc@885 400 string "}",
adamc@885 401 newline,
adamc@885 402 string "}",
adamc@885 403 newline,
adamc@885 404 newline]
adamc@885 405 end
adamc@885 406
adam@1352 407 val fmt = "\"%Y-%m-%d %H:%M:%S\""
adam@1352 408
adamc@885 409 fun p_getcol {loc, wontLeakStrings, col = i, typ = t} =
adamc@885 410 let
adamc@885 411 fun p_unsql t =
adamc@885 412 case t of
adamc@885 413 Int => box [string "sqlite3_column_int64(stmt, ", string (Int.toString i), string ")"]
adamc@885 414 | Float => box [string "sqlite3_column_double(stmt, ", string (Int.toString i), string ")"]
adamc@885 415 | String =>
adamc@885 416 if wontLeakStrings then
adamc@1014 417 box [string "(uw_Basis_string)sqlite3_column_text(stmt, ", string (Int.toString i), string ")"]
adamc@885 418 else
adamc@1014 419 box [string "uw_strdup(ctx, (uw_Basis_string)sqlite3_column_text(stmt, ", string (Int.toString i), string "))"]
adamc@1014 420 | Char => box [string "sqlite3_column_text(stmt, ", string (Int.toString i), string ")[0]"]
adamc@885 421 | Bool => box [string "(uw_Basis_bool)sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
adam@1352 422 | Time => box [string "uw_Basis_stringToTimef_error(ctx, ",
adam@1352 423 string fmt,
adam@1352 424 string ", (uw_Basis_string)sqlite3_column_text(stmt, ",
adam@1352 425 string (Int.toString i),
adam@1352 426 string "))"]
adamc@885 427 | Blob => box [string "({",
adamc@885 428 newline,
adamc@890 429 string "char *data = (char *)sqlite3_column_blob(stmt, ",
adamc@885 430 string (Int.toString i),
adamc@885 431 string ");",
adamc@885 432 newline,
adamc@890 433 string "int len = sqlite3_column_bytes(stmt, ",
adamc@885 434 string (Int.toString i),
adamc@890 435 string ");",
adamc@890 436 newline,
adamc@890 437 string "uw_Basis_blob b = {len, uw_memdup(ctx, data, len)};",
adamc@885 438 newline,
adamc@885 439 string "b;",
adamc@885 440 newline,
adamc@885 441 string "})"]
adamc@886 442 | Channel => box [string "({",
adamc@886 443 newline,
adamc@886 444 string "sqlite3_int64 n = sqlite3_column_int64(stmt, ",
adamc@886 445 string (Int.toString i),
adamc@886 446 string ");",
adamc@886 447 newline,
adamc@886 448 string "uw_Basis_channel ch = {n >> 32, n & 0xFFFFFFFF};",
adamc@886 449 newline,
adamc@886 450 string "ch;",
adamc@886 451 newline,
adamc@886 452 string "})"]
adamc@885 453 | Client => box [string "sqlite3_column_int(stmt, ", string (Int.toString i), string ")"]
adamc@885 454
adamc@885 455 | Nullable _ => raise Fail "Postgres: Recursive Nullable"
adamc@885 456
adamc@885 457 fun getter t =
adamc@885 458 case t of
adamc@885 459 Nullable t =>
adamc@885 460 box [string "(sqlite3_column_type(stmt, ",
adamc@885 461 string (Int.toString i),
adamc@885 462 string ") == SQLITE_NULL ? NULL : ",
adamc@885 463 case t of
adamc@885 464 String => getter t
adamc@885 465 | _ => box [string "({",
adamc@885 466 newline,
adamc@885 467 string (p_sql_ctype t),
adamc@885 468 space,
adamc@885 469 string "*tmp = uw_malloc(ctx, sizeof(",
adamc@885 470 string (p_sql_ctype t),
adamc@885 471 string "));",
adamc@885 472 newline,
adamc@885 473 string "*tmp = ",
adamc@885 474 getter t,
adamc@885 475 string ";",
adamc@885 476 newline,
adamc@885 477 string "tmp;",
adamc@885 478 newline,
adamc@885 479 string "})"],
adamc@885 480 string ")"]
adamc@885 481 | _ =>
adamc@885 482 box [string "(sqlite3_column_type(stmt, ",
adamc@885 483 string (Int.toString i),
adamc@885 484 string ") == SQLITE_NULL ? ",
adamc@885 485 box [string "({",
adamc@885 486 string (p_sql_ctype t),
adamc@885 487 space,
adamc@885 488 string "tmp;",
adamc@885 489 newline,
adamc@885 490 string "uw_error(ctx, FATAL, \"",
adamc@885 491 string (ErrorMsg.spanToString loc),
adamc@885 492 string ": Unexpectedly NULL field #",
adamc@885 493 string (Int.toString i),
adamc@885 494 string "\");",
adamc@885 495 newline,
adamc@885 496 string "tmp;",
adamc@885 497 newline,
adamc@885 498 string "})"],
adamc@885 499 string " : ",
adamc@885 500 p_unsql t,
adamc@885 501 string ")"]
adamc@885 502 in
adamc@885 503 getter t
adamc@885 504 end
adamc@885 505
adamc@885 506 fun queryCommon {loc, query, cols, doCols} =
adamc@885 507 box [string "int r;",
adamc@885 508 newline,
adamc@885 509
adamc@885 510 string "sqlite3_reset(stmt);",
adamc@885 511 newline,
adamc@885 512
adamc@885 513 string "uw_end_region(ctx);",
adamc@885 514 newline,
adamc@885 515 string "while ((r = sqlite3_step(stmt)) == SQLITE_ROW) {",
adamc@885 516 newline,
adamc@885 517 doCols p_getcol,
adamc@885 518 string "}",
adamc@885 519 newline,
adamc@885 520 newline,
adamc@885 521
adamc@885 522 string "if (r == SQLITE_BUSY) {",
adamc@885 523 box [string "sleep(1);",
adamc@885 524 newline,
adamc@885 525 string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");",
adamc@885 526 newline],
adamc@885 527 string "}",
adamc@885 528 newline,
adamc@885 529 newline,
adamc@885 530
adamc@885 531 string "if (r != SQLITE_DONE) uw_error(ctx, FATAL, \"",
adamc@885 532 string (ErrorMsg.spanToString loc),
adamc@1266 533 string ": query step failed: %s<br />%s\", ",
adamc@885 534 query,
adamc@885 535 string ", sqlite3_errmsg(conn->conn));",
adamc@885 536 newline,
adamc@885 537 newline]
adamc@885 538
adamc@885 539 fun query {loc, cols, doCols} =
adamc@885 540 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 541 newline,
adamc@886 542 string "sqlite3_stmt *stmt;",
adamc@885 543 newline,
adamc@885 544 newline,
adamc@1266 545 string "if (sqlite3_prepare_v2(conn->conn, query, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", sqlite3_errmsg(conn->conn), query);",
adamc@885 546 newline,
adamc@885 547 newline,
adamc@885 548 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 549 newline,
adamc@885 550 newline,
adamc@885 551
adamc@885 552 queryCommon {loc = loc, cols = cols, doCols = doCols, query = string "query"},
adamc@885 553
adamc@885 554 string "uw_pop_cleanup(ctx);",
adamc@885 555 newline]
adamc@885 556
adamc@1014 557 val p_pre_inputs =
adamc@1014 558 p_list_sepi (box [])
adamc@1014 559 (fn i => fn t =>
adamc@1014 560 case t of
adamc@1014 561 Char => box [string "char arg",
adamc@1014 562 string (Int.toString (i + 1)),
adamc@1014 563 string "s = {arg",
adamc@1014 564 string (Int.toString (i + 1)),
adamc@1014 565 string ", 0};",
adamc@1014 566 newline]
adamc@1014 567 | _ => box [])
adamc@1014 568
adamc@885 569 fun p_inputs loc =
adamc@885 570 p_list_sepi (box [])
adamc@885 571 (fn i => fn t =>
adamc@885 572 let
adamc@885 573 fun bind (t, arg) =
adamc@885 574 case t of
adamc@885 575 Int => box [string "sqlite3_bind_int64(stmt, ",
adamc@885 576 string (Int.toString (i + 1)),
adamc@885 577 string ", ",
adamc@885 578 arg,
adamc@885 579 string ")"]
adamc@885 580 | Float => box [string "sqlite3_bind_double(stmt, ",
adamc@885 581 string (Int.toString (i + 1)),
adamc@885 582 string ", ",
adamc@885 583 arg,
adamc@1014 584 string ")"]
adamc@885 585 | String => box [string "sqlite3_bind_text(stmt, ",
adamc@885 586 string (Int.toString (i + 1)),
adamc@885 587 string ", ",
adamc@885 588 arg,
adamc@885 589 string ", -1, SQLITE_TRANSIENT)"]
adamc@1014 590 | Char => box [string "sqlite3_bind_text(stmt, ",
adamc@1014 591 string (Int.toString (i + 1)),
adamc@1014 592 string ", ",
adamc@1014 593 arg,
adamc@1014 594 string "s, -1, SQLITE_TRANSIENT)"]
adamc@885 595 | Bool => box [string "sqlite3_bind_int(stmt, ",
adamc@885 596 string (Int.toString (i + 1)),
adamc@885 597 string ", ",
adamc@885 598 arg,
adamc@885 599 string ")"]
adamc@887 600 | Time => box [string "sqlite3_bind_text(stmt, ",
adamc@885 601 string (Int.toString (i + 1)),
adam@1359 602 string ", uw_Basis_timef(ctx, ",
adam@1352 603 string fmt,
adam@1352 604 string ", ",
adamc@885 605 arg,
adamc@887 606 string "), -1, SQLITE_TRANSIENT)"]
adamc@885 607 | Blob => box [string "sqlite3_bind_blob(stmt, ",
adamc@885 608 string (Int.toString (i + 1)),
adamc@885 609 string ", ",
adamc@885 610 arg,
adamc@885 611 string ".data, ",
adamc@885 612 arg,
adamc@890 613 string ".size, SQLITE_TRANSIENT)"]
adamc@886 614 | Channel => box [string "sqlite3_bind_int64(stmt, ",
adamc@885 615 string (Int.toString (i + 1)),
adamc@886 616 string ", ((sqlite3_int64)",
adamc@885 617 arg,
adamc@886 618 string ".cli << 32) | ",
adamc@886 619 arg,
adamc@886 620 string ".chn)"]
adamc@885 621 | Client => box [string "sqlite3_bind_int(stmt, ",
adamc@885 622 string (Int.toString (i + 1)),
adamc@885 623 string ", ",
adamc@885 624 arg,
adamc@885 625 string ")"]
adamc@885 626 | Nullable t => box [string "(",
adamc@885 627 arg,
adamc@885 628 string " == NULL ? sqlite3_bind_null(stmt, ",
adamc@885 629 string (Int.toString (i + 1)),
adamc@885 630 string ") : ",
adamc@885 631 bind (t, case t of
adamc@885 632 String => arg
adamc@885 633 | _ => box [string "(*", arg, string ")"]),
adamc@885 634 string ")"]
adamc@885 635 in
adamc@885 636 box [string "if (",
adamc@885 637 bind (t, box [string "arg", string (Int.toString (i + 1))]),
adamc@885 638 string " != SQLITE_OK) uw_error(ctx, FATAL, \"",
adamc@885 639 string (ErrorMsg.spanToString loc),
adamc@885 640 string ": Error binding parameter #",
adamc@885 641 string (Int.toString (i + 1)),
adamc@885 642 string ": %s\", sqlite3_errmsg(conn->conn));",
adamc@885 643 newline]
adamc@885 644 end)
adamc@885 645
adamc@885 646 fun queryPrepared {loc, id, query, inputs, cols, doCols, nested} =
adamc@885 647 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 648 newline,
adamc@1014 649 p_pre_inputs inputs,
adamc@885 650 if nested then
adamc@885 651 box [string "sqlite3_stmt *stmt;",
adamc@885 652 newline]
adamc@885 653 else
adamc@885 654 box [string "sqlite3_stmt *stmt = conn->p",
adamc@885 655 string (Int.toString id),
adamc@885 656 string ";",
adamc@885 657 newline,
adamc@885 658 newline,
adamc@885 659
adamc@885 660 string "if (stmt == NULL) {",
adamc@885 661 newline],
adamc@885 662
adamc@885 663 string "if (sqlite3_prepare_v2(conn->conn, \"",
adam@1656 664 string (Prim.toCString query),
adamc@885 665 string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
adam@1656 666 string (Prim.toCString query),
adamc@1266 667 string "<br />%s\", sqlite3_errmsg(conn->conn));",
adamc@885 668 newline,
adamc@885 669 if nested then
adamc@885 670 box [string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 671 newline]
adamc@885 672 else
adamc@885 673 box [string "conn->p",
adamc@885 674 string (Int.toString id),
adamc@885 675 string " = stmt;",
adamc@885 676 newline,
adamc@885 677 string "}",
adamc@885 678 newline,
adamc@885 679 newline,
adamc@885 680 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);",
adamc@885 681 newline,
adamc@885 682 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);",
adamc@885 683 newline],
adamc@885 684 newline,
adamc@885 685
adamc@885 686 p_inputs loc inputs,
adamc@885 687 newline,
adamc@885 688
adamc@885 689 queryCommon {loc = loc, cols = cols, doCols = doCols, query = box [string "\"",
adam@1656 690 string (Prim.toCString query),
adamc@885 691 string "\""]},
adamc@885 692
adamc@885 693 string "uw_pop_cleanup(ctx);",
adamc@885 694 newline,
adamc@885 695 if nested then
adamc@885 696 box []
adamc@885 697 else
adamc@885 698 box [string "uw_pop_cleanup(ctx);",
adamc@885 699 newline]]
adamc@885 700
adam@1293 701 fun dmlCommon {loc, dml, mode} =
adamc@885 702 box [string "int r;",
adamc@885 703 newline,
adamc@885 704
adamc@885 705 string "if ((r = sqlite3_step(stmt)) == SQLITE_BUSY) {",
adamc@885 706 box [string "sleep(1);",
adamc@885 707 newline,
adamc@885 708 string "uw_error(ctx, UNLIMITED_RETRY, \"Database is busy\");",
adamc@885 709 newline],
adamc@885 710 string "}",
adamc@885 711 newline,
adamc@885 712 newline,
adamc@885 713
adam@1293 714 string "if (r != SQLITE_DONE) ",
adam@1293 715 case mode of
adam@1293 716 Settings.Error => box [string "uw_error(ctx, FATAL, \"",
adam@1293 717 string (ErrorMsg.spanToString loc),
adam@1293 718 string ": DML step failed: %s<br />%s\", ",
adam@1293 719 dml,
adam@1293 720 string ", sqlite3_errmsg(conn->conn));"]
adam@1295 721 | Settings.None => string "uw_set_error_message(ctx, sqlite3_errmsg(conn->conn));",
adamc@885 722 newline]
adamc@885 723
adam@1293 724 fun dml (loc, mode) =
adamc@885 725 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 726 newline,
adamc@886 727 string "sqlite3_stmt *stmt;",
adamc@885 728 newline,
adamc@885 729 newline,
adamc@1266 730 string "if (sqlite3_prepare_v2(conn->conn, dml, -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: %s<br />%s\", dml, sqlite3_errmsg(conn->conn));",
adamc@885 731 newline,
adamc@885 732 newline,
adamc@885 733 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_finalize, stmt);",
adamc@885 734 newline,
adamc@885 735 newline,
adamc@885 736
adam@1293 737 dmlCommon {loc = loc, dml = string "dml", mode = mode},
adamc@885 738
adamc@885 739 string "uw_pop_cleanup(ctx);",
adamc@885 740 newline]
adamc@885 741
adam@1293 742 fun dmlPrepared {loc, id, dml, inputs, mode = mode} =
adamc@885 743 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 744 newline,
adamc@1014 745 p_pre_inputs inputs,
adamc@885 746 string "sqlite3_stmt *stmt = conn->p",
adamc@885 747 string (Int.toString id),
adamc@885 748 string ";",
adamc@885 749 newline,
adamc@885 750 newline,
adamc@885 751
adamc@885 752 string "if (stmt == NULL) {",
adamc@885 753 newline,
adamc@885 754 box [string "if (sqlite3_prepare_v2(conn->conn, \"",
adam@1656 755 string (Prim.toCString dml),
adamc@885 756 string "\", -1, &stmt, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"Error preparing statement: ",
adam@1656 757 string (Prim.toCString dml),
adamc@1266 758 string "<br />%s\", sqlite3_errmsg(conn->conn));",
adamc@885 759 newline,
adamc@885 760 string "conn->p",
adamc@885 761 string (Int.toString id),
adamc@885 762 string " = stmt;",
adamc@885 763 newline],
adamc@885 764 string "}",
adamc@885 765 newline,
adamc@885 766
adamc@885 767 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_clear_bindings, stmt);",
adamc@885 768 newline,
adamc@885 769 string "uw_push_cleanup(ctx, (void (*)(void *))sqlite3_reset, stmt);",
adamc@885 770 newline,
adamc@885 771
adamc@885 772 p_inputs loc inputs,
adamc@885 773 newline,
adamc@885 774
adamc@885 775 dmlCommon {loc = loc, dml = box [string "\"",
adam@1656 776 string (Prim.toCString dml),
adam@1293 777 string "\""], mode = mode},
adamc@885 778
adamc@885 779 string "uw_pop_cleanup(ctx);",
adamc@885 780 newline,
adamc@885 781 string "uw_pop_cleanup(ctx);",
adamc@885 782 newline]
adamc@885 783
adamc@885 784 fun nextval {loc, seqE, seqName} =
adamc@885 785 box [string "uw_conn *conn = uw_get_db(ctx);",
adamc@885 786 newline,
adamc@885 787 string "char *insert = ",
adamc@885 788 case seqName of
adamc@886 789 SOME s => string ("\"INSERT INTO " ^ s ^ " VALUES (NULL)\"")
adamc@885 790 | NONE => box [string "uw_Basis_strcat(ctx, \"INSERT INTO \", uw_Basis_strcat(ctx, ",
adamc@885 791 seqE,
adamc@885 792 string ", \" VALUES ()\"))"],
adamc@885 793 string ";",
adamc@885 794 newline,
adamc@885 795 string "char *delete = ",
adamc@885 796 case seqName of
adamc@885 797 SOME s => string ("\"DELETE FROM " ^ s ^ "\"")
adamc@885 798 | NONE => box [string "uw_Basis_strcat(ctx, \"DELETE FROM \", ",
adamc@885 799 seqE,
adamc@885 800 string ")"],
adamc@885 801 string ";",
adamc@885 802 newline,
adamc@885 803 newline,
adamc@885 804
adamc@886 805 string "if (sqlite3_exec(conn->conn, insert, NULL, NULL, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"'nextval' INSERT failed: %s\", sqlite3_errmsg(conn->conn));",
adamc@885 806 newline,
adamc@885 807 string "n = sqlite3_last_insert_rowid(conn->conn);",
adamc@885 808 newline,
adamc@886 809 string "if (sqlite3_exec(conn->conn, delete, NULL, NULL, NULL) != SQLITE_OK) uw_error(ctx, FATAL, \"'nextval' DELETE failed: %s\", sqlite3_errmsg(conn->conn));",
adamc@885 810 newline]
adamc@885 811
adamc@885 812 fun nextvalPrepared _ = raise Fail "SQLite.nextvalPrepared called"
adamc@1073 813 fun setval _ = raise Fail "SQLite.setval called"
adamc@885 814
adamc@885 815 fun sqlifyString s = "'" ^ String.translate (fn #"'" => "''"
adam@1285 816 | #"\000" => ""
adam@1285 817 | ch => str ch)
adam@1285 818 s ^ "'"
adamc@885 819
adamc@885 820 fun p_cast (s, _) = s
adamc@885 821
adamc@885 822 fun p_blank _ = "?"
adamc@885 823
adamc@885 824 val () = addDbms {name = "sqlite",
adam@1682 825 randomFunction = "RANDOM",
adam@1464 826 header = Config.sqheader,
adamc@885 827 link = "-lsqlite3",
adamc@885 828 init = init,
adamc@885 829 p_sql_type = p_sql_type,
adamc@885 830 query = query,
adamc@885 831 queryPrepared = queryPrepared,
adamc@885 832 dml = dml,
adamc@885 833 dmlPrepared = dmlPrepared,
adamc@885 834 nextval = nextval,
adamc@885 835 nextvalPrepared = nextvalPrepared,
adamc@1073 836 setval = setval,
adamc@885 837 sqlifyString = sqlifyString,
adamc@885 838 p_cast = p_cast,
adamc@885 839 p_blank = p_blank,
adamc@885 840 supportsDeleteAs = false,
adamc@886 841 supportsUpdateAs = false,
adamc@886 842 createSequence = fn s => "CREATE TABLE " ^ s ^ " (id INTEGER PRIMARY KEY AUTOINCREMENT)",
adamc@885 843 textKeysNeedLengths = false,
adamc@885 844 supportsNextval = false,
adamc@885 845 supportsNestedPrepared = false,
adamc@890 846 sqlPrefix = "",
adamc@1014 847 supportsOctetLength = false,
adamc@1014 848 trueString = "1",
adamc@1196 849 falseString = "0",
adamc@1196 850 onlyUnion = false,
adam@1777 851 nestedRelops = false,
adam@1777 852 windowFunctions = false}
adamc@885 853
adamc@885 854 end