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) ;
: 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 )
- element boa
- [ get-state element>> push ] keep ; inline
+: push-element ( type name -- )
+ element boa get-state element>> push ; inline
: pop-element ( -- element )
get-state element>> pop ; inline
drop ;
M: bson-array fix-result ( assoc type -- result )
- drop
- values ;
+ drop values ;
GENERIC: end-element ( type -- )
drop ;
M: object end-element ( type -- )
- drop
- pop-element drop ;
+ pop-element 2drop ;
-M: bson-eoo element-read ( type -- cont? )
- drop
- get-state scope>> [ pop ] keep swap ! vec assoc
- pop-element [ type>> ] keep ! vec assoc element
- [ fix-result ] dip
- rot length 0 > ! assoc element
- [ name>> peek-scope set-at t ]
- [ drop [ get-state ] dip >>result drop f ] if ;
-
-M: bson-not-eoo element-read ( type -- cont? )
- [ peek-scope ] dip ! scope type
- '[ _ read-cstring push-element [ name>> ] [ type>> ] bi
- [ element-data-read ] keep
- end-element
- swap
- ] dip set-at t ;
+M:: bson-eoo element-read ( type -- cont? )
+ pop-element :> element
+ get-state scope>>
+ [ pop element type>> fix-result ] [ empty? ] bi
+ [ [ get-state ] dip >>result drop f ]
+ [ element name>> peek-scope set-at t ] if ;
+
+M:: bson-not-eoo element-read ( type -- cont? )
+ peek-scope :> scope
+ type read-cstring [ push-element ] 2keep
+ [ [ element-data-read ] [ end-element ] bi ]
+ [ scope set-at t ] bi* ;
: [scope-changer] ( state -- state quot )
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
read-cstring >>regexp read-cstring >>options ;
M: bson-null element-data-read ( type -- bf )
- drop
- f ;
+ drop f ;
M: bson-oid element-data-read ( type -- oid )
drop
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
{ $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
M: assoc bson-write ( assoc -- )
- '[ _ [ write-oid ] keep
- [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
- write-eoo ] with-length-prefix ;
+ '[
+ _ [ write-oid ] keep
+ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ write-eoo
+ ] with-length-prefix ;
: (serialize-code) ( code -- )
object>bytes [ length write-int32 ] keep
--- /dev/null
+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 ;
[ index>> bchar ] keep
lasterror>> bchar
trial-size ] dip
- 1000000 / /i
- "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
+ 1000000000 / [ /i ] [ result get batch>> [ [ batch-size /i ] dip ] when /i ] 2bi
+ "%-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
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline
-GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
-
-M: mdb-cursor get-more
+: get-more ( mdb-cursor -- mdb-cursor seq )
[ [ query>> dup [ collection>> ] [ return#>> ] bi ]
[ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
[ f f ] if* ;
: <query> ( collection assoc -- mdb-query-msg )
<mdb-query-msg> ; inline
-GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query-msg )
-
-M: mdb-query-msg limit
+: limit ( mdb-query-msg limit# -- mdb-query-msg )
>>return# ; inline
-GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
-
-M: mdb-query-msg skip
+: skip ( mdb-query-msg skip# -- mdb-query-msg )
>>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
M: mdb-cursor find
get-more ;
-GENERIC: explain. ( mdb-query-msg -- )
-
-M: mdb-query-msg explain.
+: explain. ( mdb-query-msg -- )
t >>explain find nip . ;
-GENERIC: find-one ( mdb-query-msg -- result/f )
-
-M: mdb-query-msg find-one
+: find-one ( mdb-query-msg -- result/f )
fix-query-collection
1 >>return# send-query-plain objects>>
dup empty? [ drop f ] [ first ] if ;
-GENERIC: count ( mdb-query-msg -- result )
-
-M: mdb-query-msg count
+: count ( mdb-query-msg -- result )
[ collection>> "count" H{ } clone [ set-at ] keep ] keep
query>> [ over [ "query" ] dip set-at ] when*
[ cmd-collection ] dip <mdb-query-msg> find-one
PRIVATE>
-GENERIC: save ( collection assoc -- )
-M: assoc save
+: save ( collection assoc -- )
[ check-collection ] dip
<mdb-insert-msg> send-message-check-error ;
-GENERIC: save-unsafe ( collection assoc -- )
-M: assoc save-unsafe
+: save-unsafe ( collection assoc -- )
[ check-collection ] dip
<mdb-insert-msg> send-message ;
-GENERIC: ensure-index ( index-spec -- )
-M: index-spec ensure-index
+: ensure-index ( index-spec -- )
<linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
[ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ]
: >upsert ( mdb-update-msg -- mdb-update-msg )
1 >>upsert? ;
-GENERIC: update ( mdb-update-msg -- )
-M: mdb-update-msg update
+: update ( mdb-update-msg -- )
send-message-check-error ;
-GENERIC: update-unsafe ( mdb-update-msg -- )
-M: mdb-update-msg update-unsafe
+: update-unsafe ( mdb-update-msg -- )
send-message ;
-GENERIC: delete ( collection selector -- )
-M: assoc delete
+: delete ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message-check-error ;
-GENERIC: delete-unsafe ( collection selector -- )
-M: assoc delete-unsafe
+: delete-unsafe ( collection selector -- )
[ 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 ;
{ return# integer initial: 0 }
{ query assoc }
{ returnfields assoc }
-{ orderby sequence }
+{ orderby assoc }
explain hint ;
TUPLE: mdb-insert-msg < mdb-msg
:: 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 ]