factor/basis/db/tuples/tuples-tests.factor

! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.files.temp kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise system
math.ranges strings urls fry db.tuples.private db.private ;
IN: db.tuples.tests

: sqlite-db ( -- sqlite-db )
    "tuples-test.db" temp-file <sqlite-db> ;

: test-sqlite ( quot -- )
    '[
        [ ] [
            "tuples-test.db" temp-file <sqlite-db> _ with-db
        ] unit-test
    ] call ; inline

: postgresql-db ( -- postgresql-db )
    <postgresql-db>
        "localhost" >>host
        "postgres" >>username
        "thepasswordistrust" >>password
        "factor-test" >>database ;

: test-postgresql ( quot -- )
    '[
        os windows? cpu x86.64? and [
            [ ] [ postgresql-db _ with-db ] unit-test
        ] unless
    ] call ; inline

! These words leak resources, but are useful for interactivel testing 
: sqlite-test-db ( -- )
    sqlite-db db-open db-connection set ;

: postgresql-test-db ( -- )
    postgresql-db db-open db-connection set ;

TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;

: <person> ( name age real ts date time blob factor-blob url -- person )
    person new
        swap >>url
        swap >>factor-blob
        swap >>blob
        swap >>time
        swap >>date
        swap >>ts
        swap >>the-real
        swap >>the-number
        swap >>the-name ;

: <user-assigned-person> ( id name age real ts date time blob factor-blob url -- person )
    <person>
        swap >>the-id ;

SYMBOL: person1
SYMBOL: person2
SYMBOL: person3
SYMBOL: person4

: test-tuples ( -- )
    [ ] [ person recreate-table ] unit-test
    [ ] [ person ensure-table ] unit-test
    [ ] [ person drop-table ] unit-test
    [ ] [ person create-table ] unit-test
    [ person create-table ] must-fail
    [ ] [ person ensure-table ] unit-test
    
    [ ] [ person1 get insert-tuple ] unit-test

    [ 1 ] [ person1 get the-id>> ] unit-test

    [ ] [ person1 get 200 >>the-number drop ] unit-test

    [ ] [ person1 get update-tuple ] unit-test

    [ T{ person f 1 "billy" 200 3.14 } ]
    [ T{ person f 1 } select-tuple ] unit-test
    [ ] [ person2 get insert-tuple ] unit-test
    [
        {
            T{ person f 1 "billy" 200 3.14 }
            T{ person f 2 "johnny" 10 3.14 }
        }
    ] [ T{ person f f f f 3.14 } select-tuples ] unit-test
    [
        {
            T{ person f 1 "billy" 200 3.14 }
            T{ person f 2 "johnny" 10 3.14 }
        }
    ] [ T{ person f } select-tuples ] unit-test

    [
        {
            T{ person f 2 "johnny" 10 3.14 }
        }
    ] [ T{ person f f f 10 3.14 } select-tuples ] unit-test


    [ ] [ person1 get delete-tuples ] unit-test
    [ f ] [ T{ person f 1 } select-tuple ] unit-test

    [ ] [ person3 get insert-tuple ] unit-test

    [
        T{
            person
            f
            3
            "teddy"
            10
            3.14
            T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
            T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
            T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
            B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
        }
    ] [ T{ person f 3 } select-tuple ] unit-test

    [ ] [ person4 get insert-tuple ] unit-test
    [
        T{
            person
            f
            4
            "eddie"
            10
            3.14
            T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
            T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
            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"
        }
    ] [ T{ person f 4 } select-tuple ] unit-test

    [ ] [ person drop-table ] unit-test ;

