diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor new file mode 100644 index 0000000000..06394ecf0f --- /dev/null +++ b/mongodb/connection/connection.factor @@ -0,0 +1,82 @@ +USING: accessors assocs fry io.encodings.binary io.sockets kernel math +math.parser mongodb.msg mongodb.operations namespaces destructors +constructors sequences splitting ; + +IN: mongodb.connection + +TUPLE: mdb-db name username password nodes collections ; + +TUPLE: mdb-node master? inet ; + +CONSTRUCTOR: mdb-node ( inet master? -- mdb-node ) ; + +TUPLE: mdb-connection instance handle remote local ; + +: () ( name nodes -- mdb-db ) + mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; + +: master-node ( mdb -- inet ) + nodes>> [ t ] dip at inet>> ; + +: slave-node ( mdb -- inet ) + nodes>> [ f ] dip at inet>> ; + +: >mdb-connection ( stream -- ) + mdb-connection set ; inline + +: mdb-connection> ( -- stream ) + mdb-connection get ; inline + +: mdb-instance ( -- mdb ) + mdb-connection> instance>> ; + + + 1 >>return# '[ _ write-message read-message ] with-client + objects>> first ; + +: split-host-str ( hoststr -- host port ) + ":" split [ first ] keep + second string>number ; inline + +: eval-ismaster-result ( node result -- node result ) + [ [ "ismaster" ] dip at + >fixnum 1 = + [ t >>master? ] [ f >>master? ] if ] keep ; + +: check-node ( node -- node remote ) + dup inet>> ismaster-cmd + eval-ismaster-result + [ "remote" ] dip at ; + +PRIVATE> + +: check-nodes ( node -- nodelist ) + check-node + [ V{ } clone [ push ] keep ] dip + [ split-host-str [ f ] dip + mdb-node boa check-node drop + swap tuck push + ] when* ; + +: verify-nodes ( -- ) + mdb-instance nodes>> [ t ] dip at + check-nodes + H{ } clone tuck + '[ dup master?>> _ set-at ] each + [ mdb-instance ] dip >>nodes drop ; + +: mdb-open ( mdb -- connection ) + mdb-connection new swap + [ >>instance ] keep + master-node [ >>remote ] keep + binary [ >>handle ] dip >>local ; inline + +: mdb-close ( mdb-connection -- ) + [ dispose f ] change-handle drop ; + +M: mdb-connection dispose + mdb-close ; \ No newline at end of file diff --git a/mongodb/driver/driver-docs.factor b/mongodb/driver/driver-docs.factor index 591a84a528..1788d81e83 100644 --- a/mongodb/driver/driver-docs.factor +++ b/mongodb/driver/driver-docs.factor @@ -212,29 +212,12 @@ HELP: load-index-list } { $description "" } ; -HELP: master>> -{ $values - { "mdb" null } - { "inet" null } -} -{ $description "" } ; - -HELP: mdb -{ $values - - { "mdb" null } -} -{ $description "" } ; - HELP: mdb-collection { $var-description "" } ; HELP: mdb-cursor { $var-description "" } ; -HELP: mdb-db -{ $var-description "" } ; - HELP: mdb-error { $values { "id" null } @@ -242,12 +225,6 @@ HELP: mdb-error } { $description "" } ; -HELP: mdb-instance -{ $var-description "" } ; - -HELP: mdb-node -{ $var-description "" } ; - HELP: r/ { $values { "token" null } @@ -277,13 +254,6 @@ HELP: skip } { $description "" } ; -HELP: slave>> -{ $values - { "mdb" null } - { "inet" null } -} -{ $description "" } ; - HELP: sort { $values { "mdb-query" null } diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index e15fe9b679..9f445d71a9 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -1,14 +1,12 @@ USING: accessors assocs bson.constants bson.writer combinators -constructors continuations destructors formatting fry io -io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs -math math.parser memoize mongodb.msg mongodb.operations namespaces -parser prettyprint sequences sets splitting strings uuid ; +constructors continuations destructors formatting fry io io.pools +io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables +math math.parser memoize mongodb.connection mongodb.msg mongodb.operations namespaces +parser prettyprint sequences sets splitting strings uuid arrays ; IN: mongodb.driver -TUPLE: mdb-node master? inet ; - -TUPLE: mdb-db name nodes collections ; +TUPLE: mdb-pool < pool { mdb mdb-db } ; TUPLE: mdb-cursor collection id return# ; @@ -23,6 +21,11 @@ TUPLE: mdb-collection : ( name -- collection ) [ mdb-collection new ] dip >>name ; inline +M: mdb-pool make-connection + mdb>> mdb-open ; + +: ( mdb -- pool ) mdb-pool swap >>mdb ; + CONSTANT: MDB-GENERAL-ERROR 1 CONSTANT: PARTIAL? "partial?" @@ -30,49 +33,24 @@ CONSTANT: DIRTY? "dirty?" ERROR: mdb-error id msg ; -SYMBOL: mdb-instance - -: mdb ( -- mdb ) - mdb-instance get ; inline - -: master>> ( mdb -- inet ) - nodes>> [ t ] dip at inet>> ; - -: slave>> ( mdb -- inet ) - nodes>> [ f ] dip at inet>> ; - >mdb-stream ( stream -- ) - mdb-socket-stream set ; inline - -: mdb-stream>> ( -- stream ) - mdb-socket-stream get ; inline - : check-ok ( result -- ? ) [ "ok" ] dip key? ; inline : >mdbregexp ( value -- regexp ) first ; inline -: prepare-mdb-session ( mdb -- stream ) - [ mdb-instance set ] keep - master>> [ remote-address set ] keep - binary local-address set ; inline - PRIVATE> SYNTAX: r/ ( token -- mdbregexp ) \ / [ >mdbregexp ] parse-literal ; : with-db ( mdb quot -- ... ) - [ [ prepare-mdb-session ] dip - [ >>mdb-stream ] prepose - with-disposal ] with-scope ; inline + swap [ mdb-open &dispose >mdb-connection ] curry + prepose with-destructors ; inline : build-id-selector ( assoc -- selector ) [ MDB_OID_FIELD swap at ] keep @@ -81,76 +59,41 @@ SYNTAX: r/ ( token -- mdbregexp ) > "%s.system.indexes" sprintf ; inline + mdb-instance name>> "%s.system.indexes" sprintf ; inline : namespaces-collection ( -- ns ) - mdb name>> "%s.system.namespaces" sprintf ; inline + mdb-instance name>> "%s.system.namespaces" sprintf ; inline : cmd-collection ( -- ns ) - mdb name>> "%s.$cmd" sprintf ; inline + mdb-instance name>> "%s.$cmd" sprintf ; inline : index-ns ( colname -- index-ns ) - [ mdb name>> ] dip "%s.%s" sprintf ; inline - -: ismaster-cmd ( node -- result ) - binary "admin.$cmd" H{ { "ismaster" 1 } } - 1 >>return# '[ _ write-message read-message ] with-client - objects>> first ; - -: split-host-str ( hoststr -- host port ) - ":" split [ first ] keep - second string>number ; inline - -: eval-ismaster-result ( node result -- node result ) - [ [ "ismaster" ] dip at - >fixnum 1 = - [ t >>master? ] [ f >>master? ] if ] keep ; - -: check-node ( node -- node remote ) - dup inet>> ismaster-cmd - eval-ismaster-result - [ "remote" ] dip at ; - -: check-nodes ( node -- nodelist ) - check-node - [ V{ } clone [ push ] keep ] dip - [ split-host-str [ f ] dip - mdb-node boa check-node drop - swap tuck push - ] when* ; - -: verify-nodes ( -- ) - mdb nodes>> [ t ] dip at - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - [ mdb ] dip >>nodes drop ; + [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline : send-message ( message -- ) - [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; + [ mdb-connection> handle>> ] dip '[ _ write-message ] with-stream* ; : send-query-plain ( query-message -- result ) - [ mdb-stream>> ] dip + [ mdb-connection> handle>> ] dip '[ _ write-message read-message ] with-stream* ; -: send-query ( query-message -- cursor result ) +: make-cursor ( mdb-result-msg -- cursor/f ) + dup cursor>> 0 > + [ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] + [ drop f ] if ; + +: send-query ( query-message -- cursor/f result ) [ send-query-plain ] keep - { [ collection>> >>collection drop ] - [ return#>> >>requested# ] - } 2cleave - [ [ cursor>> 0 > ] keep - '[ _ [ cursor>> ] [ collection>> ] [ requested#>> ] tri ] - [ f ] if - ] [ objects>> ] bi ; + [ collection>> >>collection drop ] + [ return#>> >>requested# ] 2bi + [ make-cursor ] [ objects>> ] bi ; PRIVATE> : ( db host port -- mdb ) - [ f ] 2dip mdb-node boa - check-nodes - H{ } clone tuck - '[ dup master?>> _ set-at ] each - H{ } clone mdb-db boa ; + f + check-nodes [ [ master?>> ] keep 2array ] map + >hashtable () ; GENERIC: create-collection ( name -- ) M: string create-collection @@ -181,7 +124,7 @@ M: mdb-collection create-collection ( mdb-collection -- ) '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline : (ensure-collection) ( collection -- ) - mdb collections>> dup keys length 0 = + mdb-instance collections>> dup keys length 0 = [ load-collection-list [ [ "options" ] dip key? ] filter [ [ "name" ] dip at "." split second ] map @@ -196,11 +139,11 @@ PRIVATE> MEMO: ensure-collection ( collection -- fq-collection ) dup mdb-collection? [ name>> ] when - "." split1 over mdb name>> = + "." split1 over mdb-instance name>> = [ nip ] [ drop ] if [ ] [ reserved-namespace? ] bi [ [ (ensure-collection) ] keep ] unless - [ mdb name>> ] dip "%s.%s" sprintf ; inline + [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline : ( collection query -- mdb-query ) [ ensure-collection ] dip @@ -243,7 +186,8 @@ M: mdb-query-msg explain. GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one - 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; + 1 >>return# send-query-plain objects>> + dup empty? [ drop f ] [ first ] if ; GENERIC: count ( collection selector -- result ) M: assoc count diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor index 939223b0b1..6b1371eaf1 100644 --- a/mongodb/tuple/collection/collection.factor +++ b/mongodb/tuple/collection/collection.factor @@ -66,8 +66,7 @@ PRIVATE> [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline : set-slot-map ( class options -- ) - '[ _ optl>map MDB_SLOTDEF_LIST set-word-prop ] keep - dup tuple-collection link-collection ; inline + optl>map MDB_SLOTDEF_LIST set-word-prop ; inline M: tuple-class tuple-collection ( tuple -- mdb-collection ) (mdb-collection) ; diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor index 9a8a5f8dc7..061b27dd1b 100644 --- a/mongodb/tuple/persistent/persistent.factor +++ b/mongodb/tuple/persistent/persistent.factor @@ -52,12 +52,10 @@ TUPLE: cond-value value quot ; CONSTRUCTOR: cond-value ( value quot -- cond-value ) ; : write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' ) - over needs-store? mdb-dirty-handling? get and - [ over [ (( tuple -- assoc )) call-effect ] dip - [ tuple-collection name>> ] keep - [ add-storable ] dip - ] [ drop ] if - [ tuple-collection name>> ] [ _id>> ] bi ; inline + over [ (( tuple -- assoc )) call-effect ] dip + [ tuple-collection name>> ] keep + [ add-storable ] dip + [ tuple-collection name>> ] [ _id>> ] bi ; inline : write-field ( value quot: ( tuple -- assoc ) -- value' ) { diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor index f99e32aaf1..beb7f41384 100644 --- a/mongodb/tuple/tuple.factor +++ b/mongodb/tuple/tuple.factor @@ -11,10 +11,9 @@ SYNTAX: MDBTUPLE: define-tuple-class ; : define-persistent ( class collection options -- ) - [ ] dip - [ [ dup ] dip link-collection ] dip ! cl options + [ [ dupd link-collection ] when* ] dip [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip - [ dup annotate-writers ] dip + ! [ dup annotate-writers ] dip set-slot-map ; : ensure-table ( class -- )