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
io.encodings.utf8 io.streams.byte-array kernel math math.parser
namespaces quotations sequences sequences.private serialize strings
words combinators.short-circuit ;
words combinators.short-circuit literals ;
IN: bson.writer
@ -29,7 +29,6 @@ CONSTANT: INT64-SIZE 8
[ set-nth-unsafe ] keep write ] each
; inline
PRIVATE>
: reset-buffer ( buffer -- )
@ -147,7 +146,7 @@ M: sequence bson-write ( array -- )
[ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
: skip-field? ( name -- boolean )
{ "_id" "_mfd" } member? ; inline
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
M: assoc bson-write ( assoc -- )
'[ _ [ 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 -- )
[ trial-size ] 2dip
'[ _ call [ _ ] dip
'[ _ call( i -- doc ) [ _ ] dip
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
'[ _ call ] map ; inline
'[ _ call( i -- doc ) ] map ; inline
: (insert-batch) ( quot: ( i -- doc ) collection -- )
[ 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 ;
: 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: ( -- ) )
[ 0 ] dip call assoc>bv
[ 0 ] dip call( i -- doc ) assoc>bv
'[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ; inline
: check-for-key ( assoc key -- )
@ -240,41 +240,41 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
[ <result> ] prepose
[ print-result ] compose with-scope ; inline
: bench-quot ( feat-seq op-word -- quot: ( elt -- ) )
: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
'[ _ swap _
'[ [ [ _ execute ] dip
[ execute ] each _ execute benchmark ] with-result ] each
'[ [ [ _ execute( -- quot: ( i -- doc ) ) ] dip
[ execute( -- ) ] each _ execute( -- quot: ( -- ) ) benchmark ] with-result ] each
print-separator ] ; inline
: run-serialization-bench ( doc-word-seq feat-seq -- )
"Serialization Tests" print
print-separator-bold
\ serialize bench-quot each ; inline
\ serialize [bench-quot] each ; inline
: run-deserialization-bench ( doc-word-seq feat-seq -- )
"Deserialization Tests" print
print-separator-bold
\ deserialize bench-quot each ; inline
\ deserialize [bench-quot] each ; inline
: run-insert-bench ( doc-word-seq feat-seq -- )
"Insert Tests" print
print-separator-bold
\ insert bench-quot each ; inline
\ insert [bench-quot] each ; inline
: run-find-one-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-One" print
print-separator-bold
\ find-one bench-quot each ; inline
\ find-one [bench-quot] each ; inline
: run-find-all-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-All" print
print-separator-bold
\ find-all bench-quot each ; inline
\ find-all [bench-quot] each ; inline
: run-find-range-bench ( doc-word-seq feat-seq -- )
"Query Tests - Find-Range" print
print-separator-bold
\ find-range bench-quot each ; inline
\ find-range [bench-quot] each ; inline
: run-benchmarks ( -- )

165
mongodb/connection/connection.factor
View File

