added gridfs implementation, reworked mongodb commands, some minor performance improvements
Sascha Matzke
parent
aff9166f8c
commit
0c2cc6d459
|
|
@ -1,4 +1,4 @@
|
|||
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
|
||||
|
|
@ -17,6 +17,9 @@ 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 }
|
||||
|
|
@ -34,10 +37,12 @@ IN: bson.tests
|
|||
] 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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2010 Sascha Matzke.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: vocabs.loader ;
|
||||
|
||||
IN: bson
|
||||
|
|
|
|||
|
|
@ -1,5 +1,8 @@
|
|||
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 )
|
||||
|
|
@ -7,9 +10,33 @@ IN: bson.constants
|
|||
|
||||
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 ;
|
||||
|
||||
CONSTRUCTOR: objref ( ns objid -- objref ) ;
|
||||
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
|
||||
|
||||
: dbref-assoc? ( assoc -- ? )
|
||||
{ [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
|
||||
|
||||
TUPLE: mdbregexp { regexp string } { options string } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
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
|
||||
|
|
@ -40,10 +40,6 @@ PREDICATE: bson-binary-function < integer T_Binary_Function = ;
|
|||
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
|
||||
|
||||
|
|
@ -57,16 +53,16 @@ GENERIC: element-binary-read ( length type -- object )
|
|||
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
|
||||
|
|
@ -80,106 +76,75 @@ GENERIC: element-binary-read ( length type -- object )
|
|||
: peek-scope ( -- ht )
|
||||
get-state scope>> last ; inline
|
||||
|
||||
: read-elements ( -- )
|
||||
read-element-type
|
||||
element-read
|
||||
[ read-elements ] when ; inline recursive
|
||||
: bson-object-data-read ( -- object )
|
||||
read-int32 drop get-state
|
||||
[ exemplar>> clone ] [ scope>> ] bi
|
||||
[ push ] keep ; inline
|
||||
|
||||
GENERIC: fix-result ( assoc type -- result )
|
||||
: bson-binary-read ( -- binary )
|
||||
read-int32 read-byte
|
||||
bson-binary-bytes? [ read ] [ read bytes>object ] if ; inline
|
||||
|
||||
M: bson-object fix-result ( assoc type -- result )
|
||||
drop ;
|
||||
: bson-regexp-read ( -- mdbregexp )
|
||||
mdbregexp new
|
||||
read-cstring >>regexp read-cstring >>options ; inline
|
||||
|
||||
M: bson-array fix-result ( assoc type -- result )
|
||||
drop values ;
|
||||
: bson-oid-read ( -- oid )
|
||||
read-longlong read-int32 oid boa ; inline
|
||||
|
||||
GENERIC: end-element ( type -- )
|
||||
: 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
|
||||
|
||||
M: bson-object end-element ( type -- )
|
||||
drop ;
|
||||
: fix-result ( assoc type -- result )
|
||||
{
|
||||
{ [ dup T_Array = ] [ drop values ] }
|
||||
{
|
||||
[ dup T_Object = ]
|
||||
[ drop dup dbref-assoc? [ assoc>dbref ] when ]
|
||||
}
|
||||
} cond ; inline
|
||||
|
||||
M: bson-array end-element ( type -- )
|
||||
drop ;
|
||||
: end-element ( type -- )
|
||||
{ [ bson-object? ] [ bson-array? ] } 1||
|
||||
[ pop-element drop ] unless ; inline
|
||||
|
||||
M: object end-element ( type -- )
|
||||
pop-element 2drop ;
|
||||
|
||||
M:: bson-eoo element-read ( type -- cont? )
|
||||
:: 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 set-at t ] bi* ; inline
|
||||
|
||||
: [scope-changer] ( state -- state quot )
|
||||
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
|
||||
: (element-read) ( type -- cont? )
|
||||
dup bson-not-eoo?
|
||||
[ bson-not-eoo-element-read ]
|
||||
[ bson-eoo-element-read ] if ; 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 ;
|
||||
: read-elements ( -- )
|
||||
read-element-type
|
||||
(element-read) [ read-elements ] when ; inline recursive
|
||||
|
||||
PRIVATE>
|
||||
|
||||
USE: tools.continuations
|
||||
|
||||
: stream>assoc ( exemplar -- assoc )
|
||||
<state> dup state
|
||||
[ read-int32 >>size read-elements ] with-variable
|
||||
result>> ;
|
||||
[ read-int32 >>size read-elements ] with-variable
|
||||
result>> ; inline
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
BSON reader and writer
|
||||
BSON (http://en.wikipedia.org/wiki/BSON) reader and writer
|
||||
|
|
|
|||
|
|
@ -1,154 +1,153 @@
|
|||
! 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 ;
|
||||
: write-header ( name object type -- object )
|
||||
write1 [ write-cstring ] dip ; inline
|
||||
|
||||
M: f bson-write ( f -- )
|
||||
drop 0 write1 ;
|
||||
DEFER: write-pair
|
||||
|
||||
M: t bson-write ( t -- )
|
||||
drop 1 write1 ;
|
||||
: write-byte-array ( binary -- )
|
||||
[ length write-int32 ]
|
||||
[ T_Binary_Bytes write1 write ] bi ; inline
|
||||
|
||||
M: integer bson-write ( num -- )
|
||||
write-int32 ;
|
||||
|
||||
M: real bson-write ( num -- )
|
||||
>float write-double ;
|
||||
|
||||
M: timestamp bson-write ( timestamp -- )
|
||||
timestamp>millis write-longlong ;
|
||||
|
||||
M: byte-array bson-write ( binary -- )
|
||||
[ length write-int32 ] keep
|
||||
T_Binary_Bytes write1
|
||||
write ;
|
||||
|
||||
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 ;
|
||||
[ options>> write-cstring ] bi ; inline
|
||||
|
||||
: 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
|
||||
TYPED: write-sequence ( array: sequence -- )
|
||||
'[
|
||||
_ [ number>string swap write-pair ] each-index
|
||||
write-eoo
|
||||
] with-length-prefix ;
|
||||
] with-length-prefix ; inline recursive
|
||||
|
||||
: (serialize-code) ( code -- )
|
||||
object>bytes [ length write-int32 ] keep
|
||||
T_Binary_Custom write1
|
||||
write ;
|
||||
TYPED: write-oid ( oid: oid -- )
|
||||
[ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
|
||||
|
||||
M: quotation bson-write ( quotation -- )
|
||||
(serialize-code) ;
|
||||
|
||||
M: word bson-write ( word -- )
|
||||
(serialize-code) ;
|
||||
: 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? ]
|
||||
|
|
|
|||
|
|
@ -0,0 +1,132 @@
|
|||
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
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
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 )
|
||||
|
|
@ -15,7 +15,12 @@ TUPLE: mdb-node master? { address inet } remote ;
|
|||
|
||||
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 ) ;
|
||||
|
||||
|
|
@ -33,7 +38,7 @@ 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
|
||||
|
|
@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
: 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
|
||||
|
|
@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
'[ _ 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 -- ? )
|
||||
|
|
@ -78,16 +85,14 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
[ 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 -- )
|
||||
|
|
@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- 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 ;
|
||||
|
|
@ -119,7 +124,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
|
|||
|
||||
: nodelist>table ( seq -- assoc )
|
||||
[ [ master?>> ] keep 2array ] map >hashtable ;
|
||||
|
||||
|
||||
PRIVATE>
|
||||
|
||||
:: verify-nodes ( mdb -- )
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
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 ;
|
||||
|
|
@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ;
|
|||
|
||||
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 ) ;
|
||||
|
||||
|
|
@ -61,7 +61,7 @@ M: mdb-getmore-msg update-query
|
|||
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 ;
|
||||
|
|
@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result
|
|||
[ 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 ;
|
||||
|
|
@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- )
|
|||
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
|
||||
|
|
@ -128,8 +133,12 @@ M: mdb-collection create-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
|
||||
|
|
@ -215,21 +224,21 @@ M: mdb-cursor find
|
|||
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.
|
||||
|
|
@ -251,7 +260,7 @@ PRIVATE>
|
|||
<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 ]
|
||||
|
|
@ -261,11 +270,9 @@ PRIVATE>
|
|||
[ 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> ;
|
||||
|
|
@ -278,7 +285,16 @@ PRIVATE>
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -298,8 +314,7 @@ PRIVATE>
|
|||
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 ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,285 @@
|
|||
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 ;
|
||||
|
|
@ -17,52 +17,52 @@ CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
|
|||
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 )
|
||||
|
|
|
|||
|
|
@ -4,8 +4,11 @@ io.encodings.private io.encodings.binary io.encodings.string
|
|||
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 = ;
|
||||
|
|
@ -16,12 +19,6 @@ PREDICATE: mdb-delete-op < integer OP_Delete = ;
|
|||
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
|
||||
|
|
@ -40,35 +37,27 @@ 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 ;
|
||||
{
|
||||
[ length>> >>length ]
|
||||
[ req-id>> >>req-id ]
|
||||
[ resp-id>> >>resp-id ]
|
||||
[ opcode>> >>opcode ]
|
||||
[ flags>> >>flags ]
|
||||
} cleave ; inline
|
||||
|
||||
M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
|
||||
drop
|
||||
: 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
|
||||
|
|
@ -77,94 +66,97 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
|
|||
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> {
|
||||
|
|
@ -79,7 +79,7 @@ CONSTRUCTOR: cond-value ( value quot -- 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
|
||||
|
|
|
|||
Loading…
Reference in New Issue