Merge branch 'mongodb-changes' of git://github.com/x6j8x/factor

extra/bson/reader/reader.factor

@@ -1,6 +1,6 @@
 USING: accessors assocs bson.constants calendar fry io io.binary
 io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
-sequences serialize ;
+sequences serialize locals ;
 
 FROM: kernel.private => declare ;
 FROM: io.encodings.private => (read-until) ;
@@ -62,22 +62,17 @@ GENERIC: element-binary-read ( length type -- object )
 : read-byte ( -- byte )
     read-byte-raw first ; inline
 
-: utf8-read-until ( seps stream encoding -- string/f sep/f )
-    [ { utf8 } declare decode-char dup [ dup rot member? ] [ 2drop f t ] if ]
-    3curry (read-until) ;
-
 : read-cstring ( -- string )
-    "\0" input-stream get utf8 utf8-read-until drop ; inline
+    "\0" read-until drop "" like ; inline
 
 : read-sized-string ( length -- string )
-    drop read-cstring ; inline
+    read 1 head-slice* "" like ; inline
 
 : read-element-type ( -- type )
     read-byte ; inline
 
-: push-element ( type name -- element )
+: push-element ( type name -- )
-    element boa
+    element boa get-state element>> push ; inline
-    [ get-state element>> push ] keep ; inline
 
 : pop-element ( -- element )
     get-state element>> pop ; inline
@@ -96,8 +91,7 @@ M: bson-object fix-result ( assoc type -- result )
     drop ;
 
 M: bson-array fix-result ( assoc type -- result )
-    drop
+    drop values ;
-    values ;
 
 GENERIC: end-element ( type -- )
 
@@ -108,25 +102,20 @@ M: bson-array end-element ( type -- )
     drop ;
 
 M: object end-element ( type -- )
-    drop
+    pop-element 2drop ;
-    pop-element drop ;
 
-M: bson-eoo element-read ( type -- cont? )
+M:: bson-eoo element-read ( type -- cont? )
-    drop
+    pop-element :> element
-    get-state scope>> [ pop ] keep swap ! vec assoc
+    get-state scope>>
-    pop-element [ type>> ] keep       ! vec assoc element
+    [ pop element type>> fix-result ] [ empty? ] bi
-    [ fix-result ] dip
+    [ [ get-state ] dip >>result drop f ]
-    rot length 0 >                      ! assoc element 
+    [ element name>> peek-scope set-at t ] if ;
-    [ name>> peek-scope set-at t ]
-    [ drop [ get-state ] dip >>result drop f ] if ;
 
-M: bson-not-eoo element-read ( type -- cont? )
+M:: bson-not-eoo element-read ( type -- cont? )
-    [ peek-scope ] dip                                 ! scope type 
+    peek-scope :> scope
-    '[ _ read-cstring push-element [ name>> ] [ type>> ] bi 
+    type read-cstring [ push-element ] 2keep
-       [ element-data-read ] keep
+    [ [ element-data-read ] [ end-element ] bi ]
-       end-element
+    [ scope set-at t ] bi* ;
-       swap
-    ] dip set-at t ;
 
 : [scope-changer] ( state -- state quot )
     dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
@@ -173,8 +162,7 @@ M: bson-regexp element-data-read ( type -- mdbregexp )
    read-cstring >>regexp read-cstring >>options ;
  
 M: bson-null element-data-read ( type -- bf  )
-    drop
+    drop f ;
-    f ;
 
 M: bson-oid element-data-read ( type -- oid )
     drop

extra/bson/writer/writer.factor

@@ -73,11 +73,9 @@ M: word bson-type? ( word -- type ) drop T_Binary ;
 M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
 M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
 
-: write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline
-
 : write-int32 ( int -- ) INT32-SIZE >le write ; inline
 : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
-: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline
+: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
 : write-longlong ( object -- ) INT64-SIZE >le write ; inline
 
 : write-eoo ( -- ) T_EOO write1 ; inline
@@ -127,9 +125,11 @@ M: sequence bson-write ( array -- )
    { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
 
 M: assoc bson-write ( assoc -- )
-    '[ _  [ write-oid ] keep
+    '[
+        _  [ write-oid ] keep
         [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
-       write-eoo ] with-length-prefix ; 
+        write-eoo
+    ] with-length-prefix ;
 
 : (serialize-code) ( code -- )
     object>bytes [ length write-int32 ] keep

extra/furnace/mongodb/mongodb.factor

@@ -0,0 +1,12 @@
+USING: accessors http.server http.server.filters io.pools kernel
+mongodb.driver mongodb.connection namespaces unix destructors continuations ;
+
+IN: furnace.mongodb
+
+TUPLE: mdb-persistence < filter-responder pool ;
+
+: <mdb-persistence> ( responder mdb -- responder' )
+    <mdb-pool> mdb-persistence boa ;
+
+M: mdb-persistence call-responder*
+    dup pool>> [ mdb-connection set call-next-method ] with-pooled-connection ;

extra/mongodb/benchmark/benchmark.factor

@@ -224,15 +224,15 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
       [ index>> bchar ] keep
       lasterror>> bchar
       trial-size ] dip
-    1000000 / /i
+      1000000000 / [ /i ] [ result get batch>> [ [ batch-size /i ] dip ] when /i ] 2bi
-    "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
+    "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s %10s ops/s"
     sprintf print flush ; 
 
 : print-separator ( -- )
-    "----------------------------------------------------------------" print flush ; inline
+    "---------------------------------------------------------------------------------" print flush ; inline
 
 : print-separator-bold ( -- )
