steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

added gridfs implementation, reworked mongodb commands, some minor performance improvements

db4
Sascha Matzke 2010-01-12 20:40:57 +01:00
parent aff9166f8c
commit 0c2cc6d459
13 changed files with 849 additions and 422 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
extra/bson/bson-tests.factor
View File

@ -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 ; io.streams.byte-array tools.test literals calendar kernel math ;
IN: bson.tests IN: bson.tests
@ -17,6 +17,9 @@ IN: bson.tests
[ H{ { "a quotation" [ 1 2 + ] } } ] [ H{ { "a quotation" [ 1 2 + ] } } ]
[ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test [ 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 } [ H{ { "a date" T{ timestamp { year 2009 }
{ month 7 } { month 7 }
{ day 11 } { day 11 }
@ -34,10 +37,12 @@ IN: bson.tests
] unit-test ] unit-test
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } } [ 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" } } } } { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } { "quot" [ 1 2 + ] } }
] ]
[ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } } [ 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" } } } } { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
{ "quot" [ 1 2 + ] } } turnaround ] unit-test { "quot" [ 1 2 + ] } } turnaround ] unit-test

2
extra/bson/bson.factor
View File

@ -1,3 +1,5 @@
! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license.
USING: vocabs.loader ; USING: vocabs.loader ;
IN: bson IN: bson

35
extra/bson/constants/constants.factor
View File

@ -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 IN: bson.constants
: <objid> ( -- objid ) : <objid> ( -- objid )
@ -7,9 +10,33 @@ IN: bson.constants
TUPLE: oid { a initial: 0 } { b initial: 0 } ; 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 } ; TUPLE: mdbregexp { regexp string } { options string } ;

153
extra/bson/reader/reader.factor
View File

