steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

made auto node discovery work

db4
Sascha Matzke 2009-04-22 16:09:03 +02:00
parent c936517c45
commit ea87b380f3
6 changed files with 148 additions and 119 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
bson/writer/writer.factor
View File

@ -4,7 +4,7 @@ USING: accessors assocs bson.constants byte-arrays byte-vectors
calendar fry io io.binary io.encodings io.encodings.binary calendar fry io io.binary io.encodings io.encodings.binary
io.encodings.utf8 io.streams.byte-array kernel math math.parser io.encodings.utf8 io.streams.byte-array kernel math math.parser
namespaces quotations sequences sequences.private serialize strings namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit ; words combinators.short-circuit literals ;
IN: bson.writer IN: bson.writer
@ -29,7 +29,6 @@ CONSTANT: INT64-SIZE 8
[ set-nth-unsafe ] keep write ] each [ set-nth-unsafe ] keep write ] each
; inline ; inline
PRIVATE> PRIVATE>
: reset-buffer ( buffer -- ) : reset-buffer ( buffer -- )
@ -147,7 +146,7 @@ M: sequence bson-write ( array -- )
[ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
: skip-field? ( name -- boolean ) : skip-field? ( name -- boolean )
{ "_id" "_mfd" } member? ; inline { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
M: assoc bson-write ( assoc -- ) M: assoc bson-write ( assoc -- )
'[ _ [ write-oid ] keep '[ _ [ write-oid ] keep

28
mongodb/benchmark/benchmark.factor
View File

@ -131,12 +131,12 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
: (insert) ( quot: ( i -- doc ) collection -- ) : (insert) ( quot: ( i -- doc ) collection -- )
[ trial-size ] 2dip [ trial-size ] 2dip
'[ _ call [ _ ] dip '[ _ call( i -- doc ) [ _ ] dip
result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ; inline
: (prepare-batch) ( i b quot: ( i -- doc ) -- ) : (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
[ [ * ] keep 1 range boa ] dip [ [ * ] keep 1 range boa ] dip
'[ _ call ] map ; inline '[ _ call( i -- doc ) ] map ; inline
: (insert-batch) ( quot: ( i -- doc ) collection -- ) : (insert-batch) ( quot: ( i -- doc ) collection -- )
[ trial-size batch-size [ / ] keep ] 2dip [ trial-size batch-size [ / ] keep ] 2dip
@ -170,10 +170,10 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
[ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ; [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) : serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
'[ trial-size [ _ call assoc>bv drop ] each-integer ] ; inline '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ; inline
: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) : deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
[ 0 ] dip call assoc>bv [ 0 ] dip call( i -- doc ) assoc>bv
'[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline
: check-for-key ( assoc key -- ) : check-for-key ( assoc key -- )
@ -240,41 +240,41 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
[ <result> ] prepose [ <result> ] prepose
[ print-result ] compose with-scope ; inline [ print-result ] compose with-scope ; inline
: bench-quot ( feat-seq op-word -- quot: ( elt -- ) ) : [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _ '[ _ swap _
'[ [ [ _ execute ] dip '[ [ [ _ execute( -- quot: ( i -- doc ) ) ] dip
[ execute ] each _ execute benchmark ] with-result ] each [ execute( -- ) ] each _ execute( -- quot: ( -- ) ) benchmark ] with-result ] each
print-separator ] ; inline print-separator ] ; inline
: run-serialization-bench ( doc-word-seq feat-seq -- ) : run-serialization-bench ( doc-word-seq feat-seq -- )
"Serialization Tests" print "Serialization Tests" print
print-separator-bold print-separator-bold
\ serialize bench-quot each ; inline \ serialize [bench-quot] each ; inline
: run-deserialization-bench ( doc-word-seq feat-seq -- ) : run-deserialization-bench ( doc-word-seq feat-seq -- )
"Deserialization Tests" print "Deserialization Tests" print
print-separator-bold print-separator-bold
\ deserialize bench-quot each ; inline \ deserialize [bench-quot] each ; inline
: run-insert-bench ( doc-word-seq feat-seq -- ) : run-insert-bench ( doc-word-seq feat-seq -- )
"Insert Tests" print "Insert Tests" print
print-separator-bold print-separator-bold
\ insert bench-quot each ; inline \ insert [bench-quot] each ; inline
: run-find-one-bench ( doc-word-seq feat-seq -- ) : run-find-one-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-One" print "Query Tests - Find-One" print
print-separator-bold print-separator-bold
\ find-one bench-quot each ; inline \ find-one [bench-quot] each ; inline
: run-find-all-bench ( doc-word-seq feat-seq -- ) : run-find-all-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-All" print "Query Tests - Find-All" print
print-separator-bold print-separator-bold
\ find-all bench-quot each ; inline \ find-all [bench-quot] each ; inline
: run-find-range-bench ( doc-word-seq feat-seq -- ) : run-find-range-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-Range" print "Query Tests - Find-Range" print
print-separator-bold print-separator-bold
\ find-range bench-quot each ; inline \ find-range [bench-quot] each ; inline
: run-benchmarks ( -- ) : run-benchmarks ( -- )

161
mongodb/connection/connection.factor
View File

@ -1,79 +1,142 @@
USING: accessors assocs fry io.encodings.binary io.sockets kernel math USING: accessors assocs fry io.encodings.binary io.sockets kernel math
math.parser mongodb.msg mongodb.operations namespaces destructors math.parser mongodb.msg mongodb.operations namespaces destructors
constructors sequences splitting ; constructors sequences splitting checksums checksums.md5 formatting
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
arrays hashtables sequences.deep vectors locals ;
IN: mongodb.connection IN: mongodb.connection
TUPLE: mdb-db name username password nodes collections ; : md5-checksum ( string -- digest )
utf8 encode md5 checksum-bytes hex-string ; inline
TUPLE: mdb-node master? inet ; TUPLE: mdb-db name username pwd-digest nodes collections ;
CONSTRUCTOR: mdb-node ( inet master? -- mdb-node ) ; TUPLE: mdb-node master? { address inet } remote ;
TUPLE: mdb-connection instance handle remote local ; CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
: (<mdb-db>) ( name nodes -- mdb-db ) TUPLE: mdb-connection instance node handle remote local ;
CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: check-ok ( result -- ? )
[ "ok" ] dip at >integer 1 = ; inline
: <mdb-db> ( name nodes -- mdb-db )
mdb-db new swap >>nodes swap >>name H{ } clone >>collections ; mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
: master-node ( mdb -- inet ) : master-node ( mdb -- node )
nodes>> [ t ] dip at inet>> ; nodes>> t swap at ;
: slave-node ( mdb -- inet ) : slave-node ( mdb -- node )
nodes>> [ f ] dip at inet>> ; nodes>> f swap at ;
: >mdb-connection ( stream -- ) : with-connection ( connection quot -- * )
mdb-connection set ; inline [ mdb-connection set ] prepose with-scope ; inline
: mdb-connection> ( -- stream )
mdb-connection get ; inline
: mdb-instance ( -- mdb ) : mdb-instance ( -- mdb )
mdb-connection> instance>> ; mdb-connection get instance>> ; inline
: index-collection ( -- ns )
mdb-instance name>> "%s.system.indexes" sprintf ; inline
: namespaces-collection ( -- ns )
mdb-instance name>> "%s.system.namespaces" sprintf ; inline
: cmd-collection ( -- ns )
mdb-instance name>> "%s.$cmd" sprintf ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
: send-message ( message -- )
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
: send-query-plain ( query-message -- result )
[ mdb-connection get handle>> ] dip
'[ _ write-message read-message ] with-stream* ;
: send-query-1result ( collection assoc -- result )
<mdb-query-msg>
1 >>return#
send-query-plain objects>>
[ f ] [ first ] if-empty ;
<PRIVATE <PRIVATE
: get-nonce ( -- nonce )
cmd-collection H{ { "getnonce" 1 } } send-query-1result
[ "nonce" swap at ] [ f ] if* ;
: ismaster-cmd ( node -- result ) : auth? ( mdb -- ? )
binary "admin.$cmd" H{ { "ismaster" 1 } } <mdb-query-msg> [ username>> ] [ pwd-digest>> ] bi and ;
1 >>return# '[ _ write-message read-message ] with-client
objects>> first ; : calculate-key-digest ( nonce -- digest )
mdb-instance
[ username>> ]
[ pwd-digest>> ] 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 ; inline
: perform-authentication ( -- )
cmd-collection build-auth-query send-query-1result
dup check-ok [ drop ] [ [ "errmsg" ] dip at throw ] if ; inline
: authenticate-connection ( mdb-connection -- )
[ mdb-connection get instance>> auth?
[ perform-authentication ] when
] with-connection ; inline
: open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi
[ >>remote ] keep binary <client>
[ >>handle ] dip >>local ;
: get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: split-host-str ( hoststr -- host port ) : split-host-str ( hoststr -- host port )
":" split [ first ] keep ":" split [ first ] [ second string>number ] bi ; inline
second string>number ; inline
: eval-ismaster-result ( node result -- node result ) : eval-ismaster-result ( node result -- )
[ [ "ismaster" ] dip at [ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
>fixnum 1 = [ [ "remote" ] dip at
[ t >>master? ] [ f >>master? ] if ] keep ; [ split-host-str <inet> f <mdb-node> >>remote ] when*
drop ] 2bi ;
: check-node ( node -- node remote ) : check-node ( mdb node -- )
dup inet>> ismaster-cmd [ <mdb-connection> &dispose ] dip
eval-ismaster-result [ open-connection ] keep swap
[ "remote" ] dip at ; [ get-ismaster eval-ismaster-result ] with-connection ;
: nodelist>table ( seq -- assoc )
[ [ master?>> ] keep 2array ] map >hashtable ;
PRIVATE> PRIVATE>
: check-nodes ( node -- nodelist ) :: verify-nodes ( mdb -- )
check-node [ [let* | acc [ V{ } clone ]
[ V{ } clone [ push ] keep ] dip node1 [ mdb dup master-node [ check-node ] keep ]
[ split-host-str <inet> [ f ] dip node2 [ mdb node1 remote>>
mdb-node boa check-node drop [ [ check-node ] keep ]
swap tuck push [ drop f ] if* ]
] when* ; | node1 [ acc push ] when*
node2 [ acc push ] when*
mdb acc nodelist>table >>nodes drop
]
] with-destructors ;
: verify-nodes ( -- ) : mdb-open ( mdb -- mdb-connection )
mdb-instance nodes>> [ t ] dip at clone [ <mdb-connection> ] keep
check-nodes master-node open-connection
H{ } clone tuck [ authenticate-connection ] keep ; inline
'[ 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 <client> [ >>handle ] dip >>local ; inline
: mdb-close ( mdb-connection -- ) : mdb-close ( mdb-connection -- )
[ dispose f ] change-handle drop ; [ dispose f ] change-handle drop ;

47
mongodb/driver/driver.factor
View File

@ -6,7 +6,7 @@ parser prettyprint sequences sets splitting strings uuid arrays ;
IN: mongodb.driver IN: mongodb.driver
TUPLE: mdb-pool < pool { mdb mdb-db } ; TUPLE: mdb-pool < pool mdb ;
TUPLE: mdb-cursor collection id return# ; TUPLE: mdb-cursor collection id return# ;
@ -37,9 +37,6 @@ ERROR: mdb-error id msg ;
CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ; CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ;
: check-ok ( result -- ? )
[ "ok" ] dip key? ; inline
: >mdbregexp ( value -- regexp ) : >mdbregexp ( value -- regexp )
first <mdbregexp> ; inline first <mdbregexp> ; inline
@ -49,8 +46,7 @@ SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ; \ / [ >mdbregexp ] parse-literal ;
: with-db ( mdb quot -- ... ) : with-db ( mdb quot -- ... )
swap [ mdb-open &dispose >mdb-connection ] curry '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
prepose with-destructors ; inline
: build-id-selector ( assoc -- selector ) : build-id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep [ MDB_OID_FIELD swap at ] keep
@ -58,25 +54,6 @@ SYNTAX: r/ ( token -- mdbregexp )
<PRIVATE <PRIVATE
: index-collection ( -- ns )
mdb-instance name>> "%s.system.indexes" sprintf ; inline
: namespaces-collection ( -- ns )
mdb-instance name>> "%s.system.namespaces" sprintf ; inline
: cmd-collection ( -- ns )
mdb-instance name>> "%s.$cmd" sprintf ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
: send-message ( message -- )
[ mdb-connection> handle>> ] dip '[ _ write-message ] with-stream* ;
: send-query-plain ( query-message -- result )
[ mdb-connection> handle>> ] dip
'[ _ write-message read-message ] with-stream* ;
: make-cursor ( mdb-result-msg -- cursor/f ) : make-cursor ( mdb-result-msg -- cursor/f )
dup cursor>> 0 > dup cursor>> 0 >
[ [ cursor>> ] [ collection>> ] [ requested#>> ] tri <mdb-cursor> ] [ [ cursor>> ] [ collection>> ] [ requested#>> ] tri <mdb-cursor> ]
@ -91,9 +68,9 @@ SYNTAX: r/ ( token -- mdbregexp )
PRIVATE> PRIVATE>
: <mdb> ( db host port -- mdb ) : <mdb> ( db host port -- mdb )
<inet> f <mdb-node> <inet> t [ <mdb-node> ] keep
check-nodes [ [ master?>> ] keep 2array ] map H{ } clone [ set-at ] keep <mdb-db>
>hashtable (<mdb-db>) ; [ verify-nodes ] keep ;
GENERIC: create-collection ( name -- ) GENERIC: create-collection ( name -- )
M: string create-collection M: string create-collection
@ -123,7 +100,10 @@ M: mdb-collection create-collection ( mdb-collection -- )
[ ";$." intersect length 0 > ] keep [ ";$." intersect length 0 > ] keep
'[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
USE: tools.continuations
: (ensure-collection) ( collection -- ) : (ensure-collection) ( collection -- )
break
mdb-instance collections>> dup keys length 0 = mdb-instance collections>> dup keys length 0 =
[ load-collection-list [ load-collection-list
[ [ "options" ] dip key? ] filter [ [ "options" ] dip key? ] filter
@ -240,8 +220,8 @@ M: assoc ensure-index
H{ } clone H{ } clone
[ [ "index" ] dip set-at ] keep [ [ "index" ] dip set-at ] keep
[ [ "deleteIndexes" ] dip set-at ] keep [ [ "deleteIndexes" ] dip set-at ] keep
[ cmd-collection ] dip <mdb-query-msg> find-one [ cmd-collection ] dip <mdb-query-msg>
check-ok [ "could not drop index" throw ] unless ; find-one drop ;
: <update> ( collection selector object -- update-msg ) : <update> ( collection selector object -- update-msg )
[ ensure-collection ] 2dip <mdb-update-msg> ; [ ensure-collection ] 2dip <mdb-update-msg> ;
@ -274,5 +254,8 @@ M: assoc delete-unsafe
: drop-collection ( name -- ) : drop-collection ( name -- )
[ cmd-collection ] dip [ cmd-collection ] dip
"drop" H{ } clone [ set-at ] keep "drop" H{ } clone [ set-at ] keep
<mdb-query-msg> find-one check-ok <mdb-query-msg> find-one drop ;
[ "could not drop collection" throw ] unless ;
: >pwd-digest ( user password -- digest )
"mongo" swap 3array ":" join md5-checksum ;

4
mongodb/tuple/collection/collection.factor
View File

@ -1,7 +1,7 @@
USING: accessors arrays assocs bson.constants classes classes.tuple USING: accessors arrays assocs bson.constants classes classes.tuple
combinators continuations fry kernel mongodb.driver sequences strings combinators continuations fry kernel mongodb.driver sequences strings
vectors words combinators.smart ; vectors words combinators.smart literals ;
IN: mongodb.tuple IN: mongodb.tuple
@ -50,7 +50,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
PRIVATE> PRIVATE>
: MDB_ADDON_SLOTS ( -- slots ) : MDB_ADDON_SLOTS ( -- slots )
[ MDB_OID_FIELD MDB_META_FIELD ] output>array ; inline { $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
: link-class ( collection class -- ) : link-class ( collection class -- )
over classes>> over classes>>

18
mongodb/tuple/state/state.factor
View File

@ -1,5 +1,5 @@
USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection
advice words classes.tuple slots generic ; words classes.tuple slots generic ;
IN: mongodb.tuple.state IN: mongodb.tuple.state
@ -50,19 +50,3 @@ SYMBOL: mdb-dirty-handling?
: needs-store? ( tuple -- ? ) : needs-store? ( tuple -- ? )
[ persistent? not ] [ dirty? ] bi or ; [ persistent? not ] [ dirty? ] bi or ;
<PRIVATE
: create-advice ( word -- )
MDB_DIRTY_ADVICE over after advised-with?
[ drop ]
[ [ [ dup mark-dirty ] MDB_DIRTY_ADVICE ] dip advise-after ] if ;
: (annotate-writer) ( class name -- )
writer-word method [ create-advice ] when* ;
PRIVATE>
: annotate-writers ( class -- )
dup all-slots [ name>> ] map
MDB_ADDON_SLOTS '[ _ memq? not ] filter
[ (annotate-writer) ] with each ;