From: Sascha Matzke Date: Fri, 1 May 2009 12:43:45 +0000 (+0200) Subject: Merge commit 'mongo-factor-driver/master' into mongo-factor-driver X-Git-Tag: 0.97~6384 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=3bfc30c79334544d3cc07378da40d9fc693cbdb8 Merge commit 'mongo-factor-driver/master' into mongo-factor-driver moving mongodb and bson to factor source tree --- 3bfc30c79334544d3cc07378da40d9fc693cbdb8 diff --cc extra/bson/bson.factor index 0000000000,0000000000..a97b5029b0 new file mode 100644 --- /dev/null +++ b/extra/bson/bson.factor @@@ -1,0 -1,0 +1,6 @@@ ++USING: vocabs.loader ; ++ ++IN: bson ++ ++"bson.reader" require ++"bson.writer" require diff --cc extra/bson/constants/constants.factor index 0000000000,0000000000..5148413b61 new file mode 100644 --- /dev/null +++ b/extra/bson/constants/constants.factor @@@ -1,0 -1,0 +1,49 @@@ ++USING: accessors constructors kernel strings uuid ; ++ ++IN: bson.constants ++ ++: ( -- 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 } ; ++ ++: ( 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 ++ ++ diff --cc extra/bson/reader/reader.factor index 0000000000,0000000000..96cde41c2b new file mode 100644 --- /dev/null +++ b/extra/bson/reader/reader.factor @@@ -1,0 -1,0 +1,200 @@@ ++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 ++ ++ ( 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 ++ "\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 ) ++ dup state ++ [ read-int32 >>size read-elements ] with-variable ++ [ result>> ] [ read>> ] bi ; diff --cc extra/bson/writer/writer.factor index 0000000000,0000000000..ae12ca0a03 new file mode 100644 --- /dev/null +++ b/extra/bson/writer/writer.factor @@@ -1,0 -1,0 +1,168 @@@ ++! 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 ++ ++ [ 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 ++ ++ 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|| ; diff --cc extra/mongodb/benchmark/benchmark.factor index 0000000000,0000000000..02dfa8add9 new file mode 100644 --- /dev/null +++ b/extra/mongodb/benchmark/benchmark.factor @@@ -1,0 -1,0 +1,312 @@@ ++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 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 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 ++ '[ _ _ 1 limit (find) ] times ] ; ++ ++: find-all ( quot -- quot: ( -- ) ) ++ drop ++ collection-name ++ H{ } clone ++ '[ _ _ (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 ++ '[ _ _ (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 -- ) ++ '[ _ 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 ++ [ 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 ++ diff --cc extra/mongodb/connection/connection.factor index 0000000000,0000000000..7477ee5486 new file mode 100644 --- /dev/null +++ b/extra/mongodb/connection/connection.factor @@@ -1,0 -1,0 +1,146 @@@ ++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 ++ ++: ( 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 ) ++ ++ 1 >>return# ++ send-query-plain objects>> ++ [ f ] [ first ] if-empty ; ++ ++> ] [ 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 ++ [ >>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 f >>remote ] when* ++ drop ] 2bi ; ++ ++: check-node ( mdb node -- ) ++ [ &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 [ ] keep ++ master-node open-connection ++ [ authenticate-connection ] keep ; ++ ++: mdb-close ( mdb-connection -- ) ++ [ dispose f ] change-handle drop ; ++ ++M: mdb-connection dispose ++ mdb-close ; diff --cc extra/mongodb/driver/authors.txt index 0000000000,0000000000..5df962bfe0 new file mode 100644 --- /dev/null +++ b/extra/mongodb/driver/authors.txt @@@ -1,0 -1,0 +1,1 @@@ ++Sascha Matzke diff --cc extra/mongodb/driver/driver-docs.factor index 0000000000,0000000000..48d7f7b65f new file mode 100644 --- /dev/null +++ b/extra/mongodb/driver/driver-docs.factor @@@ -1,0 -1,0 +1,284 @@@ ++! 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: ++{ $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\" t >>capped 1000000 >>max" } } ; ++ ++HELP: ++{ $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 " } } ; ++ ++HELP: ++{ $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{ } " } } ; ++ ++HELP: ++{ $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 ensure-index" } ++ { $example "\"mycollection\" nameIdx [ \"name\" asc ] keyspec 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\" } } 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 } } 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{ } 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" ++ diff --cc extra/mongodb/driver/driver.factor index 0000000000,0000000000..355838b82d new file mode 100644 --- /dev/null +++ b/extra/mongodb/driver/driver.factor @@@ -1,0 -1,0 +1,305 @@@ ++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 ] dip >>mdb ; inline ++ ++CONSTANT: PARTIAL? "partial?" ++ ++ERROR: mdb-error msg ; ++ ++: >pwd-digest ( user password -- digest ) ++ "mongo" swap 3array ":" join md5-checksum ; ++ ++ ( id mdb-query-msg/mdb-getmore-msg -- mdb-cursor ) ++ ++M: mdb-query-msg ++ mdb-cursor boa ; ++ ++M: mdb-getmore-msg ++ query>> mdb-cursor boa ; ++ ++: >mdbregexp ( value -- regexp ) ++ first ; 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 ] 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 ; ++ ++: ( db host port -- mdb ) ++ t [ ] keep ++ H{ } clone [ set-at ] keep ++ [ verify-nodes ] keep ; ++ ++GENERIC: create-collection ( name -- ) ++ ++M: string create-collection ++ create-collection ; ++ ++M: mdb-collection create-collection ++ [ cmd-collection ] dip ++ [ ++ [ [ 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 1 >>return# send-query-plain drop ; ++ ++: load-collection-list ( -- collection-list ) ++ namespaces-collection ++ H{ } clone send-query-plain objects>> ; ++ ++ ] 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 ] 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 swap >>query send-query ] ++ [ f f ] if* ; ++ ++PRIVATE> ++ ++: ( collection assoc -- 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 find-one ++ [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ; ++ ++: lasterror ( -- error ) ++ cmd-collection H{ { "getlasterror" 1 } } ++ find-one [ "err" ] dip at ; ++ ++GENERIC: validate. ( collection -- ) ++ ++M: string validate. ++ [ cmd-collection ] dip ++ "validate" H{ } clone [ set-at ] keep ++ find-one [ check-ok nip ] keep ++ '[ "result" _ at print ] [ ] if ; ++ ++M: mdb-collection validate. ++ name>> validate. ; ++ ++ ++ ++GENERIC: save ( collection assoc -- ) ++M: assoc save ++ [ check-collection ] dip ++ send-message-check-error ; ++ ++GENERIC: save-unsafe ( collection object -- ) ++M: assoc save-unsafe ++ [ check-collection ] dip ++ send-message ; ++ ++GENERIC: ensure-index ( index-spec -- ) ++M: index-spec ensure-index ++ [ [ 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 ++ find-one drop ; ++ ++: ( collection selector object -- update-msg ) ++ [ check-collection ] 2dip ; ++ ++: >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 ++ send-message-check-error ; ++ ++GENERIC: delete-unsafe ( collection selector -- ) ++M: assoc delete-unsafe ++ [ check-collection ] dip ++ send-message ; ++ ++: load-index-list ( -- index-list ) ++ index-collection ++ H{ } clone find nip ; ++ ++: ensure-collection ( name -- ) ++ check-collection drop ; ++ ++: drop-collection ( name -- ) ++ [ cmd-collection ] dip ++ "drop" H{ } clone [ set-at ] keep ++ find-one drop ; ++ ++ diff --cc extra/mongodb/driver/summary.txt index 0000000000,0000000000..2ac1f95c9c new file mode 100644 --- /dev/null +++ b/extra/mongodb/driver/summary.txt @@@ -1,0 -1,0 +1,1 @@@ ++A driver for the MongoDB document-oriented database (http://www.mongodb.org) diff --cc extra/mongodb/driver/tags.txt index 0000000000,0000000000..aa0d57e895 new file mode 100644 --- /dev/null +++ b/extra/mongodb/driver/tags.txt @@@ -1,0 -1,0 +1,1 @@@ ++database diff --cc extra/mongodb/mmm/mmm.factor index 0000000000,0000000000..467070859e new file mode 100644 --- /dev/null +++ b/extra/mongodb/mmm/mmm.factor @@@ -1,0 -1,0 +1,102 @@@ ++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 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 ++ [ mmm-t-srv set ] keep ++ "127.0.0.1" mmm-port get >>insecure ++ binary >>encoding ++ [ handle-mmm-connection ] >>handler ++ start-server* ; ++ ++: run-mmm ( -- ) ++ check-options ++ start-mmm-server ; ++ ++MAIN: run-mmm diff --cc extra/mongodb/msg/msg.factor index 0000000000,0000000000..dd8bae8438 new file mode 100644 --- /dev/null +++ b/extra/mongodb/msg/msg.factor @@@ -1,0 -1,0 +1,105 @@@ ++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: ( object -- mdb-killcursors-msg ) ++ ++M: sequence ( sequences -- mdb-killcursors-msg ) ++ [ mdb-killcursors-msg new ] dip ++ [ length >>cursors# ] keep ++ >>cursors OP_KillCursors >>opcode ; inline ++ ++M: integer ( integer -- mdb-killcursors-msg ) ++ V{ } clone [ push ] keep ; ++ ++GENERIC: ( collection objects -- mdb-insert-msg ) ++ ++M: sequence ( collection sequence -- mdb-insert-msg ) ++ [ mdb-insert-msg new ] 2dip ++ [ >>collection ] dip ++ >>objects OP_Insert >>opcode ; ++ ++M: assoc ( 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 ++ diff --cc extra/mongodb/operations/operations.factor index 0000000000,0000000000..001e8443e4 new file mode 100644 --- /dev/null +++ b/extra/mongodb/operations/operations.factor @@@ -1,0 -1,0 +1,222 @@@ ++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 ++ ++ ++ ++GENERIC: write-message ( message -- ) ++ ++ ( -- 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 ++ [ ] 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) ; ++ ++> [ "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) ; ++ diff --cc extra/mongodb/tuple/collection/collection.factor index 0000000000,0000000000..a4f86cd6a3 new file mode 100644 --- /dev/null +++ b/extra/mongodb/tuple/collection/collection.factor @@@ -1,0 -1,0 +1,117 @@@ ++ ++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 ) ++ ++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 ; ++ ++ ++ ++GENERIC: ( name -- mdb-tuple-collection ) ++M: string ( 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 ) ; ++M: mdb-collection ( mdb-collection -- mdb-tuple-collection ) ++ [ name>> ] keep ++ { ++ [ capped>> >>capped ] ++ [ size>> >>size ] ++ [ max>> >>max ] ++ } cleave ; ++ ++: transient-slot? ( tuple slot -- ? ) ++ +transient+ slot-option? ; ++ ++: load-slot? ( tuple slot -- ? ) ++ +load+ slot-option? ; diff --cc extra/mongodb/tuple/index/index.factor index 0000000000,0000000000..1e7a679df3 new file mode 100644 --- /dev/null +++ b/extra/mongodb/tuple/index/index.factor @@@ -1,0 -1,0 +1,56 @@@ ++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 ; ++ ++ ] 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 ; ++ diff --cc extra/mongodb/tuple/persistent/persistent.factor index 0000000000,0000000000..061b27dd1b new file mode 100644 --- /dev/null +++ b/extra/mongodb/tuple/persistent/persistent.factor @@@ -1,0 -1,0 +1,115 @@@ ++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 ++ ++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 ++ [ 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 ; inline ++ ++: write-field ( value quot: ( tuple -- assoc ) -- 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 [ ] keep pick ; inline ++ ++: ensure-mdb-info ( tuple -- tuple ) ++ dup _id>> [ >>_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 ++ diff --cc extra/mongodb/tuple/state/state.factor index 0000000000,0000000000..21923637e5 new file mode 100644 --- /dev/null +++ b/extra/mongodb/tuple/state/state.factor @@@ -1,0 -1,0 +1,52 @@@ ++USING: classes kernel accessors sequences fry assocs mongodb.tuple.collection ++words classes.tuple slots generic ; ++ ++IN: mongodb.tuple.state ++ ++ ++ ++SYMBOL: mdb-dirty-handling? ++ ++: advised-with? ( name word loc -- ? ) ++ word-prop key? ; inline ++ ++: ( 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 ] 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 ; ++ diff --cc extra/mongodb/tuple/tuple.factor index 0000000000,0000000000..beb7f41384 new file mode 100644 --- /dev/null +++ b/extra/mongodb/tuple/tuple.factor @@@ -1,0 -1,0 +1,83 @@@ ++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 -- ) ++ [ [ 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 ; ++ ++> id-selector ; ++ ++: (save-tuples) ( collection assoc -- ) ++ swap '[ [ _ ] 2dip ++ [ id-selector ] dip ++ >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 ; ++ ++: 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 ;