@ -1,10 +1,10 @@
USING: accessors assocs bson.constants calendar fry io io.binary ! Copyright (C) 2010 Sascha Matzke.
io.encodings io.encodings.utf8 kernel math math.bitwise namespaces ! See http://factorcode.org/license.txt for BSD license.
sequences serialize locals ; USING: accessors assocs bson.constants calendar combinators
combinators.short-circuit fry io io.binary kernel locals math
FROM: kernel.private => declare ; namespaces sequences serialize tools.continuations strings ;
FROM: io.encodings.private => (read-until) ; FROM: io.encodings.binary => binary ;
FROM: io.streams.byte-array => with-byte-reader ;
IN: bson.reader IN: bson.reader
<PRIVATE <PRIVATE
@ -40,10 +40,6 @@ PREDICATE: bson-binary-function < integer T_Binary_Function = ;
PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ; PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
PREDICATE: bson-binary-custom < integer T_Binary_Custom = ; 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 ) : get-state ( -- state )
state get ; inline state get ; inline
@ -57,16 +53,16 @@ GENERIC: element-binary-read ( length type -- object )
8 read le> bits>double ; inline 8 read le> bits>double ; inline
: read-byte-raw ( -- byte-raw ) : read-byte-raw ( -- byte-raw )
1 read ; inline 1 read ;
: read-byte ( -- byte ) : read-byte ( -- byte )
read-byte-raw first ; inline read-byte-raw first ; inline
: read-cstring ( -- string ) : read-cstring ( -- string )
"\0" read-until drop "" like ; inline "\0" read-until drop >string ; inline
: read-sized-string ( length -- string ) : read-sized-string ( length -- string )
read 1 head-slice* "" like ; inline read 1 head-slice* >string ; inline
: read-element-type ( -- type ) : read-element-type ( -- type )
read-byte ; inline read-byte ; inline
@ -80,106 +76,75 @@ GENERIC: element-binary-read ( length type -- object )
: peek-scope ( -- ht ) : peek-scope ( -- ht )
get-state scope>> last ; inline get-state scope>> last ; inline
: read-elements ( -- ) : bson-object-data-read ( -- object )
read-element-type read-int32 drop get-state
element-read [ exemplar>> clone ] [ scope>> ] bi
[ read-elements ] when ; inline recursive [ 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 ) : bson-regexp-read ( -- mdbregexp )
drop ; mdbregexp new
read-cstring >>regexp read-cstring >>options ; inline
M: bson-array fix-result ( assoc type -- result ) : bson-oid-read ( -- oid )
drop values ; 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 -- ) : fix-result ( assoc type -- result )
drop ; {
{ [ dup T_Array = ] [ drop values ] }
{
[ dup T_Object = ]
[ drop dup dbref-assoc? [ assoc>dbref ] when ]
}
} cond ; inline
M: bson-array end-element ( type -- ) : end-element ( type -- )
drop ; { [ bson-object? ] [ bson-array? ] } 1||
[ pop-element drop ] unless ; inline
M: object end-element ( type -- ) :: bson-eoo-element-read ( type -- cont? )
pop-element 2drop ;
M:: bson-eoo element-read ( type -- cont? )
pop-element :> element pop-element :> element
get-state scope>> get-state scope>>
[ pop element type>> fix-result ] [ empty? ] bi [ pop element type>> fix-result ] [ empty? ] bi
[ [ get-state ] dip >>result drop f ] [ [ 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 peek-scope :> scope
type read-cstring [ push-element ] 2keep type read-cstring [ push-element ] 2keep
[ [ element-data-read ] [ end-element ] bi ] [ [ element-data-read ] [ end-element ] bi ]
[ scope set-at t ] bi* ; [ scope set-at t ] bi* ; inline
: [scope-changer] ( state -- state quot ) : (element-read) ( type -- cont? )
dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline dup bson-not-eoo?
[ bson-not-eoo-element-read ]
[ bson-eoo-element-read ] if ; inline
: (object-data-read) ( type -- object ) : read-elements ( -- )
drop read-element-type
read-int32 drop (element-read) [ read-elements ] when ; inline recursive
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 ;
PRIVATE> PRIVATE>
USE: tools.continuations
: stream>assoc ( exemplar -- assoc ) : stream>assoc ( exemplar -- assoc )
<state> dup state <state> dup state
[ read-int32 >>size read-elements ] with-variable [ read-int32 >>size read-elements ] with-variable
result>> ; result>> ; inline

2
extra/bson/summary.txt
View File

@ -1 +1 @@
BSON reader and writer BSON (http://en.wikipedia.org/wiki/BSON) reader and writer

221
extra/bson/writer/writer.factor
View File

@ -1,154 +1,153 @@
! Copyright (C) 2008 Sascha Matzke. ! Copyright (C) 2010 Sascha Matzke.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bson.constants byte-arrays byte-vectors USING: accessors arrays assocs bson.constants byte-arrays
calendar fry io io.binary io.encodings io.encodings.binary calendar combinators.short-circuit fry hashtables io io.binary
io.encodings.utf8 io.streams.byte-array kernel math math.parser kernel linked-assocs literals math math.parser namespaces
namespaces quotations sequences sequences.private serialize strings quotations sequences serialize strings vectors dlists alien.accessors ;
words combinators.short-circuit literals ; FROM: words => word? word ;
FROM: typed => TYPED: ;
FROM: io.encodings.utf8.private => char>utf8 ; FROM: combinators => cond ;
FROM: kernel.private => declare ;
IN: bson.writer IN: bson.writer
<PRIVATE <PRIVATE
SYMBOL: shared-buffer
CONSTANT: CHAR-SIZE 1 CONSTANT: CHAR-SIZE 1
CONSTANT: INT32-SIZE 4 CONSTANT: INT32-SIZE 4
CONSTANT: INT64-SIZE 8 CONSTANT: INT64-SIZE 8
: (buffer) ( -- buffer )
shared-buffer get
[ BV{ } clone [ shared-buffer set ] keep ] unless*
{ byte-vector } declare ; inline
PRIVATE> PRIVATE>
: reset-buffer ( buffer -- ) : with-length ( quot: ( -- ) -- bytes-written start-index )
0 >>length drop ; inline [ output-stream get [ length ] [ ] bi ] dip
: 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
call length swap [ - ] keep ; inline call length swap [ - ] keep ; inline
: (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b ) : (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
[ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap [ [ 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 ) : with-length-prefix ( quot: ( -- ) -- )
[ INT32-SIZE >le ] (with-length-prefix) ; inline [ ] (with-length-prefix) ; inline
: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b ) : with-length-prefix-excl ( quot: ( -- ) -- )
[ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline [ INT32-SIZE - ] (with-length-prefix) ; inline
<PRIVATE <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-int32 ( int -- ) INT32-SIZE >le write ; inline
: write-double ( real -- ) double>bits INT64-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
: write-cstring ( string -- ) B{ } like write 0 write1 ; inline : write-cstring ( string -- ) B{ } like write 0 write1 ; inline
: write-longlong ( object -- ) INT64-SIZE >le write ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline
: write-eoo ( -- ) T_EOO write1 ; 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-header ( name object type -- object )
'[ _ write-cstring ] with-length-prefix-excl ; write1 [ write-cstring ] dip ; inline
M: f bson-write ( f -- ) DEFER: write-pair
drop 0 write1 ;
M: t bson-write ( t -- ) : write-byte-array ( binary -- )
drop 1 write1 ; [ length write-int32 ]
[ T_Binary_Bytes write1 write ] bi ; inline
M: integer bson-write ( num -- ) : write-mdbregexp ( regexp -- )
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 -- )
[ regexp>> write-cstring ] [ regexp>> write-cstring ]
[ options>> write-cstring ] bi ; [ options>> write-cstring ] bi ; inline
M: sequence bson-write ( array -- ) TYPED: write-sequence ( array: sequence -- )
'[ _ [ [ write-type ] dip number>string '[
write-cstring bson-write ] each-index _ [ number>string swap write-pair ] 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 write-eoo
] with-length-prefix ; ] with-length-prefix ; inline recursive
: (serialize-code) ( code -- ) TYPED: write-oid ( oid: oid -- )
object>bytes [ length write-int32 ] keep [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
T_Binary_Custom write1
write ;
M: quotation bson-write ( quotation -- ) : write-oid-field ( assoc -- )
(serialize-code) ; [ MDB_OID_FIELD dup ] dip at
[ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ]
[ drop ] if* ; inline
M: word bson-write ( word -- ) : skip-field? ( name value -- name value boolean )
(serialize-code) ; 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> PRIVATE>
: assoc>bv ( assoc -- byte-vector ) TYPED: assoc>bv ( assoc: hashtables -- byte-vector )
[ '[ _ bson-write ] with-buffer ] with-scope ; inline [ BV{ } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
: assoc>stream ( assoc -- ) TYPED: assoc>stream ( assoc: hashtables -- )
{ assoc } declare bson-write ; inline write-assoc ; inline
: mdb-special-value? ( value -- ? ) : mdb-special-value? ( value -- ? )
{ [ timestamp? ] [ quotation? ] [ mdbregexp? ] { [ timestamp? ] [ quotation? ] [ mdbregexp? ]

132
extra/mongodb/cmd/cmd.factor Normal file
View File

@ -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

53
extra/mongodb/connection/connection.factor
View File

@ -1,9 +1,9 @@
USING: accessors assocs fry io.encodings.binary io.sockets kernel math USING: accessors arrays assocs byte-vectors checksums
math.parser mongodb.msg mongodb.operations namespaces destructors checksums.md5 constructors destructors fry hashtables
constructors sequences splitting checksums checksums.md5 io.encodings.binary io.encodings.string io.encodings.utf8
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart io.sockets io.streams.duplex kernel locals math math.parser
arrays hashtables sequences.deep vectors locals ; mongodb.cmd mongodb.msg namespaces sequences
splitting ;
IN: mongodb.connection IN: mongodb.connection
: md5-checksum ( string -- digest ) : md5-checksum ( string -- digest )
@ -15,7 +15,12 @@ TUPLE: mdb-node master? { address inet } remote ;
CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ; 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 ) ; CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
@ -33,7 +38,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
nodes>> f swap at ; nodes>> f swap at ;
: with-connection ( connection quot -- * ) : with-connection ( connection quot -- * )
[ mdb-connection set ] prepose with-scope ; inline [ mdb-connection ] dip with-variable ; inline
: mdb-instance ( -- mdb ) : mdb-instance ( -- mdb )
mdb-connection get instance>> ; inline mdb-connection get instance>> ; inline
@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: namespaces-collection ( -- ns ) : namespaces-collection ( -- ns )
mdb-instance name>> "system.namespaces" "." glue ; inline mdb-instance name>> "system.namespaces" "." glue ; inline
: cmd-collection ( -- ns ) : cmd-collection ( cmd -- ns )
mdb-instance name>> "$cmd" "." glue ; inline admin?>> [ "admin" ] [ mdb-instance name>> ] if
"$cmd" "." glue ; inline
: index-ns ( colname -- index-ns ) : index-ns ( colname -- index-ns )
[ mdb-instance name>> ] dip "." glue ; inline [ mdb-instance name>> ] dip "." glue ; inline
@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
'[ _ write-message read-message ] with-stream* ; '[ _ write-message read-message ] with-stream* ;
: send-query-1result ( collection assoc -- result ) : send-query-1result ( collection assoc -- result )
<mdb-query-msg> <mdb-query-msg> -1 >>return# send-query-plain
1 >>return# objects>> [ f ] [ first ] if-empty ;
send-query-plain objects>>
[ f ] [ first ] if-empty ; : send-cmd ( cmd -- result )
[ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
<PRIVATE <PRIVATE
: get-nonce ( -- nonce ) : get-nonce ( -- nonce )
cmd-collection H{ { "getnonce" 1 } } send-query-1result getnonce-cmd make-cmd send-cmd
[ "nonce" swap at ] [ f ] if* ; [ "nonce" swap at ] [ f ] if* ;
: auth? ( mdb -- ? ) : auth? ( mdb -- ? )
@ -78,16 +85,14 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
[ pwd-digest>> ] bi [ pwd-digest>> ] bi
3array concat md5-checksum ; inline 3array concat md5-checksum ; inline
: build-auth-query ( -- query-assoc ) : build-auth-cmd ( cmd -- cmd )
{ "authenticate" 1 } mdb-instance username>> "user" set-cmd-opt
"user" mdb-instance username>> 2array get-nonce [ "nonce" set-cmd-opt ] [ ] bi
"nonce" get-nonce 2array calculate-key-digest "key" set-cmd-opt ; inline
3array >hashtable
[ [ "nonce" ] dip at calculate-key-digest "key" ] keep
[ set-at ] keep ;
: perform-authentication ( -- ) : 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 check-ok [ drop ] [ throw ] if ; inline
: authenticate-connection ( mdb-connection -- ) : authenticate-connection ( mdb-connection -- )
@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
: open-connection ( mdb-connection node -- mdb-connection ) : open-connection ( mdb-connection node -- mdb-connection )
[ >>node ] [ address>> ] bi [ >>node ] [ address>> ] bi
[ >>remote ] keep binary <client> [ >>remote ] keep binary <client>
[ >>handle ] dip >>local ; [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
: get-ismaster ( -- result ) : get-ismaster ( -- result )
"admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;

99
extra/mongodb/driver/driver.factor
View File

@ -1,10 +1,10 @@
USING: accessors arrays assocs bson.constants combinators USING: accessors arrays assocs bson.constants combinators
combinators.smart constructors destructors formatting fry hashtables combinators.smart constructors destructors fry hashtables io
io io.pools io.sockets kernel linked-assocs math mongodb.connection io.pools io.sockets kernel linked-assocs locals math
mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections mongodb.cmd mongodb.connection mongodb.msg namespaces parser
sequences sets splitting strings prettyprint prettyprint.custom prettyprint.sections sequences
tools.continuations uuid memoize locals ; sets splitting strings ;
FROM: ascii => ascii? ;
IN: mongodb.driver IN: mongodb.driver
TUPLE: mdb-pool < pool mdb ; TUPLE: mdb-pool < pool mdb ;
@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ;
TUPLE: mdb-collection TUPLE: mdb-collection
{ name string } { name string }
{ capped boolean initial: f } { capped boolean }
{ size integer initial: -1 } { size integer }
{ max integer initial: -1 } ; { max integer } ;
CONSTRUCTOR: mdb-collection ( name -- collection ) ; CONSTRUCTOR: mdb-collection ( name -- collection ) ;
@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result
[ make-cursor ] 2tri [ make-cursor ] 2tri
swap objects>> ; 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> PRIVATE>
SYNTAX: r/ ( token -- mdbregexp ) SYNTAX: r/ ( token -- mdbregexp )
\ / [ >mdbregexp ] parse-literal ; \ / [ >mdbregexp ] parse-literal ;
: with-db ( mdb quot -- * ) : with-db ( mdb quot -- )
'[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline '[ _ 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 ) : >id-selector ( assoc -- selector )
[ MDB_OID_FIELD swap at ] keep [ MDB_OID_FIELD swap at ] keep
H{ } clone [ set-at ] keep ; H{ } clone [ set-at ] keep ;
@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- )
M: string create-collection M: string create-collection
<mdb-collection> create-collection ; <mdb-collection> create-collection ;
M: mdb-collection create-collection M: mdb-collection create-collection ( collection -- )
[ [ cmd-collection ] dip create-cmd make-cmd over
<linked-hash> [ make-collection-assoc ] keep {
<mdb-query-msg> 1 >>return# send-query-plain drop ] keep [ name>> "create" set-cmd-opt ]
[ ] [ name>> ] bi mdb-instance collections>> set-at ; [ 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 ) : load-collection-list ( -- collection-list )
namespaces-collection namespaces-collection
@ -128,8 +133,12 @@ M: mdb-collection create-collection
<PRIVATE <PRIVATE
: ensure-valid-collection-name ( collection -- ) : 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 ) : build-collection-map ( -- assoc )
H{ } clone load-collection-list H{ } clone load-collection-list
@ -215,21 +224,21 @@ M: mdb-cursor find
dup empty? [ drop f ] [ first ] if ; dup empty? [ drop f ] [ first ] if ;
: count ( mdb-query-msg -- result ) : count ( mdb-query-msg -- result )
[ collection>> "count" H{ } clone [ set-at ] keep ] keep [ count-cmd make-cmd ] dip
query>> [ over [ "query" ] dip set-at ] when* [ collection>> "count" set-cmd-opt ]
[ cmd-collection ] dip <mdb-query-msg> find-one [ query>> "query" set-cmd-opt ] bi send-cmd
[ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ; [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
: lasterror ( -- error ) : lasterror ( -- error )
cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg> getlasterror-cmd make-cmd send-cmd
find-one [ "err" ] dip at ; [ "err" ] dip at ;
GENERIC: validate. ( collection -- ) GENERIC: validate. ( collection -- )
M: string validate. M: string validate.
[ cmd-collection ] dip [ validate-cmd make-cmd ] dip
"validate" H{ } clone [ set-at ] keep "validate" set-cmd-opt send-cmd
<mdb-query-msg> find-one [ check-ok nip ] keep [ check-ok nip ] keep
'[ "result" _ at print ] [ ] if ; '[ "result" _ at print ] [ ] if ;
M: mdb-collection validate. M: mdb-collection validate.
@ -251,7 +260,7 @@ PRIVATE>
<mdb-insert-msg> send-message ; <mdb-insert-msg> send-message ;
: ensure-index ( index-spec -- ) : 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 ] [ { [ [ name>> "name" ] dip set-at ]
[ [ ns>> index-ns "ns" ] dip set-at ] [ [ ns>> index-ns "ns" ] dip set-at ]
[ [ key>> "key" ] dip set-at ] [ [ key>> "key" ] dip set-at ]
@ -261,11 +270,9 @@ PRIVATE>
[ index-collection ] dip save ; [ index-collection ] dip save ;
: drop-index ( collection name -- ) : drop-index ( collection name -- )
H{ } clone [ delete-index-cmd make-cmd ] 2dip
[ [ "index" ] dip set-at ] keep [ "deleteIndexes" set-cmd-opt ]
[ [ "deleteIndexes" ] dip set-at ] keep [ "index" set-cmd-opt ] bi* send-cmd drop ;
[ cmd-collection ] dip <mdb-query-msg>
find-one drop ;
: <update> ( collection selector object -- mdb-update-msg ) : <update> ( collection selector object -- mdb-update-msg )
[ check-collection ] 2dip <mdb-update-msg> ; [ check-collection ] 2dip <mdb-update-msg> ;
@ -279,6 +286,15 @@ PRIVATE>
: update-unsafe ( mdb-update-msg -- ) : update-unsafe ( mdb-update-msg -- )
send-message ; 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 -- ) : delete ( collection selector -- )
[ check-collection ] dip [ check-collection ] dip
<mdb-delete-msg> send-message-check-error ; <mdb-delete-msg> send-message-check-error ;
@ -298,8 +314,7 @@ PRIVATE>
check-collection drop ; check-collection drop ;
: drop-collection ( name -- ) : drop-collection ( name -- )
[ cmd-collection ] dip [ drop-cmd make-cmd ] dip
"drop" H{ } clone [ set-at ] keep "drop" set-cmd-opt send-cmd drop ;
<mdb-query-msg> find-one drop ;

285
extra/mongodb/gridfs/gridfs.factor Normal file
View File

@ -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 ;

64
extra/mongodb/msg/msg.factor
View File

@ -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 */ CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
TUPLE: mdb-msg TUPLE: mdb-msg
{ opcode integer } { opcode integer }
{ req-id integer initial: 0 } { req-id integer initial: 0 }
{ resp-id integer initial: 0 } { resp-id integer initial: 0 }
{ length integer initial: 0 } { length integer initial: 0 }
{ flags integer initial: 0 } ; { flags integer initial: 0 } ;
TUPLE: mdb-query-msg < mdb-msg TUPLE: mdb-query-msg < mdb-msg
{ collection string } { collection string }
{ skip# integer initial: 0 } { skip# integer initial: 0 }
{ return# integer initial: 0 } { return# integer initial: 0 }
{ query assoc } { query assoc }
{ returnfields assoc } { returnfields assoc }
{ orderby assoc } { orderby assoc }
explain hint ; explain hint ;
TUPLE: mdb-insert-msg < mdb-msg TUPLE: mdb-insert-msg < mdb-msg
{ collection string } { collection string }
{ objects sequence } ; { objects sequence } ;
TUPLE: mdb-update-msg < mdb-msg TUPLE: mdb-update-msg < mdb-msg
{ collection string } { collection string }
{ upsert? integer initial: 0 } { upsert? integer initial: 0 }
{ selector assoc } { selector assoc }
{ object assoc } ; { object assoc } ;
TUPLE: mdb-delete-msg < mdb-msg TUPLE: mdb-delete-msg < mdb-msg
{ collection string } { collection string }
{ selector assoc } ; { selector assoc } ;
TUPLE: mdb-getmore-msg < mdb-msg TUPLE: mdb-getmore-msg < mdb-msg
{ collection string } { collection string }
{ return# integer initial: 0 } { return# integer initial: 0 }
{ cursor integer initial: 0 } { cursor integer initial: 0 }
{ query mdb-query-msg } ; { query mdb-query-msg } ;
TUPLE: mdb-killcursors-msg < mdb-msg TUPLE: mdb-killcursors-msg < mdb-msg
{ cursors# integer initial: 0 } { cursors# integer initial: 0 }
{ cursors sequence } ; { cursors sequence } ;
TUPLE: mdb-reply-msg < mdb-msg TUPLE: mdb-reply-msg < mdb-msg
{ collection string } { collection string }
{ cursor integer initial: 0 } { cursor integer initial: 0 }
{ start# integer initial: 0 } { start# integer initial: 0 }
{ requested# integer initial: 0 } { requested# integer initial: 0 }
{ returned# integer initial: 0 } { returned# integer initial: 0 }
{ objects sequence } ; { objects sequence } ;
CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg ) CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )

200
extra/mongodb/operations/operations.factor
View File

@ -4,8 +4,11 @@ io.encodings.private io.encodings.binary io.encodings.string
io.encodings.utf8 io.encodings.utf8.private io.files kernel io.encodings.utf8 io.encodings.utf8.private io.files kernel
locals math mongodb.msg namespaces sequences uuid locals math mongodb.msg namespaces sequences uuid
bson.writer.private ; bson.writer.private ;
IN: mongodb.operations IN: mongodb.operations
M: byte-vector byte-length length ;
<PRIVATE <PRIVATE
PREDICATE: mdb-reply-op < integer OP_Reply = ; 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-getmore-op < integer OP_GetMore = ;
PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ; PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
PRIVATE>
GENERIC: write-message ( message -- )
<PRIVATE
CONSTANT: MSG-HEADER-SIZE 16 CONSTANT: MSG-HEADER-SIZE 16
SYMBOL: msg-bytes-read 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-raw ( -- byte-raw ) 1 [ read le> ] [ change-bytes-read ] bi ; inline
: read-byte ( -- byte ) read-byte-raw first ; 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 ) : copy-header ( message msg-stub -- message )
[ length>> ] keep [ >>length ] dip {
[ req-id>> ] keep [ >>req-id ] dip [ length>> >>length ]
[ resp-id>> ] keep [ >>resp-id ] dip [ req-id>> >>req-id ]
[ opcode>> ] keep [ >>opcode ] dip [ resp-id>> >>resp-id ]
flags>> >>flags ; [ opcode>> >>opcode ]
[ flags>> >>flags ]
} cleave ; inline
M: mdb-reply-op (read-message) ( msg-stub opcode -- message ) : reply-read-message ( msg-stub -- message )
drop
[ <mdb-reply-msg> ] dip copy-header [ <mdb-reply-msg> ] dip copy-header
read-longlong >>cursor read-longlong >>cursor
read-int32 >>start# read-int32 >>start#
read-int32 [ >>returned# ] keep read-int32 [ >>returned# ] keep
[ H{ } stream>assoc ] collector [ times ] dip >>objects ; [ 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-header ( message -- message )
read-int32 >>length read-int32 >>length
read-int32 >>req-id read-int32 >>req-id
@ -77,94 +66,97 @@ M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
read-int32 >>flags ; inline read-int32 >>flags ; inline
: write-header ( message -- ) : write-header ( message -- )
[ req-id>> write-int32 ] keep [ req-id>> write-int32 ]
[ resp-id>> write-int32 ] keep [ resp-id>> write-int32 ]
opcode>> write-int32 ; inline [ opcode>> write-int32 ] tri ; inline
PRIVATE> PRIVATE>
: read-message ( -- message ) : read-message ( -- message )
mdb-msg new [
0 >bytes-read mdb-msg new 0 >bytes-read read-header
read-header [ ] [ opcode>> ] bi (read-message)
[ ] [ opcode>> ] bi (read-message) ; ] with-scope ;
<PRIVATE <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-message) ( message quot -- )
'[ [ [ _ write-header ] dip _ call ] with-length-prefix ] with-buffer [ connection-buffer dup ] 2dip
! [ dump-to-file ] keep '[
write flush ; inline [ _ [ write-header ] [ @ ] bi ] with-length-prefix
] with-output-stream* write flush ; inline
:: build-query-object ( query -- selector ) :: build-query-object ( query -- selector )
H{ } clone :> selector H{ } clone :> selector
query { [ orderby>> [ "$orderby" selector set-at ] when* ] query {
[ explain>> [ "$explain" selector set-at ] when* ] [ orderby>> [ "$orderby" selector set-at ] when* ]
[ hint>> [ "$hint" selector set-at ] when* ] [ explain>> [ "$explain" selector set-at ] when* ]
[ query>> "query" selector set-at ] [ hint>> [ "$hint" selector set-at ] when* ]
} cleave [ query>> "query" selector set-at ]
selector ; } 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> PRIVATE>
M: mdb-query-msg write-message ( message -- ) : write-message ( message -- )
dup {
'[ _ { [ dup mdb-query-msg? ] [ query-write-message ] }
[ flags>> write-int32 ] keep { [ dup mdb-insert-msg? ] [ insert-write-message ] }
[ collection>> write-cstring ] keep { [ dup mdb-update-msg? ] [ update-write-message ] }
[ skip#>> write-int32 ] keep { [ dup mdb-delete-msg? ] [ delete-write-message ] }
[ return#>> write-int32 ] keep { [ dup mdb-getmore-msg? ] [ getmore-write-message ] }
[ build-query-object assoc>stream ] keep { [ dup mdb-killcursors-msg? ] [ killcursors-write-message ] }
returnfields>> [ assoc>stream ] when* } cond ;
] (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) ;

4
extra/mongodb/tuple/persistent/persistent.factor
View File

@ -54,7 +54,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
over [ call( tuple -- assoc ) ] dip over [ call( tuple -- assoc ) ] dip
[ [ tuple-collection name>> ] [ >toid ] bi ] keep [ [ tuple-collection name>> ] [ >toid ] bi ] keep
[ add-storable ] dip [ add-storable ] dip
[ tuple-collection name>> ] [ id>> ] bi <objref> ; [ tuple-collection name>> ] [ id>> ] bi <dbref> ;
: write-field ( value quot -- value' ) : write-field ( value quot -- value' )
<cond-value> { <cond-value> {
@ -79,7 +79,7 @@ CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
H{ } clone swap [ <mirror> ] keep pick ; inline H{ } clone swap [ <mirror> ] keep pick ; inline
: ensure-mdb-info ( tuple -- tuple ) : ensure-mdb-info ( tuple -- tuple )
dup id>> [ <objid> >>id ] unless ; inline dup id>> [ <oid> >>id ] unless ; inline
: with-object-map ( quot: ( -- ) -- store-assoc ) : with-object-map ( quot: ( -- ) -- store-assoc )
[ H{ } clone dup object-map ] dip with-variable ; inline [ H{ } clone dup object-map ] dip with-variable ; inline