@ -1,79 +1,142 @@
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
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
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 ;
: master-node ( mdb -- inet )
nodes>> [ t ] dip at inet>> ;
: master-node ( mdb -- node )
nodes>> t swap at ;
: slave-node ( mdb -- inet )
nodes>> [ f ] dip at inet>> ;
: >mdb-connection ( stream -- )
mdb-connection set ; inline
: mdb-connection> ( -- stream )
mdb-connection get ; inline
: slave-node ( mdb -- node )
nodes>> f swap at ;
: with-connection ( connection quot -- * )
[ mdb-connection set ] prepose with-scope ; inline
: 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
: get-nonce ( -- nonce )
cmd-collection H{ { "getnonce" 1 } } send-query-1result
[ "nonce" swap at ] [ f ] if* ;
: ismaster-cmd ( node -- result )
binary "admin.$cmd" H{ { "ismaster" 1 } } <mdb-query-msg>
1 >>return# '[ _ write-message read-message ] with-client
objects>> first ;
: auth? ( mdb -- ? )
[ username>> ] [ pwd-digest>> ] bi and ;
: 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 [ first ] keep
second string>number ; inline
":" split [ first ] [ second string>number ] bi ; inline
: eval-ismaster-result ( node result -- node result )
[ [ "ismaster" ] dip at
>fixnum 1 =
[ t >>master? ] [ f >>master? ] if ] keep ;
: eval-ismaster-result ( node result -- )
[ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
[ [ "remote" ] dip at
[ split-host-str <inet> f <mdb-node> >>remote ] when*
drop ] 2bi ;
: check-node ( node -- node remote )
dup inet>> ismaster-cmd
eval-ismaster-result
[ "remote" ] dip at ;
: check-node ( mdb node -- )
[ <mdb-connection> &dispose ] dip
[ open-connection ] keep swap
[ get-ismaster eval-ismaster-result ] with-connection ;
: nodelist>table ( seq -- assoc )
[ [ master?>> ] keep 2array ] map >hashtable ;
PRIVATE>
: check-nodes ( node -- nodelist )
check-node
[ V{ } clone [ push ] keep ] dip
[ split-host-str <inet> [ 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 <client> [ >>handle ] dip >>local ; inline
:: verify-nodes ( mdb -- )
[ [let* | acc [ V{ } clone ]
node1 [ mdb dup master-node [ check-node ] keep ]
node2 [ mdb node1 remote>>
[ [ check-node ] keep ]
[ drop f ] if* ]
| node1 [ acc push ] when*
node2 [ acc push ] when*
mdb acc nodelist>table >>nodes drop
]
] with-destructors ;
: mdb-open ( mdb -- mdb-connection )
clone [ <mdb-connection> ] keep
master-node open-connection
[ authenticate-connection ] keep ; inline
: mdb-close ( mdb-connection -- )
[ 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
TUPLE: mdb-pool < pool { mdb mdb-db } ;
TUPLE: mdb-pool < pool mdb ;
TUPLE: mdb-cursor collection id return# ;
@ -37,9 +37,6 @@ ERROR: mdb-error id msg ;
CONSTRUCTOR: mdb-cursor ( id collection return# -- cursor ) ;
: check-ok ( result -- ? )
[ "ok" ] dip key? ; inline
: >mdbregexp ( value -- regexp )
first <mdbregexp> ; inline
@ -49,8 +46,7 @@ SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
: with-db ( mdb quot -- ... )
swap [ mdb-open &dispose >mdb-connection ] curry
prepose with-destructors ; inline
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
: build-id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep
@ -58,25 +54,6 @@ SYNTAX: r/ ( token -- mdbregexp )
<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 )
dup cursor>> 0 >
[ [ cursor>> ] [ collection>> ] [ requested#>> ] tri <mdb-cursor> ]
@ -91,9 +68,9 @@ SYNTAX: r/ ( token -- mdbregexp )
PRIVATE>
: <mdb> ( db host port -- mdb )
<inet> f <mdb-node>
check-nodes [ [ master?>> ] keep 2array ] map
>hashtable (<mdb-db>) ;
<inet> t [ <mdb-node> ] keep
H{ } clone [ set-at ] keep <mdb-db>
[ verify-nodes ] keep ;
GENERIC: create-collection ( name -- )
M: string create-collection
@ -123,7 +100,10 @@ M: mdb-collection create-collection ( mdb-collection -- )
[ ";$." intersect length 0 > ] keep
'[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
USE: tools.continuations
: (ensure-collection) ( collection -- )
break
mdb-instance collections>> dup keys length 0 =
[ load-collection-list
[ [ "options" ] dip key? ] filter
@ -240,8 +220,8 @@ M: assoc ensure-index
H{ } clone
[ [ "index" ] dip set-at ] keep
[ [ "deleteIndexes" ] dip set-at ] keep
[ cmd-collection ] dip <mdb-query-msg> find-one
check-ok [ "could not drop index" throw ] unless ;
[ cmd-collection ] dip <mdb-query-msg>
find-one drop ;
: <update> ( collection selector object -- update-msg )
[ ensure-collection ] 2dip <mdb-update-msg> ;
@ -274,5 +254,8 @@ M: assoc delete-unsafe
: drop-collection ( name -- )
[ cmd-collection ] dip
"drop" H{ } clone [ set-at ] keep
<mdb-query-msg> find-one check-ok
[ "could not drop collection" throw ] unless ;
<mdb-query-msg> find-one drop ;
: >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
combinators continuations fry kernel mongodb.driver sequences strings
vectors words combinators.smart ;
vectors words combinators.smart literals ;
IN: mongodb.tuple
@ -50,7 +50,7 @@ CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
PRIVATE>
: MDB_ADDON_SLOTS ( -- slots )
[ MDB_OID_FIELD MDB_META_FIELD ] output>array ; inline
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } ; inline
: link-class ( collection class -- )
over classes>>

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

@ -1,5 +1,5 @@
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
@ -50,19 +50,3 @@ SYMBOL: mdb-dirty-handling?
: needs-store? ( tuple -- ? )
[ 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 ;