recovered files lost by my own stupidity...
Sascha Matzke
parent
3c8402dbca
commit
c0f2c3a95f
|
|
@ -0,0 +1,105 @@
|
||||||
|
USING: accessors assocs formatting kernel math classes sequences splitting strings
|
||||||
|
words classes.tuple vectors ;
|
||||||
|
|
||||||
|
IN: mongodb.collection
|
||||||
|
|
||||||
|
GENERIC: mdb-slot-definitions>> ( tuple -- string )
|
||||||
|
GENERIC: mdb-collection>> ( object -- mdb-collection )
|
||||||
|
|
||||||
|
CONSTANT: MDB_COLLECTIONS "mdb_collections"
|
||||||
|
|
||||||
|
SYMBOLS: +transient+ +load+ ;
|
||||||
|
|
||||||
|
UNION: boolean t POSTPONE: f ;
|
||||||
|
|
||||||
|
TUPLE: mdb-collection
|
||||||
|
{ name string }
|
||||||
|
{ capped boolean initial: f }
|
||||||
|
{ size integer initial: -1 }
|
||||||
|
{ max integer initial: -1 }
|
||||||
|
{ classes sequence } ;
|
||||||
|
|
||||||
|
USING: mongodb.persistent mongodb.msg mongodb.tuple
|
||||||
|
mongodb.connection mongodb.query mongodb.index ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
CONSTANT: MDB_COL_PROP "mdb_collection"
|
||||||
|
CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options"
|
||||||
|
|
||||||
|
: (mdb-collection>>) ( class -- mdb-collection )
|
||||||
|
dup props>> [ MDB_COL_PROP ] dip at
|
||||||
|
[ [ drop ] dip ]
|
||||||
|
[ superclass [ (mdb-collection>>) ] [ f ] if* ] if* ; inline recursive
|
||||||
|
|
||||||
|
: (mdb-slot-definitions>>) ( class -- slot-defs )
|
||||||
|
superclasses [ MDB_SLOTOPT_PROP word-prop ] map assoc-combine ; inline
|
||||||
|
|
||||||
|
: link-class ( class collection -- )
|
||||||
|
tuck classes>> ! col class v{}
|
||||||
|
[ 2dup member? [ 2drop ] [ push ] if ]
|
||||||
|
[ 1vector >>classes ] if* drop ;
|
||||||
|
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
M: tuple-class mdb-collection>> ( tuple -- mdb-collection )
|
||||||
|
(mdb-collection>>) ;
|
||||||
|
|
||||||
|
M: mdb-persistent mdb-collection>> ( tuple -- mdb-collection )
|
||||||
|
class (mdb-collection>>) ;
|
||||||
|
|
||||||
|
M: mdb-persistent mdb-slot-definitions>> ( tuple -- string )
|
||||||
|
class (mdb-slot-definitions>>) ;
|
||||||
|
|
||||||
|
M: tuple-class mdb-slot-definitions>> ( class -- assoc )
|
||||||
|
(mdb-slot-definitions>>) ;
|
||||||
|
|
||||||
|
M: mdb-collection mdb-slot-definitions>> ( collection -- assoc )
|
||||||
|
classes>> [ mdb-slot-definitions>> ] map assoc-combine ;
|
||||||
|
|
||||||
|
: link-collection ( class collection -- )
|
||||||
|
2dup link-class
|
||||||
|
swap [ MDB_COL_PROP ] dip props>> set-at ; inline
|
||||||
|
|
||||||
|
: declared-collections> ( -- assoc )
|
||||||
|
MDB_COLLECTIONS mdb-persistent props>> at
|
||||||
|
[ H{ } clone
|
||||||
|
[ MDB_COLLECTIONS mdb-persistent props>> set-at ] keep
|
||||||
|
] unless* ;
|
||||||
|
|
||||||
|
: <mdb-collection> ( name -- mdb-collection )
|
||||||
|
declared-collections> 2dup key?
|
||||||
|
[ at ]
|
||||||
|
[ [ mdb-collection new ] 2dip
|
||||||
|
[ [ >>name dup ] keep ] dip set-at ] if ;
|
||||||
|
|
||||||
|
: load-collections ( -- collections )
|
||||||
|
namespaces-ns
|
||||||
|
H{ } clone <mdb-query-msg> (find)
|
||||||
|
objects>> [ [ "name" ] dip at "." split second <mdb-collection> ] map
|
||||||
|
dup [ ensure-indices ] each
|
||||||
|
[ mdb>> ] dip >>collections collections>> ;
|
||||||
|
|
||||||
|
: check-ok ( result -- ? )
|
||||||
|
[ "ok" ] dip key? ; inline
|
||||||
|
|
||||||
|
: create-collection ( mdb-collection -- )
|
||||||
|
dup name>> "create" H{ } clone [ set-at ] keep
|
||||||
|
[
|
||||||
|
mdb>> [ master>> ] keep name>> "%s.$cmd" sprintf
|
||||||
|
] dip <mdb-query-one-msg> (find-one)
|
||||||
|
check-ok
|
||||||
|
[ [ ensure-indices ] keep dup name>> mdb>> collections>> set-at ]
|
||||||
|
[ "could not create collection" throw ] if ;
|
||||||
|
|
||||||
|
: get-collection-fqn ( mdb-collection -- fqdn )
|
||||||
|
mdb>> collections>>
|
||||||
|
dup keys length 0 =
|
||||||
|
[ drop load-collections ]
|
||||||
|
[ ] if
|
||||||
|
[ dup name>> ] dip
|
||||||
|
key?
|
||||||
|
[ ]
|
||||||
|
[ dup create-collection ] if
|
||||||
|
name>> [ mdb>> name>> ] dip "%s.%s" sprintf ;
|
||||||
|
|
@ -0,0 +1,61 @@
|
||||||
|
USING: accessors assocs fry io.sockets kernel math mongodb.msg
|
||||||
|
mongodb.query namespaces sequences splitting math.parser ;
|
||||||
|
|
||||||
|
IN: mongodb.connection
|
||||||
|
|
||||||
|
TUPLE: mdb-node master? inet ;
|
||||||
|
|
||||||
|
TUPLE: mdb name nodes collections ;
|
||||||
|
|
||||||
|
: mdb>> ( -- mdb )
|
||||||
|
mdb get ; inline
|
||||||
|
|
||||||
|
: with-db ( mdb quot -- ... )
|
||||||
|
'[ _ mdb set _ call ] with-scope ;
|
||||||
|
|
||||||
|
: master>> ( mdb -- inet )
|
||||||
|
nodes>> [ t ] dip at inet>> ;
|
||||||
|
|
||||||
|
: slave>> ( mdb -- inet )
|
||||||
|
nodes>> [ f ] dip at inet>> ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: ismaster-cmd ( node -- result )
|
||||||
|
"admin.$cmd" H{ { "ismaster" 1 } } <mdb-query-one-msg>
|
||||||
|
(find-one-raw) ; inline
|
||||||
|
|
||||||
|
: -push ( seq elt -- )
|
||||||
|
swap push ; inline
|
||||||
|
|
||||||
|
: split-host-str ( hoststr -- host port )
|
||||||
|
":" split [ first ] keep
|
||||||
|
second string>number ; inline
|
||||||
|
|
||||||
|
: check-nodes ( node -- nodelist )
|
||||||
|
[ V{ } clone ] dip
|
||||||
|
[ -push ] 2keep
|
||||||
|
dup inet>> ismaster-cmd ! vec node result
|
||||||
|
dup [ "ismaster" ] dip at
|
||||||
|
>fixnum 1 = ! vec node result
|
||||||
|
[ [ t >>master? drop ] dip f ]
|
||||||
|
[ [ f >>master? drop ] dip t ] if
|
||||||
|
[ "remote" ] 2dip [ at split-host-str <inet> ] dip
|
||||||
|
swap mdb-node boa swap
|
||||||
|
[ push ] keep ;
|
||||||
|
|
||||||
|
: verify-nodes ( -- )
|
||||||
|
mdb>> nodes>> [ t ] dip at
|
||||||
|
check-nodes
|
||||||
|
H{ } clone tuck
|
||||||
|
'[ dup master?>> _ set-at ] each
|
||||||
|
[ mdb>> ] dip >>nodes drop ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: (<mdb>) ( db host port -- mdb )
|
||||||
|
[ f ] 2dip <inet> mdb-node boa
|
||||||
|
check-nodes
|
||||||
|
H{ } clone tuck
|
||||||
|
'[ dup master?>> _ set-at ] each
|
||||||
|
V{ } mdb boa ;
|
||||||
|
|
@ -0,0 +1,99 @@
|
||||||
|
USING: accessors assocs combinators formatting fry kernel memoize
|
||||||
|
linked-assocs mongodb.persistent mongodb.msg
|
||||||
|
sequences sequences.deep io.encodings.binary
|
||||||
|
io.sockets prettyprint sets ;
|
||||||
|
|
||||||
|
IN: mongodb.index
|
||||||
|
|
||||||
|
DEFER: mdb-slot-definitions>>
|
||||||
|
|
||||||
|
TUPLE: index name ns key ;
|
||||||
|
|
||||||
|
SYMBOLS: +fieldindex+ +compoundindex+ +deepindex+ ;
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: index-type ( type -- name )
|
||||||
|
{ { +fieldindex+ [ "field" ] }
|
||||||
|
{ +deepindex+ [ "deep" ] }
|
||||||
|
{ +compoundindex+ [ "compound" ] } } case ;
|
||||||
|
|
||||||
|
: index-name ( slot index-spec -- name )
|
||||||
|
[ first index-type ] keep
|
||||||
|
rest "-" join
|
||||||
|
"%s-%s-%s-Idx" sprintf ;
|
||||||
|
|
||||||
|
: build-index ( element slot -- assoc )
|
||||||
|
swap [ <linked-hash> ] 2dip
|
||||||
|
[ rest ] keep first ! assoc slot options itype
|
||||||
|
{ { +fieldindex+ [ drop [ 1 ] dip pick set-at ] }
|
||||||
|
{ +deepindex+ [ first "%s.%s" sprintf [ 1 ] dip pick set-at ] }
|
||||||
|
{ +compoundindex+ [
|
||||||
|
2over swap [ 1 ] 2dip set-at [ drop ] dip ! assoc options
|
||||||
|
over '[ _ [ 1 ] 2dip set-at ] each ] }
|
||||||
|
} case ;
|
||||||
|
|
||||||
|
: build-index-seq ( slot optlist ns -- index-seq )
|
||||||
|
[ V{ } clone ] 3dip ! v{} slot optl ns
|
||||||
|
[ index new ] dip ! v{} slot optl index ns
|
||||||
|
>>ns
|
||||||
|
[ pick ] dip swap ! v{} slot optl index v{}
|
||||||
|
[ swap ] 2dip ! v{} optl slot index v{ }
|
||||||
|
'[ _ _ ! element slot exemplar
|
||||||
|
clone 2over swap index-name >>name ! element slot clone
|
||||||
|
[ build-index ] dip swap >>key _ push
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: is-index-declaration? ( entry -- ? )
|
||||||
|
first
|
||||||
|
{ { +fieldindex+ [ t ] }
|
||||||
|
{ +compoundindex+ [ t ] }
|
||||||
|
{ +deepindex+ [ t ] }
|
||||||
|
[ drop f ] } case ;
|
||||||
|
|
||||||
|
: index-assoc ( seq -- assoc )
|
||||||
|
H{ } clone tuck '[ dup name>> _ set-at ] each ;
|
||||||
|
|
||||||
|
: delete-index ( name ns -- )
|
||||||
|
"Drop index %s - %s" sprintf . ;
|
||||||
|
|
||||||
|
: clean-indices ( existing defined -- )
|
||||||
|
[ index-assoc ] bi@ assoc-diff values
|
||||||
|
[ [ name>> ] [ ns>> ] bi delete-index ] each ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
USE: mongodb.query
|
||||||
|
|
||||||
|
: load-indices ( mdb-collection -- indexlist )
|
||||||
|
[ mdb>> name>> ] dip name>> "%s.%s" sprintf
|
||||||
|
"ns" H{ } clone [ set-at ] keep [ index-ns ] dip <mdb-query-msg>
|
||||||
|
'[ _ write-request read-reply ]
|
||||||
|
[ mdb>> master>> binary ] dip with-client
|
||||||
|
objects>> [ [ index new ] dip
|
||||||
|
[ [ "ns" ] dip at >>ns ]
|
||||||
|
[ [ "name" ] dip at >>name ]
|
||||||
|
[ [ "key" ] dip at >>key ] tri
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
: build-indices ( mdb-collection mdb -- seq )
|
||||||
|
name>>
|
||||||
|
[ [ mdb-slot-definitions>> ] keep name>> ] dip
|
||||||
|
swap "%s.%s" sprintf
|
||||||
|
[ V{ } clone ] 2dip pick
|
||||||
|
'[ _
|
||||||
|
[ [ is-index-declaration? ] filter ] dip
|
||||||
|
build-index-seq _ push
|
||||||
|
] assoc-each flatten ;
|
||||||
|
|
||||||
|
: ensure-indices ( mdb-collection -- )
|
||||||
|
[ load-indices ] keep mdb>> build-indices
|
||||||
|
[ clean-indices ] keep
|
||||||
|
V{ } clone tuck
|
||||||
|
'[ _ [ <linked-hash> tuple>query ] dip push ] each
|
||||||
|
<mdb-insert-msg> mdb>> name>> "%s.system.indexes" sprintf >>collection
|
||||||
|
[ mdb>> master>> binary ] dip '[ _ write-request ] with-client ;
|
||||||
|
|
||||||
|
|
||||||
|
: show-indices ( mdb-collection -- )
|
||||||
|
load-indices . ;
|
||||||
|
|
@ -1,14 +1,19 @@
|
||||||
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
|
USING: accessors assocs fry io.encodings.binary io.sockets kernel math
|
||||||
math.parser mongodb.msg mongodb.persistent mongodb.query mongodb.tuple
|
math.parser namespaces sequences splitting ;
|
||||||
namespaces sequences splitting ;
|
|
||||||
|
|
||||||
IN: mongodb
|
IN: mongodb
|
||||||
|
|
||||||
INTERSECTION: storable mdb-persistent ;
|
! generic methods
|
||||||
|
GENERIC: store ( tuple/ht -- )
|
||||||
|
GENERIC: find ( example -- tuple/ht )
|
||||||
|
GENERIC: findOne ( exampe -- tuple/ht )
|
||||||
|
GENERIC: load ( object -- object )
|
||||||
|
|
||||||
|
USING: mongodb.msg mongodb.persistent mongodb.query mongodb.tuple
|
||||||
|
mongodb.collection mongodb.connection ;
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
||||||
: prepare-find ( example -- query )
|
: prepare-find ( example -- query )
|
||||||
[ mdb-collection>> get-collection-fqn ] keep
|
[ mdb-collection>> get-collection-fqn ] keep
|
||||||
H{ } tuple>query <mdb-query-msg> ; inline
|
H{ } tuple>query <mdb-query-msg> ; inline
|
||||||
|
|
@ -20,16 +25,8 @@ PRIVATE>
|
||||||
(<mdb>) ;
|
(<mdb>) ;
|
||||||
|
|
||||||
|
|
||||||
GENERIC: store ( tuple/ht -- )
|
|
||||||
|
|
||||||
GENERIC: find ( example -- tuple/ht )
|
M: mdb-persistent store ( tuple -- )
|
||||||
|
|
||||||
GENERIC: findOne ( exampe -- tuple/ht )
|
|
||||||
|
|
||||||
GENERIC: load ( object -- object )
|
|
||||||
|
|
||||||
|
|
||||||
M: storable store ( tuple -- )
|
|
||||||
prepare-store ! H { collection { ... values ... }
|
prepare-store ! H { collection { ... values ... }
|
||||||
[ [ <mdb-insert-msg> ] 2dip
|
[ [ <mdb-insert-msg> ] 2dip
|
||||||
[ get-collection-fqn >>collection ] dip
|
[ get-collection-fqn >>collection ] dip
|
||||||
|
|
@ -37,11 +34,11 @@ M: storable store ( tuple -- )
|
||||||
[ mdb>> master>> binary ] dip '[ _ write-request ] with-client
|
[ mdb>> master>> binary ] dip '[ _ write-request ] with-client
|
||||||
] assoc-each ;
|
] assoc-each ;
|
||||||
|
|
||||||
M: storable find ( example -- result )
|
M: mdb-persistent find ( example -- result )
|
||||||
prepare-find (find)
|
prepare-find (find)
|
||||||
build-result ;
|
build-result ;
|
||||||
|
|
||||||
M: storable findOne ( example -- result )
|
M: mdb-persistent findOne ( example -- result )
|
||||||
prepare-find (find-one)
|
prepare-find (find-one)
|
||||||
dup returned#>> 1 =
|
dup returned#>> 1 =
|
||||||
[ objects>> first ]
|
[ objects>> first ]
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,144 @@
|
||||||
|
USING: io io.encodings.utf8 io.encodings.binary alien.c-types alien.strings math
|
||||||
|
bson.writer sequences kernel accessors io.streams.byte-array fry generalizations
|
||||||
|
combinators bson.reader sequences tools.walker assocs strings mongodb.persistent ;
|
||||||
|
|
||||||
|
IN: mongodb.msg
|
||||||
|
|
||||||
|
DEFER: tuple>linked-assoc
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
CONSTANT: OP_Reply 1
|
||||||
|
CONSTANT: OP_Message 1000
|
||||||
|
CONSTANT: OP_Update 2001
|
||||||
|
CONSTANT: OP_Insert 2002
|
||||||
|
CONSTANT: OP_Query 2004
|
||||||
|
CONSTANT: OP_GetMore 2005
|
||||||
|
CONSTANT: OP_Delete 2006
|
||||||
|
CONSTANT: OP_KillCursors 2007
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
TUPLE: mdb-msg
|
||||||
|
{ opcode integer }
|
||||||
|
{ req-id integer initial: 0 }
|
||||||
|
{ resp-id integer initial: 0 }
|
||||||
|
{ length integer initial: 0 } ;
|
||||||
|
|
||||||
|
TUPLE: mdb-insert-msg < mdb-msg
|
||||||
|
{ collection string }
|
||||||
|
{ objects sequence } ;
|
||||||
|
|
||||||
|
TUPLE: mdb-query-msg < mdb-msg
|
||||||
|
{ collection string }
|
||||||
|
{ skip# integer initial: 0 }
|
||||||
|
{ return# integer initial: 0 }
|
||||||
|
{ query assoc }
|
||||||
|
{ returnfields assoc }
|
||||||
|
{ orderby sequence } ;
|
||||||
|
|
||||||
|
TUPLE: mdb-reply-msg < mdb-msg
|
||||||
|
{ flags integer initial: 0 }
|
||||||
|
{ cursor integer initial: 0 }
|
||||||
|
{ start# integer initial: 0 }
|
||||||
|
{ returned# integer initial: 0 }
|
||||||
|
{ objects sequence } ;
|
||||||
|
|
||||||
|
|
||||||
|
: <mdb-query-msg> ( collection assoc -- mdb-query-msg )
|
||||||
|
[ mdb-query-msg new ] 2dip
|
||||||
|
[ >>collection ] dip
|
||||||
|
>>query OP_Query >>opcode ; inline
|
||||||
|
|
||||||
|
: <mdb-query-one-msg> ( collection assoc -- mdb-query-msg )
|
||||||
|
<mdb-query-msg> 1 >>return# ; inline
|
||||||
|
|
||||||
|
GENERIC: <mdb-insert-msg> ( sequence -- mdb-insert-msg )
|
||||||
|
|
||||||
|
M: tuple <mdb-insert-msg> ( tuple -- mdb-insert-msg )
|
||||||
|
[ mdb-insert-msg new ] dip
|
||||||
|
tuple>linked-assoc V{ } clone tuck push
|
||||||
|
>>objects OP_Insert >>opcode ;
|
||||||
|
|
||||||
|
M: sequence <mdb-insert-msg> ( sequence -- mdb-insert-msg )
|
||||||
|
[ mdb-insert-msg new ] dip >>objects OP_Insert >>opcode ;
|
||||||
|
|
||||||
|
|
||||||
|
: <mdb-reply-msg> ( -- mdb-reply-msg )
|
||||||
|
mdb-reply-msg new ; inline
|
||||||
|
|
||||||
|
|
||||||
|
GENERIC: write-request ( message -- )
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
CONSTANT: MSG-HEADER-SIZE 16
|
||||||
|
|
||||||
|
: write-byte ( byte -- ) <char> write ; inline
|
||||||
|
: write-int32 ( int -- ) <int> write ; inline
|
||||||
|
: write-double ( real -- ) <double> write ; inline
|
||||||
|
: write-cstring ( string -- ) utf8 string>alien write ; inline
|
||||||
|
: write-longlong ( object -- ) <longlong> write ; inline
|
||||||
|
|
||||||
|
: read-int32 ( -- int32 ) 4 read *int ; inline
|
||||||
|
: read-longlong ( -- longlong ) 8 read *longlong ; inline
|
||||||
|
: read-byte-raw ( -- byte-raw ) 1 read ; inline
|
||||||
|
: read-byte ( -- byte ) read-byte-raw *char ; inline
|
||||||
|
|
||||||
|
: (read-cstring) ( acc -- acc )
|
||||||
|
read-byte-raw dup
|
||||||
|
B{ 0 } =
|
||||||
|
[ append ]
|
||||||
|
[ append (read-cstring) ] if ; recursive inline
|
||||||
|
|
||||||
|
: read-cstring ( -- string )
|
||||||
|
B{ } clone
|
||||||
|
(read-cstring) utf8 alien>string ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: read-reply-header ( message -- message )
|
||||||
|
read-int32 >>length
|
||||||
|
read-int32 >>req-id
|
||||||
|
read-int32 >>resp-id
|
||||||
|
read-int32 >>opcode ; inline
|
||||||
|
|
||||||
|
: read-reply-message ( message -- message )
|
||||||
|
read-int32 >>flags read-longlong >>cursor
|
||||||
|
read-int32 >>start# read-int32 tuck >>returned# swap
|
||||||
|
[ H{ } stream>assoc ] accumulator [ times ] dip >>objects ; inline
|
||||||
|
|
||||||
|
: read-reply ( -- message )
|
||||||
|
<mdb-reply-msg>
|
||||||
|
read-reply-header
|
||||||
|
read-reply-message ; inline
|
||||||
|
|
||||||
|
: write-request-header ( message length -- )
|
||||||
|
MSG-HEADER-SIZE + write-int32
|
||||||
|
[ req-id>> write-int32 ] keep
|
||||||
|
[ resp-id>> write-int32 ] keep
|
||||||
|
opcode>> write-int32 ; inline
|
||||||
|
|
||||||
|
: (write-message) ( message quot -- )
|
||||||
|
[ binary ] dip with-byte-writer dup
|
||||||
|
[ length write-request-header ] dip
|
||||||
|
write flush ; inline
|
||||||
|
|
||||||
|
M: mdb-query-msg write-request ( message -- )
|
||||||
|
dup
|
||||||
|
'[ _
|
||||||
|
[ 4 write-int32 ] dip
|
||||||
|
[ collection>> write-cstring ] keep
|
||||||
|
[ skip#>> write-int32 ] keep
|
||||||
|
[ return#>> write-int32 ] keep
|
||||||
|
query>> assoc>array write
|
||||||
|
] (write-message) ;
|
||||||
|
|
||||||
|
M: mdb-insert-msg write-request ( message -- )
|
||||||
|
dup
|
||||||
|
'[ _
|
||||||
|
[ 0 write-int32 ] dip
|
||||||
|
[ collection>> write-cstring ] keep
|
||||||
|
objects>> [ assoc>array write ] each
|
||||||
|
] (write-message) ;
|
||||||
|
|
||||||
|
|
@ -20,13 +20,9 @@ GENERIC# tuple>assoc 1 ( tuple exemplar -- assoc )
|
||||||
|
|
||||||
GENERIC# tuple>query 1 ( tuple examplar -- query-assoc )
|
GENERIC# tuple>query 1 ( tuple examplar -- query-assoc )
|
||||||
|
|
||||||
GENERIC: mdb-collection>> ( tuple -- string )
|
|
||||||
|
|
||||||
GENERIC: mdb-slot-definitions>> ( tuple -- string )
|
|
||||||
|
|
||||||
|
|
||||||
DEFER: assoc>tuple
|
DEFER: assoc>tuple
|
||||||
DEFER: create-mdb-command
|
DEFER: create-mdb-command
|
||||||
|
DEFER: mdb-collection>>
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -0,0 +1,64 @@
|
||||||
|
USING: accessors combinators fry io.encodings.binary io.sockets kernel
|
||||||
|
mongodb.msg mongodb.persistent sequences math namespaces assocs
|
||||||
|
formatting ;
|
||||||
|
|
||||||
|
IN: mongodb.query
|
||||||
|
|
||||||
|
TUPLE: mdb-node master? inet ;
|
||||||
|
|
||||||
|
TUPLE: mdb name nodes collections ;
|
||||||
|
|
||||||
|
: mdb>> ( -- mdb )
|
||||||
|
mdb get ; inline
|
||||||
|
|
||||||
|
: with-db ( mdb quot -- * )
|
||||||
|
'[ _ mdb set _ call ] with-scope ; inline
|
||||||
|
|
||||||
|
: master>> ( mdb -- inet )
|
||||||
|
nodes>> [ t ] dip at ;
|
||||||
|
|
||||||
|
: slave>> ( mdb -- inet )
|
||||||
|
nodes>> [ f ] dip at ;
|
||||||
|
|
||||||
|
TUPLE: mdb-result { cursor integer }
|
||||||
|
{ start# integer }
|
||||||
|
{ returned# integer }
|
||||||
|
{ objects sequence } ;
|
||||||
|
|
||||||
|
: index-ns ( -- ns )
|
||||||
|
mdb>> name>> "%s.system.indexes" sprintf ; inline
|
||||||
|
|
||||||
|
: namespaces-ns ( -- ns )
|
||||||
|
mdb>> name>> "%s.system.namespaces" sprintf ; inline
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: (execute-query) ( inet quot -- result )
|
||||||
|
[ binary ] dip with-client ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: (find-raw) ( inet query -- result )
|
||||||
|
'[ _ write-request read-reply ] (execute-query) ; inline
|
||||||
|
|
||||||
|
: (find-one-raw) ( inet query -- result )
|
||||||
|
(find-raw) objects>> first ; inline
|
||||||
|
|
||||||
|
: (find) ( query -- result )
|
||||||
|
[ mdb>> master>> ] dip (find-raw) ;
|
||||||
|
|
||||||
|
: (find-one) ( query -- result )
|
||||||
|
[ mdb>> master>> ] dip (find-one-raw) ;
|
||||||
|
|
||||||
|
: build-result ( resultmsg -- mdb-result )
|
||||||
|
[ mdb-result new ] dip
|
||||||
|
{
|
||||||
|
[ cursor>> >>cursor ]
|
||||||
|
[ start#>> >>start# ]
|
||||||
|
[ returned#>> >>returned# ]
|
||||||
|
[ objects>> [ assoc>tuple ] map >>objects ]
|
||||||
|
} cleave ;
|
||||||
|
|
||||||
|
: query-collections ( -- result )
|
||||||
|
namespaces-ns H{ } clone <mdb-query-msg> (find) ;
|
||||||
|
|
||||||
|
|
@ -0,0 +1,66 @@
|
||||||
|
USING: accessors assocs classes classes.mixin classes.tuple vectors math
|
||||||
|
classes.tuple.parser formatting generalizations kernel sequences fry
|
||||||
|
prettyprint strings compiler.units slots tools.walker words arrays
|
||||||
|
mongodb.collection mongodb.persistent ;
|
||||||
|
|
||||||
|
IN: mongodb.tuple
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
CONSTANT: MDB_SLOTOPT_PROP "mdb_slot_options"
|
||||||
|
CONSTANT: MDB_P_SLOTS { "_id" }
|
||||||
|
CONSTANT: MDB_OID "_id"
|
||||||
|
|
||||||
|
: mdb-check-id-slot ( superclass slots -- superclass slots )
|
||||||
|
over
|
||||||
|
all-slots [ name>> ] map [ MDB_OID ] dip memq?
|
||||||
|
[ ]
|
||||||
|
[ MDB_P_SLOTS prepend ] if ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: show-persistence-info ( class -- )
|
||||||
|
H{ } clone
|
||||||
|
[ [ dup mdb-collection>> "collection" ] dip set-at ] keep
|
||||||
|
[ [ mdb-slot-definitions>> "slots" ] dip set-at ] keep . ;
|
||||||
|
|
||||||
|
GENERIC: mdb-persisted? ( tuple -- ? )
|
||||||
|
|
||||||
|
M: mdb-persistent mdb-persisted? ( tuple -- ? )
|
||||||
|
_id>> f = not ;
|
||||||
|
|
||||||
|
M: assoc mdb-persisted? ( assoc -- ? )
|
||||||
|
[ MDB_OID ] dip key? ; inline
|
||||||
|
|
||||||
|
: MDBTUPLE:
|
||||||
|
parse-tuple-definition
|
||||||
|
mdb-check-id-slot
|
||||||
|
define-tuple-class ; parsing
|
||||||
|
|
||||||
|
<PRIVATE
|
||||||
|
|
||||||
|
: split-olist ( seq -- key options )
|
||||||
|
[ first ] [ rest ] bi ; inline
|
||||||
|
|
||||||
|
: link-class ( class collection -- )
|
||||||
|
tuck classes>> ! col class v{}
|
||||||
|
[ 2dup member? [ 2drop ] [ push ] if ]
|
||||||
|
[ 1vector >>classes ] if* drop ;
|
||||||
|
|
||||||
|
: optl>assoc ( seq -- assoc )
|
||||||
|
[ dup assoc?
|
||||||
|
[ 1array { "" } append ] unless
|
||||||
|
] map ;
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
: set-slot-options ( class options -- )
|
||||||
|
H{ } clone tuck '[ _ [ split-olist optl>assoc swap ] dip set-at ] each
|
||||||
|
over [ MDB_SLOTOPT_PROP ] dip props>> set-at
|
||||||
|
dup mdb-collection>> link-collection ;
|
||||||
|
|
||||||
|
: define-collection ( class collection options -- )
|
||||||
|
[ [ dup ] dip link-collection ] dip ! cl options
|
||||||
|
[ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
|
||||||
|
set-slot-options ;
|
||||||
|
|
||||||
Loading…
Reference in New Issue