add foreign key integrity to sqlite

db4
Doug Coleman 2008-09-29 23:43:34 -05:00
parent b5664733ed
commit 34ce3e13e4
6 changed files with 208 additions and 259 deletions

View File

@ -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
<simple-statement> maybe-make-retryable ; inline
{ "" { } { } { } } nmake
[ <simple-statement> maybe-make-retryable ] dip
[
[ 1array ] dip append
] unless-empty ; inline
: where-primary-key% ( specs -- )
" where " 0%
@ -152,25 +157,20 @@ M: db <select-by-slots-statement> ( 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

View File

@ -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 }
} ;

View File

@ -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 ;

View File

@ -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 -- )
{ } { } <simple-statement> 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 ;

View File

@ -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" <user-assigned-person> 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

View File

@ -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
: <sql-spec> ( 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 <sql-spec> ;
: 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 ;