From 0c2cc6d459335e5a436b81947a4b009da72d30de Mon Sep 17 00:00:00 2001 From: Sascha Matzke Date: Tue, 12 Jan 2010 20:40:57 +0100 Subject: [PATCH] added gridfs implementation, reworked mongodb commands, some minor performance improvements --- extra/bson/bson-tests.factor | 7 +- extra/bson/bson.factor | 2 + extra/bson/constants/constants.factor | 35 ++- extra/bson/reader/reader.factor | 155 ++++------ extra/bson/summary.txt | 2 +- extra/bson/writer/writer.factor | 223 +++++++------- extra/mongodb/cmd/cmd.factor | 132 ++++++++ extra/mongodb/connection/connection.factor | 55 ++-- extra/mongodb/driver/driver.factor | 105 ++++--- extra/mongodb/gridfs/gridfs.factor | 285 ++++++++++++++++++ extra/mongodb/msg/msg.factor | 64 ++-- extra/mongodb/operations/operations.factor | 202 ++++++------- .../tuple/persistent/persistent.factor | 4 +- 13 files changed, 849 insertions(+), 422 deletions(-) create mode 100644 extra/mongodb/cmd/cmd.factor create mode 100644 extra/mongodb/gridfs/gridfs.factor diff --git a/extra/bson/bson-tests.factor b/extra/bson/bson-tests.factor index 9db3451f26..f068e951ae 100644 --- a/extra/bson/bson-tests.factor +++ b/extra/bson/bson-tests.factor @@ -1,4 +1,4 @@ -USING: bson.reader bson.writer byte-arrays io.encodings.binary +USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary io.streams.byte-array tools.test literals calendar kernel math ; IN: bson.tests @@ -17,6 +17,9 @@ IN: bson.tests [ H{ { "a quotation" [ 1 2 + ] } } ] [ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test +[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ] +[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test + [ H{ { "a date" T{ timestamp { year 2009 } { month 7 } { day 11 } @@ -34,10 +37,12 @@ IN: bson.tests ] unit-test [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } } + { "ref" T{ dbref f "a" "b" "c" } } { "array" H{ { "a list" { 1 2.234 "hello world" } } } } { "quot" [ 1 2 + ] } } ] [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } } + { "ref" T{ dbref f "a" "b" "c" } } { "array" H{ { "a list" { 1 2.234 "hello world" } } } } { "quot" [ 1 2 + ] } } turnaround ] unit-test diff --git a/extra/bson/bson.factor b/extra/bson/bson.factor index a97b5029b0..0c217e1c08 100644 --- a/extra/bson/bson.factor +++ b/extra/bson/bson.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2010 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader ; IN: bson diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor index 5148413b61..2d126857c3 100644 --- a/extra/bson/constants/constants.factor +++ b/extra/bson/constants/constants.factor @@ -1,5 +1,8 @@ -USING: accessors constructors kernel strings uuid ; - +! Copyright (C) 2010 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs calendar combinators +combinators.short-circuit constructors kernel linked-assocs +math math.bitwise random strings uuid ; IN: bson.constants : ( -- objid ) @@ -7,9 +10,33 @@ IN: bson.constants TUPLE: oid { a initial: 0 } { b initial: 0 } ; -TUPLE: objref ns objid ; +: ( -- oid ) + oid new + now timestamp>micros >>a + 8 random-bits 16 shift HEX: FF0000 mask + 16 random-bits HEX: FFFF mask + bitor >>b ; -CONSTRUCTOR: objref ( ns objid -- objref ) ; +TUPLE: dbref ref id db ; + +CONSTRUCTOR: dbref ( ref id -- dbref ) ; + +: dbref>assoc ( dbref -- assoc ) + [ ] dip over + { + [ [ ref>> "$ref" ] [ set-at ] bi* ] + [ [ id>> "$id" ] [ set-at ] bi* ] + [ over db>> [ + [ db>> "$db" ] [ set-at ] bi* + ] [ 2drop ] if ] + } 2cleave ; inline + +: assoc>dbref ( assoc -- dbref ) + [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri + dbref boa ; inline + +: dbref-assoc? ( assoc -- ? ) + { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline TUPLE: mdbregexp { regexp string } { options string } ; diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 51aa5f3817..000e5a8f0c 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -1,10 +1,10 @@ -USING: accessors assocs bson.constants calendar fry io io.binary -io.encodings io.encodings.utf8 kernel math math.bitwise namespaces -sequences serialize locals ; - -FROM: kernel.private => declare ; -FROM: io.encodings.private => (read-until) ; - +! Copyright (C) 2010 Sascha Matzke. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs bson.constants calendar combinators +combinators.short-circuit fry io io.binary kernel locals math +namespaces sequences serialize tools.continuations strings ; +FROM: io.encodings.binary => binary ; +FROM: io.streams.byte-array => with-byte-reader ; IN: bson.reader bits>double ; inline : read-byte-raw ( -- byte-raw ) - 1 read ; inline + 1 read ; : read-byte ( -- byte ) read-byte-raw first ; inline : read-cstring ( -- string ) - "\0" read-until drop "" like ; inline + "\0" read-until drop >string ; inline : read-sized-string ( length -- string ) - read 1 head-slice* "" like ; inline + read 1 head-slice* >string ; inline : read-element-type ( -- type ) read-byte ; inline @@ -80,106 +76,75 @@ GENERIC: element-binary-read ( length type -- object ) : peek-scope ( -- ht ) get-state scope>> last ; inline -: read-elements ( -- ) - read-element-type - element-read - [ read-elements ] when ; inline recursive +: bson-object-data-read ( -- object ) + read-int32 drop get-state + [ exemplar>> clone ] [ scope>> ] bi + [ push ] keep ; inline -GENERIC: fix-result ( assoc type -- result ) +: bson-binary-read ( -- binary ) + read-int32 read-byte + bson-binary-bytes? [ read ] [ read bytes>object ] if ; inline -M: bson-object fix-result ( assoc type -- result ) - drop ; +: bson-regexp-read ( -- mdbregexp ) + mdbregexp new + read-cstring >>regexp read-cstring >>options ; inline -M: bson-array fix-result ( assoc type -- result ) - drop values ; +: bson-oid-read ( -- oid ) + read-longlong read-int32 oid boa ; inline -GENERIC: end-element ( type -- ) +: element-data-read ( type -- object ) + { + { T_OID [ bson-oid-read ] } + { T_String [ read-int32 read-sized-string ] } + { T_Integer [ read-int32 ] } + { T_Binary [ bson-binary-read ] } + { T_Object [ bson-object-data-read ] } + { T_Array [ bson-object-data-read ] } + { T_Double [ read-double ] } + { T_Boolean [ read-byte 1 = ] } + { T_Date [ read-longlong millis>timestamp ] } + { T_Regexp [ bson-regexp-read ] } + { T_NULL [ f ] } + } case ; inline -M: bson-object end-element ( type -- ) - drop ; +: fix-result ( assoc type -- result ) + { + { [ dup T_Array = ] [ drop values ] } + { + [ dup T_Object = ] + [ drop dup dbref-assoc? [ assoc>dbref ] when ] + } + } cond ; inline -M: bson-array end-element ( type -- ) - drop ; +: end-element ( type -- ) + { [ bson-object? ] [ bson-array? ] } 1|| + [ pop-element drop ] unless ; inline -M: object end-element ( type -- ) - pop-element 2drop ; - -M:: bson-eoo element-read ( type -- cont? ) +:: bson-eoo-element-read ( type -- cont? ) pop-element :> element get-state scope>> [ pop element type>> fix-result ] [ empty? ] bi [ [ get-state ] dip >>result drop f ] - [ element name>> peek-scope set-at t ] if ; + [ element name>> peek-scope set-at t ] if ; inline -M:: bson-not-eoo element-read ( type -- cont? ) +:: bson-not-eoo-element-read ( type -- cont? ) peek-scope :> scope type read-cstring [ push-element ] 2keep [ [ element-data-read ] [ end-element ] bi ] - [ scope set-at t ] bi* ; + [ scope set-at t ] bi* ; inline -: [scope-changer] ( state -- state quot ) - dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline +: (element-read) ( type -- cont? ) + dup bson-not-eoo? + [ bson-not-eoo-element-read ] + [ bson-eoo-element-read ] if ; inline -: (object-data-read) ( type -- object ) - drop - read-int32 drop - get-state - [scope-changer] change-scope - scope>> last ; inline - -M: bson-object element-data-read ( type -- object ) - (object-data-read) ; - -M: bson-string element-data-read ( type -- object ) - drop - read-int32 read-sized-string ; - -M: bson-array element-data-read ( type -- object ) - (object-data-read) ; - -M: bson-integer element-data-read ( type -- object ) - drop - read-int32 ; - -M: bson-double element-data-read ( type -- double ) - drop - read-double ; - -M: bson-boolean element-data-read ( type -- boolean ) - drop - read-byte 1 = ; - -M: bson-date element-data-read ( type -- timestamp ) - drop - read-longlong millis>timestamp ; - -M: bson-binary element-data-read ( type -- binary ) - drop - read-int32 read-byte element-binary-read ; - -M: bson-regexp element-data-read ( type -- mdbregexp ) - drop mdbregexp new - read-cstring >>regexp read-cstring >>options ; - -M: bson-null element-data-read ( type -- bf ) - drop f ; - -M: bson-oid element-data-read ( type -- oid ) - drop - read-longlong - read-int32 oid boa ; - -M: bson-binary-bytes element-binary-read ( size type -- bytes ) - drop read ; - -M: bson-binary-custom element-binary-read ( size type -- quot ) - drop read bytes>object ; +: read-elements ( -- ) + read-element-type + (element-read) [ read-elements ] when ; inline recursive PRIVATE> -USE: tools.continuations - : stream>assoc ( exemplar -- assoc ) dup state - [ read-int32 >>size read-elements ] with-variable - result>> ; + [ read-int32 >>size read-elements ] with-variable + result>> ; inline diff --git a/extra/bson/summary.txt b/extra/bson/summary.txt index 58604e6990..e0d8b9ca89 100644 --- a/extra/bson/summary.txt +++ b/extra/bson/summary.txt @@ -1 +1 @@ -BSON reader and writer +BSON (http://en.wikipedia.org/wiki/BSON) reader and writer diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index 2ae8737c70..965eace1ad 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -1,154 +1,153 @@ -! Copyright (C) 2008 Sascha Matzke. +! Copyright (C) 2010 Sascha Matzke. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bson.constants byte-arrays byte-vectors -calendar fry io io.binary io.encodings io.encodings.binary -io.encodings.utf8 io.streams.byte-array kernel math math.parser -namespaces quotations sequences sequences.private serialize strings -words combinators.short-circuit literals ; - -FROM: io.encodings.utf8.private => char>utf8 ; -FROM: kernel.private => declare ; - +USING: accessors arrays assocs bson.constants byte-arrays +calendar combinators.short-circuit fry hashtables io io.binary +kernel linked-assocs literals math math.parser namespaces +quotations sequences serialize strings vectors dlists alien.accessors ; +FROM: words => word? word ; +FROM: typed => TYPED: ; +FROM: combinators => cond ; IN: bson.writer -: reset-buffer ( buffer -- ) - 0 >>length drop ; inline - -: ensure-buffer ( -- ) - (buffer) drop ; inline - -: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector ) - [ (buffer) [ reset-buffer ] keep dup ] dip - with-output-stream* ; inline - -: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index ) - [ (buffer) [ length ] keep ] dip +: with-length ( quot: ( -- ) -- bytes-written start-index ) + [ output-stream get [ length ] [ ] bi ] dip call length swap [ - ] keep ; inline : (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b ) [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap - [ call ] dip (buffer) copy ; inline + [ call output-stream get underlying>> ] dip set-alien-unsigned-4 ; inline -: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b ) - [ INT32-SIZE >le ] (with-length-prefix) ; inline +: with-length-prefix ( quot: ( -- ) -- ) + [ ] (with-length-prefix) ; inline -: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b ) - [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline +: with-length-prefix-excl ( quot: ( -- ) -- ) + [ INT32-SIZE - ] (with-length-prefix) ; inline le write ; inline + : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline + : write-cstring ( string -- ) B{ } like write 0 write1 ; inline + : write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-eoo ( -- ) T_EOO write1 ; inline -: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline -: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline -M: string bson-write ( obj -- ) - '[ _ write-cstring ] with-length-prefix-excl ; +: write-header ( name object type -- object ) + write1 [ write-cstring ] dip ; inline -M: f bson-write ( f -- ) - drop 0 write1 ; +DEFER: write-pair -M: t bson-write ( t -- ) - drop 1 write1 ; +: write-byte-array ( binary -- ) + [ length write-int32 ] + [ T_Binary_Bytes write1 write ] bi ; inline -M: integer bson-write ( num -- ) - write-int32 ; - -M: real bson-write ( num -- ) - >float write-double ; - -M: timestamp bson-write ( timestamp -- ) - timestamp>millis write-longlong ; - -M: byte-array bson-write ( binary -- ) - [ length write-int32 ] keep - T_Binary_Bytes write1 - write ; - -M: oid bson-write ( oid -- ) - [ a>> write-longlong ] [ b>> write-int32 ] bi ; - -M: mdbregexp bson-write ( regexp -- ) +: write-mdbregexp ( regexp -- ) [ regexp>> write-cstring ] - [ options>> write-cstring ] bi ; - -M: sequence bson-write ( array -- ) - '[ _ [ [ write-type ] dip number>string - write-cstring bson-write ] each-index - write-eoo ] with-length-prefix ; + [ options>> write-cstring ] bi ; inline -: write-oid ( assoc -- ) - [ MDB_OID_FIELD ] dip at - [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline - -: skip-field? ( name -- boolean ) - { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline - -M: assoc bson-write ( assoc -- ) - '[ - _ [ write-oid ] keep - [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each +TYPED: write-sequence ( array: sequence -- ) + '[ + _ [ number>string swap write-pair ] each-index write-eoo - ] with-length-prefix ; + ] with-length-prefix ; inline recursive -: (serialize-code) ( code -- ) - object>bytes [ length write-int32 ] keep - T_Binary_Custom write1 - write ; +TYPED: write-oid ( oid: oid -- ) + [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline -M: quotation bson-write ( quotation -- ) - (serialize-code) ; - -M: word bson-write ( word -- ) - (serialize-code) ; +: write-oid-field ( assoc -- ) + [ MDB_OID_FIELD dup ] dip at + [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ] + [ drop ] if* ; inline + +: skip-field? ( name value -- name value boolean ) + over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline + +UNION: hashtables hashtable linked-assoc ; + +TYPED: write-assoc ( assoc: hashtables -- ) + '[ _ [ write-oid-field ] [ + [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each + ] bi write-eoo + ] with-length-prefix ; inline recursive + +UNION: code word quotation ; + +TYPED: (serialize-code) ( code: code -- ) + object>bytes + [ length write-int32 ] + [ T_Binary_Custom write1 write ] bi ; inline + +TYPED: write-string ( string: string -- ) + '[ _ write-cstring ] with-length-prefix-excl ; inline + +TYPED: write-boolean ( bool: boolean -- ) + [ 1 write1 ] [ 0 write1 ] if ; inline + +: write-pair ( name obj -- ) + { + { + [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ] + [ T_Object write-header write-assoc ] + } { + [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ] + [ T_Array write-header write-sequence ] + } { + [ dup byte-array? ] + [ T_Binary write-header write-byte-array ] + } { + [ dup string? ] + [ T_String write-header write-string ] + } { + [ dup oid? ] + [ T_OID write-header write-oid ] + } { + [ dup integer? ] + [ T_Integer write-header write-int32 ] + } { + [ dup boolean? ] + [ T_Boolean write-header write-boolean ] + } { + [ dup real? ] + [ T_Double write-header >float write-double ] + } { + [ dup timestamp? ] + [ T_Date write-header timestamp>millis write-longlong ] + } { + [ dup mdbregexp? ] + [ T_Regexp write-header write-mdbregexp ] + } { + [ dup quotation? ] + [ T_Binary write-header (serialize-code) ] + } { + [ dup word? ] + [ T_Binary write-header (serialize-code) ] + } { + [ dup dbref? ] + [ T_Object write-header dbref>assoc write-assoc ] + } { + [ dup f = ] + [ T_NULL write-header drop ] + } + } cond ; PRIVATE> -: assoc>bv ( assoc -- byte-vector ) - [ '[ _ bson-write ] with-buffer ] with-scope ; inline +TYPED: assoc>bv ( assoc: hashtables -- byte-vector ) + [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline -: assoc>stream ( assoc -- ) - { assoc } declare bson-write ; inline +TYPED: assoc>stream ( assoc: hashtables -- ) + write-assoc ; inline : mdb-special-value? ( value -- ? ) { [ timestamp? ] [ quotation? ] [ mdbregexp? ] diff --git a/extra/mongodb/cmd/cmd.factor b/extra/mongodb/cmd/cmd.factor new file mode 100644 index 0000000000..49959d690c --- /dev/null +++ b/extra/mongodb/cmd/cmd.factor @@ -0,0 +1,132 @@ +USING: accessors assocs hashtables kernel linked-assocs strings ; +IN: mongodb.cmd + + + +CONSTANT: buildinfo-cmd + T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } } + +CONSTANT: list-databases-cmd + T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } } + +! Options: { "async" t } +CONSTANT: fsync-cmd + T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } } + +! Value: { "clone" from_host } +CONSTANT: clone-db-cmd + T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } } + +! Options { { "fromdb" db } { "todb" db } { fromhost host } } +CONSTANT: copy-db-cmd + T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } } + +CONSTANT: shutdown-cmd + T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t } + +CONSTANT: reseterror-cmd + T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } } + +CONSTANT: getlasterror-cmd + T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } } + +CONSTANT: getpreverror-cmd + T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } } + +CONSTANT: forceerror-cmd + T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } } + +CONSTANT: drop-db-cmd + T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } } + +! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } } +CONSTANT: repair-db-cmd + T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } } + +! Options: -1 gets the current profile level; 0-2 set the profile level +CONSTANT: profile-cmd + T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } } + +CONSTANT: server-status-cmd + T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } } + +CONSTANT: assertinfo-cmd + T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } } + +CONSTANT: getoptime-cmd + T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } } + +CONSTANT: oplog-cmd + T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } } + +! Value: { "deleteIndexes" collection-name } +! Options: { "index" index_name or "*" } +CONSTANT: delete-index-cmd + T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } } + +! Value: { "create" collection-name } +! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } } +CONSTANT: create-cmd + T{ mongodb-cmd f "drop" f f f H{ { "create" f } } } + +! Value { "drop" collection-name } +CONSTANT: drop-cmd + T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } } + +! Value { "count" collection-name } +! Options: { "query" query-object } +CONSTANT: count-cmd + T{ mongodb-cmd f "count" f f f H{ { "count" f } } } + +! Value { "validate" collection-name } +CONSTANT: validate-cmd + T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } } + +! Value { "collstats" collection-name } +CONSTANT: collstats-cmd + T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } } + +! Value: { "distinct" collection-name } +! Options: { "key" key-name } +CONSTANT: distinct-cmd + T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } } + +! Value: { "filemd5" oid } +! Options: { "root" bucket-name } +CONSTANT: filemd5-cmd + T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } } + +CONSTANT: getnonce-cmd + T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } } + +! Options: { { "user" username } { "nonce" nonce } { "key" digest } } +CONSTANT: authenticate-cmd + T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } } + +CONSTANT: logout-cmd + T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } } + +! Value: { "findandmodify" collection-name } +! Options: { { "query" selector } { "sort" sort-spec } +! { "remove" t/f } { "update" modified-object } +! { "new" t/f } } +CONSTANT: findandmodify-cmd + T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } } + +: make-cmd ( cmd-stub -- cmd-assoc ) + dup const?>> [ ] [ + clone [ clone ] change-assoc + ] if ; inline + +: set-cmd-opt ( cmd value key -- cmd ) + pick assoc>> set-at ; inline diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor index 1d38aa38d5..3083160828 100644 --- a/extra/mongodb/connection/connection.factor +++ b/extra/mongodb/connection/connection.factor @@ -1,9 +1,9 @@ -USING: accessors assocs fry io.encodings.binary io.sockets kernel math -math.parser mongodb.msg mongodb.operations namespaces destructors -constructors sequences splitting checksums checksums.md5 -io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart -arrays hashtables sequences.deep vectors locals ; - +USING: accessors arrays assocs byte-vectors checksums +checksums.md5 constructors destructors fry hashtables +io.encodings.binary io.encodings.string io.encodings.utf8 +io.sockets io.streams.duplex kernel locals math math.parser +mongodb.cmd mongodb.msg namespaces sequences +splitting ; IN: mongodb.connection : md5-checksum ( string -- digest ) @@ -15,7 +15,12 @@ TUPLE: mdb-node master? { address inet } remote ; CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ; -TUPLE: mdb-connection instance node handle remote local ; +TUPLE: mdb-connection instance node handle remote local buffer ; + +: connection-buffer ( -- buffer ) + mdb-connection get buffer>> 0 >>length ; inline + +USE: mongodb.operations CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; @@ -33,7 +38,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; nodes>> f swap at ; : with-connection ( connection quot -- * ) - [ mdb-connection set ] prepose with-scope ; inline + [ mdb-connection ] dip with-variable ; inline : mdb-instance ( -- mdb ) mdb-connection get instance>> ; inline @@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; : namespaces-collection ( -- ns ) mdb-instance name>> "system.namespaces" "." glue ; inline -: cmd-collection ( -- ns ) - mdb-instance name>> "$cmd" "." glue ; inline +: cmd-collection ( cmd -- ns ) + admin?>> [ "admin" ] [ mdb-instance name>> ] if + "$cmd" "." glue ; inline : index-ns ( colname -- index-ns ) [ mdb-instance name>> ] dip "." glue ; inline @@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; '[ _ write-message read-message ] with-stream* ; : send-query-1result ( collection assoc -- result ) - - 1 >>return# - send-query-plain objects>> - [ f ] [ first ] if-empty ; + -1 >>return# send-query-plain + objects>> [ f ] [ first ] if-empty ; + +: send-cmd ( cmd -- result ) + [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline > ] bi 3array concat md5-checksum ; inline -: build-auth-query ( -- query-assoc ) - { "authenticate" 1 } - "user" mdb-instance username>> 2array - "nonce" get-nonce 2array - 3array >hashtable - [ [ "nonce" ] dip at calculate-key-digest "key" ] keep - [ set-at ] keep ; +: build-auth-cmd ( cmd -- cmd ) + mdb-instance username>> "user" set-cmd-opt + get-nonce [ "nonce" set-cmd-opt ] [ ] bi + calculate-key-digest "key" set-cmd-opt ; inline : perform-authentication ( -- ) - cmd-collection build-auth-query send-query-1result + authenticate-cmd make-cmd + build-auth-cmd send-cmd check-ok [ drop ] [ throw ] if ; inline : authenticate-connection ( mdb-connection -- ) @@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; : open-connection ( mdb-connection node -- mdb-connection ) [ >>node ] [ address>> ] bi [ >>remote ] keep binary - [ >>handle ] dip >>local ; + [ >>handle ] dip >>local 4096 >>buffer ; : get-ismaster ( -- result ) "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; @@ -119,7 +124,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; : nodelist>table ( seq -- assoc ) [ [ master?>> ] keep 2array ] map >hashtable ; - + PRIVATE> :: verify-nodes ( mdb -- ) diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 78d0b62734..0bd22ee7fe 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -1,10 +1,10 @@ USING: accessors arrays assocs bson.constants combinators -combinators.smart constructors destructors formatting fry hashtables -io io.pools io.sockets kernel linked-assocs math mongodb.connection -mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections -sequences sets splitting strings -tools.continuations uuid memoize locals ; - +combinators.smart constructors destructors fry hashtables io +io.pools io.sockets kernel linked-assocs locals math +mongodb.cmd mongodb.connection mongodb.msg namespaces parser +prettyprint prettyprint.custom prettyprint.sections sequences +sets splitting strings ; +FROM: ascii => ascii? ; IN: mongodb.driver TUPLE: mdb-pool < pool mdb ; @@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ; TUPLE: mdb-collection { name string } -{ capped boolean initial: f } -{ size integer initial: -1 } -{ max integer initial: -1 } ; +{ capped boolean } +{ size integer } +{ max integer } ; CONSTRUCTOR: mdb-collection ( name -- collection ) ; @@ -61,7 +61,7 @@ M: mdb-getmore-msg update-query query>> update-query ; : make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f ) - over cursor>> 0 > + over cursor>> 0 > [ [ update-query ] [ [ cursor>> ] dip ] 2bi ] [ 2drop f ] if ; @@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result [ make-cursor ] 2tri swap objects>> ; -: make-collection-assoc ( collection assoc -- ) - [ [ name>> "create" ] dip set-at ] - [ [ [ capped>> ] keep ] dip - '[ _ _ - [ [ drop t "capped" ] dip set-at ] - [ [ size>> "size" ] dip set-at ] - [ [ max>> "max" ] dip set-at ] 2tri ] when - ] 2bi ; PRIVATE> SYNTAX: r/ ( token -- mdbregexp ) \ / [ >mdbregexp ] parse-literal ; -: with-db ( mdb quot -- * ) +: with-db ( mdb quot -- ) '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline - + +: with-mdb ( mdb quot -- ) + [ ] dip + [ mdb-pool swap with-variable ] curry with-disposal ; inline + +: with-mdb-connection ( quot -- ) + [ mdb-pool get ] dip + '[ _ with-connection ] with-pooled-connection ; inline + : >id-selector ( assoc -- selector ) [ MDB_OID_FIELD swap at ] keep H{ } clone [ set-at ] keep ; @@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- ) M: string create-collection create-collection ; -M: mdb-collection create-collection - [ [ cmd-collection ] dip - [ make-collection-assoc ] keep - 1 >>return# send-query-plain drop ] keep - [ ] [ name>> ] bi mdb-instance collections>> set-at ; +M: mdb-collection create-collection ( collection -- ) + create-cmd make-cmd over + { + [ name>> "create" set-cmd-opt ] + [ capped>> [ "capped" set-cmd-opt ] when* ] + [ max>> [ "max" set-cmd-opt ] when* ] + [ size>> [ "size" set-cmd-opt ] when* ] + } cleave send-cmd check-ok + [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ] + [ throw ] if ; : load-collection-list ( -- collection-list ) namespaces-collection @@ -128,8 +133,12 @@ M: mdb-collection create-collection ] keep - '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline + [ + [ ";$." intersect length 0 > ] keep + '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when + ] [ + [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless + ] bi ; inline : build-collection-map ( -- assoc ) H{ } clone load-collection-list @@ -215,21 +224,21 @@ M: mdb-cursor find dup empty? [ drop f ] [ first ] if ; : count ( mdb-query-msg -- result ) - [ collection>> "count" H{ } clone [ set-at ] keep ] keep - query>> [ over [ "query" ] dip set-at ] when* - [ cmd-collection ] dip find-one + [ count-cmd make-cmd ] dip + [ collection>> "count" set-cmd-opt ] + [ query>> "query" set-cmd-opt ] bi send-cmd [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ; : lasterror ( -- error ) - cmd-collection H{ { "getlasterror" 1 } } - find-one [ "err" ] dip at ; + getlasterror-cmd make-cmd send-cmd + [ "err" ] dip at ; GENERIC: validate. ( collection -- ) M: string validate. - [ cmd-collection ] dip - "validate" H{ } clone [ set-at ] keep - find-one [ check-ok nip ] keep + [ validate-cmd make-cmd ] dip + "validate" set-cmd-opt send-cmd + [ check-ok nip ] keep '[ "result" _ at print ] [ ] if ; M: mdb-collection validate. @@ -251,7 +260,7 @@ PRIVATE> send-message ; : ensure-index ( index-spec -- ) - [ [ uuid1 "_id" ] dip set-at ] keep + [ [ "_id" ] dip set-at ] keep [ { [ [ name>> "name" ] dip set-at ] [ [ ns>> index-ns "ns" ] dip set-at ] [ [ key>> "key" ] dip set-at ] @@ -261,11 +270,9 @@ PRIVATE> [ index-collection ] dip save ; : drop-index ( collection name -- ) - H{ } clone - [ [ "index" ] dip set-at ] keep - [ [ "deleteIndexes" ] dip set-at ] keep - [ cmd-collection ] dip - find-one drop ; + [ delete-index-cmd make-cmd ] 2dip + [ "deleteIndexes" set-cmd-opt ] + [ "index" set-cmd-opt ] bi* send-cmd drop ; : ( collection selector object -- mdb-update-msg ) [ check-collection ] 2dip ; @@ -278,7 +285,16 @@ PRIVATE> : update-unsafe ( mdb-update-msg -- ) send-message ; - + +: find-and-modify ( collection selector modifier -- mongodb-cmd ) + [ findandmodify-cmd make-cmd ] 3dip + [ "findandmodify" set-cmd-opt ] + [ "query" set-cmd-opt ] + [ "update" set-cmd-opt ] tri* ; inline + +: run-cmd ( cmd -- result ) + send-cmd ; inline + : delete ( collection selector -- ) [ check-collection ] dip send-message-check-error ; @@ -298,8 +314,7 @@ PRIVATE> check-collection drop ; : drop-collection ( name -- ) - [ cmd-collection ] dip - "drop" H{ } clone [ set-at ] keep - find-one drop ; + [ drop-cmd make-cmd ] dip + "drop" set-cmd-opt send-cmd drop ; diff --git a/extra/mongodb/gridfs/gridfs.factor b/extra/mongodb/gridfs/gridfs.factor new file mode 100644 index 0000000000..0c5ba6f9a6 --- /dev/null +++ b/extra/mongodb/gridfs/gridfs.factor @@ -0,0 +1,285 @@ +USING: accessors arrays assocs base64 bson.constants +byte-arrays byte-vectors calendar combinators +combinators.short-circuit destructors formatting fry hashtables +io kernel linked-assocs locals math math.parser mongodb.cmd +mongodb.connection mongodb.driver mongodb.msg namespaces +sequences splitting strings ; +FROM: mongodb.driver => update ; +IN: mongodb.gridfs + +CONSTANT: default-chunk-size 262144 + +TUPLE: gridfs + { bucket string } + { files string } + { chunks string } ; + + + ( -- gridfs ) + gridfs get ; inline + +: files-collection ( -- str ) gridfs> files>> ; inline +: chunks-collection ( -- str ) gridfs> chunks>> ; inline + + +: init-gridfs ( gridfs -- ) + chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } } + ensure-index ; inline + +PRIVATE> + +: ( bucket -- gridfs ) + [ ] + [ "files" "%s.%s" sprintf ] + [ "chunks" "%s.%s" sprintf ] tri + gridfs boa [ init-gridfs ] keep ; + +: with-gridfs ( gridfs quot -- * ) + [ gridfs ] dip with-variable ; inline + +TUPLE: entry + { id oid } + { filename string } + { content-type string } + { length integer } + { chunk-size integer } + { created timestamp } + { aliases array } + { metadata hashtable } + { md5 string } ; + +base64 ( id -- str ) + [ a>> >hex ] [ b>> >hex ] bi + 2array "#" join >base64 >string ; inline + +: base64>id ( str -- objid ) + base64> >string "#" split + [ first ] [ second ] bi + [ hex> ] bi@ oid boa ; inline + +PRIVATE> + +: ( name content-type -- entry ) + entry new + swap >>content-type swap >>filename + >>id 0 >>length default-chunk-size >>chunk-size + now >>created ; inline + + ( assoc key -- value/f ) + swap at ; inline + +:: >set-at ( assoc value key -- ) + value key assoc set-at ; inline + +: (update-file) ( entry assoc -- entry ) + { + [ "_id" at> >>id ] + [ "filename" at> >>filename ] + [ "contentType" at> >>content-type ] + [ "length" at> >>length ] + [ "chunkSize" at> >>chunk-size ] + [ "uploadDate" at> >>created ] + [ "aliases" at> >>aliases ] + [ "metadata" at> >>metadata ] + [ "md5" at> >>md5 ] + } cleave ; inline + +: assoc>chunk ( assoc -- chunk ) + [ chunk new ] dip + { + [ "_id" at> >>id ] + [ "files_id" at> >>fileid ] + [ "n" at> >>n ] + [ "data" at> >>data ] + } cleave ; + +: assoc>entry ( assoc -- entry ) + [ entry new ] dip (update-file) ; + +: entry>assoc ( entry -- assoc ) + [ H{ } clone ] dip + { + [ id>> "_id" >set-at ] + [ filename>> "filename" >set-at ] + [ content-type>> "contentType" >set-at ] + [ length>> "length" >set-at ] + [ chunk-size>> "chunkSize" >set-at ] + [ created>> "uploadDate" >set-at ] + [ aliases>> "aliases" >set-at ] + [ metadata>> "metadata" >set-at ] + [ md5>> "md5" >set-at ] + [ drop ] + } 2cleave ; inline + +: create-entry ( entry -- entry ) + [ [ files-collection ] dip entry>assoc save ] [ ] bi ; + +TUPLE: state bytes count ; + +: ( -- state ) + 0 0 state boa ; inline + +: get-state ( -- n ) + state get ; inline + +: with-state ( quot -- state ) + [ state ] dip + [ get-state ] compose + with-variable ; inline + +: update-state ( bytes -- ) + [ get-state ] dip + '[ _ + ] change-bytes + [ 1 + ] change-count drop ; inline + +:: store-chunk ( chunk entry n -- ) + entry id>> :> id + H{ { "files_id" id } + { "n" n } { "data" chunk } } + [ chunks-collection ] dip save ; inline + +:: write-chunks ( stream entry -- length ) + entry chunk-size>> :> chunk-size + [ + [ + chunk-size stream stream-read dup [ + [ entry get-state count>> store-chunk ] + [ length update-state ] bi + ] when* + ] loop + ] with-state bytes>> ; + +: (entry-selector) ( entry -- selector ) + id>> "_id" associate ; inline + +:: file-md5 ( id -- md5-str ) + filemd5-cmd make-cmd + id "filemd5" set-cmd-opt + gridfs> bucket>> "root" set-cmd-opt + send-cmd "md5" at> ; inline + +: update-entry ( bytes entry -- entry ) + [ swap >>length dup id>> file-md5 >>md5 ] + [ nip [ (entry-selector) ] [ ] bi + [ length>> "length" associate "$set" associate + [ files-collection ] 2dip update ] + [ md5>> "md5" associate "$set" associate + [ files-collection ] 2dip update ] 2bi + ] 2bi ; + +TUPLE: gridfs-input-stream entry chunk n offset cpos ; + +: ( entry -- stream ) + [ gridfs-input-stream new ] dip + >>entry 0 >>offset 0 >>cpos -1 >>n ; + +PRIVATE> + +: write-entry ( input-stream entry -- entry ) + create-entry [ write-chunks ] keep update-entry ; + +: get-entry ( id -- entry ) + [ files-collection ] dip + "_id" associate find-one assoc>entry ; + +: open-entry ( entry -- input-stream ) + ; + +: entry-contents ( entry -- bytearray ) + stream-contents ; + +> id>> "files_id" associate ] + [ n>> "n" associate ] bi assoc-union + [ chunks-collection ] dip + find-one dup [ assoc>chunk ] when ; + +: exhausted? ( stream -- boolean ) + [ offset>> ] [ entry>> length>> ] bi = ; inline + +: fresh? ( stream -- boolean ) + [ offset>> 0 = ] [ chunk>> f = ] bi and ; inline + +: data-available ( stream -- int/f ) + [ cpos>> ] [ chunk>> data>> length ] bi + 2dup < [ swap - ] [ 2drop f ] if ; inline + +: next-chunk ( stream -- available chunk/f ) + 0 >>cpos [ 1 + ] change-n + [ ] [ load-chunk ] bi >>chunk + [ data-available ] [ chunk>> ] bi ; inline + +: ?chunk ( stream -- available chunk/f ) + dup fresh? [ next-chunk ] [ + dup exhausted? [ drop 0 f ] [ + dup data-available [ swap chunk>> ] [ next-chunk ] if* + ] if + ] if ; inline + +: set-stream ( n stream -- ) + swap { + [ >>offset drop ] + [ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ] + [ drop dup load-chunk >>chunk drop ] + } 2cleave ; inline + +:: advance-stream ( n stream -- ) + stream [ n + ] change-cpos [ n + ] change-offset drop ; inline + +: read-part ( n stream chunk -- seq/f ) + [ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* ] + [ drop advance-stream ] 3bi ; inline + +:: (stream-read-partial) ( n stream -- seq/f ) + stream ?chunk :> chunk :> available + chunk [ + n available < + [ n ] [ available ] if + stream chunk read-part + ] [ f ] if ; inline + +:: (stream-read) ( n stream acc -- ) + n stream (stream-read-partial) + { + { [ dup not ] [ drop ] } + { [ dup length n = ] [ acc push-all ] } + { [ dup length n < ] [ + [ acc push-all ] [ length ] bi + n swap - stream acc (stream-read) ] + } + } cond ; inline recursive + +PRIVATE> + +M: gridfs-input-stream stream-element-type drop +byte+ ; + +M: gridfs-input-stream stream-read ( n stream -- seq/f ) + over [ (stream-read) ] [ ] bi + dup empty? [ drop f ] [ >byte-array ] if ; + +M: gridfs-input-stream stream-read-partial ( n stream -- seq/f ) + (stream-read-partial) ; + +M: gridfs-input-stream stream-tell ( stream -- n ) + offset>> ; + +M: gridfs-input-stream stream-seek ( n seek-type stream -- ) + swap seek-absolute = + [ set-stream ] + [ "seek-type not supported" throw ] if ; + +M: gridfs-input-stream dispose drop ; diff --git a/extra/mongodb/msg/msg.factor b/extra/mongodb/msg/msg.factor index ada0ab42d0..ca9393a108 100644 --- a/extra/mongodb/msg/msg.factor +++ b/extra/mongodb/msg/msg.factor @@ -17,52 +17,52 @@ CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */ CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */ TUPLE: mdb-msg -{ opcode integer } -{ req-id integer initial: 0 } -{ resp-id integer initial: 0 } -{ length integer initial: 0 } -{ flags integer initial: 0 } ; + { opcode integer } + { req-id integer initial: 0 } + { resp-id integer initial: 0 } + { length integer initial: 0 } + { flags integer initial: 0 } ; TUPLE: mdb-query-msg < mdb-msg -{ collection string } -{ skip# integer initial: 0 } -{ return# integer initial: 0 } -{ query assoc } -{ returnfields assoc } -{ orderby assoc } -explain hint ; + { collection string } + { skip# integer initial: 0 } + { return# integer initial: 0 } + { query assoc } + { returnfields assoc } + { orderby assoc } + explain hint ; TUPLE: mdb-insert-msg < mdb-msg -{ collection string } -{ objects sequence } ; + { collection string } + { objects sequence } ; TUPLE: mdb-update-msg < mdb-msg -{ collection string } -{ upsert? integer initial: 0 } -{ selector assoc } -{ object assoc } ; + { collection string } + { upsert? integer initial: 0 } + { selector assoc } + { object assoc } ; TUPLE: mdb-delete-msg < mdb-msg -{ collection string } -{ selector assoc } ; + { collection string } + { selector assoc } ; TUPLE: mdb-getmore-msg < mdb-msg -{ collection string } -{ return# integer initial: 0 } -{ cursor integer initial: 0 } -{ query mdb-query-msg } ; + { collection string } + { return# integer initial: 0 } + { cursor integer initial: 0 } + { query mdb-query-msg } ; TUPLE: mdb-killcursors-msg < mdb-msg -{ cursors# integer initial: 0 } -{ cursors sequence } ; + { cursors# integer initial: 0 } + { cursors sequence } ; TUPLE: mdb-reply-msg < mdb-msg -{ collection string } -{ cursor integer initial: 0 } -{ start# integer initial: 0 } -{ requested# integer initial: 0 } -{ returned# integer initial: 0 } -{ objects sequence } ; + { collection string } + { cursor integer initial: 0 } + { start# integer initial: 0 } + { requested# integer initial: 0 } + { returned# integer initial: 0 } + { objects sequence } ; CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg ) diff --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor index 56e560f07a..a53e00858f 100644 --- a/extra/mongodb/operations/operations.factor +++ b/extra/mongodb/operations/operations.factor @@ -4,8 +4,11 @@ io.encodings.private io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ; + IN: mongodb.operations +M: byte-vector byte-length length ; + - -GENERIC: write-message ( message -- ) - - ] [ change-bytes-read ] bi ; inline : read-byte ( -- byte ) read-byte-raw first ; inline -: (read-cstring) ( acc -- ) - [ read-byte ] dip ! b acc - 2dup push ! b acc - [ 0 = ] dip ! bool acc - '[ _ (read-cstring) ] unless ; inline recursive - -: read-cstring ( -- string ) - BV{ } clone - [ (read-cstring) ] keep - [ zero? ] trim-tail - >byte-array utf8 decode ; inline - -GENERIC: (read-message) ( message opcode -- message ) - : copy-header ( message msg-stub -- message ) - [ length>> ] keep [ >>length ] dip - [ req-id>> ] keep [ >>req-id ] dip - [ resp-id>> ] keep [ >>resp-id ] dip - [ opcode>> ] keep [ >>opcode ] dip - flags>> >>flags ; + { + [ length>> >>length ] + [ req-id>> >>req-id ] + [ resp-id>> >>resp-id ] + [ opcode>> >>opcode ] + [ flags>> >>flags ] + } cleave ; inline -M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) - drop +: reply-read-message ( msg-stub -- message ) [ ] dip copy-header read-longlong >>cursor read-int32 >>start# read-int32 [ >>returned# ] keep [ H{ } stream>assoc ] collector [ times ] dip >>objects ; +: (read-message) ( message opcode -- message ) + OP_Reply = + [ reply-read-message ] + [ "unknown message type" throw ] if ; inline + : read-header ( message -- message ) read-int32 >>length read-int32 >>req-id @@ -77,94 +66,97 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) read-int32 >>flags ; inline : write-header ( message -- ) - [ req-id>> write-int32 ] keep - [ resp-id>> write-int32 ] keep - opcode>> write-int32 ; inline + [ req-id>> write-int32 ] + [ resp-id>> write-int32 ] + [ opcode>> write-int32 ] tri ; inline PRIVATE> : read-message ( -- message ) - mdb-msg new - 0 >bytes-read - read-header - [ ] [ opcode>> ] bi (read-message) ; + [ + mdb-msg new 0 >bytes-read read-header + [ ] [ opcode>> ] bi (read-message) + ] with-scope ; selector - query { [ orderby>> [ "$orderby" selector set-at ] when* ] - [ explain>> [ "$explain" selector set-at ] when* ] - [ hint>> [ "$hint" selector set-at ] when* ] - [ query>> "query" selector set-at ] - } cleave - selector ; + query { + [ orderby>> [ "$orderby" selector set-at ] when* ] + [ explain>> [ "$explain" selector set-at ] when* ] + [ hint>> [ "$hint" selector set-at ] when* ] + [ query>> "query" selector set-at ] + } cleave selector ; inline + +: query-write-message ( message -- ) + [ + { + [ flags>> write-int32 ] + [ collection>> write-cstring ] + [ skip#>> write-int32 ] + [ return#>> write-int32 ] + [ build-query-object assoc>stream ] + [ returnfields>> [ assoc>stream ] when* ] + } cleave + ] (write-message) ; inline + +: insert-write-message ( message -- ) + [ + [ flags>> write-int32 ] + [ collection>> write-cstring ] + [ objects>> [ assoc>stream ] each ] tri + ] (write-message) ; inline + +: update-write-message ( message -- ) + [ + { + [ flags>> write-int32 ] + [ collection>> write-cstring ] + [ upsert?>> write-int32 ] + [ selector>> assoc>stream ] + [ object>> assoc>stream ] + } cleave + ] (write-message) ; inline + +: delete-write-message ( message -- ) + [ + [ flags>> write-int32 ] + [ collection>> write-cstring ] + [ 0 write-int32 selector>> assoc>stream ] tri + ] (write-message) ; inline + +: getmore-write-message ( message -- ) + [ + { + [ flags>> write-int32 ] + [ collection>> write-cstring ] + [ return#>> write-int32 ] + [ cursor>> write-longlong ] + } cleave + ] (write-message) ; inline + +: killcursors-write-message ( message -- ) + [ + [ flags>> write-int32 ] + [ cursors#>> write-int32 ] + [ cursors>> [ write-longlong ] each ] tri + ] (write-message) ; inline PRIVATE> -M: mdb-query-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ skip#>> write-int32 ] keep - [ return#>> write-int32 ] keep - [ build-query-object assoc>stream ] keep - returnfields>> [ assoc>stream ] when* - ] (write-message) ; - -M: mdb-insert-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - objects>> [ assoc>stream ] each - ] (write-message) ; - -M: mdb-update-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ upsert?>> write-int32 ] keep - [ selector>> assoc>stream ] keep - object>> assoc>stream - ] (write-message) ; - -M: mdb-delete-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - 0 write-int32 - selector>> assoc>stream - ] (write-message) ; - -M: mdb-getmore-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ collection>> write-cstring ] keep - [ return#>> write-int32 ] keep - cursor>> write-longlong - ] (write-message) ; - -M: mdb-killcursors-msg write-message ( message -- ) - dup - '[ _ - [ flags>> write-int32 ] keep - [ cursors#>> write-int32 ] keep - cursors>> [ write-longlong ] each - ] (write-message) ; - +: write-message ( message -- ) + { + { [ dup mdb-query-msg? ] [ query-write-message ] } + { [ dup mdb-insert-msg? ] [ insert-write-message ] } + { [ dup mdb-update-msg? ] [ update-write-message ] } + { [ dup mdb-delete-msg? ] [ delete-write-message ] } + { [ dup mdb-getmore-msg? ] [ getmore-write-message ] } + { [ dup mdb-killcursors-msg? ] [ killcursors-write-message ] } + } cond ; diff --git a/extra/mongodb/tuple/persistent/persistent.factor b/extra/mongodb/tuple/persistent/persistent.factor index 9ea66fba52..625341a211 100644 --- a/extra/mongodb/tuple/persistent/persistent.factor +++ b/extra/mongodb/tuple/persistent/persistent.factor @@ -54,7 +54,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; over [ call( tuple -- assoc ) ] dip [ [ tuple-collection name>> ] [ >toid ] bi ] keep [ add-storable ] dip - [ tuple-collection name>> ] [ id>> ] bi ; + [ tuple-collection name>> ] [ id>> ] bi ; : write-field ( value quot -- value' ) { @@ -79,7 +79,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; H{ } clone swap [ ] keep pick ; inline : ensure-mdb-info ( tuple -- tuple ) - dup id>> [ >>id ] unless ; inline + dup id>> [ >>id ] unless ; inline : with-object-map ( quot: ( -- ) -- store-assoc ) [ H{ } clone dup object-map ] dip with-variable ; inline