-USING: bson.reader bson.writer byte-arrays io.encodings.binary
+USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
io.streams.byte-array tools.test literals calendar kernel math ;
IN: bson.tests
[ H{ { "a quotation" [ 1 2 + ] } } ]
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
+
[ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 }
{ day 11 }
] unit-test
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } }
]
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
+ { "ref" T{ dbref f "a" "b" "c" } }
{ "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } turnaround ] unit-test
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader ;
IN: bson
-USING: accessors constructors kernel strings uuid ;
-
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs calendar combinators
+combinators.short-circuit constructors kernel linked-assocs
+math math.bitwise random strings uuid ;
IN: bson.constants
: <objid> ( -- objid )
TUPLE: oid { a initial: 0 } { b initial: 0 } ;
-TUPLE: objref ns objid ;
+: <oid> ( -- oid )
+ oid new
+ now timestamp>micros >>a
+ 8 random-bits 16 shift HEX: FF0000 mask
+ 16 random-bits HEX: FFFF mask
+ bitor >>b ;
+
+TUPLE: dbref ref id db ;
+
+CONSTRUCTOR: dbref ( ref id -- dbref ) ;
+
+: dbref>assoc ( dbref -- assoc )
+ [ <linked-hash> ] dip over
+ {
+ [ [ ref>> "$ref" ] [ set-at ] bi* ]
+ [ [ id>> "$id" ] [ set-at ] bi* ]
+ [ over db>> [
+ [ db>> "$db" ] [ set-at ] bi*
+ ] [ 2drop ] if ]
+ } 2cleave ; inline
+
+: assoc>dbref ( assoc -- dbref )
+ [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
+ dbref boa ; inline
-CONSTRUCTOR: objref ( ns objid -- objref ) ;
+: dbref-assoc? ( assoc -- ? )
+ { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
TUPLE: mdbregexp { regexp string } { options string } ;
-USING: accessors assocs bson.constants calendar fry io io.binary
-io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
-sequences serialize locals ;
-
-FROM: kernel.private => declare ;
-FROM: io.encodings.private => (read-until) ;
-
+! Copyright (C) 2010 Sascha Matzke.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs bson.constants calendar combinators
+combinators.short-circuit fry io io.binary kernel locals math
+namespaces sequences serialize tools.continuations strings ;
+FROM: io.encodings.binary => binary ;
+FROM: io.streams.byte-array => with-byte-reader ;
IN: bson.reader
<PRIVATE
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
-GENERIC: element-read ( type -- cont? )
-GENERIC: element-data-read ( type -- object )
-GENERIC: element-binary-read ( length type -- object )
-
: get-state ( -- state )
state get ; inline
8 read le> bits>double ; inline
: read-byte-raw ( -- byte-raw )
- 1 read ; inline
+ 1 read ;
: read-byte ( -- byte )
read-byte-raw first ; inline
: read-cstring ( -- string )
- "\0" read-until drop "" like ; inline
+ "\0" read-until drop >string ; inline
: read-sized-string ( length -- string )
- read 1 head-slice* "" like ; inline
+ read 1 head-slice* >string ; inline
: read-element-type ( -- type )
read-byte ; inline
: peek-scope ( -- ht )
get-state scope>> last ; inline
-: read-elements ( -- )
- read-element-type
- element-read
- [ read-elements ] when ; inline recursive
-
-GENERIC: fix-result ( assoc type -- result )
-
-M: bson-object fix-result ( assoc type -- result )
- drop ;
-
-M: bson-array fix-result ( assoc type -- result )
- drop values ;
-
-GENERIC: end-element ( type -- )
-
-M: bson-object end-element ( type -- )
- drop ;
-
-M: bson-array end-element ( type -- )
- drop ;
-
-M: object end-element ( type -- )
- pop-element 2drop ;
-
-M:: bson-eoo element-read ( type -- cont? )
+: bson-object-data-read ( -- object )
+ read-int32 drop get-state
+ [ exemplar>> clone ] [ scope>> ] bi
+ [ push ] keep ; inline
+
+: bson-binary-read ( -- binary )
+ read-int32 read-byte
+ bson-binary-bytes? [ read ] [ read bytes>object ] if ; inline
+
+: bson-regexp-read ( -- mdbregexp )
+ mdbregexp new
+ read-cstring >>regexp read-cstring >>options ; inline
+
+: bson-oid-read ( -- oid )
+ read-longlong read-int32 oid boa ; inline
+
+: element-data-read ( type -- object )
+ {
+ { T_OID [ bson-oid-read ] }
+ { T_String [ read-int32 read-sized-string ] }
+ { T_Integer [ read-int32 ] }
+ { T_Binary [ bson-binary-read ] }
+ { T_Object [ bson-object-data-read ] }
+ { T_Array [ bson-object-data-read ] }
+ { T_Double [ read-double ] }
+ { T_Boolean [ read-byte 1 = ] }
+ { T_Date [ read-longlong millis>timestamp ] }
+ { T_Regexp [ bson-regexp-read ] }
+ { T_NULL [ f ] }
+ } case ; inline
+
+: fix-result ( assoc type -- result )
+ {
+ { [ dup T_Array = ] [ drop values ] }
+ {
+ [ dup T_Object = ]
+ [ drop dup dbref-assoc? [ assoc>dbref ] when ]
+ }
+ } cond ; inline
+
+: end-element ( type -- )
+ { [ bson-object? ] [ bson-array? ] } 1||
+ [ pop-element drop ] unless ; inline
+
+:: 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 ;
+ [ element name>> peek-scope set-at t ] if ; inline
-M:: bson-not-eoo element-read ( type -- cont? )
+:: 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
-
-: (object-data-read) ( type -- object )
- drop
- read-int32 drop
- get-state
- [scope-changer] change-scope
- scope>> last ; inline
-
-M: bson-object element-data-read ( type -- object )
- (object-data-read) ;
-
-M: bson-string element-data-read ( type -- object )
- drop
- read-int32 read-sized-string ;
-
-M: bson-array element-data-read ( type -- object )
- (object-data-read) ;
-
-M: bson-integer element-data-read ( type -- object )
- drop
- read-int32 ;
-
-M: bson-double element-data-read ( type -- double )
- drop
- read-double ;
-
-M: bson-boolean element-data-read ( type -- boolean )
- drop
- read-byte 1 = ;
-
-M: bson-date element-data-read ( type -- timestamp )
- drop
- read-longlong millis>timestamp ;
-
-M: bson-binary element-data-read ( type -- binary )
- drop
- read-int32 read-byte element-binary-read ;
-
-M: bson-regexp element-data-read ( type -- mdbregexp )
- drop mdbregexp new
- read-cstring >>regexp read-cstring >>options ;
-
-M: bson-null element-data-read ( type -- bf )
- drop f ;
-
-M: bson-oid element-data-read ( type -- oid )
- drop
- read-longlong
- read-int32 oid boa ;
-
-M: bson-binary-bytes element-binary-read ( size type -- bytes )
- drop read ;
-
-M: bson-binary-custom element-binary-read ( size type -- quot )
- drop read bytes>object ;
+ [ scope set-at t ] bi* ; inline
-PRIVATE>
+: (element-read) ( type -- cont? )
+ dup bson-not-eoo?
+ [ bson-not-eoo-element-read ]
+ [ bson-eoo-element-read ] if ; inline
-USE: tools.continuations
+: read-elements ( -- )
+ read-element-type
+ (element-read) [ read-elements ] when ; inline recursive
+
+PRIVATE>
: stream>assoc ( exemplar -- assoc )
<state> dup state
- [ read-int32 >>size read-elements ] with-variable
- result>> ;
+ [ read-int32 >>size read-elements ] with-variable
+ result>> ; inline
-BSON reader and writer
+BSON (http://en.wikipedia.org/wiki/BSON) reader and writer
-! Copyright (C) 2008 Sascha Matzke.
+! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
-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 literals ;
-
-FROM: io.encodings.utf8.private => char>utf8 ;
-FROM: kernel.private => declare ;
-
+USING: accessors arrays assocs bson.constants byte-arrays
+calendar combinators.short-circuit fry hashtables io io.binary
+kernel linked-assocs literals math math.parser namespaces
+quotations sequences serialize strings vectors dlists alien.accessors ;
+FROM: words => word? word ;
+FROM: typed => TYPED: ;
+FROM: combinators => cond ;
IN: bson.writer
<PRIVATE
-SYMBOL: shared-buffer
-
CONSTANT: CHAR-SIZE 1
CONSTANT: INT32-SIZE 4
CONSTANT: INT64-SIZE 8
-: (buffer) ( -- buffer )
- shared-buffer get
- [ BV{ } clone [ shared-buffer set ] keep ] unless*
- { byte-vector } declare ; inline
-
PRIVATE>
-: reset-buffer ( buffer -- )
- 0 >>length drop ; inline
-
-: ensure-buffer ( -- )
- (buffer) drop ; inline
-
-: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
- [ (buffer) [ reset-buffer ] keep dup ] dip
- with-output-stream* ; inline
-
-: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
- [ (buffer) [ length ] keep ] dip
+: with-length ( quot: ( -- ) -- bytes-written start-index )
+ [ output-stream get [ length ] [ ] bi ] dip
call length swap [ - ] keep ; inline
: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
- [ call ] dip (buffer) copy ; inline
+ [ call output-stream get underlying>> ] dip set-alien-unsigned-4 ; inline
-: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
- [ INT32-SIZE >le ] (with-length-prefix) ; inline
+: with-length-prefix ( quot: ( -- ) -- )
+ [ ] (with-length-prefix) ; inline
-: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
- [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
+: with-length-prefix-excl ( quot: ( -- ) -- )
+ [ INT32-SIZE - ] (with-length-prefix) ; inline
<PRIVATE
-GENERIC: bson-type? ( obj -- type )
-GENERIC: bson-write ( obj -- )
-
-M: t bson-type? ( boolean -- type ) drop T_Boolean ;
-M: f bson-type? ( boolean -- type ) drop T_Boolean ;
-
-M: string bson-type? ( string -- type ) drop T_String ;
-M: integer bson-type? ( integer -- type ) drop T_Integer ;
-M: assoc bson-type? ( assoc -- type ) drop T_Object ;
-M: real bson-type? ( real -- type ) drop T_Double ;
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
-M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
-M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
-
-M: oid bson-type? ( word -- type ) drop T_OID ;
-M: objref bson-type? ( objref -- type ) drop T_Binary ;
-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-int32 ( int -- ) INT32-SIZE >le write ; inline
+
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
+
: write-cstring ( string -- ) B{ } like write 0 write1 ; inline
+
: write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-eoo ( -- ) T_EOO write1 ; inline
-: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
-
-M: string bson-write ( obj -- )
- '[ _ write-cstring ] with-length-prefix-excl ;
-
-M: f bson-write ( f -- )
- drop 0 write1 ;
-
-M: t bson-write ( t -- )
- drop 1 write1 ;
-
-M: integer bson-write ( num -- )
- write-int32 ;
-M: real bson-write ( num -- )
- >float write-double ;
+: write-header ( name object type -- object )
+ write1 [ write-cstring ] dip ; inline
-M: timestamp bson-write ( timestamp -- )
- timestamp>millis write-longlong ;
+DEFER: write-pair
-M: byte-array bson-write ( binary -- )
- [ length write-int32 ] keep
- T_Binary_Bytes write1
- write ;
+: write-byte-array ( binary -- )
+ [ length write-int32 ]
+ [ T_Binary_Bytes write1 write ] bi ; inline
-M: oid bson-write ( oid -- )
- [ a>> write-longlong ] [ b>> write-int32 ] bi ;
-
-M: mdbregexp bson-write ( regexp -- )
+: write-mdbregexp ( regexp -- )
[ regexp>> write-cstring ]
- [ options>> write-cstring ] bi ;
-
-M: sequence bson-write ( array -- )
- '[ _ [ [ write-type ] dip number>string
- write-cstring bson-write ] each-index
- write-eoo ] with-length-prefix ;
-
-: write-oid ( assoc -- )
- [ MDB_OID_FIELD ] dip at
- [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
-
-: skip-field? ( name -- boolean )
- { $[ 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 ;
-
-: (serialize-code) ( code -- )
- object>bytes [ length write-int32 ] keep
- T_Binary_Custom write1
- write ;
+ [ options>> write-cstring ] bi ; inline
-M: quotation bson-write ( quotation -- )
- (serialize-code) ;
-
-M: word bson-write ( word -- )
- (serialize-code) ;
+TYPED: write-sequence ( array: sequence -- )
+ '[
+ _ [ number>string swap write-pair ] each-index
+ write-eoo
+ ] with-length-prefix ; inline recursive
+
+TYPED: write-oid ( oid: oid -- )
+ [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
+
+: write-oid-field ( assoc -- )
+ [ MDB_OID_FIELD dup ] dip at
+ [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
+ [ drop ] if* ; inline
+
+: skip-field? ( name value -- name value boolean )
+ over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
+
+UNION: hashtables hashtable linked-assoc ;
+
+TYPED: write-assoc ( assoc: hashtables -- )
+ '[ _ [ write-oid-field ] [
+ [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
+ ] bi write-eoo
+ ] with-length-prefix ; inline recursive
+
+UNION: code word quotation ;
+
+TYPED: (serialize-code) ( code: code -- )
+ object>bytes
+ [ length write-int32 ]
+ [ T_Binary_Custom write1 write ] bi ; inline
+
+TYPED: write-string ( string: string -- )
+ '[ _ write-cstring ] with-length-prefix-excl ; inline
+
+TYPED: write-boolean ( bool: boolean -- )
+ [ 1 write1 ] [ 0 write1 ] if ; inline
+
+: write-pair ( name obj -- )
+ {
+ {
+ [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
+ [ T_Object write-header write-assoc ]
+ } {
+ [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
+ [ T_Array write-header write-sequence ]
+ } {
+ [ dup byte-array? ]
+ [ T_Binary write-header write-byte-array ]
+ } {
+ [ dup string? ]
+ [ T_String write-header write-string ]
+ } {
+ [ dup oid? ]
+ [ T_OID write-header write-oid ]
+ } {
+ [ dup integer? ]
+ [ T_Integer write-header write-int32 ]
+ } {
+ [ dup boolean? ]
+ [ T_Boolean write-header write-boolean ]
+ } {
+ [ dup real? ]
+ [ T_Double write-header >float write-double ]
+ } {
+ [ dup timestamp? ]
+ [ T_Date write-header timestamp>millis write-longlong ]
+ } {
+ [ dup mdbregexp? ]
+ [ T_Regexp write-header write-mdbregexp ]
+ } {
+ [ dup quotation? ]
+ [ T_Binary write-header (serialize-code) ]
+ } {
+ [ dup word? ]
+ [ T_Binary write-header (serialize-code) ]
+ } {
+ [ dup dbref? ]
+ [ T_Object write-header dbref>assoc write-assoc ]
+ } {
+ [ dup f = ]
+ [ T_NULL write-header drop ]
+ }
+ } cond ;
PRIVATE>
-: assoc>bv ( assoc -- byte-vector )
- [ '[ _ bson-write ] with-buffer ] with-scope ; inline
+TYPED: assoc>bv ( assoc: hashtables -- byte-vector )
+ [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
-: assoc>stream ( assoc -- )
- { assoc } declare bson-write ; inline
+TYPED: assoc>stream ( assoc: hashtables -- )
+ write-assoc ; inline
: mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ]
--- /dev/null
+USING: accessors assocs hashtables kernel linked-assocs strings ;
+IN: mongodb.cmd
+
+<PRIVATE
+
+TUPLE: mongodb-cmd
+ { name string }
+ { const? boolean }
+ { admin? boolean }
+ { auth? boolean }
+ { assoc assoc }
+ { norep? boolean } ;
+
+PRIVATE>
+
+CONSTANT: buildinfo-cmd
+ T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
+
+CONSTANT: list-databases-cmd
+ T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
+
+! Options: { "async" t }
+CONSTANT: fsync-cmd
+ T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
+
+! Value: { "clone" from_host }
+CONSTANT: clone-db-cmd
+ T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
+
+! Options { { "fromdb" db } { "todb" db } { fromhost host } }
+CONSTANT: copy-db-cmd
+ T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
+
+CONSTANT: shutdown-cmd
+ T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
+
+CONSTANT: reseterror-cmd
+ T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
+
+CONSTANT: getlasterror-cmd
+ T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
+
+CONSTANT: getpreverror-cmd
+ T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
+
+CONSTANT: forceerror-cmd
+ T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
+
+CONSTANT: drop-db-cmd
+ T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
+
+! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
+CONSTANT: repair-db-cmd
+ T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
+
+! Options: -1 gets the current profile level; 0-2 set the profile level
+CONSTANT: profile-cmd
+ T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
+
+CONSTANT: server-status-cmd
+ T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
+
+CONSTANT: assertinfo-cmd
+ T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
+
+CONSTANT: getoptime-cmd
+ T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
+
+CONSTANT: oplog-cmd
+ T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
+
+! Value: { "deleteIndexes" collection-name }
+! Options: { "index" index_name or "*" }
+CONSTANT: delete-index-cmd
+ T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
+
+! Value: { "create" collection-name }
+! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
+CONSTANT: create-cmd
+ T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
+
+! Value { "drop" collection-name }
+CONSTANT: drop-cmd
+ T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
+
+! Value { "count" collection-name }
+! Options: { "query" query-object }
+CONSTANT: count-cmd
+ T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
+
+! Value { "validate" collection-name }
+CONSTANT: validate-cmd
+ T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
+
+! Value { "collstats" collection-name }
+CONSTANT: collstats-cmd
+ T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
+
+! Value: { "distinct" collection-name }
+! Options: { "key" key-name }
+CONSTANT: distinct-cmd
+ T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
+
+! Value: { "filemd5" oid }
+! Options: { "root" bucket-name }
+CONSTANT: filemd5-cmd
+ T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
+
+CONSTANT: getnonce-cmd
+ T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
+
+! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
+CONSTANT: authenticate-cmd
+ T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
+
+CONSTANT: logout-cmd
+ T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
+
+! Value: { "findandmodify" collection-name }
+! Options: { { "query" selector } { "sort" sort-spec }
+! { "remove" t/f } { "update" modified-object }
+! { "new" t/f } }
+CONSTANT: findandmodify-cmd
+ T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
+
+: make-cmd ( cmd-stub -- cmd-assoc )
+ dup const?>> [ ] [
+ clone [ clone <linked-assoc> ] change-assoc
+ ] if ; inline
+
+: set-cmd-opt ( cmd value key -- cmd )
+ pick assoc>> set-at ; inline
-USING: accessors assocs fry io.encodings.binary io.sockets kernel math
-math.parser mongodb.msg mongodb.operations namespaces destructors
-constructors sequences splitting checksums checksums.md5
-io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
-arrays hashtables sequences.deep vectors locals ;
-
+USING: accessors arrays assocs byte-vectors checksums
+checksums.md5 constructors destructors fry hashtables
+io.encodings.binary io.encodings.string io.encodings.utf8
+io.sockets io.streams.duplex kernel locals math math.parser
+mongodb.cmd mongodb.msg namespaces sequences
+splitting ;
IN: mongodb.connection
: md5-checksum ( string -- digest )
CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
-TUPLE: mdb-connection instance node handle remote local ;
+TUPLE: mdb-connection instance node handle remote local buffer ;
+
+: connection-buffer ( -- buffer )
+ mdb-connection get buffer>> 0 >>length ; inline
+
+USE: mongodb.operations
CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
nodes>> f swap at ;
: with-connection ( connection quot -- * )
- [ mdb-connection set ] prepose with-scope ; inline
+ [ mdb-connection ] dip with-variable ; inline
: mdb-instance ( -- mdb )
mdb-connection get instance>> ; inline
: namespaces-collection ( -- ns )
mdb-instance name>> "system.namespaces" "." glue ; inline
-: cmd-collection ( -- ns )
- mdb-instance name>> "$cmd" "." glue ; inline
+: cmd-collection ( cmd -- ns )
+ admin?>> [ "admin" ] [ mdb-instance name>> ] if
+ "$cmd" "." glue ; inline
: index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "." glue ; inline
'[ _ 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 ;
+ <mdb-query-msg> -1 >>return# send-query-plain
+ objects>> [ f ] [ first ] if-empty ;
+
+: send-cmd ( cmd -- result )
+ [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
<PRIVATE
: get-nonce ( -- nonce )
- cmd-collection H{ { "getnonce" 1 } } send-query-1result
+ getnonce-cmd make-cmd send-cmd
[ "nonce" swap at ] [ f ] if* ;
: auth? ( mdb -- ? )
[ 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 ;
+: build-auth-cmd ( cmd -- cmd )
+ mdb-instance username>> "user" set-cmd-opt
+ get-nonce [ "nonce" set-cmd-opt ] [ ] bi
+ calculate-key-digest "key" set-cmd-opt ; inline
: perform-authentication ( -- )
- cmd-collection build-auth-query send-query-1result
+ authenticate-cmd make-cmd
+ build-auth-cmd send-cmd
check-ok [ drop ] [ throw ] if ; inline
: authenticate-connection ( mdb-connection -- )
: open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi
[ >>remote ] keep binary <client>
- [ >>handle ] dip >>local ;
+ [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
: nodelist>table ( seq -- assoc )
[ [ master?>> ] keep 2array ] map >hashtable ;
-
+
PRIVATE>
:: verify-nodes ( mdb -- )
USING: accessors arrays assocs bson.constants combinators
-combinators.smart constructors destructors formatting fry hashtables
-io io.pools io.sockets kernel linked-assocs math mongodb.connection
-mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
-sequences sets splitting strings
-tools.continuations uuid memoize locals ;
-
+combinators.smart constructors destructors fry hashtables io
+io.pools io.sockets kernel linked-assocs locals math
+mongodb.cmd mongodb.connection mongodb.msg namespaces parser
+prettyprint prettyprint.custom prettyprint.sections sequences
+sets splitting strings ;
+FROM: ascii => ascii? ;
IN: mongodb.driver
TUPLE: mdb-pool < pool mdb ;
TUPLE: mdb-collection
{ name string }
-{ capped boolean initial: f }
-{ size integer initial: -1 }
-{ max integer initial: -1 } ;
+{ capped boolean }
+{ size integer }
+{ max integer } ;
CONSTRUCTOR: mdb-collection ( name -- collection ) ;
query>> update-query ;
: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
- over cursor>> 0 >
+ over cursor>> 0 >
[ [ update-query ]
[ [ cursor>> ] dip <mdb-cursor> ] 2bi
] [ 2drop f ] if ;
[ make-cursor ] 2tri
swap objects>> ;
-: make-collection-assoc ( collection assoc -- )
- [ [ name>> "create" ] dip set-at ]
- [ [ [ capped>> ] keep ] dip
- '[ _ _
- [ [ drop t "capped" ] dip set-at ]
- [ [ size>> "size" ] dip set-at ]
- [ [ max>> "max" ] dip set-at ] 2tri ] when
- ] 2bi ;
PRIVATE>
SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ;
-: with-db ( mdb quot -- * )
+: with-db ( mdb quot -- )
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
-
+
+: with-mdb ( mdb quot -- )
+ [ <mdb-pool> ] dip
+ [ mdb-pool swap with-variable ] curry with-disposal ; inline
+
+: with-mdb-connection ( quot -- )
+ [ mdb-pool get ] dip
+ '[ _ with-connection ] with-pooled-connection ; inline
+
: >id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep
H{ } clone [ set-at ] keep ;
M: string create-collection
<mdb-collection> create-collection ;
-M: mdb-collection create-collection
- [ [ cmd-collection ] dip
- <linked-hash> [ make-collection-assoc ] keep
- <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
- [ ] [ name>> ] bi mdb-instance collections>> set-at ;
+M: mdb-collection create-collection ( collection -- )
+ create-cmd make-cmd over
+ {
+ [ name>> "create" set-cmd-opt ]
+ [ capped>> [ "capped" set-cmd-opt ] when* ]
+ [ max>> [ "max" set-cmd-opt ] when* ]
+ [ size>> [ "size" set-cmd-opt ] when* ]
+ } cleave send-cmd check-ok
+ [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
+ [ throw ] if ;
: load-collection-list ( -- collection-list )
namespaces-collection
<PRIVATE
: ensure-valid-collection-name ( collection -- )
- [ ";$." intersect length 0 > ] keep
- '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
+ [
+ [ ";$." intersect length 0 > ] keep
+ '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
+ ] [
+ [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
+ ] bi ; inline
: build-collection-map ( -- assoc )
H{ } clone load-collection-list
dup empty? [ drop f ] [ first ] if ;
: 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
+ [ count-cmd make-cmd ] dip
+ [ collection>> "count" set-cmd-opt ]
+ [ query>> "query" set-cmd-opt ] bi send-cmd
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
: lasterror ( -- error )
- cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
- find-one [ "err" ] dip at ;
+ getlasterror-cmd make-cmd send-cmd
+ [ "err" ] dip at ;
GENERIC: validate. ( collection -- )
M: string validate.
- [ cmd-collection ] dip
- "validate" H{ } clone [ set-at ] keep
- <mdb-query-msg> find-one [ check-ok nip ] keep
+ [ validate-cmd make-cmd ] dip
+ "validate" set-cmd-opt send-cmd
+ [ check-ok nip ] keep
'[ "result" _ at print ] [ ] if ;
M: mdb-collection validate.
<mdb-insert-msg> send-message ;
: ensure-index ( index-spec -- )
- <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
+ <linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
[ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ]
[ [ key>> "key" ] dip set-at ]
[ index-collection ] dip save ;
: drop-index ( collection name -- )
- H{ } clone
- [ [ "index" ] dip set-at ] keep
- [ [ "deleteIndexes" ] dip set-at ] keep
- [ cmd-collection ] dip <mdb-query-msg>
- find-one drop ;
+ [ delete-index-cmd make-cmd ] 2dip
+ [ "deleteIndexes" set-cmd-opt ]
+ [ "index" set-cmd-opt ] bi* send-cmd drop ;
: <update> ( collection selector object -- mdb-update-msg )
[ check-collection ] 2dip <mdb-update-msg> ;
: update-unsafe ( mdb-update-msg -- )
send-message ;
-
+
+: find-and-modify ( collection selector modifier -- mongodb-cmd )
+ [ findandmodify-cmd make-cmd ] 3dip
+ [ "findandmodify" set-cmd-opt ]
+ [ "query" set-cmd-opt ]
+ [ "update" set-cmd-opt ] tri* ; inline
+
+: run-cmd ( cmd -- result )
+ send-cmd ; inline
+
: delete ( collection selector -- )
[ check-collection ] dip
<mdb-delete-msg> send-message-check-error ;
check-collection drop ;
: drop-collection ( name -- )
- [ cmd-collection ] dip
- "drop" H{ } clone [ set-at ] keep
- <mdb-query-msg> find-one drop ;
+ [ drop-cmd make-cmd ] dip
+ "drop" set-cmd-opt send-cmd drop ;
--- /dev/null
+USING: accessors arrays assocs base64 bson.constants
+byte-arrays byte-vectors calendar combinators
+combinators.short-circuit destructors formatting fry hashtables
+io kernel linked-assocs locals math math.parser mongodb.cmd
+mongodb.connection mongodb.driver mongodb.msg namespaces
+sequences splitting strings ;
+FROM: mongodb.driver => update ;
+IN: mongodb.gridfs
+
+CONSTANT: default-chunk-size 262144
+
+TUPLE: gridfs
+ { bucket string }
+ { files string }
+ { chunks string } ;
+
+
+<PRIVATE
+
+: gridfs> ( -- gridfs )
+ gridfs get ; inline
+
+: files-collection ( -- str ) gridfs> files>> ; inline
+: chunks-collection ( -- str ) gridfs> chunks>> ; inline
+
+
+: init-gridfs ( gridfs -- )
+ chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } }
+ <index-spec> ensure-index ; inline
+
+PRIVATE>
+
+: <gridfs> ( bucket -- gridfs )
+ [ ]
+ [ "files" "%s.%s" sprintf ]
+ [ "chunks" "%s.%s" sprintf ] tri
+ gridfs boa [ init-gridfs ] keep ;
+
+: with-gridfs ( gridfs quot -- * )
+ [ gridfs ] dip with-variable ; inline
+
+TUPLE: entry
+ { id oid }
+ { filename string }
+ { content-type string }
+ { length integer }
+ { chunk-size integer }
+ { created timestamp }
+ { aliases array }
+ { metadata hashtable }
+ { md5 string } ;
+
+<PRIVATE
+
+: id>base64 ( id -- str )
+ [ a>> >hex ] [ b>> >hex ] bi
+ 2array "#" join >base64 >string ; inline
+
+: base64>id ( str -- objid )
+ base64> >string "#" split
+ [ first ] [ second ] bi
+ [ hex> ] bi@ oid boa ; inline
+
+PRIVATE>
+
+: <entry> ( name content-type -- entry )
+ entry new
+ swap >>content-type swap >>filename
+ <oid> >>id 0 >>length default-chunk-size >>chunk-size
+ now >>created ; inline
+
+<PRIVATE
+
+TUPLE: chunk
+ { id oid }
+ { fileid oid }
+ { n integer }
+ { data byte-array } ;
+
+: at> ( assoc key -- value/f )
+ swap at ; inline
+
+:: >set-at ( assoc value key -- )
+ value key assoc set-at ; inline
+
+: (update-file) ( entry assoc -- entry )
+ {
+ [ "_id" at> >>id ]
+ [ "filename" at> >>filename ]
+ [ "contentType" at> >>content-type ]
+ [ "length" at> >>length ]
+ [ "chunkSize" at> >>chunk-size ]
+ [ "uploadDate" at> >>created ]
+ [ "aliases" at> >>aliases ]
+ [ "metadata" at> >>metadata ]
+ [ "md5" at> >>md5 ]
+ } cleave ; inline
+
+: assoc>chunk ( assoc -- chunk )
+ [ chunk new ] dip
+ {
+ [ "_id" at> >>id ]
+ [ "files_id" at> >>fileid ]
+ [ "n" at> >>n ]
+ [ "data" at> >>data ]
+ } cleave ;
+
+: assoc>entry ( assoc -- entry )
+ [ entry new ] dip (update-file) ;
+
+: entry>assoc ( entry -- assoc )
+ [ H{ } clone ] dip
+ {
+ [ id>> "_id" >set-at ]
+ [ filename>> "filename" >set-at ]
+ [ content-type>> "contentType" >set-at ]
+ [ length>> "length" >set-at ]
+ [ chunk-size>> "chunkSize" >set-at ]
+ [ created>> "uploadDate" >set-at ]
+ [ aliases>> "aliases" >set-at ]
+ [ metadata>> "metadata" >set-at ]
+ [ md5>> "md5" >set-at ]
+ [ drop ]
+ } 2cleave ; inline
+
+: create-entry ( entry -- entry )
+ [ [ files-collection ] dip entry>assoc save ] [ ] bi ;
+
+TUPLE: state bytes count ;
+
+: <state> ( -- state )
+ 0 0 state boa ; inline
+
+: get-state ( -- n )
+ state get ; inline
+
+: with-state ( quot -- state )
+ [ <state> state ] dip
+ [ get-state ] compose
+ with-variable ; inline
+
+: update-state ( bytes -- )
+ [ get-state ] dip
+ '[ _ + ] change-bytes
+ [ 1 + ] change-count drop ; inline
+
+:: store-chunk ( chunk entry n -- )
+ entry id>> :> id
+ H{ { "files_id" id }
+ { "n" n } { "data" chunk } }
+ [ chunks-collection ] dip save ; inline
+
+:: write-chunks ( stream entry -- length )
+ entry chunk-size>> :> chunk-size
+ [
+ [
+ chunk-size stream stream-read dup [
+ [ entry get-state count>> store-chunk ]
+ [ length update-state ] bi
+ ] when*
+ ] loop
+ ] with-state bytes>> ;
+
+: (entry-selector) ( entry -- selector )
+ id>> "_id" associate ; inline
+
+:: file-md5 ( id -- md5-str )
+ filemd5-cmd make-cmd
+ id "filemd5" set-cmd-opt
+ gridfs> bucket>> "root" set-cmd-opt
+ send-cmd "md5" at> ; inline
+
+: update-entry ( bytes entry -- entry )
+ [ swap >>length dup id>> file-md5 >>md5 ]
+ [ nip [ (entry-selector) ] [ ] bi
+ [ length>> "length" associate "$set" associate
+ [ files-collection ] 2dip <update> update ]
+ [ md5>> "md5" associate "$set" associate
+ [ files-collection ] 2dip <update> update ] 2bi
+ ] 2bi ;
+
+TUPLE: gridfs-input-stream entry chunk n offset cpos ;
+
+: <gridfs-input-stream> ( entry -- stream )
+ [ gridfs-input-stream new ] dip
+ >>entry 0 >>offset 0 >>cpos -1 >>n ;
+
+PRIVATE>
+
+: write-entry ( input-stream entry -- entry )
+ create-entry [ write-chunks ] keep update-entry ;
+
+: get-entry ( id -- entry )
+ [ files-collection ] dip
+ "_id" associate <query> find-one assoc>entry ;
+
+: open-entry ( entry -- input-stream )
+ <gridfs-input-stream> ;
+
+: entry-contents ( entry -- bytearray )
+ <gridfs-input-stream> stream-contents ;
+
+<PRIVATE
+
+: load-chunk ( stream -- chunk/f )
+ [ entry>> id>> "files_id" associate ]
+ [ n>> "n" associate ] bi assoc-union
+ [ chunks-collection ] dip
+ <query> find-one dup [ assoc>chunk ] when ;
+
+: exhausted? ( stream -- boolean )
+ [ offset>> ] [ entry>> length>> ] bi = ; inline
+
+: fresh? ( stream -- boolean )
+ [ offset>> 0 = ] [ chunk>> f = ] bi and ; inline
+
+: data-available ( stream -- int/f )
+ [ cpos>> ] [ chunk>> data>> length ] bi
+ 2dup < [ swap - ] [ 2drop f ] if ; inline
+
+: next-chunk ( stream -- available chunk/f )
+ 0 >>cpos [ 1 + ] change-n
+ [ ] [ load-chunk ] bi >>chunk
+ [ data-available ] [ chunk>> ] bi ; inline
+
+: ?chunk ( stream -- available chunk/f )
+ dup fresh? [ next-chunk ] [
+ dup exhausted? [ drop 0 f ] [
+ dup data-available [ swap chunk>> ] [ next-chunk ] if*
+ ] if
+ ] if ; inline
+
+: set-stream ( n stream -- )
+ swap {
+ [ >>offset drop ]
+ [ over entry>> chunk-size>> /mod [ >>n ] [ >>cpos ] bi* drop ]
+ [ drop dup load-chunk >>chunk drop ]
+ } 2cleave ; inline
+
+:: advance-stream ( n stream -- )
+ stream [ n + ] change-cpos [ n + ] change-offset drop ; inline
+
+: read-part ( n stream chunk -- seq/f )
+ [ [ cpos>> swap [ drop ] [ + ] 2bi ] [ data>> ] bi* <slice> ]
+ [ drop advance-stream ] 3bi ; inline
+
+:: (stream-read-partial) ( n stream -- seq/f )
+ stream ?chunk :> chunk :> available
+ chunk [
+ n available <
+ [ n ] [ available ] if
+ stream chunk read-part
+ ] [ f ] if ; inline
+
+:: (stream-read) ( n stream acc -- )
+ n stream (stream-read-partial)
+ {
+ { [ dup not ] [ drop ] }
+ { [ dup length n = ] [ acc push-all ] }
+ { [ dup length n < ] [
+ [ acc push-all ] [ length ] bi
+ n swap - stream acc (stream-read) ]
+ }
+ } cond ; inline recursive
+
+PRIVATE>
+
+M: gridfs-input-stream stream-element-type drop +byte+ ;
+
+M: gridfs-input-stream stream-read ( n stream -- seq/f )
+ over <byte-vector> [ (stream-read) ] [ ] bi
+ dup empty? [ drop f ] [ >byte-array ] if ;
+
+M: gridfs-input-stream stream-read-partial ( n stream -- seq/f )
+ (stream-read-partial) ;
+
+M: gridfs-input-stream stream-tell ( stream -- n )
+ offset>> ;
+
+M: gridfs-input-stream stream-seek ( n seek-type stream -- )
+ swap seek-absolute =
+ [ set-stream ]
+ [ "seek-type not supported" throw ] if ;
+
+M: gridfs-input-stream dispose drop ;
CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
TUPLE: mdb-msg
-{ opcode integer }
-{ req-id integer initial: 0 }
-{ resp-id integer initial: 0 }
-{ length integer initial: 0 }
-{ flags integer initial: 0 } ;
+ { opcode integer }
+ { req-id integer initial: 0 }
+ { resp-id integer initial: 0 }
+ { length integer initial: 0 }
+ { flags integer initial: 0 } ;
TUPLE: mdb-query-msg < mdb-msg
-{ collection string }
-{ skip# integer initial: 0 }
-{ return# integer initial: 0 }
-{ query assoc }
-{ returnfields assoc }
-{ orderby assoc }
-explain hint ;
+ { collection string }
+ { skip# integer initial: 0 }
+ { return# integer initial: 0 }
+ { query assoc }
+ { returnfields assoc }
+ { orderby assoc }
+ explain hint ;
TUPLE: mdb-insert-msg < mdb-msg
-{ collection string }
-{ objects sequence } ;
+ { collection string }
+ { objects sequence } ;
TUPLE: mdb-update-msg < mdb-msg
-{ collection string }
-{ upsert? integer initial: 0 }
-{ selector assoc }
-{ object assoc } ;
+ { collection string }
+ { upsert? integer initial: 0 }
+ { selector assoc }
+ { object assoc } ;
TUPLE: mdb-delete-msg < mdb-msg
-{ collection string }
-{ selector assoc } ;
+ { collection string }
+ { selector assoc } ;
TUPLE: mdb-getmore-msg < mdb-msg
-{ collection string }
-{ return# integer initial: 0 }
-{ cursor integer initial: 0 }
-{ query mdb-query-msg } ;
+ { collection string }
+ { return# integer initial: 0 }
+ { cursor integer initial: 0 }
+ { query mdb-query-msg } ;
TUPLE: mdb-killcursors-msg < mdb-msg
-{ cursors# integer initial: 0 }
-{ cursors sequence } ;
+ { cursors# integer initial: 0 }
+ { cursors sequence } ;
TUPLE: mdb-reply-msg < mdb-msg
-{ collection string }
-{ cursor integer initial: 0 }
-{ start# integer initial: 0 }
-{ requested# integer initial: 0 }
-{ returned# integer initial: 0 }
-{ objects sequence } ;
+ { collection string }
+ { cursor integer initial: 0 }
+ { start# integer initial: 0 }
+ { requested# integer initial: 0 }
+ { returned# integer initial: 0 }
+ { objects sequence } ;
CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
io.encodings.utf8 io.encodings.utf8.private io.files kernel
locals math mongodb.msg namespaces sequences uuid
bson.writer.private ;
+
IN: mongodb.operations
+M: byte-vector byte-length length ;
+
<PRIVATE
PREDICATE: mdb-reply-op < integer OP_Reply = ;
PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
-PRIVATE>
-
-GENERIC: write-message ( message -- )
-
-<PRIVATE
-
CONSTANT: MSG-HEADER-SIZE 16
SYMBOL: msg-bytes-read
: read-byte-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
: read-byte ( -- byte ) read-byte-raw first ; inline
-: (read-cstring) ( acc -- )
- [ read-byte ] dip ! b acc
- 2dup push ! b acc
- [ 0 = ] dip ! bool acc
- '[ _ (read-cstring) ] unless ; inline recursive
-
-: read-cstring ( -- string )
- BV{ } clone
- [ (read-cstring) ] keep
- [ zero? ] trim-tail
- >byte-array utf8 decode ; inline
-
-GENERIC: (read-message) ( message opcode -- message )
-
: copy-header ( message msg-stub -- message )
- [ length>> ] keep [ >>length ] dip
- [ req-id>> ] keep [ >>req-id ] dip
- [ resp-id>> ] keep [ >>resp-id ] dip
- [ opcode>> ] keep [ >>opcode ] dip
- flags>> >>flags ;
-
-M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
- drop
+ {
+ [ length>> >>length ]
+ [ req-id>> >>req-id ]
+ [ resp-id>> >>resp-id ]
+ [ opcode>> >>opcode ]
+ [ flags>> >>flags ]
+ } cleave ; inline
+
+: reply-read-message ( msg-stub -- message )
[ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor
read-int32 >>start#
read-int32 [ >>returned# ] keep
[ H{ } stream>assoc ] collector [ times ] dip >>objects ;
+: (read-message) ( message opcode -- message )
+ OP_Reply =
+ [ reply-read-message ]
+ [ "unknown message type" throw ] if ; inline
+
: read-header ( message -- message )
read-int32 >>length
read-int32 >>req-id
read-int32 >>flags ; inline
: write-header ( message -- )
- [ req-id>> write-int32 ] keep
- [ resp-id>> write-int32 ] keep
- opcode>> write-int32 ; inline
+ [ req-id>> write-int32 ]
+ [ resp-id>> write-int32 ]
+ [ opcode>> write-int32 ] tri ; inline
PRIVATE>
: read-message ( -- message )
- mdb-msg new
- 0 >bytes-read
- read-header
- [ ] [ opcode>> ] bi (read-message) ;
+ [
+ mdb-msg new 0 >bytes-read read-header
+ [ ] [ opcode>> ] bi (read-message)
+ ] with-scope ;
<PRIVATE
-USE: tools.walker
-
-: dump-to-file ( array -- )
- [ uuid1 "/tmp/mfb/%s.dump" sprintf binary ] dip
- '[ _ write ] with-file-writer ;
-
-: (write-message) ( message quot -- )
- '[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer
- ! [ dump-to-file ] keep
- write flush ; inline
+: (write-message) ( message quot -- )
+ [ connection-buffer dup ] 2dip
+ '[
+ [ _ [ write-header ] [ @ ] bi ] with-length-prefix
+ ] with-output-stream* write flush ; inline
:: build-query-object ( query -- selector )
H{ } clone :> selector
- query { [ orderby>> [ "$orderby" selector set-at ] when* ]
- [ explain>> [ "$explain" selector set-at ] when* ]
- [ hint>> [ "$hint" selector set-at ] when* ]
- [ query>> "query" selector set-at ]
- } cleave
- selector ;
+ query {
+ [ orderby>> [ "$orderby" selector set-at ] when* ]
+ [ explain>> [ "$explain" selector set-at ] when* ]
+ [ hint>> [ "$hint" selector set-at ] when* ]
+ [ query>> "query" selector set-at ]
+ } cleave selector ; inline
+
+: query-write-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ skip#>> write-int32 ]
+ [ return#>> write-int32 ]
+ [ build-query-object assoc>stream ]
+ [ returnfields>> [ assoc>stream ] when* ]
+ } cleave
+ ] (write-message) ; inline
+
+: insert-write-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ objects>> [ assoc>stream ] each ] tri
+ ] (write-message) ; inline
+
+: update-write-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ upsert?>> write-int32 ]
+ [ selector>> assoc>stream ]
+ [ object>> assoc>stream ]
+ } cleave
+ ] (write-message) ; inline
+
+: delete-write-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ 0 write-int32 selector>> assoc>stream ] tri
+ ] (write-message) ; inline
+
+: getmore-write-message ( message -- )
+ [
+ {
+ [ flags>> write-int32 ]
+ [ collection>> write-cstring ]
+ [ return#>> write-int32 ]
+ [ cursor>> write-longlong ]
+ } cleave
+ ] (write-message) ; inline
+
+: killcursors-write-message ( message -- )
+ [
+ [ flags>> write-int32 ]
+ [ cursors#>> write-int32 ]
+ [ cursors>> [ write-longlong ] each ] tri
+ ] (write-message) ; inline
PRIVATE>
-M: mdb-query-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- [ skip#>> write-int32 ] keep
- [ return#>> write-int32 ] keep
- [ build-query-object assoc>stream ] keep
- returnfields>> [ assoc>stream ] when*
- ] (write-message) ;
-
-M: mdb-insert-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- objects>> [ assoc>stream ] each
- ] (write-message) ;
-
-M: mdb-update-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- [ upsert?>> write-int32 ] keep
- [ selector>> assoc>stream ] keep
- object>> assoc>stream
- ] (write-message) ;
-
-M: mdb-delete-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- 0 write-int32
- selector>> assoc>stream
- ] (write-message) ;
-
-M: mdb-getmore-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ collection>> write-cstring ] keep
- [ return#>> write-int32 ] keep
- cursor>> write-longlong
- ] (write-message) ;
-
-M: mdb-killcursors-msg write-message ( message -- )
- dup
- '[ _
- [ flags>> write-int32 ] keep
- [ cursors#>> write-int32 ] keep
- cursors>> [ write-longlong ] each
- ] (write-message) ;
-
+: write-message ( message -- )
+ {
+ { [ dup mdb-query-msg? ] [ query-write-message ] }
+ { [ dup mdb-insert-msg? ] [ insert-write-message ] }
+ { [ dup mdb-update-msg? ] [ update-write-message ] }
+ { [ dup mdb-delete-msg? ] [ delete-write-message ] }
+ { [ dup mdb-getmore-msg? ] [ getmore-write-message ] }
+ { [ dup mdb-killcursors-msg? ] [ killcursors-write-message ] }
+ } cond ;
over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip
- [ tuple-collection name>> ] [ id>> ] bi <objref> ;
+ [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
: write-field ( value quot -- value' )
<cond-value> {
H{ } clone swap [ <mirror> ] keep pick ; inline
: ensure-mdb-info ( tuple -- tuple )
- dup id>> [ <objid> >>id ] unless ; inline
+ dup id>> [ <oid> >>id ] unless ; inline
: with-object-map ( quot: ( -- ) -- store-assoc )
[ H{ } clone dup object-map ] dip with-variable ; inline
projects / factor.git / commitdiff