-    "================================================================" print flush ; inline
+    "=================================================================================" print flush ; inline
 
 : print-header ( -- )
     trial-size

extra/mongodb/driver/driver.factor

@@ -165,9 +165,7 @@ M: mdb-collection create-collection
 : fix-query-collection ( mdb-query -- mdb-query )
     [ check-collection ] change-collection ; inline
 
-GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
+: get-more ( mdb-cursor -- mdb-cursor seq )
-
-M: mdb-cursor get-more 
     [ [ query>> dup [ collection>> ] [ return#>> ] bi ]
       [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ] 
     [ f f ] if* ;
@@ -177,21 +175,20 @@ PRIVATE>
 : <query> ( collection assoc -- mdb-query-msg )
     <mdb-query-msg> ; inline
 
-GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
+: limit ( mdb-query-msg limit# -- mdb-query-msg )
-
-M: mdb-query-msg limit 
     >>return# ; inline
 
-GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
+: skip ( mdb-query-msg skip# -- mdb-query-msg )
-
-M: mdb-query-msg skip 
     >>skip# ; inline
 
 : asc ( key -- spec ) 1 2array ; inline
 : desc ( key -- spec ) -1 2array ; inline
 
 : sort ( mdb-query-msg sort-quot -- mdb-query-msg )
-    output>array [ 1array >hashtable ] map >>orderby ; inline
+    output>array >hashtable >>orderby ; inline
+
+: filter-fields ( mdb-query-msg filterseq -- mdb-query-msg )
+    [ asc ] map >hashtable >>returnfields ; inline
 
 : key-spec ( spec-quot -- spec-assoc )
     output>array >hashtable ; inline
@@ -209,21 +206,15 @@ M: mdb-query-msg find
 M: mdb-cursor find
     get-more ;
 
-GENERIC: explain. ( mdb-query-msg -- )
+: explain. ( mdb-query-msg -- )
-
-M: mdb-query-msg explain.
     t >>explain find nip . ;
 
-GENERIC: find-one ( mdb-query-msg -- result/f )
+: find-one ( mdb-query-msg -- result/f )
-
-M: mdb-query-msg find-one
     fix-query-collection 
     1 >>return# send-query-plain objects>>
     dup empty? [ drop f ] [ first ] if ;
 
-GENERIC: count ( mdb-query-msg -- result )
+: count ( mdb-query-msg -- result )
-
-M: mdb-query-msg count    
     [ collection>> "count" H{ } clone [ set-at ] keep ] keep
     query>> [ over [ "query" ] dip set-at ] when*
     [ cmd-collection ] dip <mdb-query-msg> find-one 
@@ -251,18 +242,15 @@ M: mdb-collection validate.
 
 PRIVATE>
 
-GENERIC: save ( collection assoc -- )
+: save ( collection assoc -- )
-M: assoc save
     [ check-collection ] dip
     <mdb-insert-msg> send-message-check-error ;
 
-GENERIC: save-unsafe ( collection assoc -- )
+: save-unsafe ( collection assoc -- )
-M: assoc save-unsafe
     [ check-collection ] dip
     <mdb-insert-msg> send-message ;
 
-GENERIC: ensure-index ( index-spec -- )
+: ensure-index ( index-spec -- )
-M: index-spec ensure-index
     <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
     [ { [ [ name>> "name" ] dip set-at ]
         [ [ ns>> index-ns "ns" ] dip set-at ]
@@ -285,24 +273,23 @@ M: index-spec ensure-index
 : >upsert ( mdb-update-msg -- mdb-update-msg )
     1 >>upsert? ; 
 
-GENERIC: update ( mdb-update-msg -- )
+: update ( mdb-update-msg -- )
-M: mdb-update-msg update
     send-message-check-error ;
 
-GENERIC: update-unsafe ( mdb-update-msg -- )
+: update-unsafe ( mdb-update-msg -- )
-M: mdb-update-msg update-unsafe
     send-message ;
  
-GENERIC: delete ( collection selector -- )
+: delete ( collection selector -- )
-M: assoc delete
     [ check-collection ] dip
     <mdb-delete-msg> send-message-check-error ;
 
-GENERIC: delete-unsafe ( collection selector -- )
+: delete-unsafe ( collection selector -- )
-M: assoc delete-unsafe
     [ check-collection ] dip
     <mdb-delete-msg> send-message ;
 
+: kill-cursor ( mdb-cursor -- )
+    id>> <mdb-killcursors-msg> send-message ;
+
 : load-index-list ( -- index-list )
     index-collection
     H{ } clone <mdb-query-msg> find nip ;

extra/mongodb/msg/msg.factor

@@ -29,7 +29,7 @@ TUPLE: mdb-query-msg < mdb-msg
 { return# integer initial: 0 }
 { query assoc }
 { returnfields assoc }
-{ orderby sequence }
+{ orderby assoc }
 explain hint ;
 
 TUPLE: mdb-insert-msg < mdb-msg

extra/mongodb/operations/operations.factor

@@ -107,7 +107,7 @@ USE: tools.walker
 
 :: build-query-object ( query -- selector )
     H{ } clone :> selector
-    query { [ orderby>> [ "orderby" selector set-at ] when* ]
+    query { [ orderby>> [ "$orderby" selector set-at ] when* ]
       [ explain>> [ "$explain" selector set-at ] when* ]
       [ hint>> [ "$hint" selector set-at ] when* ] 
       [ query>> "query" selector set-at ]