parent
							
								
									22a891b483
								
							
						
					
					
						commit
						75c28ee62f
					
				|  | @ -12,6 +12,7 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; | ||||||
| TUPLE: objref ns objid ; | TUPLE: objref ns objid ; | ||||||
| 
 | 
 | ||||||
| CONSTANT: MDB_OID_FIELD "_id" | CONSTANT: MDB_OID_FIELD "_id" | ||||||
|  | CONSTANT: MDB_INTERNAL_FIELD "_mdb_" | ||||||
| 
 | 
 | ||||||
| CONSTANT: T_EOO  0   | CONSTANT: T_EOO  0   | ||||||
| CONSTANT: T_Double  1   | CONSTANT: T_Double  1   | ||||||
|  |  | ||||||
|  | @ -3,7 +3,7 @@ | ||||||
| USING: accessors assocs bson.constants byte-arrays fry io io.binary | USING: accessors assocs bson.constants byte-arrays fry io io.binary | ||||||
| io.encodings.binary io.encodings.string io.encodings.utf8 | io.encodings.binary io.encodings.string io.encodings.utf8 | ||||||
| io.streams.byte-array kernel math math.parser quotations sequences | io.streams.byte-array kernel math math.parser quotations sequences | ||||||
| serialize strings words ; | serialize strings words hashtables ; | ||||||
| 
 | 
 | ||||||
| IN: bson.writer | IN: bson.writer | ||||||
| 
 | 
 | ||||||
|  | @ -20,10 +20,10 @@ M: f bson-type? ( boolean -- type ) drop T_Boolean ; | ||||||
| M: real bson-type? ( real -- type ) drop T_Double ;  | M: real bson-type? ( real -- type ) drop T_Double ;  | ||||||
| M: word bson-type? ( word -- type ) drop T_String ;  | M: word bson-type? ( word -- type ) drop T_String ;  | ||||||
| M: tuple bson-type? ( tuple -- type ) drop T_Object ;   | M: tuple bson-type? ( tuple -- type ) drop T_Object ;   | ||||||
| M: assoc bson-type? ( hashtable -- type ) drop T_Object ;  | M: sequence bson-type? ( seq -- type ) drop T_Array ; | ||||||
| M: string bson-type? ( string -- type ) drop T_String ;  | M: string bson-type? ( string -- type ) drop T_String ;  | ||||||
| M: integer bson-type? ( integer -- type ) drop T_Integer ;  | M: integer bson-type? ( integer -- type ) drop T_Integer ;  | ||||||
| M: sequence bson-type? ( seq -- type ) drop T_Array ; | M: hashtable bson-type? ( hashtable -- type ) drop T_Object ;  | ||||||
| 
 | 
 | ||||||
