made auto node discovery work

diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor
index 4ad1d7fdccc7c235c83c82da6a1fb65db3b162bb..ae12ca0a0340ef323d8773cfb01d42080271ef4a 100644 (file)
--- a/bson/writer/writer.factor
+++ b/bson/writer/writer.factor
@@ -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

diff --git a/mongodb/benchmark/benchmark.factor b/mongodb/benchmark/benchmark.factor
index 424aa7732c36de285d5deee60a59e5d986ecebc2..683f41b83bdc0ba51246da62fedffac01a58520b 100644 (file)
--- a/mongodb/benchmark/benchmark.factor
+++ b/mongodb/benchmark/benchmark.factor
@@ -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 ( -- )

diff --git a/mongodb/connection/connection.factor b/mongodb/connection/connection.factor
index 06394ecf0f81fc0bb0ce4b696b48933f6123ab43..87718a97884421a8d495883ef5adf2a4ab5159a4 100644 (file)
--- a/mongodb/connection/connection.factor
+++ b/mongodb/connection/connection.factor
@@ -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 )
-    mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
+TUPLE: mdb-connection instance node handle remote local ;
+
+CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
 
-: master-node ( mdb -- inet )
-    nodes>> [ t ] dip at inet>> ;
+: check-ok ( result -- ? )
+     [ "ok" ] dip at >integer 1 =  ; inline 
 
-: slave-node ( mdb -- inet )
-    nodes>> [ f ] dip at inet>> ;
+: <mdb-db> ( name nodes -- mdb-db )
+    mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
 
-: >mdb-connection ( stream -- )
-    mdb-connection set ; inline
+: master-node ( mdb -- node )
+    nodes>> t swap at ;
 
-: 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
 
-<PRIVATE
+: index-collection ( -- ns )
+    mdb-instance name>> "%s.system.indexes" sprintf ; inline
 
+: namespaces-collection ( -- ns )
+    mdb-instance name>> "%s.system.namespaces" sprintf ; inline
 
-: ismaster-cmd ( node -- result )
-    binary "admin.$cmd" H{ { "ismaster" 1 } } <mdb-query-msg>
-    1 >>return# '[ _ write-message read-message ] with-client
-    objects>> first ; 
+: cmd-collection ( -- ns )
+    mdb-instance name>> "%s.$cmd" sprintf ; inline
 
-: split-host-str ( hoststr -- host port )
-    ":" split [ first ] keep
-    second string>number ; inline
+: index-ns ( colname -- index-ns )
+    [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
 
-: eval-ismaster-result ( node result -- node result )
-    [ [ "ismaster" ] dip at
-      >fixnum 1 =
-      [ t >>master? ] [ f >>master? ] if ] keep ;
+: send-message ( message -- )
+    [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
 
-: check-node ( node -- node remote )
-    dup inet>> ismaster-cmd  
-    eval-ismaster-result
-    [ "remote" ] dip at ;
+: 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* ;
+
+: 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 ] [ second string>number ] bi ; inline
+
+: 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 ( 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 ;

diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor
index 9f445d71a9047d2938e23ef052e61069a4391a5a..3c61c8e4f0f0e6c949a54331f383713883817635 100644 (file)
--- a/mongodb/driver/driver.factor
+++ b/mongodb/driver/driver.factor
@@ -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 ; 
+

diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor
index 6b1371eaf15ac1421fe1627880c4b71a93163830..a4f86cd6a3be1d9f845f1f92dd243b4ba83aa8fa 100644 (file)
--- a/mongodb/tuple/collection/collection.factor
+++ b/mongodb/tuple/collection/collection.factor
@@ -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>>

diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor
index 955f66c6ce5d2615dafb3a08b982e5895562ac4a..21923637e5421ca1f8154afcec33a031f23139e8 100644 (file)
--- a/mongodb/tuple/state/state.factor
+++ b/mongodb/tuple/state/state.factor
@@ -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 ;
\ No newline at end of file