From 34ce3e13e4696a911beaae93b66c8c4ca93acabc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 29 Sep 2008 23:43:34 -0500 Subject: [PATCH] add foreign key integrity to sqlite --- basis/db/queries/queries.factor | 32 +++--- basis/db/sql/sql-tests.factor | 42 ------- basis/db/sql/sql.factor | 172 ---------------------------- basis/db/sqlite/sqlite.factor | 109 +++++++++++++++++- basis/db/tuples/tuples-tests.factor | 97 ++++++++++++---- basis/db/types/types.factor | 15 ++- 6 files changed, 208 insertions(+), 259 deletions(-) delete mode 100644 basis/db/sql/sql-tests.factor delete mode 100755 basis/db/sql/sql.factor diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor index f7809de578..e3322ada44 100644 --- a/basis/db/queries/queries.factor +++ b/basis/db/queries/queries.factor @@ -3,7 +3,7 @@ USING: accessors kernel math namespaces make sequences random strings math.parser math.intervals combinators math.bitwise nmake db db.tuples db.types db.sql classes words shuffle arrays -destructors continuations db.tuples.private ; +destructors continuations db.tuples.private prettyprint ; IN: db.queries GENERIC: where ( specs obj -- ) @@ -45,11 +45,16 @@ M: retryable execute-statement* ( statement type -- ) : sql-props ( class -- columns table ) [ db-columns ] [ db-table ] bi ; -: query-make ( class quot -- ) +: query-make ( class quot -- statements ) + #! query, input, outputs, secondary queries + over unparse "table" set [ sql-props ] dip [ 0 sql-counter rot with-variable ] curry - { "" { } { } } nmake - maybe-make-retryable ; inline + { "" { } { } { } } nmake + [ maybe-make-retryable ] dip + [ + [ 1array ] dip append + ] unless-empty ; inline : where-primary-key% ( specs -- ) " where " 0% @@ -152,25 +157,20 @@ M: db ( tuple class -- statement ) where-clause ] query-make ; +: splice ( string1 string2 string3 -- string ) + swap 3append ; + : do-group ( tuple groups -- ) - [ - ", " join " group by " swap 3append - ] curry change-sql drop ; + [ ", " join " group by " splice ] curry change-sql drop ; : do-order ( tuple order -- ) - [ - ", " join " order by " swap 3append - ] curry change-sql drop ; + [ ", " join " order by " splice ] curry change-sql drop ; : do-offset ( tuple n -- ) - [ - number>string " offset " swap 3append - ] curry change-sql drop ; + [ number>string " offset " splice ] curry change-sql drop ; : do-limit ( tuple n -- ) - [ - number>string " limit " swap 3append - ] curry change-sql drop ; + [ number>string " limit " splice ] curry change-sql drop ; : make-query* ( tuple query -- tuple' ) dupd diff --git a/basis/db/sql/sql-tests.factor b/basis/db/sql/sql-tests.factor deleted file mode 100644 index 0b57c2d8fa..0000000000 --- a/basis/db/sql/sql-tests.factor +++ /dev/null @@ -1,42 +0,0 @@ -USING: kernel namespaces db.sql sequences math ; -IN: db.sql.tests - -! TUPLE: person name age ; -: insert-1 - { insert - { - { table "person" } - { columns "name" "age" } - { values "erg" 26 } - } - } ; - -: update-1 - { update "person" - { set { "name" "erg" } - { "age" 6 } } - { where { "age" 6 } } - } ; - -: select-1 - { select - { columns - "branchno" - { count "staffno" as "mycount" } - { sum "salary" as "mysum" } } - { from "staff" "lol" } - { where - { "salary" > all - { select - { columns "salary" } - { from "staff" } - { where { "branchno" = "b003" } } - } - } - { "branchno" > 3 } } - { group-by "branchno" "lol2" } - { having { count "staffno" > 1 } } - { order-by "branchno" } - { offset 40 } - { limit 20 } - } ; diff --git a/basis/db/sql/sql.factor b/basis/db/sql/sql.factor deleted file mode 100755 index ba0673ae24..0000000000 --- a/basis/db/sql/sql.factor +++ /dev/null @@ -1,172 +0,0 @@ -USING: kernel parser quotations classes.tuple words math.order -nmake namespaces sequences arrays combinators -prettyprint strings math.parser math symbols db ; -IN: db.sql - -SYMBOLS: insert update delete select distinct columns from as -where group-by having order-by limit offset is-null desc all -any count avg table values ; - -: input-spec, ( obj -- ) 1, ; -: output-spec, ( obj -- ) 2, ; -: input, ( obj -- ) 3, ; -: output, ( obj -- ) 4, ; - -DEFER: sql% - -: (sql-interleave) ( seq sep -- ) - [ sql% ] curry [ sql% ] interleave ; - -: sql-interleave ( seq str sep -- ) - swap sql% (sql-interleave) ; - -: sql-function, ( seq function -- ) - sql% "(" sql% unclip sql% ")" sql% [ sql% ] each ; - -: sql-where, ( seq -- ) - [ - [ second 0, ] - [ first 0, ] - [ third 1, \ ? 0, ] tri - ] each ; - -HOOK: sql-create db ( object -- ) -M: db sql-create ( object -- ) - drop - "create table" sql% ; - -HOOK: sql-drop db ( object -- ) -M: db sql-drop ( object -- ) - drop - "drop table" sql% ; - -HOOK: sql-insert db ( object -- ) -M: db sql-insert ( object -- ) - drop - "insert into" sql% ; - -HOOK: sql-update db ( object -- ) -M: db sql-update ( object -- ) - drop - "update" sql% ; - -HOOK: sql-delete db ( object -- ) -M: db sql-delete ( object -- ) - drop - "delete" sql% ; - -HOOK: sql-select db ( object -- ) -M: db sql-select ( object -- ) - "select" sql% "," (sql-interleave) ; - -HOOK: sql-columns db ( object -- ) -M: db sql-columns ( object -- ) - "," (sql-interleave) ; - -HOOK: sql-from db ( object -- ) -M: db sql-from ( object -- ) - "from" "," sql-interleave ; - -HOOK: sql-where db ( object -- ) -M: db sql-where ( object -- ) - "where" 0, sql-where, ; - -HOOK: sql-group-by db ( object -- ) -M: db sql-group-by ( object -- ) - "group by" "," sql-interleave ; - -HOOK: sql-having db ( object -- ) -M: db sql-having ( object -- ) - "having" "," sql-interleave ; - -HOOK: sql-order-by db ( object -- ) -M: db sql-order-by ( object -- ) - "order by" "," sql-interleave ; - -HOOK: sql-offset db ( object -- ) -M: db sql-offset ( object -- ) - "offset" sql% sql% ; - -HOOK: sql-limit db ( object -- ) -M: db sql-limit ( object -- ) - "limit" sql% sql% ; - -! GENERIC: sql-subselect db ( object -- ) -! M: db sql-subselectselect ( object -- ) - ! "(select" sql% sql% ")" sql% ; - -HOOK: sql-table db ( object -- ) -M: db sql-table ( object -- ) - sql% ; - -HOOK: sql-set db ( object -- ) -M: db sql-set ( object -- ) - "set" "," sql-interleave ; - -HOOK: sql-values db ( object -- ) -M: db sql-values ( object -- ) - "values(" sql% "," (sql-interleave) ")" sql% ; - -HOOK: sql-count db ( object -- ) -M: db sql-count ( object -- ) - "count" sql-function, ; - -HOOK: sql-sum db ( object -- ) -M: db sql-sum ( object -- ) - "sum" sql-function, ; - -HOOK: sql-avg db ( object -- ) -M: db sql-avg ( object -- ) - "avg" sql-function, ; - -HOOK: sql-min db ( object -- ) -M: db sql-min ( object -- ) - "min" sql-function, ; - -HOOK: sql-max db ( object -- ) -M: db sql-max ( object -- ) - "max" sql-function, ; - -: sql-array% ( array -- ) - unclip - { - { \ create [ sql-create ] } - { \ drop [ sql-drop ] } - { \ insert [ sql-insert ] } - { \ update [ sql-update ] } - { \ delete [ sql-delete ] } - { \ select [ sql-select ] } - { \ columns [ sql-columns ] } - { \ from [ sql-from ] } - { \ where [ sql-where ] } - { \ group-by [ sql-group-by ] } - { \ having [ sql-having ] } - { \ order-by [ sql-order-by ] } - { \ offset [ sql-offset ] } - { \ limit [ sql-limit ] } - { \ table [ sql-table ] } - { \ set [ sql-set ] } - { \ values [ sql-values ] } - { \ count [ sql-count ] } - { \ sum [ sql-sum ] } - { \ avg [ sql-avg ] } - { \ min [ sql-min ] } - { \ max [ sql-max ] } - [ sql% [ sql% ] each ] - } case ; - -ERROR: no-sql-match ; -: sql% ( obj -- ) - { - { [ dup string? ] [ 0, ] } - { [ dup array? ] [ sql-array% ] } - { [ dup number? ] [ number>string sql% ] } - { [ dup symbol? ] [ unparse sql% ] } - { [ dup word? ] [ unparse sql% ] } - { [ dup quotation? ] [ call ] } - [ no-sql-match ] - } cond ; - -: parse-sql ( obj -- sql in-spec out-spec in out ) - [ [ sql% ] each ] { { } { } { } } nmake - [ " " join ] 2dip ; diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index aab1e5f40f..4fc3dbb227 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -5,7 +5,8 @@ io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators math.intervals io nmake accessors vectors math.ranges random -math.bitwise db.queries destructors db.tuples.private ; +math.bitwise db.queries destructors db.tuples.private interpolate +io.streams.string multiline make ; IN: db.sqlite TUPLE: sqlite-db < db path ; @@ -117,7 +118,8 @@ M: sqlite-db create-sql-statement ( class -- statement ) dupd "create table " 0% 0% "(" 0% [ ", " 0% ] [ - dup column-name>> 0% + dup "sql-spec" set + dup column-name>> [ "table-id" set ] [ 0% ] bi " " 0% dup type>> lookup-create-type 0% modifiers 0% @@ -203,9 +205,110 @@ M: sqlite-db persistent-table ( -- assoc ) { random-generator { f f f } } } ; +: insert-trigger ( -- string ) + [ + <" + CREATE TRIGGER fki_${table}_${foreign-table}_id + BEFORE INSERT ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: insert-trigger-not-null ( -- string ) + [ + <" + CREATE TRIGGER fki_${table}_${foreign-table}_id + BEFORE INSERT ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE NEW.${foreign-table-id} IS NOT NULL + AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: update-trigger ( -- string ) + [ + <" + CREATE TRIGGER fku_${table}_${foreign-table}_id + BEFORE UPDATE ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: update-trigger-not-null ( -- string ) + [ + <" + CREATE TRIGGER fku_${table}_${foreign-table}_id + BEFORE UPDATE ON ${table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE NEW.${foreign-table-id} IS NOT NULL + AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; + END; + "> interpolate + ] with-string-writer ; + +: delete-trigger-restrict ( -- string ) + [ + <" + CREATE TRIGGER fkd_${table}_${foreign-table}_id + BEFORE DELETE ON ${foreign-table} + FOR EACH ROW BEGIN + SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"') + WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; + END; + "> interpolate + ] with-string-writer ; + +: delete-trigger-cascade ( -- string ) + [ + <" + CREATE TRIGGER fkd_${table}_${foreign-table}_id + BEFORE DELETE ON ${foreign-table} + FOR EACH ROW BEGIN + DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id}; + END; + "> interpolate + ] with-string-writer ; + +: can-be-null? ( -- ? ) + "sql-spec" get modifiers>> [ +not-null+ = ] contains? not ; + +: delete-cascade? ( -- ? ) + "sql-spec" get modifiers>> [ +cascade+ = ] contains? ; + +: sqlite-trigger, ( string -- ) + { } { } 3, ; + +: create-sqlite-triggers ( -- ) + can-be-null? [ + insert-trigger sqlite-trigger, + update-trigger sqlite-trigger, + ] [ + insert-trigger-not-null sqlite-trigger, + update-trigger-not-null sqlite-trigger, + ] if + delete-cascade? [ + delete-trigger-cascade sqlite-trigger, + ] [ + delete-trigger-restrict sqlite-trigger, + ] if ; + M: sqlite-db compound ( string seq -- new-string ) over { { "default" [ first number>string join-space ] } - { "references" [ >reference-string ] } + { "references" [ + [ >reference-string ] keep + first2 [ "foreign-table" set ] + [ "foreign-table-id" set ] bi* + create-sqlite-triggers + ] } [ 2drop ] } case ; diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor index 6a5e78aa4b..9550ea1cd8 100755 --- a/basis/db/tuples/tuples-tests.factor +++ b/basis/db/tuples/tuples-tests.factor @@ -176,26 +176,49 @@ SYMBOL: person4 T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } } f H{ { 1 2 } { 3 4 } { 5 "lol" } } URL" http://www.google.com/search?hl=en&q=trailer+park+boys&btnG=Google+Search" person4 set ; + TUPLE: paste n summary author channel mode contents timestamp annotations ; TUPLE: annotation n paste-id summary author mode contents ; -: db-assigned-paste-schema ( -- ) - paste "PASTE" - { - { "n" "ID" +db-assigned-id+ } - { "summary" "SUMMARY" TEXT } - { "author" "AUTHOR" TEXT } - { "channel" "CHANNEL" TEXT } - { "mode" "MODE" TEXT } - { "contents" "CONTENTS" TEXT } - { "timestamp" "DATE" TIMESTAMP } - { "annotations" { +has-many+ annotation } } - } define-persistent +paste "PASTE" +{ + { "n" "ID" +db-assigned-id+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "channel" "CHANNEL" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + { "timestamp" "DATE" TIMESTAMP } + { "annotations" { +has-many+ annotation } } +} define-persistent +: annotation-schema-foreign-key ( -- ) annotation "ANNOTATION" { { "n" "ID" +db-assigned-id+ } - { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + +: annotation-schema-foreign-key-not-null ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +not-null+ } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + +: annotation-schema-cascade ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } +on-delete+ +cascade+ } { "summary" "SUMMARY" TEXT } { "author" "AUTHOR" TEXT } @@ -203,8 +226,18 @@ TUPLE: annotation n paste-id summary author mode contents ; { "contents" "CONTENTS" TEXT } } define-persistent ; +: annotation-schema-restrict ( -- ) + annotation "ANNOTATION" + { + { "n" "ID" +db-assigned-id+ } + { "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "ID" } } + { "summary" "SUMMARY" TEXT } + { "author" "AUTHOR" TEXT } + { "mode" "MODE" TEXT } + { "contents" "CONTENTS" TEXT } + } define-persistent ; + : test-paste-schema ( -- ) - [ ] [ db-assigned-paste-schema ] unit-test [ ] [ paste ensure-table ] unit-test [ ] [ annotation ensure-table ] unit-test [ ] [ annotation drop-table ] unit-test @@ -229,14 +262,38 @@ TUPLE: annotation n paste-id summary author mode contents ; "erg" >>author "annotation contents" >>contents insert-tuple - ] unit-test + ] unit-test ; - [ ] [ - ] unit-test - ; +: test-foreign-key ( -- ) + [ ] [ annotation-schema-foreign-key ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; -[ test-paste-schema ] test-sqlite -[ test-paste-schema ] test-postgresql +: test-foreign-key-not-null ( -- ) + [ ] [ annotation-schema-foreign-key-not-null ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +: test-cascade ( -- ) + [ ] [ annotation-schema-cascade ] unit-test + test-paste-schema + [ ] [ paste new 1 >>n delete-tuples ] unit-test + [ 0 ] [ paste new select-tuples length ] unit-test ; + +: test-restrict ( -- ) + [ ] [ annotation-schema-restrict ] unit-test + test-paste-schema + [ paste new 1 >>n delete-tuples ] must-fail ; + +[ test-foreign-key ] test-sqlite +[ test-foreign-key-not-null ] test-sqlite +[ test-cascade ] test-sqlite +[ test-restrict ] test-sqlite + +[ test-foreign-key ] test-postgresql +[ test-foreign-key-not-null ] test-postgresql +[ test-cascade ] test-postgresql +[ test-restrict ] test-postgresql : test-repeated-insert [ ] [ person ensure-table ] unit-test diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor index bc33792e52..242339264d 100755 --- a/basis/db/types/types.factor +++ b/basis/db/types/types.factor @@ -87,16 +87,17 @@ SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL URL ; -: spec>tuple ( class spec -- tuple ) - 3 f pad-right - [ first3 ] keep 3 tail +: ( class slot-name column-name type modifiers -- sql-spec ) sql-spec new swap >>modifiers swap >>type swap >>column-name swap >>slot-name swap >>class - dup normalize-spec ; + dup normalize-spec ; + +: spec>tuple ( class spec -- tuple ) + 3 f pad-right [ first3 ] keep 3 tail ; : number>string* ( n/string -- string ) dup number? [ number>string ] when ; @@ -115,7 +116,6 @@ FACTOR-BLOB NULL URL ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html - : ?at ( obj assoc -- value/obj ? ) dupd at* [ [ nip ] [ drop ] if ] keep ; @@ -159,8 +159,11 @@ ERROR: no-sql-type type ; HOOK: bind% db ( spec -- ) HOOK: bind# db ( spec obj -- ) +ERROR: no-column column ; + : >reference-string ( string pair -- string ) first2 [ [ unparse join-space ] [ db-columns ] bi ] dip - swap [ slot-name>> = ] with find nip + swap [ column-name>> = ] with find nip + [ no-column ] unless* column-name>> paren append ;