| M: oid bson-type? ( word -- type ) drop T_OID ; | M: oid bson-type? ( word -- type ) drop T_OID ; | ||||||
| M: objid bson-type? ( objid -- type ) drop T_Binary ; | M: objid bson-type? ( objid -- type ) drop T_Binary ; | ||||||
|  | @ -98,11 +98,11 @@ M: sequence bson-write ( array -- ) | ||||||
|     [ MDB_OID_FIELD ] dip at* |     [ MDB_OID_FIELD ] dip at* | ||||||
|     [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline |     [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline | ||||||
| 
 | 
 | ||||||
| : oid-field? ( name -- boolean ) | : skip-field? ( name -- boolean ) | ||||||
|     MDB_OID_FIELD = ; inline |     { MDB_OID_FIELD MDB_INTERNAL_FIELD } member? ; inline | ||||||
| 
 | 
 | ||||||
| M: assoc bson-write ( hashtable -- ) | M: hashtable bson-write ( hashtable -- ) | ||||||
|     '[ _ [ write-oid ] [ [ over oid-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] |     '[ _ [ write-oid ] [ [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each ] bi ] | ||||||
|     binary swap with-byte-writer |     binary swap with-byte-writer | ||||||
|     [ length 5 + bson-write ] keep |     [ length 5 + bson-write ] keep | ||||||
|     write |     write | ||||||
|  |  | ||||||
|  | @ -6,7 +6,7 @@ IN: mongodb.driver | ||||||
| 
 | 
 | ||||||
| TUPLE: mdb-node master? inet ; | TUPLE: mdb-node master? inet ; | ||||||
| 
 | 
 | ||||||
| TUPLE: mdb name nodes collections ; | TUPLE: mdb-db name nodes collections ; | ||||||
| 
 | 
 | ||||||
| TUPLE: mdb-cursor collection id return# ; | TUPLE: mdb-cursor collection id return# ; | ||||||
| 
 | 
 | ||||||
|  | @ -23,9 +23,6 @@ CONSTRUCTOR: mdb-collection ( name -- collection ) ; | ||||||
| 
 | 
 | ||||||
| CONSTANT: MDB-GENERAL-ERROR 1 | CONSTANT: MDB-GENERAL-ERROR 1 | ||||||
| 
 | 
 | ||||||
| CONSTANT: MDB_OID "_id" |  | ||||||
| CONSTANT: MDB_PROPERTIES  "_mdb_" |  | ||||||
| 
 |  | ||||||
| CONSTANT: PARTIAL? "partial?" | CONSTANT: PARTIAL? "partial?" | ||||||
| CONSTANT: DIRTY? "dirty?" | CONSTANT: DIRTY? "dirty?" | ||||||
| 
 | 
 | ||||||
|  | @ -43,8 +40,10 @@ SYMBOL: mdb-socket-stream | ||||||
| 
 | 
 | ||||||
| PRIVATE> | PRIVATE> | ||||||
| 
 | 
 | ||||||
| : mdb>> ( -- mdb ) | SYMBOL: mdb-instance | ||||||
|     mdb get ; inline | 
 | ||||||
|  | : mdb ( -- mdb ) | ||||||
|  |     mdb-instance get ; inline | ||||||
| 
 | 
 | ||||||
| : master>> ( mdb -- inet ) | : master>> ( mdb -- inet ) | ||||||
|     nodes>> [ t ] dip at inet>> ; |     nodes>> [ t ] dip at inet>> ; | ||||||
|  | @ -53,7 +52,7 @@ PRIVATE> | ||||||
|     nodes>> [ f ] dip at inet>> ; |     nodes>> [ f ] dip at inet>> ; | ||||||
| 
 | 
 | ||||||
| : with-db ( mdb quot -- ... ) | : with-db ( mdb quot -- ... ) | ||||||
|     [ [ '[ _ [ mdb set ] keep master>> |     [ [ '[ _ [ mdb-instance set ] keep master>> | ||||||
|            [ remote-address set ] keep |            [ remote-address set ] keep | ||||||
|            binary <client> |            binary <client> | ||||||
|            local-address set |            local-address set | ||||||
|  | @ -64,16 +63,16 @@ PRIVATE> | ||||||
| <PRIVATE | <PRIVATE | ||||||
| 
 | 
 | ||||||
| : index-collection ( -- ns ) | : index-collection ( -- ns ) | ||||||
|    mdb>> name>> "%s.system.indexes" sprintf ; inline |    mdb name>> "%s.system.indexes" sprintf ; inline | ||||||
| 
 | 
 | ||||||
| : namespaces-collection ( -- ns ) | : namespaces-collection ( -- ns ) | ||||||
|     mdb>> name>> "%s.system.namespaces" sprintf ; inline |     mdb name>> "%s.system.namespaces" sprintf ; inline | ||||||
| 
 | 
 | ||||||
| : cmd-collection ( -- ns ) | : cmd-collection ( -- ns ) | ||||||
|     mdb>> name>> "%s.$cmd" sprintf ; inline |     mdb name>> "%s.$cmd" sprintf ; inline | ||||||
|   |   | ||||||
| : index-ns ( colname -- index-ns ) | : index-ns ( colname -- index-ns ) | ||||||
|     [ mdb>> name>> ] dip "%s.%s" sprintf ; inline |     [ mdb name>> ] dip "%s.%s" sprintf ; inline | ||||||
| 
 | 
 | ||||||
| : ismaster-cmd ( node -- result ) | : ismaster-cmd ( node -- result ) | ||||||
|     binary "admin.$cmd" H{ { "ismaster" 1 } } <mdb-query-msg> |     binary "admin.$cmd" H{ { "ismaster" 1 } } <mdb-query-msg> | ||||||
|  | @ -103,11 +102,11 @@ PRIVATE> | ||||||
|     ] when* ; |     ] when* ; | ||||||
| 
 | 
 | ||||||
| : verify-nodes ( -- ) | : verify-nodes ( -- ) | ||||||
|     mdb>> nodes>> [ t ] dip at |     mdb nodes>> [ t ] dip at | ||||||
|     check-nodes |     check-nodes | ||||||
|     H{ } clone tuck |     H{ } clone tuck | ||||||
|     '[ dup master?>> _ set-at ] each |     '[ dup master?>> _ set-at ] each | ||||||
|     [ mdb>> ] dip >>nodes drop ; |     [ mdb ] dip >>nodes drop ; | ||||||
| 
 | 
 | ||||||
| : send-message ( message -- ) | : send-message ( message -- ) | ||||||
|     [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; |     [ mdb-stream>> ] dip '[ _ write-message ] with-stream* ; | ||||||
|  | @ -133,7 +132,7 @@ PRIVATE> | ||||||
|     check-nodes |     check-nodes | ||||||
|     H{ } clone tuck |     H{ } clone tuck | ||||||
|     '[ dup master?>> _ set-at ] each |     '[ dup master?>> _ set-at ] each | ||||||
|     H{ } clone mdb boa ; |     H{ } clone mdb-db boa ; | ||||||
| 
 | 
 | ||||||
| : create-collection ( name -- ) | : create-collection ( name -- ) | ||||||
|     [ cmd-collection ] dip |     [ cmd-collection ] dip | ||||||
|  | @ -152,7 +151,7 @@ PRIVATE> | ||||||
|     '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline |     '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline | ||||||
| 
 | 
 | ||||||
| : (ensure-collection) ( collection --  ) | : (ensure-collection) ( collection --  ) | ||||||
|     mdb>> collections>> dup keys length 0 =  |     mdb collections>> dup keys length 0 =  | ||||||
|     [ load-collection-list       |     [ load-collection-list       | ||||||
|       [ [ "options" ] dip key? ] filter |       [ [ "options" ] dip key? ] filter | ||||||
|       [ [ "name" ] dip at "." split second <mdb-collection> ] map |       [ [ "name" ] dip at "." split second <mdb-collection> ] map | ||||||
|  | @ -166,11 +165,11 @@ MEMO: reserved-namespace? ( name -- ? ) | ||||||
| PRIVATE> | PRIVATE> | ||||||
| 
 | 
 | ||||||
| MEMO: ensure-collection ( collection -- fq-collection ) | MEMO: ensure-collection ( collection -- fq-collection ) | ||||||
|     "." split1 over mdb>> name>> = |     "." split1 over mdb name>> = | ||||||
|     [ [ drop ] dip ] [ drop ] if |     [ [ drop ] dip ] [ drop ] if | ||||||
|     [ ] [ reserved-namespace? ] bi |     [ ] [ reserved-namespace? ] bi | ||||||
|     [ [ (ensure-collection) ] keep ] unless |     [ [ (ensure-collection) ] keep ] unless | ||||||
|     [ mdb>> name>> ] dip "%s.%s" sprintf ; inline |     [ mdb name>> ] dip "%s.%s" sprintf ; inline | ||||||
| 
 | 
 | ||||||
| : <query> ( collection query -- mdb-query ) | : <query> ( collection query -- mdb-query ) | ||||||
|     [ ensure-collection ] dip |     [ ensure-collection ] dip | ||||||
|  |  | ||||||
|  | @ -1,4 +1,4 @@ | ||||||
| USING: accessors assocs constructors kernel linked-assocs math | USING: accessors assocs hashtables constructors kernel linked-assocs math | ||||||
| sequences strings ; | sequences strings ; | ||||||
| 
 | 
 | ||||||
| IN: mongodb.msg | IN: mongodb.msg | ||||||
|  | @ -86,7 +86,7 @@ M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg ) | ||||||
|     [ >>collection ] dip |     [ >>collection ] dip | ||||||
|     >>objects OP_Insert >>opcode ; |     >>objects OP_Insert >>opcode ; | ||||||
| 
 | 
 | ||||||
| M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg ) | M: hashtable <mdb-insert-msg> ( collection assoc -- mdb-insert-msg ) | ||||||
|     [ mdb-insert-msg new ] 2dip |     [ mdb-insert-msg new ] 2dip | ||||||
|     [ >>collection ] dip |     [ >>collection ] dip | ||||||
|     V{ } clone tuck push |     V{ } clone tuck push | ||||||
|  |  | ||||||
		Loading…
	
		Reference in New Issue