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 formatting
+constructors sequences splitting checksums checksums.md5
io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
arrays hashtables sequences.deep vectors locals ;
mdb-connection get instance>> ; inline
: index-collection ( -- ns )
- mdb-instance name>> "%s.system.indexes" sprintf ; inline
+ mdb-instance name>> "system.indexes" 2array "." join ; inline
: namespaces-collection ( -- ns )
- mdb-instance name>> "%s.system.namespaces" sprintf ; inline
+ mdb-instance name>> "system.namespaces" 2array "." join ; inline
: cmd-collection ( -- ns )
- mdb-instance name>> "%s.$cmd" sprintf ; inline
+ mdb-instance name>> "$cmd" 2array "." join ; inline
: index-ns ( colname -- index-ns )
- [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
+ [ mdb-instance name>> ] dip 2array "." join ; inline
: send-message ( message -- )
[ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
-USING: accessors assocs bson.constants bson.writer combinators combinators.smart
-constructors continuations destructors formatting fry io io.pools
-io.encodings.binary io.sockets io.streams.duplex kernel linked-assocs hashtables
-namespaces parser prettyprint sequences sets splitting strings uuid arrays
-math math.parser memoize mongodb.connection mongodb.msg mongodb.operations ;
+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 sequences sets splitting strings
+tools.continuations uuid memoize locals ;
IN: mongodb.driver
CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
-: unique-index ( index-spec -- index-spec )
- t >>unique? ;
-
M: mdb-pool make-connection
mdb>> mdb-open ;
[ 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 )
H{ } clone [ set-at ] keep <mdb-db>
[ verify-nodes ] keep ;
-GENERIC: create-collection ( name -- )
+GENERIC: create-collection ( name/collection -- )
M: string create-collection
<mdb-collection> create-collection ;
M: mdb-collection create-collection
- [ cmd-collection ] dip
- <linked-hash> [
- [ [ 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
- ] keep <mdb-query-msg> 1 >>return# send-query-plain drop ;
-
+ [ [ 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 ;
+
: load-collection-list ( -- collection-list )
namespaces-collection
H{ } clone <mdb-query-msg> send-query-plain objects>> ;
: ensure-valid-collection-name ( collection -- )
[ ";$." intersect length 0 > ] keep
- '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline
-
-: (ensure-collection) ( collection -- )
- mdb-instance collections>> dup keys length 0 =
- [ load-collection-list
- [ [ "options" ] dip key? ] filter
- [ [ "name" ] dip at "." split second <mdb-collection> ] map
- over '[ [ ] [ name>> ] bi _ set-at ] each ] [ ] if
- [ dup ] dip key? [ drop ]
- [ [ ensure-valid-collection-name ] keep create-collection ] if ;
-
+ '[ _ "contains invalid characters ( . $ ; )" 2array "." join throw ] when ; inline
+
+: build-collection-map ( -- assoc )
+ H{ } clone load-collection-list
+ [ [ "name" ] dip at "." split second <mdb-collection> ] map
+ over '[ [ ] [ name>> ] bi _ set-at ] each ;
+
+: ensure-collection-map ( mdb-instance -- assoc )
+ dup collections>> dup keys length 0 =
+ [ drop build-collection-map [ >>collections drop ] keep ]
+ [ nip ] if ;
+
+: (ensure-collection) ( collection mdb-instance -- collection )
+ ensure-collection-map [ dup ] dip key?
+ [ ] [ [ ensure-valid-collection-name ]
+ [ create-collection ]
+ [ ] tri ] if ;
+
: reserved-namespace? ( name -- ? )
[ "$cmd" = ] [ "system" head? ] bi or ;
: check-collection ( collection -- fq-collection )
- dup mdb-collection? [ name>> ] when
- "." split1 over mdb-instance name>> =
- [ nip ] [ drop ] if
- [ ] [ reserved-namespace? ] bi
- [ [ (ensure-collection) ] keep ] unless
- [ mdb-instance name>> ] dip "%s.%s" sprintf ;
+ [let* | instance [ mdb-instance ]
+ instance-name [ instance name>> ] |
+ dup mdb-collection? [ name>> ] when
+ "." split1 over instance-name =
+ [ nip ] [ drop ] if
+ [ ] [ reserved-namespace? ] bi
+ [ instance (ensure-collection) ] unless
+ [ instance-name ] dip 2array "." join ] ;
: fix-query-collection ( mdb-query -- mdb-query )
[ check-collection ] change-collection ; inline