add foreign key integrity to sqlite

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
+    { "" { } { } { } } nmake
-    <simple-statement> maybe-make-retryable ; inline
+    [ <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 " splice ] curry change-sql drop ;
-        ", " join " group by " swap 3append
-    ] curry change-sql drop ;
 
 : do-order ( tuple order -- )
-    [
+    [ ", " join " order by " splice ] curry change-sql drop ;
-        ", " join " order by " swap 3append
-    ] curry change-sql drop ;
 
 : do-offset ( tuple n -- )
-    [
+    [ number>string " offset " splice ] curry change-sql drop ;
-        number>string " offset " swap 3append
-    ] curry change-sql drop ;
 
 : do-limit ( tuple n -- )
-    [
+    [ number>string " limit " splice ] curry change-sql drop ;
-        number>string " limit " swap 3append
-    ] curry change-sql drop ;
 
 : make-query* ( tuple query -- tuple' )
     dupd

basis/db/sql/sql-tests.factor

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

basis/db/sql/sql.factor

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

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 -- )
+    { } { } <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 ;

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" <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"
-    paste "PASTE"
+{
-    {
+    { "n" "ID" +db-assigned-id+ }
-        { "n" "ID" +db-assigned-id+ }
+    { "summary" "SUMMARY" TEXT }
-        { "summary" "SUMMARY" TEXT }
+    { "author" "AUTHOR" TEXT }
-        { "author" "AUTHOR" TEXT }
+    { "channel" "CHANNEL" TEXT }
-        { "channel" "CHANNEL" TEXT }
+    { "mode" "MODE" TEXT }
-        { "mode" "MODE" TEXT }
+    { "contents" "CONTENTS" TEXT }
-        { "contents" "CONTENTS" TEXT }
+    { "timestamp" "DATE" TIMESTAMP }
-        { "timestamp" "DATE" TIMESTAMP }
+    { "annotations" { +has-many+ annotation } }
-        { "annotations" { +has-many+ annotation } }
+} define-persistent
-    } 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 ;
 
-    [ ] [
+: test-foreign-key ( -- )
-    ] unit-test
+    [ ] [ annotation-schema-foreign-key ] unit-test
-    ;
+    test-paste-schema
+    [ paste new 1 >>n delete-tuples ] must-fail ;
 
-[ test-paste-schema ] test-sqlite
+: test-foreign-key-not-null ( -- )
-[ test-paste-schema ] test-postgresql
+    [ ] [ 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

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 )
+: <sql-spec> ( class slot-name column-name type modifiers -- sql-spec )
-    3 f pad-right
-    [ first3 ] keep 3 tail
     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 ;