: db-assigned-person-schema ( -- )
    person "PERSON"
    {
        { "the-id" "ID" +db-assigned-id+ }
        { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
        { "the-number" "AGE" INTEGER { +default+ 0 } }
        { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
        { "ts" "TS" TIMESTAMP }
        { "date" "D" DATE }
        { "time" "T" TIME }
        { "blob" "B" BLOB }
        { "factor-blob" "FB" FACTOR-BLOB }
        { "url" "U" URL }
    } define-persistent
    "billy" 10 3.14 f f f f f f <person> person1 set
    "johnny" 10 3.14 f f f f f f <person> person2 set
    "teddy" 10 3.14
        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
        T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
        B{ 115 116 111 114 101 105 110 97 98 108 111 98 } f f <person> person3 set
    "eddie" 10 3.14
        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
        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"  <person> person4 set ;

: user-assigned-person-schema ( -- )
    person "PERSON"
    {
        { "the-id" "ID" INTEGER +user-assigned-id+ }
        { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
        { "the-number" "AGE" INTEGER { +default+ 0 } }
        { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
        { "ts" "TS" TIMESTAMP }
        { "date" "D" DATE }
        { "time" "T" TIME }
        { "blob" "B" BLOB }
        { "factor-blob" "FB" FACTOR-BLOB }
        { "url" "U" URL }
    } define-persistent
    1 "billy" 10 3.14 f f f f f f <user-assigned-person> person1 set
    2 "johnny" 10 3.14 f f f f f f <user-assigned-person> person2 set
    3 "teddy" 10 3.14
        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
        T{ timestamp f 0 0 0 12 34 56 T{ duration f 0 0 0 0 0 0 } }
        B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
        f f <user-assigned-person> person3 set
    4 "eddie" 10 3.14
        T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
        T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
        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 ;

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 "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 }
        { "mode" "MODE" TEXT }
        { "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 ( -- )
    [ ] [ paste ensure-table ] unit-test
    [ ] [ annotation ensure-table ] unit-test
    [ ] [ annotation drop-table ] unit-test
    [ ] [ paste drop-table ] unit-test
    [ ] [ paste create-table ] unit-test
    [ ] [ annotation create-table ] unit-test

    [ ] [
        paste new
            "summary1" >>summary
            "erg" >>author
            "#lol" >>channel
            "contents1" >>contents
            now >>timestamp
        insert-tuple
    ] unit-test

    [ ] [
        annotation new
            1 >>paste-id
            "annotation1" >>summary
            "erg" >>author
            "annotation contents" >>contents
        insert-tuple
    ] unit-test ;

: test-foreign-key ( -- )
    [ ] [ annotation-schema-foreign-key ] unit-test
    test-paste-schema
    [ paste new 1 >>n delete-tuples ] must-fail ;

: 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
    [ ] [ person1 get insert-tuple ] unit-test
    [ person1 get insert-tuple ] must-fail ;

TUPLE: serialize-me id data ;

: test-serialize ( -- )
    serialize-me "SERIALIZED"
    {
        { "id" "ID" +db-assigned-id+ }
        { "data" "DATA" FACTOR-BLOB }
    } define-persistent
    [ serialize-me drop-table ] [ drop ] recover
    [ ] [ serialize-me create-table ] unit-test

    [ ] [ T{ serialize-me f f H{ { 1 2 } } } insert-tuple ] unit-test
    [
        { T{ serialize-me f 1 H{ { 1 2 } } } }
    ] [ T{ serialize-me f 1 } select-tuples ] unit-test ;

TUPLE: exam id name score ; 

: random-exam ( -- exam )
        f
        6 [ CHAR: a CHAR: z [a,b] random ] replicate >string
        100 random
    exam boa ;

: test-intervals ( -- )
    [
        exam "EXAM"
        {
            { "idd" "ID" +db-assigned-id+ }
            { "named" "NAME" TEXT }
            { "score" "SCORE" INTEGER }
        } define-persistent
    ] [
        seq>> { "idd" "named" } =
    ] must-fail-with

    exam "EXAM"
    {
        { "id" "ID" +db-assigned-id+ }
        { "name" "NAME" TEXT }
        { "score" "SCORE" INTEGER }
    } define-persistent
    [ exam drop-table ] [ drop ] recover
    [ ] [ exam create-table ] unit-test

    [ ] [ T{ exam f f "Kyle" 100 } insert-tuple ] unit-test
    [ ] [ T{ exam f f "Stan" 80 } insert-tuple ] unit-test
    [ ] [ T{ exam f f "Kenny" 60 } insert-tuple ] unit-test
    [ ] [ T{ exam f f "Cartman" 41 } insert-tuple ] unit-test

    [ 4 ]
    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples length ] unit-test

    [ f ]
    [ T{ exam { name IGNORE } { score IGNORE } } select-tuples first score>> ] unit-test

    [ T{ exam { name IGNORE } { score IGNORE } { id IGNORE } } select-tuples first score>> ] [ class>> "EXAM" = ] must-fail-with

    [
        {
            T{ exam f 3 "Kenny" 60 }
            T{ exam f 4 "Cartman" 41 }
        }
    ] [
        T{ exam f f f T{ interval f { 0 t } { 70 t } } } select-tuples
    ] unit-test

    [
        { }
    ] [
        T{ exam f T{ interval f { 3 f } { 4 f } } f } select-tuples
    ] unit-test
    [
        {
            T{ exam f 4 "Cartman" 41 }
        }
    ] [
        T{ exam f T{ interval f { 3 f } { 4 t } } f } select-tuples
    ] unit-test
    [
        {
            T{ exam f 3 "Kenny" 60 }
        }
    ] [
        T{ exam f T{ interval f { 3 t } { 4 f } } f } select-tuples
    ] unit-test
    [
        {
            T{ exam f 3 "Kenny" 60 }
            T{ exam f 4 "Cartman" 41 }
        }
    ] [
        T{ exam f T{ interval f { 3 t } { 4 t } } f } select-tuples
    ] unit-test

    [
        {
            T{ exam f 1 "Kyle" 100 }
            T{ exam f 2 "Stan" 80 }
        }
    ] [
        T{ exam f f { "Stan" "Kyle" } } select-tuples
    ] unit-test

    [
        {
            T{ exam f 1 "Kyle" 100 }
            T{ exam f 2 "Stan" 80 }
            T{ exam f 3 "Kenny" 60 }
        }
    ] [
        T{ exam f T{ range f 1 3 1 } } select-tuples
    ] unit-test

    [
        {
            T{ exam f 2 "Stan" 80 }
            T{ exam f 3 "Kenny" 60 }
            T{ exam f 4 "Cartman" 41 }
        }
    ] [
        T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
    ] unit-test

    [
        {
            T{ exam f 1 "Kyle" 100 }
        }
    ] [
        T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
    ] unit-test

    [
        {
            T{ exam f 1 "Kyle" 100 }
            T{ exam f 2 "Stan" 80 }
            T{ exam f 3 "Kenny" 60 }
            T{ exam f 4 "Cartman" 41 }
        }
    ] [
        T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
    ] unit-test
    
    [
        {
            T{ exam f 1 "Kyle" 100 }
            T{ exam f 2 "Stan" 80 }
            T{ exam f 3 "Kenny" 60 }
            T{ exam f 4 "Cartman" 41 }
        }
    ] [
        T{ exam } select-tuples
    ] unit-test

    [ 4 ] [ T{ exam } count-tuples ] unit-test

    [ ] [ T{ exam { score 10 } } insert-tuple ] unit-test

    [ 10 ]
    [ T{ exam { name NULL } } select-tuples first score>> ] unit-test ;

TUPLE: bignum-test id m n o ;
: <bignum-test> ( m n o -- obj )
    bignum-test new
        swap >>o
        swap >>n
        swap >>m ;

: test-bignum
    bignum-test "BIGNUM_TEST"
    {
        { "id" "ID" +db-assigned-id+ }
        { "m" "M" BIG-INTEGER }
        { "n" "N" UNSIGNED-BIG-INTEGER }
        { "o" "O" SIGNED-BIG-INTEGER }
    } define-persistent
    [ bignum-test drop-table ] ignore-errors
    [ ] [ bignum-test ensure-table ] unit-test
    [ ] [ 63 2^ 1- dup dup <bignum-test> insert-tuple ] unit-test ;

    ! sqlite only
    ! [ T{ bignum-test f 1
        ! -9223372036854775808 9223372036854775808 -9223372036854775808 } ]
    ! [ T{ bignum-test f 1 } select-tuple ] unit-test ;

TUPLE: secret n message ;
C: <secret> secret

: test-random-id
    secret "SECRET"
    {
        { "n" "ID" +random-id+ system-random-generator }
        { "message" "MESSAGE" TEXT }
    } define-persistent

    [ ] [ secret recreate-table ] unit-test

    [ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test

    [ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test

    [ ] [ f "kilroy was here3" <secret> insert-tuple ] unit-test

    [ t ] [
        T{ secret } select-tuples
        first message>> "kilroy was here" head?
    ] unit-test

    [ t ] [
        T{ secret } select-tuples length 3 =
    ] unit-test ;

[ db-assigned-person-schema test-tuples ] test-sqlite
[ user-assigned-person-schema test-tuples ] test-sqlite
[ user-assigned-person-schema test-repeated-insert ] test-sqlite
[ test-bignum ] test-sqlite
[ test-serialize ] test-sqlite
[ test-intervals ] test-sqlite
[ test-random-id ] test-sqlite

[ db-assigned-person-schema test-tuples ] test-postgresql
[ user-assigned-person-schema test-tuples ] test-postgresql
[ user-assigned-person-schema test-repeated-insert ] test-postgresql
[ test-bignum ] test-postgresql
[ test-serialize ] test-postgresql
[ test-intervals ] test-postgresql
[ test-random-id ] test-postgresql

TUPLE: does-not-persist ;

[
    [ does-not-persist create-sql-statement ]
    [ class \ not-persistent = ] must-fail-with
] test-sqlite

[
    [ does-not-persist create-sql-statement ]
    [ class \ not-persistent = ] must-fail-with
] test-postgresql


TUPLE: suparclass id a ;

suparclass f {
    { "id" "ID" +db-assigned-id+ }
    { "a" "A" INTEGER }
} define-persistent

TUPLE: subbclass < suparclass b ;

subbclass "SUBCLASS" {
    { "b" "B" TEXT }
} define-persistent

TUPLE: fubbclass < subbclass ;

fubbclass "FUBCLASS" { } define-persistent

: test-db-inheritance ( -- )
    [ ] [ subbclass ensure-table ] unit-test
    [ ] [ fubbclass ensure-table ] unit-test
    
    [ ] [
        subbclass new 5 >>a "hi" >>b dup insert-tuple id>> "id" set
    ] unit-test
    
    [ t "hi" 5 ] [
        subbclass new "id" get >>id select-tuple
        [ subbclass? ] [ b>> ] [ a>> ] tri
    ] unit-test
    
    [ ] [ fubbclass new 0 >>a "hi" >>b insert-tuple ] unit-test
    
    [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ;

[ test-db-inheritance ] test-sqlite
[ test-db-inheritance ] test-postgresql


TUPLE: string-encoding-test id string ;

string-encoding-test "STRING_ENCODING_TEST" {
    { "id" "ID" +db-assigned-id+ }
    { "string" "STRING" TEXT }
} define-persistent

: test-string-encoding ( -- )
    [ ] [ string-encoding-test ensure-table ] unit-test

    [ ] [
        string-encoding-test new
            "\u{copyright-sign}\u{bengali-letter-cha}" >>string
        [ insert-tuple ] [ id>> "id" set ] bi
    ] unit-test
    
    [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [
        string-encoding-test new "id" get >>id select-tuple string>>
    ] unit-test ;

[ test-string-encoding ] test-sqlite
[ test-string-encoding ] test-postgresql

! Don't comment these out. These words must infer
\ bind-tuple must-infer
\ insert-tuple must-infer
\ update-tuple must-infer
\ delete-tuples must-infer
\ select-tuple must-infer
\ define-persistent must-infer
\ ensure-table must-infer
\ create-table must-infer
\ drop-table must-infer

: test-queries ( -- )
    [ ] [ exam ensure-table ] unit-test
    [ ] [ 1000 [ random-exam insert-tuple ] times ] unit-test
    [ 5 ] [
        <query>
        T{ exam { score T{ interval { from { 0 t } } { to { 100 t } } } } }
            >>tuple
        5 >>limit select-tuples length
    ] unit-test ;

TUPLE: compound-foo a b c ;

compound-foo "COMPOUND_FOO" 
{
    { "a" "A" INTEGER +user-assigned-id+ }
    { "b" "B" INTEGER +user-assigned-id+ }
    { "c" "C" INTEGER }
} define-persistent

: test-compound-primary-key ( -- )
    [ ] [ compound-foo ensure-table ] unit-test
    [ ] [ compound-foo drop-table ] unit-test
    [ ] [ compound-foo create-table ] unit-test
    [ ] [ 1 2 3 compound-foo boa insert-tuple ] unit-test
    [ 1 2 3 compound-foo boa insert-tuple ] must-fail
    [ ] [ 2 3 4 compound-foo boa insert-tuple ] unit-test
    [ T{ compound-foo { a 2 } { b 3 } { c 4 } } ]
    [ compound-foo new 4 >>c select-tuple ] unit-test ;

[ test-compound-primary-key ] test-sqlite
[ test-compound-primary-key ] test-postgresql