diff --git a/bson/constants/constants.factor b/bson/constants/constants.factor index 0da3cc0bb5..aa852bbff8 100644 --- a/bson/constants/constants.factor +++ b/bson/constants/constants.factor @@ -1,4 +1,4 @@ -USING: accessors kernel math parser sequences strings uuid ; +USING: accessors constructors kernel strings uuid ; IN: bson.constants @@ -11,6 +11,8 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ; TUPLE: objref ns objid ; +CONSTRUCTOR: objref ( ns objid -- objref ) ; + TUPLE: mdbregexp { regexp string } { options string } ; : ( string -- mdbregexp ) @@ -18,7 +20,7 @@ TUPLE: mdbregexp { regexp string } { options string } ; CONSTANT: MDB_OID_FIELD "_id" -CONSTANT: MDB_INTERNAL_FIELD "_mdb_" +CONSTANT: MDB_META_FIELD "_mfd" CONSTANT: T_EOO 0 CONSTANT: T_Double 1 diff --git a/bson/writer/writer.factor b/bson/writer/writer.factor index 4c94840888..3684a644d5 100644 --- a/bson/writer/writer.factor +++ b/bson/writer/writer.factor @@ -149,7 +149,7 @@ M: sequence bson-write ( array -- ) [ [ MDB_OID_FIELD ] dip write-pair ] [ drop ] if ; inline : skip-field? ( name -- boolean ) - { "_id" "_mdb" } member? ; inline + { "_id" "_mfd" } member? ; inline M: assoc bson-write ( assoc -- ) '[ _ [ write-oid ] keep diff --git a/mongodb/driver/driver.factor b/mongodb/driver/driver.factor index a70dfb25c4..1853beb81f 100644 --- a/mongodb/driver/driver.factor +++ b/mongodb/driver/driver.factor @@ -20,7 +20,8 @@ TUPLE: mdb-collection { size integer initial: -1 } { max integer initial: -1 } ; -CONSTRUCTOR: mdb-collection ( name -- collection ) ; +: ( name -- collection ) + [ mdb-collection new ] dip >>name ; inline CONSTANT: MDB-GENERAL-ERROR 1 @@ -73,6 +74,10 @@ SYNTAX: r/ ( token -- mdbregexp ) [ >>mdb-stream ] prepose with-disposal ] with-scope ; inline +: build-id-selector ( assoc -- selector ) + [ MDB_OID_FIELD swap at ] keep + H{ } clone [ set-at ] keep ; + > "size" ] dip set-at ] [ [ max>> "max" ] dip set-at ] 2tri ] when ] 2bi - ] keep 1 >>return# send-query-plain objects>> first check-ok + ] keep 1 >>return# send-query-plain + objects>> first check-ok [ "could not create collection" throw ] unless ; : load-collection-list ( -- collection-list ) @@ -238,7 +244,7 @@ GENERIC: find-one ( mdb-query -- result/f ) M: mdb-query-msg find-one 1 >>return# send-query-plain objects>> [ first ] [ f ] if* ; -GENERIC: count ( collection query -- result ) +GENERIC: count ( collection selector -- result ) M: assoc count [ "count" H{ } clone [ set-at ] keep ] dip [ over [ "query" ] dip set-at ] when* diff --git a/mongodb/tuple/collection/collection.factor b/mongodb/tuple/collection/collection.factor new file mode 100644 index 0000000000..e5dedf1967 --- /dev/null +++ b/mongodb/tuple/collection/collection.factor @@ -0,0 +1,90 @@ + +USING: accessors arrays assocs bson.constants classes classes.tuple +continuations fry kernel mongodb.driver sequences +vectors words ; + +IN: mongodb.tuple.collection + +MIXIN: mdb-persistent + +SLOT: _id +SLOT: _mfd + +TUPLE: mdb-tuple-collection < mdb-collection { classes } ; + +GENERIC: tuple-collection ( object -- mdb-collection ) + +GENERIC: mdb-slot-list ( tuple -- string ) + +assoc ( seq -- assoc ) + [ dup assoc? + [ 1array { "" } append ] unless ] map ; + +: optl>map ( seq -- map ) + H{ } clone tuck + '[ split-optl opt>assoc swap _ set-at ] each ; inline + +PRIVATE> + +: MDB_ADDON_SLOTS ( -- slots ) + { } [ MDB_OID_FIELD MDB_META_FIELD ] with-datastack ; inline + +: link-class ( collection class -- ) + over classes>> + [ 2dup member? [ 2drop ] [ push ] if ] + [ 1vector >>classes ] if* drop ; inline + +: link-collection ( class collection -- ) + [ swap link-class ] + [ MDB_COLLECTION set-word-prop ] 2bi ; inline + +: mdb-check-slots ( superclass slots -- superclass slots ) + over all-slots [ name>> ] map [ MDB_OID_FIELD ] dip member? + [ ] [ MDB_ADDON_SLOTS prepend ] if ; inline + +: set-slot-options ( class options -- ) + '[ MDB_SLOTDEF_LIST _ optl>map set-word-prop ] keep + dup tuple-collection link-collection ; inline + +M: tuple-class tuple-collection ( tuple -- mdb-collection ) + (mdb-collection) ; + +M: mdb-persistent tuple-collection ( tuple -- mdb-collection ) + class (mdb-collection) ; + +M: mdb-persistent mdb-slot-list ( tuple -- string ) + class (mdb-slot-list) ; + +M: tuple-class mdb-slot-list ( class -- assoc ) + (mdb-slot-list) ; + +M: mdb-collection mdb-slot-list ( collection -- assoc ) + classes>> [ mdb-slot-list ] map assoc-combine ; + +: collection-map ( -- assoc ) + MDB_COLLECTION_MAP mdb-persistent word-prop + [ mdb-persistent MDB_COLLECTION_MAP H{ } clone + [ set-word-prop ] keep ] unless* ; inline + +: ( name -- mdb-tuple-collection ) + collection-map [ ] [ key? ] 2bi + [ at ] [ [ mdb-tuple-collection new dup ] 2dip + [ [ >>name ] keep ] dip set-at ] if ; inline + diff --git a/mongodb/tuple/index/index.factor b/mongodb/tuple/index/index.factor new file mode 100644 index 0000000000..466c36f719 --- /dev/null +++ b/mongodb/tuple/index/index.factor @@ -0,0 +1,54 @@ +USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep +mongodb.tuple.collection combinators mongodb.tuple.collection ; + +IN: mongodb.tuple.index + +TUPLE: tuple-index name spec ; + +SYMBOLS: +transient+ +load+ +fieldindex+ +compoundindex+ +deepindex+ ; + + ] 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 -- index-seq ) + [ V{ } clone ] 2dip pick ! v{} slot optl v{} + [ swap ] dip ! v{} optl slot v{ } + '[ _ tuple-index new ! element slot exemplar + 2over swap index-name >>name ! element slot clone + [ build-index ] dip swap >>spec _ push + ] each ; + +: is-index-declaration? ( entry -- ? ) + first + { { +fieldindex+ [ t ] } + { +compoundindex+ [ t ] } + { +deepindex+ [ t ] } + [ drop f ] } case ; + +PRIVATE> + +: tuple-index-list ( mdb-collection/class -- seq ) + mdb-slot-list V{ } clone tuck + '[ [ is-index-declaration? ] filter + build-index-seq _ push + ] assoc-each flatten ; + diff --git a/mongodb/tuple/persistent/persistent.factor b/mongodb/tuple/persistent/persistent.factor new file mode 100644 index 0000000000..9b6b8e646e --- /dev/null +++ b/mongodb/tuple/persistent/persistent.factor @@ -0,0 +1,92 @@ +USING: accessors assocs classes fry kernel linked-assocs math mirrors +namespaces sequences strings vectors words bson.constants +continuations mongodb.driver mongodb.tuple.collection mongodb.tuple.state ; + +IN: mongodb.tuple.persistent + +SYMBOL: mdb-store-list + +GENERIC: tuple>assoc ( tuple -- assoc ) + +GENERIC: tuple>selector ( tuple -- selector ) + +DEFER: assoc>tuple +DEFER: mdb-persistent? + +tuple-class ( tuple-info -- class ) + [ first ] keep second lookup ; inline + +: tuple-instance ( tuple-info -- instance ) + mdbinfo>tuple-class new ; inline + +: [keys>tuple] ( mirror assoc -- quot: ( elt -- ) ) + '[ dup _ at assoc>tuple swap _ set-at ] ; + +: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc ) + [ tuple-info tuple-instance dup + [ keys ] keep ] keep swap ; inline + +: make-tuple ( assoc -- tuple ) + prepare-assoc>tuple [keys>tuple] each + [ set-persistent ] keep ; inline + +: at+ ( value key assoc -- value ) + 2dup key? + [ at nip ] [ [ dup ] 2dip set-at ] if ; inline + +: data-tuple? ( tuple -- ? ) + dup tuple? + [ assoc? not ] [ drop f ] if ; inline + +: add-storable ( assoc ns -- ) + [ H{ } clone ] dip mdb-store-list get at+ + [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline + +: write-tuple-fields ( mirror assoc conv-quot -- ) + swap [ dup ] dip ! m a a q + '[ [ dup mdb-persistent? + [ _ keep + [ tuple-collection ] keep + [ add-storable ] dip + [ tuple-collection ] [ _id>> ] bi ] + [ dup data-tuple? _ [ ] if ] if _ set-at ] [ drop ] if* + ] assoc-each ; + +: prepare-assoc ( tuple -- assoc mirror assoc ) + H{ } clone tuck ; inline + +: ensure-mdb-info ( tuple -- tuple ) + dup _id>> [ >>_id ] unless + [ set-persistent ] keep ; inline + +: with-store-list ( quot: ( -- ) -- store-assoc ) + [ H{ } clone dup mdb-store-list ] dip with-variable ; inline + +: (tuple>assoc) ( tuple -- assoc ) + [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep + over set-tuple-info ; + +PRIVATE> + +GENERIC: tuple>storable ( tuple -- storable ) +M: mdb-persistent tuple>storable ( mdb-persistent -- store-list ) + '[ _ [ tuple>assoc ] keep tuple-collection add-storable ] with-store-list ; inline + +M: mdb-persistent tuple>assoc ( tuple -- assoc ) + ensure-mdb-info (tuple>assoc) ; + +M: tuple tuple>assoc ( tuple -- assoc ) + (tuple>assoc) ; + +M: tuple tuple>selector ( tuple -- assoc ) + prepare-assoc [ tuple>selector ] write-tuple-fields ; + +: assoc>tuple ( assoc -- tuple ) + dup assoc? + [ [ dup tuple-info? + [ make-tuple ] + [ ] if ] [ drop ] recover + ] [ ] if ; inline + diff --git a/mongodb/tuple/state/state.factor b/mongodb/tuple/state/state.factor new file mode 100644 index 0000000000..1d6dde3654 --- /dev/null +++ b/mongodb/tuple/state/state.factor @@ -0,0 +1,44 @@ +USING: classes kernel accessors sequences assocs mongodb.tuple.collection ; + +IN: mongodb.tuple.state + + + +: ( tuple -- tuple-info ) + class V{ } clone tuck + [ [ name>> ] dip push ] + [ [ vocabulary>> ] dip push ] 2bi ; inline + +: tuple-info ( assoc -- tuple-info ) + [ MDB_TUPLE_INFO ] dip at ; inline + +: set-tuple-info ( tuple assoc -- ) + [ MDB_TUPLE_INFO ] dip set-at ; inline + +: tuple-info? ( assoc -- ? ) + [ MDB_TUPLE_INFO ] dip key? ; + +: tuple-meta ( tuple -- assoc ) + dup _mfd>> [ ] [ H{ } clone [ >>_mfd ] keep ] if* nip ; inline + +: dirty? ( tuple -- ? ) + MDB_DIRTY_FLAG tuple-meta at ; + +: set-dirty ( tuple -- ) + t MDB_DIRTY_FLAG tuple-meta set-at ; + +: persistent? ( tuple -- ? ) + MDB_PERSISTENT_FLAG tuple-meta at ; + +: set-persistent ( tuple -- ) + t MDB_PERSISTENT_FLAG tuple-meta set-at ; + +: needs-store? ( tuple -- ? ) + [ persistent? not ] [ dirty? ] bi or ; + diff --git a/mongodb/tuple/tuple.factor b/mongodb/tuple/tuple.factor new file mode 100644 index 0000000000..9b4f462f2e --- /dev/null +++ b/mongodb/tuple/tuple.factor @@ -0,0 +1,83 @@ +USING: accessors assocs classes classes.mixin classes.tuple vectors math +classes.tuple.parser formatting generalizations kernel sequences fry combinators +linked-assocs sequences.deep mongodb.driver continuations memoize bson.constants +prettyprint strings compiler.units slots tools.walker words arrays ; + +IN: mongodb.tuple + +USING: mongodb.tuple.state mongodb.tuple.persistent mongodb.tuple.collection +mongodb.tuple.index mongodb.msg ; + +SYNTAX: MDBTUPLE: + parse-tuple-definition + mdb-check-slots + define-tuple-class ; + +: define-persistent ( class collection options -- ) + [ [ dup ] dip link-collection ] dip ! cl options + [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip + set-slot-options ; + +: ensure-table ( class -- ) + tuple-collection + [ create-collection ] + [ [ tuple-index-list ] keep + '[ _ swap [ name>> ] [ spec>> ] bi ensure-index ] each + ] bi ; + +: ensure-tables ( classes -- ) + [ ensure-table ] each ; + +: drop-table ( class -- ) + tuple-collection + [ [ tuple-index-list ] keep + '[ _ swap name>> drop-index ] each ] + [ name>> drop-collection ] bi ; + +: recreate-table ( class -- ) + [ drop-table ] + [ ensure-table ] bi ; + +> id-selector ; + +: (save-tuples) ( collection assoc -- ) + swap '[ [ _ ] 2dip + [ id-selector ] dip + update ] assoc-each ; inline +PRIVATE> + +: save-tuple ( tuple -- ) + tuple>assoc [ (save-tuples) ] assoc-each ; + +: update-tuple ( tuple -- ) + save-tuple ; + +: insert-tuple ( tuple -- ) + save-tuple ; + +: delete-tuple ( tuple -- ) + dup persistent? + [ [ tuple-collection name>> ] keep + id-selector delete ] [ drop ] if ; + +: tuple>query ( tuple -- query ) + [ tuple-collection name>> ] keep + tuple>selector ; + +: select-tuple ( tuple/query -- tuple/f ) + dup mdb-query-msg? [ ] [ tuple>query ] if + find-one [ assoc>tuple ] [ f ] if* ; + +: select-tuples ( tuple/query -- cursor tuples/f ) + dup mdb-query-msg? [ ] [ tuple>query ] if + find [ assoc>tuple ] map ; + +: count-tuples ( tuple/query -- n ) + dup mdb-query-msg? [ tuple>query ] unless + [ collection>> ] [ query>> ] bi count ;