basis/db/sqlite/sqlite.factor

   1 ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien arrays assocs classes compiler db hashtables
   4 io.files kernel math math.parser namespaces prettyprint fry
   5 sequences strings classes.tuple alien.c-types continuations
   6 db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
   7 math.intervals io nmake accessors vectors math.ranges random
   8 math.bitwise db.queries destructors db.tuples.private interpolate
   9 io.streams.string multiline make db.private sequences.deep
  10 db.errors.sqlite ;
  11 IN: db.sqlite
  12
  13 TUPLE: sqlite-db path ;
  14
  15 : <sqlite-db> ( path -- sqlite-db )
  16     sqlite-db new
  17         swap >>path ;
  18
  19 <PRIVATE
  20
  21 TUPLE: sqlite-db-connection < db-connection ;
  22
  23 : <sqlite-db-connection> ( handle -- db-connection )
  24     sqlite-db-connection new-db-connection
  25         swap >>handle ;
  26
  27 PRIVATE>
  28
  29 M: sqlite-db db-open ( db -- db-connection )
  30     path>> sqlite-open <sqlite-db-connection> ;
  31
  32 M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
  33
  34 TUPLE: sqlite-statement < statement ;
  35
  36 TUPLE: sqlite-result-set < result-set has-more? ;
  37
  38 M: sqlite-db-connection <simple-statement> ( str in out -- obj )
  39     <prepared-statement> ;
  40
  41 M: sqlite-db-connection <prepared-statement> ( str in out -- obj )
  42     sqlite-statement new-statement ;
  43
  44 : sqlite-maybe-prepare ( statement -- statement )
  45     dup handle>> [
  46         db-connection get handle>> over sql>> sqlite-prepare
  47         >>handle
  48     ] unless ;
  49
  50 M: sqlite-statement dispose ( statement -- )
  51     handle>>
  52     [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
  53
  54 M: sqlite-result-set dispose ( result-set -- )
  55     f >>handle drop ;
  56
  57 : reset-bindings ( statement -- )
  58     sqlite-maybe-prepare
  59     handle>> [ sqlite3_reset drop ] [ sqlite3_clear_bindings drop ] bi ;
  60
  61 M: sqlite-statement low-level-bind ( statement -- )
  62     [ handle>> ] [ bind-params>> ] bi
  63     [ [ key>> ] [ value>> ] [ type>> ] tri sqlite-bind-type ] with each ;
  64
  65 M: sqlite-statement bind-statement* ( statement -- )
  66     sqlite-maybe-prepare
  67     dup bound?>> [ dup reset-bindings ] when
  68     low-level-bind ;
  69
  70 GENERIC: sqlite-bind-conversion ( tuple obj -- array )
  71
  72 TUPLE: sqlite-low-level-binding < low-level-binding key type ;
  73 : <sqlite-low-level-binding> ( key value type -- obj )
  74     sqlite-low-level-binding new
  75         swap >>type
  76         swap >>value
  77         swap >>key ;
  78
  79 M: sql-spec sqlite-bind-conversion ( tuple spec -- array )
  80     [ column-name>> ":" prepend ]
  81     [ slot-name>> rot get-slot-named ]
  82     [ type>> ] tri <sqlite-low-level-binding> ;
  83
  84 M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
  85     nip [ key>> ] [ value>> ] [ type>> ] tri
  86     <sqlite-low-level-binding> ;
  87
  88 M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
  89     tuck
  90     [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
  91     rot set-slot-named
  92     [ [ key>> ] [ type>> ] bi ] dip
  93     swap <sqlite-low-level-binding> ;
  94
  95 M: sqlite-statement bind-tuple ( tuple statement -- )
  96     [
  97         in-params>> [ sqlite-bind-conversion ] with map
  98     ] keep bind-statement ;
  99
 100 ERROR: sqlite-last-id-fail ;
 101
 102 : last-insert-id ( -- id )
 103     db-connection get handle>> sqlite3_last_insert_rowid
 104     dup zero? [ sqlite-last-id-fail ] when ;
 105
 106 M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
 107     execute-statement last-insert-id swap set-primary-key ;
 108
 109 M: sqlite-result-set #columns ( result-set -- n )
 110     handle>> sqlite-#columns ;
 111
 112 M: sqlite-result-set row-column ( result-set n -- obj )
 113     [ handle>> ] [ sqlite-column ] bi* ;
 114
 115 M: sqlite-result-set row-column-typed ( result-set n -- obj )
 116     dup pick out-params>> nth type>>
 117     [ handle>> ] 2dip sqlite-column-typed ;
 118
 119 M: sqlite-result-set advance-row ( result-set -- )
 120     dup handle>> sqlite-next >>has-more? drop ;
 121
 122 M: sqlite-result-set more-rows? ( result-set -- ? )
 123     has-more?>> ;
 124
 125 M: sqlite-statement query-results ( query -- result-set )
 126     sqlite-maybe-prepare
 127     dup handle>> sqlite-result-set new-result-set
 128     dup advance-row ;
 129
 130 M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
 131     [
 132         "insert into " 0% 0%
 133         "(" 0%
 134         remove-db-assigned-id
 135         dup [ ", " 0% ] [ column-name>> 0% ] interleave
 136         ") values(" 0%
 137         [ ", " 0% ] [
 138             dup type>> +random-id+ = [
 139                 [ slot-name>> ]
 140                 [
 141                     column-name>> ":" prepend dup 0%
 142                     random-id-generator
 143                 ] [ type>> ] tri <generator-bind> 1,
 144             ] [
 145                 bind%
 146             ] if
 147         ] interleave
 148         ");" 0%
 149     ] query-make ;
 150
 151 M: sqlite-db-connection <insert-user-assigned-statement> ( tuple -- statement )
 152     <insert-db-assigned-statement> ;
 153
 154 M: sqlite-db-connection bind# ( spec obj -- )
 155     [
 156         [ column-name>> ":" next-sql-counter surround dup 0% ]
 157         [ type>> ] bi
 158     ] dip <literal-bind> 1, ;
 159
 160 M: sqlite-db-connection bind% ( spec -- )
 161     dup 1, column-name>> ":" prepend 0% ;
 162
 163 M: sqlite-db-connection persistent-table ( -- assoc )
 164     H{
 165         { +db-assigned-id+ { "integer" "integer" f } }
 166         { +user-assigned-id+ { f f f } }
 167         { +random-id+ { "integer" "integer" f } }
 168         { +foreign-id+ { "integer" "integer" "references" } }
 169
 170         { +on-update+ { f f "on update" } }
 171         { +on-delete+ { f f "on delete" } }
 172         { +restrict+ { f f "restrict" } }
 173         { +cascade+ { f f "cascade" } }
 174         { +set-null+ { f f "set null" } }
 175         { +set-default+ { f f "set default" } }
 176
 177         { BOOLEAN { "boolean" "boolean" f } }
 178         { INTEGER { "integer" "integer" f } }
 179         { BIG-INTEGER { "bigint" "bigint" f } }
 180         { SIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 181         { UNSIGNED-BIG-INTEGER { "bigint" "bigint" f } }
 182         { TEXT { "text" "text" f } }
 183         { VARCHAR { "text" "text" f } }
 184         { DATE { "date" "date" f } }
 185         { TIME { "time" "time" f } }
 186         { DATETIME { "datetime" "datetime" f } }
 187         { TIMESTAMP { "timestamp" "timestamp" f } }
 188         { DOUBLE { "real" "real" f } }
 189         { BLOB { "blob" "blob" f } }
 190         { FACTOR-BLOB { "blob" "blob" f } }
 191         { URL { "text" "text" f } }
 192         { +autoincrement+ { f f "autoincrement" } }
 193         { +unique+ { f f "unique" } }
 194         { +default+ { f f "default" } }
 195         { +null+ { f f "null" } }
 196         { +not-null+ { f f "not null" } }
 197         { system-random-generator { f f f } }
 198         { secure-random-generator { f f f } }
 199         { random-generator { f f f } }
 200     } ;
 201
 202 : insert-trigger ( -- string )
 203     [
 204     <"
 205         CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
 206         BEFORE INSERT ON ${table-name}
 207         FOR EACH ROW BEGIN
 208             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
 209             WHERE  (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 210         END;
 211     "> interpolate
 212     ] with-string-writer ;
 213
 214 : insert-trigger-not-null ( -- string )
 215     [
 216     <"
 217         CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
 218         BEFORE INSERT ON ${table-name}
 219         FOR EACH ROW BEGIN
 220             SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
 221             WHERE NEW.${table-id} IS NOT NULL
 222                 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 223         END;
 224     "> interpolate
 225     ] with-string-writer ;
 226
 227 : update-trigger ( -- string )
 228     [
 229     <"
 230         CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
 231         BEFORE UPDATE ON ${table-name}
 232         FOR EACH ROW BEGIN
 233             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
 234             WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 235         END;
 236     "> interpolate
 237     ] with-string-writer ;
 238
 239 : update-trigger-not-null ( -- string )
 240     [
 241     <"
 242         CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
 243         BEFORE UPDATE ON ${table-name}
 244         FOR EACH ROW BEGIN
 245             SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
 246             WHERE NEW.${table-id} IS NOT NULL
 247                 AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
 248         END;
 249     "> interpolate
 250     ] with-string-writer ;
 251
 252 : delete-trigger-restrict ( -- string )
 253     [
 254     <"
 255         CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
 256         BEFORE DELETE ON ${foreign-table-name}
 257         FOR EACH ROW BEGIN
 258             SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
 259             WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
 260         END;
 261     "> interpolate
 262     ] with-string-writer ;
 263
 264 : delete-trigger-cascade ( -- string )
 265     [
 266     <"
 267         CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
 268         BEFORE DELETE ON ${foreign-table-name}
 269         FOR EACH ROW BEGIN
 270             DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
 271         END;
 272     "> interpolate
 273     ] with-string-writer ;
 274
 275 : can-be-null? ( -- ? )
 276     "sql-spec" get modifiers>> [ +not-null+ = ] any? not ;
 277
 278 : delete-cascade? ( -- ? )
 279     "sql-spec" get modifiers>> { +on-delete+ +cascade+ } swap subseq? ;
 280
 281 : sqlite-trigger, ( string -- )
 282     { } { } <simple-statement> 3, ;
 283
 284 : create-sqlite-triggers ( -- )
 285     can-be-null? [
 286         insert-trigger sqlite-trigger,
 287         update-trigger sqlite-trigger,
 288     ] [
 289         insert-trigger-not-null sqlite-trigger,
 290         update-trigger-not-null sqlite-trigger,
 291     ] if
 292     delete-cascade? [
 293         delete-trigger-cascade sqlite-trigger,
 294     ] [
 295         delete-trigger-restrict sqlite-trigger,
 296     ] if ;
 297
 298 : create-db-triggers ( sql-specs -- )
 299     [ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
 300     [
 301         [ class>> db-table-name "db-table" set ]
 302         [
 303             [ "sql-spec" set ]
 304             [ column-name>> "table-id" set ]
 305             [ ] tri
 306             modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
 307             [
 308                 [ second db-table-name "foreign-table-name" set ]
 309                 [ third "foreign-table-id" set ] bi
 310                 create-sqlite-triggers
 311             ] each
 312         ] bi
 313     ] each ;
 314
 315 : sqlite-create-table ( sql-specs class-name -- )
 316     [
 317         "create table " 0% 0%
 318         "(" 0% [ ", " 0% ] [
 319             dup "sql-spec" set
 320             dup column-name>> [ "table-id" set ] [ 0% ] bi
 321             " " 0%
 322             dup type>> lookup-create-type 0%
 323             modifiers 0%
 324         ] interleave
 325     ] [
 326         drop
 327         find-primary-key [
 328             ", " 0%
 329             "primary key(" 0%
 330             [ "," 0% ] [ column-name>> 0% ] interleave
 331             ")" 0%
 332         ] unless-empty
 333         ");" 0%
 334     ] 2bi ;
 335
 336 M: sqlite-db-connection create-sql-statement ( class -- statement )
 337     [
 338         [ sqlite-create-table ]
 339         [ drop create-db-triggers ] 2bi
 340     ] query-make ;
 341
 342 M: sqlite-db-connection drop-sql-statement ( class -- statements )
 343     [ nip "drop table " 0% 0% ";" 0% ] query-make ;
 344
 345 M: sqlite-db-connection compound ( string seq -- new-string )
 346     over {
 347         { "default" [ first number>string " " glue ] }
 348         { "references" [ >reference-string ] }
 349         [ 2drop ]
 350     } case ;
 351
 352 M: sqlite-db-connection parse-db-error
 353     dup n>> {
 354         { 1 [ string>> parse-sqlite-sql-error ] }
 355         [ drop ]
 356     } case ;