From a81aaa61009f3d84983b1004e94f925f466d4ea7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 19 Apr 2008 19:27:54 -0500 Subject: [PATCH] add random-id, still needs to retry if insert fails --- extra/db/db.factor | 6 +-- extra/db/sql/sql.factor | 6 +-- extra/db/sqlite/ffi/ffi.factor | 10 ++++- extra/db/sqlite/lib/lib.factor | 17 ++++++-- extra/db/sqlite/sqlite.factor | 34 +++++++++++++-- extra/db/tuples/tuples-tests.factor | 57 +++++++++++++++++++++---- extra/db/tuples/tuples.factor | 23 ++++++----- extra/db/types/types.factor | 64 ++++++++++++++++++----------- 8 files changed, 158 insertions(+), 59 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index 7a28dea558..ce6232f414 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -36,7 +36,7 @@ HOOK: db-close db ( handle -- ) ] with-variable ; ! TUPLE: sql sql in-params out-params ; -TUPLE: statement handle sql in-params out-params bind-params bound? type quot ; +TUPLE: statement handle sql in-params out-params bind-params bound? type ; TUPLE: simple-statement < statement ; TUPLE: prepared-statement < statement ; @@ -62,13 +62,9 @@ SINGLETON: retryable over sequence? [ [ make-retryable ] curry map ] [ - >>quot retryable >>type ] if ; -: handle-random-id ( statement -- ) - drop ; - TUPLE: result-set sql in-params out-params handle n max ; : construct-statement ( sql in out class -- statement ) diff --git a/extra/db/sql/sql.factor b/extra/db/sql/sql.factor index d7ef986ea6..4561424a9d 100755 --- a/extra/db/sql/sql.factor +++ b/extra/db/sql/sql.factor @@ -38,7 +38,7 @@ DEFER: sql% { \ select [ "(select" sql% sql% ")" sql% ] } { \ table [ sql% ] } { \ set [ "set" "," sql-interleave ] } - { \ values [ break "values(" sql% "," (sql-interleave) ")" sql% ] } + { \ values [ "values(" sql% "," (sql-interleave) ")" sql% ] } { \ count [ "count" sql-function, ] } { \ sum [ "sum" sql-function, ] } { \ avg [ "avg" sql-function, ] } @@ -47,7 +47,7 @@ DEFER: sql% [ sql% [ sql% ] each ] } case ; -TUPLE: no-sql-match ; +ERROR: no-sql-match ; : sql% ( obj -- ) { { [ dup string? ] [ " " 0% 0% ] } @@ -56,7 +56,7 @@ TUPLE: no-sql-match ; { [ dup symbol? ] [ unparse sql% ] } { [ dup word? ] [ unparse sql% ] } { [ dup quotation? ] [ call ] } - [ T{ no-sql-match } throw ] + [ no-sql-match ] } cond ; : parse-sql ( obj -- sql in-spec out-spec in out ) diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor index c724025874..6b94c02c65 100755 --- a/extra/db/sqlite/ffi/ffi.factor +++ b/extra/db/sqlite/ffi/ffi.factor @@ -3,7 +3,7 @@ ! An interface to the sqlite database. Tested against sqlite v3.1.3. ! Not all functions have been wrapped. USING: alien compiler kernel math namespaces sequences strings alien.syntax - system combinators ; + system combinators alien.c-types ; IN: db.sqlite.ffi << "sqlite" { @@ -112,11 +112,14 @@ FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppSt FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ; FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ; -FUNCTION: sqlite3_int64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; +FUNCTION: sqlite3_uint64 sqlite3_last_insert_rowid ( sqlite3* pStmt ) ; FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ; FUNCTION: int sqlite3_bind_double ( sqlite3_stmt* pStmt, int index, double x ) ; FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ; FUNCTION: int sqlite3_bind_int64 ( sqlite3_stmt* pStmt, int index, sqlite3_int64 n ) ; +: sqlite3-bind-uint64 ( pStmt index in64 -- int ) + "int" "sqlite" "sqlite3_bind_int64" + { "sqlite3_stmt*" "int" "sqlite3_uint64" } alien-invoke ; FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ; FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ; FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ; @@ -126,6 +129,9 @@ FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ; +: sqlite3-column-uint64 ( pStmt col -- uint64 ) + "sqlite3_uint64" "sqlite" "sqlite3_column_int64" + { "sqlite3_stmt*" "int" } alien-invoke ; FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ; FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor index b6221e5a1e..61070b078b 100755 --- a/extra/db/sqlite/lib/lib.factor +++ b/extra/db/sqlite/lib/lib.factor @@ -52,6 +52,9 @@ IN: db.sqlite.lib : sqlite-bind-int64 ( handle i n -- ) sqlite3_bind_int64 sqlite-check-result ; +: sqlite-bind-uint64 ( handle i n -- ) + sqlite3-bind-uint64 sqlite-check-result ; + : sqlite-bind-double ( handle i x -- ) sqlite3_bind_double sqlite-check-result ; @@ -69,7 +72,10 @@ IN: db.sqlite.lib parameter-index sqlite-bind-int ; : sqlite-bind-int64-by-name ( handle name int64 -- ) - parameter-index sqlite-bind-int ; + parameter-index sqlite-bind-int64 ; + +: sqlite-bind-uint64-by-name ( handle name int64 -- ) + parameter-index sqlite-bind-uint64 ; : sqlite-bind-double-by-name ( handle name double -- ) parameter-index sqlite-bind-double ; @@ -86,6 +92,8 @@ IN: db.sqlite.lib { { INTEGER [ sqlite-bind-int-by-name ] } { BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { SIGNED-BIG-INTEGER [ sqlite-bind-int64-by-name ] } + { UNSIGNED-BIG-INTEGER [ sqlite-bind-uint64-by-name ] } { TEXT [ sqlite-bind-text-by-name ] } { VARCHAR [ sqlite-bind-text-by-name ] } { DOUBLE [ sqlite-bind-double-by-name ] } @@ -99,6 +107,7 @@ IN: db.sqlite.lib sqlite-bind-blob-by-name ] } { +native-id+ [ sqlite-bind-int-by-name ] } + { +random-id+ [ sqlite-bind-int64-by-name ] } { NULL [ sqlite-bind-null-by-name ] } [ no-sql-type ] } case ; @@ -121,10 +130,12 @@ IN: db.sqlite.lib : sqlite-column-typed ( handle index type -- obj ) dup array? [ first ] when { - { +native-id+ [ sqlite3_column_int64 ] } - { +random-id+ [ sqlite3_column_int64 ] } + { +native-id+ [ sqlite3_column_int64 ] } + { +random-id+ [ sqlite3-column-uint64 ] } { INTEGER [ sqlite3_column_int ] } { BIG-INTEGER [ sqlite3_column_int64 ] } + { SIGNED-BIG-INTEGER [ sqlite3_column_int64 ] } + { UNSIGNED-BIG-INTEGER [ sqlite3-column-uint64 ] } { DOUBLE [ sqlite3_column_double ] } { TEXT [ sqlite3_column_text ] } { VARCHAR [ sqlite3_column_text ] } diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index e2ea28fe9a..5f8247f67b 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,7 +5,8 @@ hashtables 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 combinators.lib db.types combinators math.intervals -io namespaces.lib accessors vectors math.ranges ; +io namespaces.lib accessors vectors math.ranges random +math.bitfields.lib ; USE: tools.walker IN: db.sqlite @@ -65,6 +66,9 @@ M: sql-spec sqlite-bind-conversion ( tuple spec -- array ) M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri 3array ; +M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + nip [ key>> ] [ quot>> call ] [ type>> ] tri 3array ; + M: sqlite-statement bind-tuple ( tuple statement -- ) [ in-params>> [ sqlite-bind-conversion ] with map @@ -105,8 +109,7 @@ M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ; : sqlite-make ( class quot -- ) >r sql-props r> [ 0 sql-counter rot with-variable ] { "" { } { } } nmake - - dup handle-random-id ; inline + ; M: sqlite-db create-sql-statement ( class -- statement ) [ @@ -129,7 +132,21 @@ M: sqlite-db ( tuple -- statement ) maybe-remove-id dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% - [ ", " 0% ] [ bind% ] interleave + [ ", " 0% ] [ + dup type>> +random-id+ = [ +break + dup modifiers>> find-random-generator + [ + [ + column-name>> ":" prepend + dup 0% random-id-quot + ] with-random + ] curry + [ type>> ] bi 10 1, + ] [ + bind% + ] if + ] interleave ");" 0% ] sqlite-make ; @@ -219,6 +236,9 @@ M: sqlite-db ( tuple class -- statement ) dup empty? [ 2drop ] [ where-clause ] if ";" 0% ] sqlite-make ; +M: sqlite-db random-id-quot ( -- quot ) + [ 64 [ 2^ random ] keep 1 - set-bit ] ; + M: sqlite-db modifier-table ( -- hashtable ) H{ { +native-id+ "primary key" } @@ -229,6 +249,9 @@ M: sqlite-db modifier-table ( -- hashtable ) { +default+ "default" } { +null+ "null" } { +not-null+ "not null" } + { system-random-generator "" } + { secure-random-generator "" } + { random-generator "" } } ; M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ; @@ -244,6 +267,9 @@ M: sqlite-db type-table ( -- assoc ) { +native-id+ "integer primary key" } { +random-id+ "integer primary key" } { INTEGER "integer" } + { BIG-INTEGER "bigint" } + { SIGNED-BIG-INTEGER "bigint" } + { UNSIGNED-BIG-INTEGER "bigint" } { TEXT "text" } { VARCHAR "text" } { DATE "date" } diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 56e401d5ec..083cf059c9 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel tools.test db db.tuples +USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges -prettyprint tools.walker db.sqlite calendar -math.intervals db.postgresql ; +prettyprint tools.walker db.sqlite calendar sequences +math.intervals db.postgresql accessors random math.bitfields.lib ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -290,8 +290,37 @@ TUPLE: exam id name score ; [ test-intervals ] test-sqlite -: test-ranges - ; +TUPLE: bignum-test id m n o ; +: ( m n o -- obj ) + bignum-test new + swap >>o + swap >>n + swap >>m ; + +: test-bignum + bignum-test "BIGNUM_TEST" + { + { "id" "ID" +native-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^ dup dup insert-tuple ] unit-test + + [ T{ bignum-test f 1 + -9223372036854775808 9223372036854775808 -9223372036854775808 } ] + [ T{ bignum-test f 1 } select-tuple ] unit-test ; + +[ test-bignum ] test-sqlite + +TUPLE: does-not-persist ; + +[ + [ does-not-persist create-sql-statement ] + [ class \ not-persistent = ] must-fail-with +] test-sqlite TUPLE: secret n message ; C: secret @@ -299,14 +328,26 @@ C: secret : test-random-id secret "SECRET" { - { "n" "ID" +random-id+ } + { "n" "ID" +random-id+ system-random-generator } { "message" "MESSAGE" TEXT } } define-persistent [ ] [ secret ensure-table ] unit-test + [ ] [ f "kilroy was here" insert-tuple ] unit-test - [ ] [ T{ secret } select-tuples ] unit-test - ; + + [ ] [ f "kilroy was here2" insert-tuple ] unit-test + + [ ] [ f "kilroy was here3" 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 ; [ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor index 32431b4ddc..e0b4fce2f3 100755 --- a/extra/db/tuples/tuples.factor +++ b/extra/db/tuples/tuples.factor @@ -13,9 +13,16 @@ IN: db.tuples "db-columns" set-word-prop "db-relations" set-word-prop ; -: db-table ( class -- obj ) "db-table" word-prop ; -: db-columns ( class -- obj ) "db-columns" word-prop ; -: db-relations ( class -- obj ) "db-relations" word-prop ; +ERROR: not-persistent ; + +: db-table ( class -- obj ) + "db-table" word-prop [ not-persistent ] unless* ; + +: db-columns ( class -- obj ) + "db-columns" word-prop ; + +: db-relations ( class -- obj ) + "db-relations" word-prop ; : set-primary-key ( key tuple -- ) [ @@ -61,7 +68,7 @@ HOOK: insert-tuple* db ( tuple statement -- ) ] curry 2each ; : sql-props ( class -- columns table ) - dup db-columns swap db-table ; + [ db-columns ] [ db-table ] bi ; : with-disposals ( seq quot -- ) over sequence? [ @@ -88,17 +95,13 @@ HOOK: insert-tuple* db ( tuple statement -- ) [ bind-tuple ] 2keep insert-tuple* ; : insert-nonnative ( tuple -- ) -! TODO logic here for unique ids dup class db get db-insert-statements [ ] cache [ bind-tuple ] keep execute-statement ; : insert-tuple ( tuple -- ) - dup class db-columns find-primary-key nonnative-id? [ - insert-nonnative - ] [ - insert-native - ] if ; + dup class db-columns find-primary-key nonnative-id? + [ insert-nonnative ] [ insert-native ] if ; : update-tuple ( tuple -- ) dup class diff --git a/extra/db/types/types.factor b/extra/db/types/types.factor index 9959e894a7..b8855ce296 100755 --- a/extra/db/types/types.factor +++ b/extra/db/types/types.factor @@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser sequences continuations sequences.deep sequences.lib words namespaces tools.walker slots slots.private classes mirrors classes.tuple combinators calendar.format symbols -classes.singleton ; +classes.singleton accessors quotations random ; IN: db.types HOOK: modifier-table db ( -- hash ) @@ -12,12 +12,16 @@ HOOK: compound-modifier db ( str seq -- hash ) HOOK: type-table db ( -- hash ) HOOK: create-type-table db ( -- hash ) HOOK: compound-type db ( str n -- hash ) +HOOK: random-id-quot db ( -- quot ) -TUPLE: sql-spec class slot-name column-name type modifiers primary-key ; +TUPLE: sql-spec class slot-name column-name type primary-key modifiers ; TUPLE: literal-bind key type value ; C: literal-bind +TUPLE: generator-bind key quot type retries ; +C: generator-bind + SINGLETON: +native-id+ SINGLETON: +assigned-id+ SINGLETON: +random-id+ @@ -27,6 +31,15 @@ UNION: +nonnative-id+ +random-id+ +assigned-id+ ; SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ +foreign-id+ +has-many+ ; +: find-random-generator ( seq -- obj ) + [ + { + random-generator + system-random-generator + secure-random-generator + } member? + ] find nip [ system-random-generator ] unless* ; + : primary-key? ( spec -- ? ) sql-spec-primary-key +primary-key+? ; @@ -51,26 +64,27 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+ : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ; -SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR -DATE TIME DATETIME TIMESTAMP BLOB FACTOR-BLOB NULL ; +: handle-random-id ( statement -- ) + dup in-params>> [ type>> +random-id+ = ] find drop >boolean [ + retryable >>type + random-id-quot >>quot + ] when drop ; + +SYMBOLS: INTEGER BIG-INTEGER SIGNED-BIG-INTEGER UNSIGNED-BIG-INTEGER +DOUBLE REAL BOOLEAN TEXT VARCHAR DATE TIME DATETIME TIMESTAMP BLOB +FACTOR-BLOB NULL ; : spec>tuple ( class spec -- tuple ) - [ ?first3 ] keep 3 ?tail* - { - set-sql-spec-class - set-sql-spec-slot-name - set-sql-spec-column-name - set-sql-spec-type - set-sql-spec-modifiers - } sql-spec construct + 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 ; -TUPLE: no-sql-type ; -: no-sql-type ( -- * ) T{ no-sql-type } throw ; - -TUPLE: no-sql-modifier ; -: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ; - : number>string* ( n/str -- str ) dup number? [ number>string ] when ; @@ -88,13 +102,15 @@ TUPLE: no-sql-modifier ; ! PostgreSQL Types: ! http://developer.postgresql.org/pgdocs/postgres/datatype.html +ERROR: unknown-modifier ; + : lookup-modifier ( obj -- str ) - dup array? [ - unclip lookup-modifier swap compound-modifier - ] [ - modifier-table at* - [ "unknown modifier" throw ] unless - ] if ; + { + { [ dup array? ] [ unclip lookup-modifier swap compound-modifier ] } + [ modifier-table at* [ unknown-modifier ] unless ] + } cond ; + +ERROR: no-sql-type ; : lookup-type* ( obj -- str ) dup array? [