--- /dev/null
--- /dev/null
++USING: vocabs.loader ;
++
++IN: bson
++
++"bson.reader" require
++"bson.writer" require
--- /dev/null
--- /dev/null
++USING: accessors constructors kernel strings uuid ;
++
++IN: bson.constants
++
++: <objid> ( -- objid )
++ uuid1 ; inline
++
++TUPLE: oid { a initial: 0 } { b initial: 0 } ;
++
++TUPLE: objref ns objid ;
++
++CONSTRUCTOR: objref ( ns objid -- objref ) ;
++
++TUPLE: mdbregexp { regexp string } { options string } ;
++
++: <mdbregexp> ( string -- mdbregexp )
++ [ mdbregexp new ] dip >>regexp ;
++
++
++CONSTANT: MDB_OID_FIELD "_id"
++CONSTANT: MDB_META_FIELD "_mfd"
++
++CONSTANT: T_EOO 0
++CONSTANT: T_Double 1
++CONSTANT: T_Integer 16
++CONSTANT: T_Boolean 8
++CONSTANT: T_String 2
++CONSTANT: T_Object 3
++CONSTANT: T_Array 4
++CONSTANT: T_Binary 5
++CONSTANT: T_Undefined 6
++CONSTANT: T_OID 7
++CONSTANT: T_Date 9
++CONSTANT: T_NULL 10
++CONSTANT: T_Regexp 11
++CONSTANT: T_DBRef 12
++CONSTANT: T_Code 13
++CONSTANT: T_ScopedCode 17
++CONSTANT: T_Symbol 14
++CONSTANT: T_JSTypeMax 16
++CONSTANT: T_MaxKey 127
++
++CONSTANT: T_Binary_Function 1
++CONSTANT: T_Binary_Bytes 2
++CONSTANT: T_Binary_UUID 3
++CONSTANT: T_Binary_MD5 5
++CONSTANT: T_Binary_Custom 128
++
++
--- /dev/null
--- /dev/null
++USING: accessors assocs bson.constants byte-arrays byte-vectors fry io
++io.binary io.encodings.string io.encodings.utf8 kernel math namespaces
++sequences serialize arrays calendar io.encodings ;
++
++IN: bson.reader
++
++<PRIVATE
++
++TUPLE: element { type integer } name ;
++TUPLE: state
++ { size initial: -1 } { read initial: 0 } exemplar
++ result scope element ;
++
++: <state> ( exemplar -- state )
++ [ state new ] dip
++ [ clone >>exemplar ] keep
++ clone [ >>result ] [ V{ } clone [ push ] keep >>scope ] bi
++ V{ } clone [ T_Object "" element boa swap push ] keep >>element ;
++
++PREDICATE: bson-eoo < integer T_EOO = ;
++PREDICATE: bson-not-eoo < integer T_EOO > ;
++
++PREDICATE: bson-double < integer T_Double = ;
++PREDICATE: bson-integer < integer T_Integer = ;
++PREDICATE: bson-string < integer T_String = ;
++PREDICATE: bson-object < integer T_Object = ;
++PREDICATE: bson-array < integer T_Array = ;
++PREDICATE: bson-binary < integer T_Binary = ;
++PREDICATE: bson-regexp < integer T_Regexp = ;
++PREDICATE: bson-binary-bytes < integer T_Binary_Bytes = ;
++PREDICATE: bson-binary-function < integer T_Binary_Function = ;
++PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
++PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
++PREDICATE: bson-oid < integer T_OID = ;
++PREDICATE: bson-boolean < integer T_Boolean = ;
++PREDICATE: bson-date < integer T_Date = ;
++PREDICATE: bson-null < integer T_NULL = ;
++PREDICATE: bson-ref < integer T_DBRef = ;
++
++GENERIC: element-read ( type -- cont? )
++GENERIC: element-data-read ( type -- object )
++GENERIC: element-binary-read ( length type -- object )
++
++: byte-array>number ( seq -- number )
++ byte-array>bignum >integer ; inline
++
++: get-state ( -- state )
++ state get ; inline
++
++: count-bytes ( count -- )
++ [ get-state ] dip '[ _ + ] change-read drop ; inline
++
++: read-int32 ( -- int32 )
++ 4 [ read byte-array>number ] [ count-bytes ] bi ; inline
++
++: read-longlong ( -- longlong )
++ 8 [ read byte-array>number ] [ count-bytes ] bi ; inline
++
++: read-double ( -- double )
++ 8 [ read byte-array>number bits>double ] [ count-bytes ] bi ; inline
++
++: read-byte-raw ( -- byte-raw )
++ 1 [ read ] [ count-bytes ] bi ; inline
++
++: read-byte ( -- byte )
++ read-byte-raw first ; inline
++
++: read-cstring ( -- string )
++ input-stream get utf8 <decoder>
++ "\0" swap stream-read-until drop ; inline
++
++: read-sized-string ( length -- string )
++ drop read-cstring ; inline
++
++: read-element-type ( -- type )
++ read-byte ; inline
++
++: push-element ( type name -- element )
++ element boa
++ [ get-state element>> push ] keep ; inline
++
++: pop-element ( -- element )
++ get-state element>> pop ; inline
++
++: peek-scope ( -- ht )
++ get-state scope>> peek ; inline
++
++: read-elements ( -- )
++ read-element-type
++ element-read
++ [ read-elements ] when ; inline recursive
++
++GENERIC: fix-result ( assoc type -- result )
++
++M: bson-object fix-result ( assoc type -- result )
++ drop ;
++
++M: bson-array fix-result ( assoc type -- result )
++ drop
++ values ;
++
++GENERIC: end-element ( type -- )
++
++M: bson-object end-element ( type -- )
++ drop ;
++
++M: bson-array end-element ( type -- )
++ drop ;
++
++M: object end-element ( type -- )
++ drop
++ pop-element drop ;
++
++M: bson-eoo element-read ( type -- cont? )
++ drop
++ get-state scope>> [ pop ] keep swap ! vec assoc
++ pop-element [ type>> ] keep ! vec assoc element
++ [ fix-result ] dip
++ rot length 0 > ! assoc element
++ [ name>> peek-scope set-at t ]
++ [ drop [ get-state ] dip >>result drop f ] if ;
++
++M: bson-not-eoo element-read ( type -- cont? )
++ [ peek-scope ] dip ! scope type
++ '[ _ read-cstring push-element [ name>> ] [ type>> ] bi
++ [ element-data-read ] keep
++ end-element
++ swap
++ ] dip set-at t ;
++
++: [scope-changer] ( state -- state quot )
++ dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
++
++: (object-data-read) ( type -- object )
++ drop
++ read-int32 drop
++ get-state
++ [scope-changer] change-scope
++ scope>> peek ; inline
++
++M: bson-object element-data-read ( type -- object )
++ (object-data-read) ;
++
++M: bson-array element-data-read ( type -- object )
++ (object-data-read) ;
++
++M: bson-string element-data-read ( type -- object )
++ drop
++ read-int32 read-sized-string ;
++
++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-custom element-binary-read ( size type -- dbref )
++ 2drop
++ read-cstring
++ read-cstring objref boa ;
++
++M: bson-binary-bytes element-binary-read ( size type -- bytes )
++ drop read ;
++
++M: bson-binary-function element-binary-read ( size type -- quot )
++ drop read bytes>object ;
++
++PRIVATE>
++
++: stream>assoc ( exemplar -- assoc bytes-read )
++ <state> dup state
++ [ read-int32 >>size read-elements ] with-variable
++ [ result>> ] [ read>> ] bi ;
--- /dev/null
--- /dev/null
++! Copyright (C) 2008 Sascha Matzke.
++! See http://factorcode.org/license.txt for BSD license.
++USING: accessors assocs bson.constants byte-arrays byte-vectors
++calendar fry io io.binary io.encodings io.encodings.binary
++io.encodings.utf8 io.streams.byte-array kernel math math.parser
++namespaces quotations sequences sequences.private serialize strings
++words combinators.short-circuit literals ;
++
++
++IN: bson.writer
++
++#! Writes the object out to a byte-vector in BSON format
++
++<PRIVATE
++
++SYMBOL: shared-buffer
++
++CONSTANT: INT32-SIZE 4
++CONSTANT: CHAR-SIZE 1
++CONSTANT: INT64-SIZE 8
++
++: (buffer) ( -- buffer )
++ shared-buffer get
++ [ 8192 <byte-vector> [ shared-buffer set ] keep ] unless* ; inline
++
++: >le-stream ( x n -- )
++ ! >le write
++ swap '[ _ swap nth-byte 0 B{ 0 }
++ [ set-nth-unsafe ] keep write ] each
++ ; inline
++
++PRIVATE>
++
++: reset-buffer ( buffer -- )
++ 0 >>length drop ; inline
++
++: ensure-buffer ( -- )
++ (buffer) drop ; inline
++
++: with-buffer ( quot -- byte-vector )
++ [ (buffer) [ reset-buffer ] keep dup ] dip
++ with-output-stream* dup encoder? [ stream>> ] when ; inline
++
++: with-length ( quot: ( -- ) -- bytes-written start-index )
++ [ (buffer) [ length ] keep ] dip call
++ length swap [ - ] keep ; inline
++
++: with-length-prefix ( quot: ( -- ) -- )
++ [ B{ 0 0 0 0 } write ] prepose with-length
++ [ INT32-SIZE >le ] dip (buffer)
++ '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
++ [ INT32-SIZE ] dip each-integer ; inline
++
++: with-length-prefix-excl ( quot: ( -- ) -- )
++ [ B{ 0 0 0 0 } write ] prepose with-length
++ [ INT32-SIZE - INT32-SIZE >le ] dip (buffer)
++ '[ _ over [ nth-unsafe ] dip _ + _ set-nth-unsafe ]
++ [ INT32-SIZE ] dip each-integer ; inline
++
++<PRIVATE
++
++GENERIC: bson-type? ( obj -- type ) foldable flushable
++GENERIC: bson-write ( obj -- )
++
++M: t bson-type? ( boolean -- type ) drop T_Boolean ;
++M: f bson-type? ( boolean -- type ) drop T_Boolean ;
++
++M: real bson-type? ( real -- type ) drop T_Double ;
++M: word bson-type? ( word -- type ) drop T_String ;
++M: tuple bson-type? ( tuple -- type ) drop T_Object ;
++M: sequence bson-type? ( seq -- type ) drop T_Array ;
++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: 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: quotation bson-type? ( quotation -- type ) drop T_Binary ;
++M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
++
++: write-utf8-string ( string -- )
++ output-stream get utf8 <encoder> stream-write ; inline
++
++: write-byte ( byte -- ) CHAR-SIZE >le-stream ; inline
++: write-int32 ( int -- ) INT32-SIZE >le-stream ; inline
++: write-double ( real -- ) double>bits INT64-SIZE >le-stream ; inline
++: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline
++: write-longlong ( object -- ) INT64-SIZE >le-stream ; inline
++
++: write-eoo ( -- ) T_EOO write-byte ; inline
++: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline
++: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
++
++M: f bson-write ( f -- )
++ drop 0 write-byte ;
++
++M: t bson-write ( t -- )
++ drop 1 write-byte ;
++
++M: string bson-write ( obj -- )
++ '[ _ write-cstring ] with-length-prefix-excl ;
++
++M: integer bson-write ( num -- )
++ 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 write-byte
++ write ;
++
++M: quotation bson-write ( quotation -- )
++ object>bytes [ length write-int32 ] keep
++ T_Binary_Function write-byte
++ write ;
++
++M: oid bson-write ( oid -- )
++ [ a>> write-longlong ] [ b>> write-int32 ] bi ;
++
++M: objref bson-write ( objref -- )
++ [ binary ] dip
++ '[ _
++ [ ns>> write-cstring ]
++ [ objid>> write-cstring ] bi ] with-byte-writer
++ [ length write-int32 ] keep
++ T_Binary_Custom write-byte write ;
++
++M: mdbregexp bson-write ( regexp -- )
++ [ regexp>> write-cstring ]
++ [ options>> write-cstring ] bi ;
++
++M: sequence bson-write ( array -- )
++ '[ _ [ [ write-type ] dip number>string
++ write-cstring bson-write ] 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 ] with-length-prefix ;
++
++M: word bson-write name>> bson-write ;
++
++PRIVATE>
++
++: assoc>bv ( assoc -- byte-vector )
++ [ '[ _ bson-write ] with-buffer ] with-scope ; inline
++
++: assoc>stream ( assoc -- )
++ bson-write ; inline
++
++: mdb-special-value? ( value -- ? )
++ { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
++ [ oid? ] [ byte-array? ] } 1|| ;
--- /dev/null
--- /dev/null
++USING: calendar math fry kernel assocs math.ranges bson.reader io.streams.byte-array
++sequences formatting combinators namespaces io tools.time prettyprint io.encodings.binary
++accessors words mongodb.driver strings math.parser tools.walker bson.writer
++tools.continuations ;
++
++IN: mongodb.benchmark
++
++SYMBOL: collection
++
++: get* ( symbol default -- value )
++ [ get ] dip or ; inline
++
++: ensure-number ( v -- n )
++ dup string? [ string>number ] when ; inline
++
++: trial-size ( -- size )
++ "per-trial" 5000 get* ensure-number ; inline flushable
++
++: batch-size ( -- size )
++ "batch-size" 100 get* ensure-number ; inline flushable
++
++TUPLE: result doc collection index batch lasterror ;
++
++: <result> ( -- ) result new result set ; inline
++
++
++CONSTANT: CHECK-KEY f
++
++CONSTANT: DOC-SMALL H{ }
++
++CONSTANT: DOC-MEDIUM H{ { "integer" 5 }
++ { "number" 5.05 }
++ { "boolean" f }
++ { "array"
++ { "test" "benchmark" } } }
++
++CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" }
++ { "total_word_count" 6743 }
++ { "access_time" f }
++ { "meta_tags" H{ { "description" "i am a long description string" }
++ { "author" "Holly Man" }
++ { "dynamically_created_meta_tag" "who know\n what" } } }
++ { "page_structure" H{ { "counted_tags" 3450 }
++ { "no_of_js_attached" 10 }
++ { "no_of_images" 6 } } }
++ { "harvested_words" { "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo"
++ "10gen" "web" "open" "source" "application" "paas"
++ "platform-as-a-service" "technology" "helps"
++ "developers" "focus" "building" "mongodb" "mongo" } } }
++
++: set-doc ( name -- )
++ [ result ] dip '[ _ >>doc ] change ; inline
++
++: small-doc ( -- quot )
++ "small" set-doc [ ] ; inline
++
++: medium-doc ( -- quot )
++ "medium" set-doc [ ] ; inline
++
++: large-doc ( -- quot )
++ "large" set-doc [ ] ; inline
++
++: small-doc-prepare ( -- quot: ( i -- doc ) )
++ small-doc drop
++ '[ "x" DOC-SMALL clone [ set-at ] keep ] ;
++
++: medium-doc-prepare ( -- quot: ( i -- doc ) )
++ medium-doc drop
++ '[ "x" DOC-MEDIUM clone [ set-at ] keep ] ;
++
++: large-doc-prepare ( -- quot: ( i -- doc ) )
++ large-doc drop
++ [ "x" DOC-LARGE clone [ set-at ] keep
++ [ now "access-time" ] dip
++ [ set-at ] keep ] ;
++
++: (insert) ( quot: ( i -- doc ) collection -- )
++ [ trial-size ] 2dip
++ '[ _ call( i -- doc ) [ _ ] dip
++ result get lasterror>> [ save ] [ save-unsafe ] if ] each-integer ;
++
++: (prepare-batch) ( i b quot: ( i -- doc ) -- batch-seq )
++ [ [ * ] keep 1 range boa ] dip
++ '[ _ call( i -- doc ) ] map ;
++
++: (insert-batch) ( quot: ( i -- doc ) collection -- )
++ [ trial-size batch-size [ / ] keep ] 2dip
++ '[ _ _ (prepare-batch) [ _ ] dip
++ result get lasterror>> [ save ] [ save-unsafe ] if
++ ] each-integer ;
++
++: bchar ( boolean -- char )
++ [ "t" ] [ "f" ] if ; inline
++
++: collection-name ( -- collection )
++ collection "benchmark" get*
++ result get doc>>
++ result get index>> bchar
++ "%s-%s-%s" sprintf
++ [ [ result get ] dip >>collection drop ] keep ;
++
++: prepare-collection ( -- collection )
++ collection-name
++ [ "_x_idx" drop-index ] keep
++ [ drop-collection ] keep
++ [ create-collection ] keep ;
++
++: prepare-index ( collection -- )
++ "_x_idx" [ "x" asc ] key-spec <index-spec> unique-index ensure-index ;
++
++: insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
++ prepare-collection
++ result get index>> [ [ prepare-index ] keep ] when
++ result get batch>>
++ [ '[ _ _ (insert-batch) ] ] [ '[ _ _ (insert) ] ] if ;
++
++: serialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
++ '[ trial-size [ _ call( i -- doc ) assoc>bv drop ] each-integer ] ;
++
++: deserialize ( doc-quot: ( i -- doc ) -- quot: ( -- ) )
++ [ 0 ] dip call( i -- doc ) assoc>bv
++ '[ trial-size [ _ binary [ H{ } stream>assoc 2drop ] with-byte-reader ] times ] ;
++
++: check-for-key ( assoc key -- )
++ CHECK-KEY [ swap key? [ "ups... where's the key" throw ] unless ] [ 2drop ] if ;
++
++: (check-find-result) ( result -- )
++ "x" check-for-key ; inline
++
++: (find) ( cursor -- )
++ [ find [ (check-find-result) ] each (find) ] when* ; inline recursive
++
++: find-one ( quot -- quot: ( -- ) )
++ drop
++ [ trial-size
++ collection-name
++ trial-size 2 / "x" H{ } clone [ set-at ] keep
++ '[ _ _ <query> 1 limit (find) ] times ] ;
++
++: find-all ( quot -- quot: ( -- ) )
++ drop
++ collection-name
++ H{ } clone
++ '[ _ _ <query> (find) ] ;
++
++: find-range ( quot -- quot: ( -- ) )
++ drop
++ [ trial-size batch-size /i
++ collection-name
++ trial-size 2 / "$gt" H{ } clone [ set-at ] keep
++ [ trial-size 2 / batch-size + "$lt" ] dip [ set-at ] keep
++ "x" H{ } clone [ set-at ] keep
++ '[ _ _ <query> (find) ] times ] ;
++
++: batch ( -- )
++ result [ t >>batch ] change ; inline
++
++: index ( -- )
++ result [ t >>index ] change ; inline
++
++: errcheck ( -- )
++ result [ t >>lasterror ] change ; inline
++
++: print-result ( time -- )
++ [ result get [ collection>> ] keep
++ [ batch>> bchar ] keep
++ [ index>> bchar ] keep
++ lasterror>> bchar
++ trial-size ] dip
++ 1000000 / /i
++ "%-18s: {batch:%s,index:%s;errchk:%s} %10s docs/s"
++ sprintf print flush ;
++
++: print-separator ( -- )
++ "----------------------------------------------------------------" print flush ; inline
++
++: print-separator-bold ( -- )
++ "================================================================" print flush ; inline
++
++: print-header ( -- )
++ trial-size
++ batch-size
++ "MongoDB Factor Driver Benchmark\n%d ops per Trial, Batch-Size: %d"
++ sprintf print flush
++ print-separator-bold ;
++
++: with-result ( options quot -- )
++ '[ <result> _ call( options -- time ) print-result ] with-scope ;
++
++: [bench-quot] ( feat-seq op-word -- quot: ( doc-word -- ) )
++ '[ _ swap _
++ '[ [ [ _ execute( -- quot ) ] dip
++ [ execute( -- ) ] each _ execute( quot -- quot ) benchmark ] with-result ] each
++ print-separator ] ;
++
++: run-serialization-bench ( doc-word-seq feat-seq -- )
++ "Serialization Tests" print
++ print-separator-bold
++ \ serialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
++
++: run-deserialization-bench ( doc-word-seq feat-seq -- )
++ "Deserialization Tests" print
++ print-separator-bold
++ \ deserialize [bench-quot] '[ _ call( doc-word -- ) ] each ;
++
++: run-insert-bench ( doc-word-seq feat-seq -- )
++ "Insert Tests" print
++ print-separator-bold
++ \ insert [bench-quot] '[ _ call( doc-word -- ) ] each ;
++
++: run-find-one-bench ( doc-word-seq feat-seq -- )
++ "Query Tests - Find-One" print
++ print-separator-bold
++ \ find-one [bench-quot] '[ _ call( doc-word -- ) ] each ;
++
++: run-find-all-bench ( doc-word-seq feat-seq -- )
++ "Query Tests - Find-All" print
++ print-separator-bold
++ \ find-all [bench-quot] '[ _ call( doc-word -- ) ] each ;
++
++: run-find-range-bench ( doc-word-seq feat-seq -- )
++ "Query Tests - Find-Range" print
++ print-separator-bold
++ \ find-range [bench-quot] '[ _ call( doc-word -- ) ] each ;
++
++
++: run-benchmarks ( -- )
++ "db" "db" get* "host" "127.0.0.1" get* "port" 27020 get* ensure-number <mdb>
++ [ print-header
++ ! serialization
++ { small-doc-prepare medium-doc-prepare
++ large-doc-prepare }
++ { { } } run-serialization-bench
++ ! deserialization
++ { small-doc-prepare medium-doc-prepare
++ large-doc-prepare }
++ { { } } run-deserialization-bench
++ ! insert
++ { small-doc-prepare medium-doc-prepare
++ large-doc-prepare }
++ { { } { index } { errcheck } { index errcheck }
++ { batch } { batch errcheck } { batch index errcheck }
++ } run-insert-bench
++ ! find-one
++ { small-doc medium-doc large-doc }
++ { { } { index } } run-find-one-bench
++ ! find-all
++ { small-doc medium-doc large-doc }
++ { { } { index } } run-find-all-bench
++ ! find-range
++ { small-doc medium-doc large-doc }
++ { { } { index } } run-find-range-bench
++ ] with-db ;
++
++MAIN: run-benchmarks
++
--- /dev/null
--- /dev/null
++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
++io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
++arrays hashtables sequences.deep vectors locals ;
++
++IN: mongodb.connection
++
++: md5-checksum ( string -- digest )
++ utf8 encode md5 checksum-bytes hex-string ; inline
++
++TUPLE: mdb-db name username pwd-digest nodes collections ;
++
++TUPLE: mdb-node master? { address inet } remote ;
++
++CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
++
++TUPLE: mdb-connection instance node handle remote local ;
++
++CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
++
++: check-ok ( result -- errmsg ? )
++ [ [ "errmsg" ] dip at ]
++ [ [ "ok" ] dip at >integer 1 = ] bi ; inline
++
++: <mdb-db> ( name nodes -- mdb-db )
++ mdb-db new swap >>nodes swap >>name H{ } clone >>collections ;
++
++: master-node ( mdb -- node )
++ nodes>> t swap at ;
++
++: slave-node ( mdb -- node )
++ nodes>> f swap at ;
++
++: with-connection ( connection quot -- * )
++ [ mdb-connection set ] prepose with-scope ; inline
++
++: mdb-instance ( -- mdb )
++ mdb-connection get instance>> ; inline
++
++: index-collection ( -- ns )
++ mdb-instance name>> "%s.system.indexes" sprintf ; inline
++
++: namespaces-collection ( -- ns )
++ mdb-instance name>> "%s.system.namespaces" sprintf ; inline
++
++: cmd-collection ( -- ns )
++ mdb-instance name>> "%s.$cmd" sprintf ; inline
++
++: index-ns ( colname -- index-ns )
++ [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline
++
++: send-message ( message -- )
++ [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ;
++
++: send-query-plain ( query-message -- result )
++ [ mdb-connection get handle>> ] dip
++ '[ _ write-message read-message ] with-stream* ;
++
++: send-query-1result ( collection assoc -- result )
++ <mdb-query-msg>
++ 1 >>return#
++ send-query-plain objects>>
++ [ f ] [ first ] if-empty ;
++
++<PRIVATE
++
++: get-nonce ( -- nonce )
++ cmd-collection H{ { "getnonce" 1 } } send-query-1result
++ [ "nonce" swap at ] [ f ] if* ;
++
++: auth? ( mdb -- ? )
++ [ username>> ] [ pwd-digest>> ] bi and ;
++
++: calculate-key-digest ( nonce -- digest )
++ mdb-instance
++ [ username>> ]
++ [ pwd-digest>> ] bi
++ 3array concat md5-checksum ; inline
++
++: build-auth-query ( -- query-assoc )
++ { "authenticate" 1 }
++ "user" mdb-instance username>> 2array
++ "nonce" get-nonce 2array
++ 3array >hashtable
++ [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
++ [ set-at ] keep ;
++
++: perform-authentication ( -- )
++ cmd-collection build-auth-query send-query-1result
++ check-ok [ drop ] [ throw ] if ; inline
++
++: authenticate-connection ( mdb-connection -- )
++ [ mdb-connection get instance>> auth?
++ [ perform-authentication ] when
++ ] with-connection ; inline
++
++: open-connection ( mdb-connection node -- mdb-connection )
++ [ >>node ] [ address>> ] bi
++ [ >>remote ] keep binary <client>
++ [ >>handle ] dip >>local ;
++
++: get-ismaster ( -- result )
++ "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ;
++
++: split-host-str ( hoststr -- host port )
++ ":" split [ first ] [ second string>number ] bi ; inline
++
++: eval-ismaster-result ( node result -- )
++ [ [ "ismaster" ] dip at >integer 1 = >>master? drop ]
++ [ [ "remote" ] dip at
++ [ split-host-str <inet> f <mdb-node> >>remote ] when*
++ drop ] 2bi ;
++
++: check-node ( mdb node -- )
++ [ <mdb-connection> &dispose ] dip
++ [ open-connection ] keep swap
++ [ get-ismaster eval-ismaster-result ] with-connection ;
++
++: nodelist>table ( seq -- assoc )
++ [ [ master?>> ] keep 2array ] map >hashtable ;
++
++PRIVATE>
++
++:: verify-nodes ( mdb -- )
++ [ [let* | acc [ V{ } clone ]
++ node1 [ mdb dup master-node [ check-node ] keep ]
++ node2 [ mdb node1 remote>>
++ [ [ check-node ] keep ]
++ [ drop f ] if* ]
++ | node1 [ acc push ] when*
++ node2 [ acc push ] when*
++ mdb acc nodelist>table >>nodes drop
++ ]
++ ] with-destructors ;
++
++: mdb-open ( mdb -- mdb-connection )
++ clone [ <mdb-connection> ] keep
++ master-node open-connection
++ [ authenticate-connection ] keep ;
++
++: mdb-close ( mdb-connection -- )
++ [ dispose f ] change-handle drop ;
++
++M: mdb-connection dispose
++ mdb-close ;
--- /dev/null
--- /dev/null
++Sascha Matzke
--- /dev/null
--- /dev/null
++! Copyright (C) 2009 Your name.
++! See http://factorcode.org/license.txt for BSD license.
++USING: assocs help.markup help.syntax kernel quotations ;
++IN: mongodb.driver
++
++HELP: <mdb-collection>
++{ $values
++ { "name" "name of the collection" }
++ { "collection" "mdb-collection instance" }
++}
++{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections. See also: " { $link mdb-collection } }
++{ $examples
++ { $example "! creates a mdb-collection instance capped to a maximum of 1000000 entries"
++ "\"mycollection\" <mdb-collection> t >>capped 1000000 >>max" } } ;
++
++HELP: <mdb>
++{ $values
++ { "db" "name of the database to use" }
++ { "host" "host name or IP address" }
++ { "port" "port number" }
++ { "mdb" "mdb-db instance" }
++}
++{ $description "Create a new mdb-db instance and automatically resolves master/slave information in a paired MongoDB setup." }
++{ $examples
++ { $example "\"db\" \"127.0.0.1\" 27017 <mdb>" } } ;
++
++HELP: <query>
++{ $values
++ { "collection" "collection to query" }
++ { "assoc" "query assoc" }
++ { "mdb-query-msg" "mdb-query-msg instance" }
++}
++{ $description "Creates a new mdb-query-msg instance. "
++ "This word must be called from within a with-db scope."
++ "For more see: "
++ { $link with-db } }
++{ $examples
++ { $example "\"mycollection\" H{ } <query>" } } ;
++
++HELP: <update>
++{ $values
++ { "collection" "collection to update" }
++ { "selector" "selector assoc (selects which object(s) to update" }
++ { "object" "updated object or update instruction" }
++ { "mdb-update-msg" "mdb-update-msg instance" }
++}
++{ $description "Creates an update message for the object(s) identified by the given selector."
++ "MongoDB supports full object updates as well as partial update modifiers such as $set, $inc or $push"
++ "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Updates" } } ;
++
++HELP: >upsert
++{ $values
++ { "mdb-update-msg" "a mdb-update-msg" }
++ { "mdb-update-msg" "mdb-update-msg with the upsert indicator set to t" }
++}
++{ $description "Marks a mdb-update-msg as upsert operation"
++ "(inserts object identified by the update selector if it doesn't exist in the collection)" } ;
++
++HELP: PARTIAL?
++{ $values
++ { "value" "partial?" }
++}
++{ $description "key which refers to a partially loaded object" } ;
++
++HELP: asc
++{ $values
++ { "key" "sort key" }
++ { "spec" "sort spec" }
++}
++{ $description "indicates that the values of the specified key should be sorted in ascending order" } ;
++
++HELP: count
++{ $values
++ { "mdb-query-msg" "query" }
++ { "result" "number of objects in the collection that match the query" }
++}
++{ $description "count objects in a collection" } ;
++
++HELP: create-collection
++{ $values
++ { "name" "collection name" }
++}
++{ $description "Creates a new collection with the given name." } ;
++
++HELP: delete
++{ $values
++ { "collection" "a collection" }
++ { "selector" "assoc which identifies the objects to be removed from the collection" }
++}
++{ $description "removes objects from the collection (with lasterror check)" } ;
++
++HELP: delete-unsafe
++{ $values
++ { "collection" "a collection" }
++ { "selector" "assoc which identifies the objects to be removed from the collection" }
++}
++{ $description "removes objects from the collection (without error check)" } ;
++
++HELP: desc
++{ $values
++ { "key" "sort key" }
++ { "spec" "sort spec" }
++}
++{ $description "indicates that the values of the specified key should be sorted in descending order" } ;
++
++HELP: drop-collection
++{ $values
++ { "name" "a collection" }
++}
++{ $description "removes the collection and all objects in it from the database" } ;
++
++HELP: drop-index
++{ $values
++ { "collection" "a collection" }
++ { "name" "an index name" }
++}
++{ $description "drops the specified index from the collection" } ;
++
++HELP: ensure-collection
++{ $values
++ { "collection" "a collection; e.g. mycollection " }
++ { "fq-collection" "full qualified collection name; e.g. db.mycollection" }
++}
++{ $description "ensures that the collection exists in the database and returns its full qualified name" } ;
++
++HELP: ensure-index
++{ $values
++ { "collection" "a collection" }
++ { "name" "index name" }
++ { "spec" "index spec" }
++}
++{ $description "Ensures the existence of the given index. "
++ "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } }
++{ $examples
++ { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> ensure-index" }
++ { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec <index-spec> unique-index ensure-index" } } ;
++
++HELP: explain.
++{ $values
++ { "mdb-query-msg" "a query message" }
++}
++{ $description "Prints the execution plan for the given query" } ;
++
++HELP: find
++{ $values
++ { "mdb-query" "a query" }
++ { "cursor" "a cursor (if there are more results) or f" }
++ { "result" "a sequences of objects" }
++}
++{ $description "executes the given query" }
++{ $examples
++ { $example "\"mycollection\" H{ { \"name\" \"Alfred\" } } <query> find " } } ;
++
++HELP: find-one
++{ $values
++ { "mdb-query" "a query" }
++ { "result" "a single object or f" }
++}
++{ $description "Executes the query and returns one object at most" } ;
++
++HELP: hint
++{ $values
++ { "mdb-query" "a query" }
++ { "index-hint" "a hint to an index" }
++ { "mdb-query" "modified query object" }
++}
++{ $description "Annotates the query with a hint to an index. "
++ "For detailed information see: " { $url "http://www.mongodb.org/display/DOCS/Optimizing+Mongo+Performance#OptimizingMongoPerformance-Hint" } }
++{ $examples
++ { $example "\"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } <query> H{ { \"name\" 1 } } hint find" } } ;
++
++HELP: lasterror
++{ $values
++
++ { "error" "error message or f" }
++}
++{ $description "Checks if the last operation resulted in an error on the MongoDB side"
++ "For more information see: " { $url "http://www.mongodb.org/display/DOCS/Mongo+Commands#MongoCommands-LastErrorCommands" } } ;
++
++HELP: limit
++{ $values
++ { "mdb-query" "a query" }
++ { "limit#" "number of objects that should be returned at most" }
++ { "mdb-query" "modified query object" }
++}
++{ $description "Limits the number of returned objects to limit#" }
++{ $examples
++ { $example "\"mycollection\" H{ } <query> 10 limit find" } } ;
++
++HELP: load-collection-list
++{ $values
++
++ { "collection-list" "list of collections in the current database" }
++}
++{ $description "Returns a list of all collections that exist in the current database" } ;
++
++HELP: load-index-list
++{ $values
++
++ { "index-list" "list of indexes" }
++}
++{ $description "Returns a list of all indexes that exist in the current database" } ;
++
++HELP: mdb-collection
++{ $var-description "" } ;
++
++HELP: mdb-cursor
++{ $var-description "" } ;
++
++HELP: mdb-error
++{ $values
++ { "msg" "error message" }
++}
++{ $description "" } ;
++
++HELP: r/
++{ $values
++ { "token" null }
++ { "mdbregexp" null }
++}
++{ $description "" } ;
++
++HELP: save
++{ $values
++ { "collection" "a collection" }
++ { "assoc" "object" }
++}
++{ $description "Saves the object to the given collection."
++ " If the object contains a field name \"_id\" this command automatically performs an update (with upsert) instead of a plain save" } ;
++
++HELP: save-unsafe
++{ $values
++ { "collection" null }
++ { "object" object }
++}
++{ $description "" } ;
++
++HELP: skip
++{ $values
++ { "mdb-query" null }
++ { "skip#" null }
++ { "mdb-query" null }
++}
++{ $description "" } ;
++
++HELP: sort
++{ $values
++ { "mdb-query" null }
++ { "quot" quotation }
++ { "mdb-query" null }
++}
++{ $description "" } ;
++
++HELP: update
++{ $values
++ { "mdb-update-msg" null }
++}
++{ $description "" } ;
++
++HELP: update-unsafe
++{ $values
++ { "mdb-update-msg" null }
++}
++{ $description "" } ;
++
++HELP: validate.
++{ $values
++ { "collection" null }
++}
++{ $description "" } ;
++
++HELP: with-db
++{ $values
++ { "mdb" null }
++ { "quot" quotation }
++}
++{ $description "" } ;
++
++ARTICLE: "mongodb.driver" "mongodb.driver"
++{ $vocab-link "mongodb.driver" }
++;
++
++ABOUT: "mongodb.driver"
++
--- /dev/null
--- /dev/null
++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 ;
++
++IN: mongodb.driver
++
++TUPLE: mdb-pool < pool mdb ;
++
++TUPLE: mdb-cursor id query ;
++
++TUPLE: mdb-collection
++{ name string }
++{ capped boolean initial: f }
++{ size integer initial: -1 }
++{ max integer initial: -1 } ;
++
++CONSTRUCTOR: mdb-collection ( name -- collection ) ;
++
++TUPLE: index-spec
++{ ns string } { name string } { key hashtable } { unique? boolean initial: f } ;
++
++CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ;
++
++: unique-index ( index-spec -- index-spec )
++ t >>unique? ;
++
++M: mdb-pool make-connection
++ mdb>> mdb-open ;
++
++: <mdb-pool> ( mdb -- pool ) [ mdb-pool <pool> ] dip >>mdb ; inline
++
++CONSTANT: PARTIAL? "partial?"
++
++ERROR: mdb-error msg ;
++
++: >pwd-digest ( user password -- digest )
++ "mongo" swap 3array ":" join md5-checksum ;
++
++<PRIVATE
++
++GENERIC: <mdb-cursor> ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor )
++
++M: mdb-query-msg <mdb-cursor>
++ mdb-cursor boa ;
++
++M: mdb-getmore-msg <mdb-cursor>
++ query>> mdb-cursor boa ;
++
++: >mdbregexp ( value -- regexp )
++ first <mdbregexp> ; inline
++
++GENERIC: update-query ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- )
++
++M: mdb-query-msg update-query
++ swap [ start#>> ] [ returned#>> ] bi + >>skip# drop ;
++
++M: mdb-getmore-msg update-query
++ query>> update-query ;
++
++: make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
++ over cursor>> 0 >
++ [ [ update-query ]
++ [ [ cursor>> ] dip <mdb-cursor> ] 2bi
++ ] [ 2drop f ] if ;
++
++DEFER: send-query
++
++GENERIC: verify-query-result ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-result-msg mdb-query-msg/mdb-getmore-msg )
++
++M: mdb-query-msg verify-query-result ;
++
++M: mdb-getmore-msg verify-query-result
++ over flags>> ResultFlag_CursorNotFound =
++ [ nip query>> [ send-query-plain ] keep ] when ;
++
++: send-query ( mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f seq )
++ [ send-query-plain ] keep
++ verify-query-result
++ [ collection>> >>collection drop ]
++ [ return#>> >>requested# ]
++ [ make-cursor ] 2tri
++ swap objects>> ;
++
++PRIVATE>
++
++SYNTAX: r/ ( token -- mdbregexp )
++ \ / [ >mdbregexp ] parse-literal ;
++
++: with-db ( mdb quot -- * )
++ '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
++
++: >id-selector ( assoc -- selector )
++ [ MDB_OID_FIELD swap at ] keep
++ H{ } clone [ set-at ] keep ;
++
++: <mdb> ( db host port -- mdb )
++ <inet> t [ <mdb-node> ] keep
++ H{ } clone [ set-at ] keep <mdb-db>
++ [ verify-nodes ] keep ;
++
++GENERIC: create-collection ( name -- )
++
++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 ;
++
++: load-collection-list ( -- collection-list )
++ namespaces-collection
++ H{ } clone <mdb-query-msg> send-query-plain objects>> ;
++
++<PRIVATE
++
++: 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 ;
++
++: 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 ;
++
++: fix-query-collection ( mdb-query -- mdb-query )
++ [ check-collection ] change-collection ; inline
++
++GENERIC: get-more ( mdb-cursor -- mdb-cursor seq )
++
++M: mdb-cursor get-more
++ [ [ query>> dup [ collection>> ] [ return#>> ] bi ]
++ [ id>> ] bi <mdb-getmore-msg> swap >>query send-query ]
++ [ f f ] if* ;
++
++PRIVATE>
++
++: <query> ( collection assoc -- mdb-query-msg )
++ <mdb-query-msg> ; inline
++
++GENERIC# limit 1 ( mdb-query-msg limit# -- mdb-query )
++
++M: mdb-query-msg limit
++ >>return# ; inline
++
++GENERIC# skip 1 ( mdb-query-msg skip# -- mdb-query-msg )
++
++M: mdb-query-msg skip
++ >>skip# ; inline
++
++: asc ( key -- spec ) 1 2array ; inline
++: desc ( key -- spec ) -1 2array ; inline
++
++GENERIC# sort 1 ( mdb-query-msg sort-quot -- mdb-query-msg )
++
++M: mdb-query-msg sort
++ output>array >>orderby ; inline
++
++: key-spec ( spec-quot -- spec-assoc )
++ output>array >hashtable ; inline
++
++GENERIC# hint 1 ( mdb-query-msg index-hint -- mdb-query-msg )
++
++M: mdb-query-msg hint
++ >>hint ;
++
++GENERIC: find ( mdb-query-msg/mdb-cursor -- mdb-cursor seq )
++
++M: mdb-query-msg find
++ fix-query-collection send-query ;
++
++M: mdb-cursor find
++ get-more ;
++
++GENERIC: explain. ( mdb-query-msg -- )
++
++M: mdb-query-msg explain.
++ t >>explain find nip . ;
++
++GENERIC: find-one ( mdb-query-msg -- result/f )
++
++M: mdb-query-msg find-one
++ fix-query-collection
++ 1 >>return# send-query-plain objects>>
++ dup empty? [ drop f ] [ first ] if ;
++
++GENERIC: count ( mdb-query-msg -- result )
++
++M: mdb-query-msg count
++ [ collection>> "count" H{ } clone [ set-at ] keep ] keep
++ query>> [ over [ "query" ] dip set-at ] when*
++ [ cmd-collection ] dip <mdb-query-msg> find-one
++ [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
++
++: lasterror ( -- error )
++ cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
++ find-one [ "err" ] dip at ;
++
++GENERIC: validate. ( collection -- )
++
++M: string validate.
++ [ cmd-collection ] dip
++ "validate" H{ } clone [ set-at ] keep
++ <mdb-query-msg> find-one [ check-ok nip ] keep
++ '[ "result" _ at print ] [ ] if ;
++
++M: mdb-collection validate.
++ name>> validate. ;
++
++<PRIVATE
++
++: send-message-check-error ( message -- )
++ send-message lasterror [ mdb-error ] when* ;
++
++PRIVATE>
++
++GENERIC: save ( collection assoc -- )
++M: assoc save
++ [ check-collection ] dip
++ <mdb-insert-msg> send-message-check-error ;
++
++GENERIC: save-unsafe ( collection object -- )
++M: assoc save-unsafe
++ [ check-collection ] dip
++ <mdb-insert-msg> send-message ;
++
++GENERIC: ensure-index ( index-spec -- )
++M: index-spec ensure-index
++ <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
++ [ { [ [ name>> "name" ] dip set-at ]
++ [ [ ns>> index-ns "ns" ] dip set-at ]
++ [ [ key>> "key" ] dip set-at ]
++ [ swap unique?>>
++ [ swap [ "unique" ] dip set-at ] [ drop ] if* ] } 2cleave
++ ] keep
++ [ index-collection ] dip save ;
++
++: drop-index ( collection name -- )
++ H{ } clone
++ [ [ "index" ] dip set-at ] keep
++ [ [ "deleteIndexes" ] dip set-at ] keep
++ [ cmd-collection ] dip <mdb-query-msg>
++ find-one drop ;
++
++: <update> ( collection selector object -- update-msg )
++ [ check-collection ] 2dip <mdb-update-msg> ;
++
++: >upsert ( mdb-update-msg -- mdb-update-msg )
++ 1 >>upsert? ;
++
++GENERIC: update ( mdb-update-msg -- )
++M: mdb-update-msg update
++ send-message-check-error ;
++
++GENERIC: update-unsafe ( mdb-update-msg -- )
++M: mdb-update-msg update-unsafe
++ send-message ;
++
++GENERIC: delete ( collection selector -- )
++M: assoc delete
++ [ check-collection ] dip
++ <mdb-delete-msg> send-message-check-error ;
++
++GENERIC: delete-unsafe ( collection selector -- )
++M: assoc delete-unsafe
++ [ check-collection ] dip
++ <mdb-delete-msg> send-message ;
++
++: load-index-list ( -- index-list )
++ index-collection
++ H{ } clone <mdb-query-msg> find nip ;
++
++: ensure-collection ( name -- )
++ check-collection drop ;
++
++: drop-collection ( name -- )
++ [ cmd-collection ] dip
++ "drop" H{ } clone [ set-at ] keep
++ <mdb-query-msg> find-one drop ;
++
++
--- /dev/null
--- /dev/null
++A driver for the MongoDB document-oriented database (http://www.mongodb.org)
--- /dev/null
--- /dev/null
++database
--- /dev/null
--- /dev/null
++USING: accessors fry io io.encodings.binary io.servers.connection
++io.sockets io.streams.byte-array kernel math mongodb.msg classes formatting
++namespaces prettyprint tools.walker calendar calendar.format
++json.writer mongodb.operations.private mongodb.operations ;
++
++IN: mongodb.mmm
++
++SYMBOLS: mmm-port mmm-server-ip mmm-server-port mmm-server mmm-dump-output mmm-t-srv ;
++
++GENERIC: dump-message ( message -- )
++
++: check-options ( -- )
++ mmm-port get [ 27040 mmm-port set ] unless
++ mmm-server-ip get [ "127.0.0.1" mmm-server-ip set ] unless
++ mmm-server-port get [ 27017 mmm-server-port set ] unless
++ mmm-server-ip get mmm-server-port get <inet> mmm-server set ;
++
++: read-msg-binary ( -- )
++ read-int32
++ [ write-int32 ] keep
++ 4 - read write ;
++
++: read-request-header ( -- msg-stub )
++ mdb-msg new
++ read-int32 MSG-HEADER-SIZE - >>length
++ read-int32 >>req-id
++ read-int32 >>resp-id
++ read-int32 >>opcode ;
++
++: read-request ( -- msg-stub binary )
++ binary [ read-msg-binary ] with-byte-writer
++ [ binary [ read-request-header ] with-byte-reader ] keep ; ! msg-stub binary
++
++: dump-request ( msg-stub binary -- )
++ [ mmm-dump-output get ] 2dip
++ '[ _ drop _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
++
++: read-reply ( -- binary )
++ binary [ read-msg-binary ] with-byte-writer ;
++
++: forward-request-read-reply ( msg-stub binary -- binary )
++ [ mmm-server get binary ] 2dip
++ '[ _ opcode>> _ write flush
++ OP_Query =
++ [ read-reply ]
++ [ f ] if ] with-client ;
++
++: dump-reply ( binary -- )
++ [ mmm-dump-output get ] dip
++ '[ _ binary [ read-message dump-message ] with-byte-reader ] with-output-stream ;
++
++: message-prefix ( message -- prefix message )
++ [ now timestamp>http-string ] dip
++ [ class name>> ] keep
++ [ "%s: %s" sprintf ] dip ; inline
++
++M: mdb-query-msg dump-message ( message -- )
++ message-prefix
++ [ collection>> ] keep
++ query>> >json
++ "%s -> %s: %s \n" printf ;
++
++M: mdb-insert-msg dump-message ( message -- )
++ message-prefix
++ [ collection>> ] keep
++ objects>> >json
++ "%s -> %s : %s \n" printf ;
++
++M: mdb-reply-msg dump-message ( message -- )
++ message-prefix
++ [ cursor>> ] keep
++ [ start#>> ] keep
++ [ returned#>> ] keep
++ objects>> >json
++ "%s -> cursor: %d, start: %d, returned#: %d, -> %s \n" printf ;
++
++M: mdb-msg dump-message ( message -- )
++ message-prefix drop "%s \n" printf ;
++
++: forward-reply ( binary -- )
++ write flush ;
++
++: handle-mmm-connection ( -- )
++ read-request
++ [ dump-request ] 2keep
++ forward-request-read-reply
++ [ dump-reply ] keep
++ forward-reply ;
++
++: start-mmm-server ( -- )
++ output-stream get mmm-dump-output set
++ <threaded-server> [ mmm-t-srv set ] keep
++ "127.0.0.1" mmm-port get <inet4> >>insecure
++ binary >>encoding
++ [ handle-mmm-connection ] >>handler
++ start-server* ;
++
++: run-mmm ( -- )
++ check-options
++ start-mmm-server ;
++
++MAIN: run-mmm
--- /dev/null
--- /dev/null
++USING: accessors assocs hashtables constructors kernel linked-assocs math
++sequences strings ;
++
++IN: mongodb.msg
++
++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
++
++CONSTANT: ResultFlag_CursorNotFound 1 ! /* returned, with zero results, when getMore is called but the cursor id is not valid at the server. */
++CONSTANT: ResultFlag_ErrSet 2 ! /* { $err : ... } is being returned */
++CONSTANT: ResultFlag_ShardConfigStale 4 ! /* have to update config from the server, usually $err is also set */
++
++TUPLE: mdb-msg
++{ opcode integer }
++{ req-id integer initial: 0 }
++{ resp-id integer initial: 0 }
++{ length integer initial: 0 }
++{ flags integer initial: 0 } ;
++
++TUPLE: mdb-query-msg < mdb-msg
++{ collection string }
++{ skip# integer initial: 0 }
++{ return# integer initial: 0 }
++{ query assoc }
++{ returnfields assoc }
++{ orderby sequence }
++explain hint ;
++
++TUPLE: mdb-insert-msg < mdb-msg
++{ collection string }
++{ objects sequence } ;
++
++TUPLE: mdb-update-msg < mdb-msg
++{ collection string }
++{ upsert? integer initial: 0 }
++{ selector assoc }
++{ object assoc } ;
++
++TUPLE: mdb-delete-msg < mdb-msg
++{ collection string }
++{ selector assoc } ;
++
++TUPLE: mdb-getmore-msg < mdb-msg
++{ collection string }
++{ return# integer initial: 0 }
++{ cursor integer initial: 0 }
++{ query mdb-query-msg } ;
++
++TUPLE: mdb-killcursors-msg < mdb-msg
++{ cursors# integer initial: 0 }
++{ cursors sequence } ;
++
++TUPLE: mdb-reply-msg < mdb-msg
++{ collection string }
++{ cursor integer initial: 0 }
++{ start# integer initial: 0 }
++{ requested# integer initial: 0 }
++{ returned# integer initial: 0 }
++{ objects sequence } ;
++
++
++CONSTRUCTOR: mdb-getmore-msg ( collection return# cursor -- mdb-getmore-msg )
++ OP_GetMore >>opcode ; inline
++
++CONSTRUCTOR: mdb-delete-msg ( collection selector -- mdb-delete-msg )
++ OP_Delete >>opcode ; inline
++
++CONSTRUCTOR: mdb-query-msg ( collection query -- mdb-query-msg )
++ OP_Query >>opcode ; inline
++
++GENERIC: <mdb-killcursors-msg> ( object -- mdb-killcursors-msg )
++
++M: sequence <mdb-killcursors-msg> ( sequences -- mdb-killcursors-msg )
++ [ mdb-killcursors-msg new ] dip
++ [ length >>cursors# ] keep
++ >>cursors OP_KillCursors >>opcode ; inline
++
++M: integer <mdb-killcursors-msg> ( integer -- mdb-killcursors-msg )
++ V{ } clone [ push ] keep <mdb-killcursors-msg> ;
++
++GENERIC: <mdb-insert-msg> ( collection objects -- mdb-insert-msg )
++
++M: sequence <mdb-insert-msg> ( collection sequence -- mdb-insert-msg )
++ [ mdb-insert-msg new ] 2dip
++ [ >>collection ] dip
++ >>objects OP_Insert >>opcode ;
++
++M: assoc <mdb-insert-msg> ( collection assoc -- mdb-insert-msg )
++ [ mdb-insert-msg new ] 2dip
++ [ >>collection ] dip
++ V{ } clone tuck push
++ >>objects OP_Insert >>opcode ;
++
++
++CONSTRUCTOR: mdb-update-msg ( collection selector object -- mdb-update-msg )
++ OP_Update >>opcode ; inline
++
++CONSTRUCTOR: mdb-reply-msg ( -- mdb-reply-msg ) ; inline
++
--- /dev/null
--- /dev/null
++USING: accessors assocs bson.reader bson.writer byte-arrays
++byte-vectors combinators formatting fry io io.binary io.encodings.private
++io.encodings.binary io.encodings.string io.encodings.utf8 io.encodings.utf8.private io.files
++kernel locals math mongodb.msg namespaces sequences uuid bson.writer.private ;
++
++IN: alien.c-types
++
++M: byte-vector byte-length length ;
++
++IN: mongodb.operations
++
++<PRIVATE
++
++PREDICATE: mdb-reply-op < integer OP_Reply = ;
++PREDICATE: mdb-query-op < integer OP_Query = ;
++PREDICATE: mdb-insert-op < integer OP_Insert = ;
++PREDICATE: mdb-update-op < integer OP_Update = ;
++PREDICATE: mdb-delete-op < integer OP_Delete = ;
++PREDICATE: mdb-getmore-op < integer OP_GetMore = ;
++PREDICATE: mdb-killcursors-op < integer OP_KillCursors = ;
++
++PRIVATE>
++
++GENERIC: write-message ( message -- )
++
++<PRIVATE
++
++CONSTANT: MSG-HEADER-SIZE 16
++
++SYMBOL: msg-bytes-read
++
++: bytes-read> ( -- integer )
++ msg-bytes-read get ; inline
++
++: >bytes-read ( integer -- )
++ msg-bytes-read set ; inline
++
++: change-bytes-read ( integer -- )
++ bytes-read> [ 0 ] unless* + >bytes-read ; inline
++
++: read-int32 ( -- int32 ) 4 [ read le> ] [ change-bytes-read ] bi ; inline
++: read-longlong ( -- longlong ) 8 [ 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-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 )
++ [ length>> ] keep [ >>length ] dip
++ [ req-id>> ] keep [ >>req-id ] dip
++ [ resp-id>> ] keep [ >>resp-id ] dip
++ [ opcode>> ] keep [ >>opcode ] dip
++ flags>> >>flags ;
++
++M: mdb-query-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ mdb-query-msg new ] dip copy-header
++ read-cstring >>collection
++ read-int32 >>skip#
++ read-int32 >>return#
++ H{ } stream>assoc change-bytes-read >>query
++ dup length>> bytes-read> >
++ [ H{ } stream>assoc change-bytes-read >>returnfields ] when ;
++
++M: mdb-insert-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ mdb-insert-msg new ] dip copy-header
++ read-cstring >>collection
++ V{ } clone >>objects
++ [ '[ _ length>> bytes-read> > ] ] keep tuck
++ '[ H{ } stream>assoc change-bytes-read _ objects>> push ]
++ while ;
++
++M: mdb-delete-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ mdb-delete-msg new ] dip copy-header
++ read-cstring >>collection
++ H{ } stream>assoc change-bytes-read >>selector ;
++
++M: mdb-getmore-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ mdb-getmore-msg new ] dip copy-header
++ read-cstring >>collection
++ read-int32 >>return#
++ read-longlong >>cursor ;
++
++M: mdb-killcursors-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ mdb-killcursors-msg new ] dip copy-header
++ read-int32 >>cursors#
++ V{ } clone >>cursors
++ [ [ cursors#>> ] keep
++ '[ read-longlong _ cursors>> push ] times ] keep ;
++
++M: mdb-update-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ mdb-update-msg new ] dip copy-header
++ read-cstring >>collection
++ read-int32 >>upsert?
++ H{ } stream>assoc change-bytes-read >>selector
++ H{ } stream>assoc change-bytes-read >>object ;
++
++M: mdb-reply-op (read-message) ( msg-stub opcode -- message )
++ drop
++ [ <mdb-reply-msg> ] dip copy-header
++ read-longlong >>cursor
++ read-int32 >>start#
++ read-int32 [ >>returned# ] keep
++ [ H{ } stream>assoc drop ] accumulator [ times ] dip >>objects ;
++
++: read-header ( message -- message )
++ read-int32 >>length
++ read-int32 >>req-id
++ read-int32 >>resp-id
++ read-int32 >>opcode
++ read-int32 >>flags ; inline
++
++: write-header ( message -- )
++ [ req-id>> write-int32 ] keep
++ [ resp-id>> write-int32 ] keep
++ opcode>> write-int32 ; inline
++
++PRIVATE>
++
++: read-message ( -- message )
++ mdb-msg new
++ 0 >bytes-read
++ read-header
++ [ ] [ opcode>> ] bi (read-message) ;
++
++<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-header ] dip _ call ] with-length-prefix ] with-buffer
++ ! [ dump-to-file ] keep
++ write flush ; inline
++
++: build-query-object ( query -- selector )
++ [let | selector [ H{ } clone ] |
++ { [ orderby>> [ "orderby" selector set-at ] when* ]
++ [ explain>> [ "$explain" selector set-at ] when* ]
++ [ hint>> [ "$hint" selector set-at ] when* ]
++ [ query>> "query" selector set-at ]
++ } cleave
++ selector
++ ] ;
++
++PRIVATE>
++
++M: mdb-query-msg write-message ( message -- )
++ dup
++ '[ _
++ [ flags>> write-int32 ] keep
++ [ collection>> write-cstring ] keep
++ [ skip#>> write-int32 ] keep
++ [ return#>> write-int32 ] keep
++ [ build-query-object assoc>stream ] keep
++ returnfields>> [ assoc>stream ] when*
++ ] (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) ;
++
--- /dev/null
--- /dev/null
++
++USING: accessors arrays assocs bson.constants classes classes.tuple
++combinators continuations fry kernel mongodb.driver sequences strings
++vectors words combinators.smart literals ;
++
++IN: mongodb.tuple
++
++SINGLETONS: +transient+ +load+ ;
++
++IN: mongodb.tuple.collection
++
++FROM: mongodb.tuple => +transient+ +load+ ;
++
++MIXIN: mdb-persistent
++
++SLOT: _id
++SLOT: _mfd
++
++TUPLE: mdb-tuple-collection < mdb-collection { classes } ;
++
++GENERIC: tuple-collection ( object -- mdb-collection )
++
++GENERIC: mdb-slot-map ( tuple -- string )
++
++<PRIVATE
++
++CONSTANT: MDB_COLLECTION "_mdb_col"
++CONSTANT: MDB_SLOTDEF_LIST "_mdb_slot_list"
++CONSTANT: MDB_COLLECTION_MAP "_mdb_col_map"
++
++: (mdb-collection) ( class -- mdb-collection )
++ dup MDB_COLLECTION word-prop
++ [ nip ]
++ [ superclass [ (mdb-collection) ] [ f ] if* ] if* ; inline recursive
++
++: (mdb-slot-map) ( class -- slot-defs )
++ superclasses [ MDB_SLOTDEF_LIST word-prop ] map assoc-combine ; inline
++
++: split-optl ( seq -- key options )
++ [ first ] [ rest ] bi ; inline
++
++: opt>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 ] } ; 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-map ( class options -- )
++ optl>map MDB_SLOTDEF_LIST set-word-prop ; 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-map ( tuple -- string )
++ class (mdb-slot-map) ;
++
++M: tuple-class mdb-slot-map ( class -- assoc )
++ (mdb-slot-map) ;
++
++M: mdb-collection mdb-slot-map ( collection -- assoc )
++ classes>> [ mdb-slot-map ] map assoc-combine ;
++
++<PRIVATE
++
++: collection-map ( -- assoc )
++ mdb-persistent MDB_COLLECTION_MAP word-prop
++ [ mdb-persistent MDB_COLLECTION_MAP H{ } clone
++ [ set-word-prop ] keep ] unless* ; inline
++
++: slot-option? ( tuple slot option -- ? )
++ [ swap mdb-slot-map at ] dip
++ '[ _ swap key? ] [ f ] if* ;
++
++PRIVATE>
++
++GENERIC: <mdb-tuple-collection> ( name -- mdb-tuple-collection )
++M: string <mdb-tuple-collection> ( name -- mdb-tuple-collection )
++ collection-map [ ] [ key? ] 2bi
++ [ at ] [ [ mdb-tuple-collection new dup ] 2dip
++ [ [ >>name ] keep ] dip set-at ] if ; inline
++M: mdb-tuple-collection <mdb-tuple-collection> ( mdb-tuple-collection -- mdb-tuple-collection ) ;
++M: mdb-collection <mdb-tuple-collection> ( mdb-collection -- mdb-tuple-collection )
++ [ name>> <mdb-tuple-collection> ] keep
++ {
++ [ capped>> >>capped ]
++ [ size>> >>size ]
++ [ max>> >>max ]
++ } cleave ;
++
++: transient-slot? ( tuple slot -- ? )
++ +transient+ slot-option? ;
++
++: load-slot? ( tuple slot -- ? )
++ +load+ slot-option? ;
--- /dev/null
--- /dev/null
++USING: kernel fry accessors formatting linked-assocs assocs sequences sequences.deep
++mongodb.tuple.collection combinators mongodb.tuple.collection ;
++
++IN: mongodb.tuple
++
++SINGLETONS: +fieldindex+ +compoundindex+ +deepindex+ ;
++
++IN: mongodb.tuple.index
++
++TUPLE: tuple-index name spec ;
++
++<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 -- 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-map V{ } clone tuck
++ '[ [ is-index-declaration? ] filter
++ build-index-seq _ push
++ ] assoc-each flatten ;
++
--- /dev/null
--- /dev/null
++USING: accessors assocs bson.constants combinators.short-circuit
++constructors continuations fry kernel mirrors mongodb.tuple.collection
++mongodb.tuple.state namespaces sequences words bson.writer combinators
++hashtables linked-assocs ;
++
++IN: mongodb.tuple.persistent
++
++SYMBOLS: object-map ;
++
++GENERIC: tuple>assoc ( tuple -- assoc )
++
++GENERIC: tuple>selector ( tuple -- selector )
++
++DEFER: assoc>tuple
++
++<PRIVATE
++
++: mdbinfo>tuple-class ( tuple-info -- class )
++ [ first ] keep second lookup ; inline
++
++: tuple-instance ( tuple-info -- instance )
++ mdbinfo>tuple-class new ; inline
++
++: prepare-assoc>tuple ( assoc -- tuple keylist mirror assoc )
++ [ tuple-info tuple-instance dup
++ <mirror> [ keys ] keep ] keep swap ; inline
++
++: make-tuple ( assoc -- tuple )
++ prepare-assoc>tuple
++ '[ dup _ at assoc>tuple swap _ set-at ] each
++ [ mark-persistent ] keep ; inline recursive
++
++: 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 object-map get at+
++ [ dup [ MDB_OID_FIELD ] dip at ] dip set-at ; inline
++
++: write-field? ( tuple key value -- ? )
++ pick mdb-persistent? [
++ { [ [ 2drop ] dip not ]
++ [ drop transient-slot? ] } 3|| not ] [ 3drop t ] if ; inline
++
++TUPLE: cond-value value quot ;
++
++CONSTRUCTOR: cond-value ( value quot -- cond-value ) ;
++
++: write-mdb-persistent ( value quot: ( tuple -- assoc ) -- value' )
++ over [ (( tuple -- assoc )) call-effect ] dip
++ [ tuple-collection name>> ] keep
++ [ add-storable ] dip
++ [ tuple-collection name>> ] [ _id>> ] bi <objref> ; inline
++
++: write-field ( value quot: ( tuple -- assoc ) -- value' )
++ <cond-value> {
++ { [ dup value>> mdb-special-value? ] [ value>> ] }
++ { [ dup value>> mdb-persistent? ]
++ [ [ value>> ] [ quot>> ] bi write-mdb-persistent ] }
++ { [ dup value>> data-tuple? ]
++ [ [ value>> ] [ quot>> ] bi (( tuple -- assoc )) call-effect ] }
++ { [ dup value>> [ hashtable? ] [ linked-assoc? ] bi or ]
++ [ [ value>> ] [ quot>> ] bi '[ _ write-field ] assoc-map ] }
++ [ value>> ]
++ } cond ; inline recursive
++
++: write-tuple-fields ( mirror tuple assoc quot: ( tuple -- assoc ) -- )
++ swap ! m t q q a
++ '[ _ 2over write-field?
++ [ _ write-field swap _ set-at ]
++ [ 2drop ] if
++ ] assoc-each ;
++
++: prepare-assoc ( tuple -- assoc mirror tuple assoc )
++ H{ } clone swap [ <mirror> ] keep pick ; inline
++
++: ensure-mdb-info ( tuple -- tuple )
++ dup _id>> [ <objid> >>_id ] unless
++ [ mark-persistent ] keep ; inline
++
++: with-object-map ( quot: ( -- ) -- store-assoc )
++ [ H{ } clone dup object-map ] dip with-variable ; inline
++
++: (tuple>assoc) ( tuple -- assoc )
++ [ prepare-assoc [ tuple>assoc ] write-tuple-fields ] keep
++ over set-tuple-info ; inline
++
++PRIVATE>
++
++GENERIC: tuple>storable ( tuple -- storable )
++
++M: mdb-persistent tuple>storable ( mdb-persistent -- object-map )
++ '[ _ [ tuple>assoc ] write-mdb-persistent drop ] with-object-map ; 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 recursive
++
--- /dev/null
--- /dev/null
++USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection
++words classes.tuple slots generic ;
++
++IN: mongodb.tuple.state
++
++<PRIVATE
++
++CONSTANT: MDB_TUPLE_INFO "_mfd_t_info"
++CONSTANT: MDB_DIRTY_FLAG "d?"
++CONSTANT: MDB_PERSISTENT_FLAG "p?"
++CONSTANT: MDB_DIRTY_ADVICE "mdb-dirty-set"
++
++PRIVATE>
++
++SYMBOL: mdb-dirty-handling?
++
++: advised-with? ( name word loc -- ? )
++ word-prop key? ; inline
++
++: <tuple-info> ( 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 -- )
++ [ <tuple-info> 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 ] dip tuple-meta at ;
++
++: mark-dirty ( tuple -- )
++ [ t MDB_DIRTY_FLAG ] dip tuple-meta set-at ;
++
++: persistent? ( tuple -- ? )
++ [ MDB_PERSISTENT_FLAG ] dip tuple-meta at ;
++
++: mark-persistent ( tuple -- )
++ [ t MDB_PERSISTENT_FLAG ] dip tuple-meta [ set-at ] keep
++ [ f MDB_DIRTY_FLAG ] dip set-at ;
++
++: needs-store? ( tuple -- ? )
++ [ persistent? not ] [ dirty? ] bi or ;
++
--- /dev/null
--- /dev/null
++USING: accessors assocs classes.mixin classes.tuple
++classes.tuple.parser compiler.units fry kernel sequences mongodb.driver
++mongodb.msg mongodb.tuple.collection mongodb.tuple.index
++mongodb.tuple.persistent mongodb.tuple.state strings ;
++
++IN: mongodb.tuple
++
++SYNTAX: MDBTUPLE:
++ parse-tuple-definition
++ mdb-check-slots
++ define-tuple-class ;
++
++: define-persistent ( class collection options -- )
++ [ [ <mdb-tuple-collection> dupd link-collection ] when* ] dip
++ [ dup '[ _ mdb-persistent add-mixin-instance ] with-compilation-unit ] dip
++ ! [ dup annotate-writers ] dip
++ set-slot-map ;
++
++: ensure-table ( class -- )
++ tuple-collection
++ [ create-collection ]
++ [ [ tuple-index-list ] keep
++ '[ _ name>> swap [ name>> ] [ spec>> ] bi ensure-index ] each
++ ] bi ;
++
++: ensure-tables ( classes -- )
++ [ ensure-table ] each ;
++
++: drop-table ( class -- )
++ tuple-collection
++ [ [ tuple-index-list ] keep
++ '[ _ name>> swap name>> drop-index ] each ]
++ [ name>> drop-collection ] bi ;
++
++: recreate-table ( class -- )
++ [ drop-table ]
++ [ ensure-table ] bi ;
++
++<PRIVATE
++
++GENERIC: id-selector ( object -- selector )
++
++M: string id-selector ( objid -- selector )
++ "_id" H{ } clone [ set-at ] keep ; inline
++
++M: mdb-persistent id-selector ( mdb-persistent -- selector )
++ _id>> id-selector ;
++
++: (save-tuples) ( collection assoc -- )
++ swap '[ [ _ ] 2dip
++ [ id-selector ] dip
++ <update> >upsert update ] assoc-each ; inline
++PRIVATE>
++
++: save-tuple ( tuple -- )
++ tuple>storable [ (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 <query> ;
++
++: 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 ;
projects / factor.git / commitdiff