diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index 6e82e16268..7940703140 100644 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -23,7 +23,7 @@ IN: bootstrap.compiler "cpu." cpu name>> append require -enable-compiler +enable-optimizer ! Push all tuple layouts to tenured space to improve method caching gc diff --git a/basis/compiler/compiler-docs.factor b/basis/compiler/compiler-docs.factor index 49511fe579..306ab515a8 100644 --- a/basis/compiler/compiler-docs.factor +++ b/basis/compiler/compiler-docs.factor @@ -4,16 +4,16 @@ compiler.units help.markup help.syntax io parser quotations sequences words ; IN: compiler -HELP: enable-compiler +HELP: enable-optimizer { $description "Enables the optimizing compiler." } ; -HELP: disable-compiler +HELP: disable-optimizer { $description "Disable the optimizing compiler." } ; ARTICLE: "compiler-usage" "Calling the optimizing compiler" "Normally, new word definitions are recompiled automatically. This can be changed:" -{ $subsection disable-compiler } -{ $subsection enable-compiler } +{ $subsection disable-optimizer } +{ $subsection enable-optimizer } "Removing a word's optimized definition:" { $subsection decompile } "Compiling a single quotation:" diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index cc9899878a..e418f0ef60 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -192,10 +192,13 @@ M: optimizing-compiler recompile ( words -- alist ) compiled get >alist ] with-scope ; -: enable-compiler ( -- ) +: with-optimizer ( quot -- ) + [ optimizing-compiler compiler-impl ] dip with-variable ; inline + +: enable-optimizer ( -- ) optimizing-compiler compiler-impl set-global ; -: disable-compiler ( -- ) +: disable-optimizer ( -- ) f compiler-impl set-global ; : recompile-all ( -- ) diff --git a/basis/compiler/tests/generic.factor b/basis/compiler/tests/generic.factor new file mode 100644 index 0000000000..6b0ef2d439 --- /dev/null +++ b/basis/compiler/tests/generic.factor @@ -0,0 +1,11 @@ +IN: compiler.tests.generic +USING: tools.test math kernel compiler.units definitions ; + +GENERIC: bad ( -- ) +M: integer bad ; +M: object bad ; + +[ 0 bad ] must-fail +[ "" bad ] must-fail + +[ ] [ [ \ bad forget ] with-compilation-unit ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/redefine14.factor b/basis/compiler/tests/redefine14.factor index 807f3ed2c7..a72db4833c 100644 --- a/basis/compiler/tests/redefine14.factor +++ b/basis/compiler/tests/redefine14.factor @@ -1,8 +1,8 @@ USING: compiler.units definitions tools.test sequences ; IN: compiler.tests.redefine14 -! TUPLE: bad ; -! -! M: bad length 1 2 3 ; -! -! [ ] [ [ { bad length } forget ] with-compilation-unit ] unit-test +TUPLE: bad ; + +M: bad length 1 2 3 ; + +[ ] [ [ M\ bad length forget ] with-compilation-unit ] unit-test diff --git a/basis/compiler/tests/redefine17.factor b/basis/compiler/tests/redefine17.factor new file mode 100644 index 0000000000..4ed3e36f4d --- /dev/null +++ b/basis/compiler/tests/redefine17.factor @@ -0,0 +1,49 @@ +IN: compiler.tests.redefine17 +USING: tools.test classes.mixin compiler.units arrays kernel.private +strings sequences vocabs definitions kernel ; + +<< "compiler.tests.redefine17" words forget-all >> + +GENERIC: bong ( a -- b ) + +M: array bong ; + +M: string bong length ; + +MIXIN: mixin + +INSTANCE: array mixin + +: blah ( a -- b ) { mixin } declare bong ; + +[ { } ] [ { } blah ] unit-test + +[ ] [ [ \ array \ mixin remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ string \ mixin add-mixin-instance ] with-compilation-unit ] unit-test + +[ 0 ] [ "" blah ] unit-test + +MIXIN: mixin1 + +INSTANCE: string mixin1 + +MIXIN: mixin2 + +GENERIC: billy ( a -- b ) + +M: mixin2 billy ; + +M: array billy drop "BILLY" ; + +INSTANCE: string mixin2 + +: bully ( a -- b ) { mixin1 } declare billy ; + +[ "" ] [ "" bully ] unit-test + +[ ] [ [ \ string \ mixin1 remove-mixin-instance ] with-compilation-unit ] unit-test + +[ ] [ [ \ array \ mixin1 add-mixin-instance ] with-compilation-unit ] unit-test + +[ "BILLY" ] [ { } bully ] unit-test diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 2776ed914f..4d4b22218d 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -59,21 +59,18 @@ CONSTANT: object-info T{ value-info f object full-interval } : ( -- info ) \ value-info new ; -: read-only-slots ( values class -- slots ) - all-slots - [ read-only>> [ drop f ] unless ] 2map - f prefix ; - DEFER: +: tuple-slot-infos ( tuple -- slots ) + [ tuple-slots ] [ class all-slots ] bi + [ read-only>> [ ] [ drop f ] if ] 2map + f prefix ; + : init-literal-info ( info -- info ) dup literal>> class >>class dup literal>> dup real? [ [a,a] >>interval ] [ [ [-inf,inf] >>interval ] dip - dup tuple? [ - [ tuple-slots [ ] map ] [ class ] bi - read-only-slots >>slots - ] [ drop ] if + dup tuple? [ tuple-slot-infos >>slots ] [ drop ] if ] if ; inline : init-value-info ( info -- info ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index ed8d2983b5..eba41dbfdf 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays.double system sorting math.libm -math.intervals ; +math.intervals quotations ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -686,3 +686,8 @@ TUPLE: littledan-2 { from read-only } { to read-only } ; [ V{ 0 } ] [ [ { } length ] final-literals ] unit-test [ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test + +! Mutable tuples with circularity should not cause problems +TUPLE: circle me ; + +[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 89c2bada8b..86114772f7 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -30,8 +30,13 @@ UNION: fixed-length-sequence array byte-array string ; [ [ literal>> ] map ] dip prefix >tuple ; +: read-only-slots ( values class -- slots ) + all-slots + [ read-only>> [ value-info ] [ drop f ] if ] 2map + f prefix ; + : (propagate-tuple-constructor) ( values class -- info ) - [ [ value-info ] map ] dip [ read-only-slots ] keep + [ read-only-slots ] keep over rest-slice [ dup [ literal?>> ] when ] all? [ [ rest-slice ] dip fold- ] [ diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index b280afc01e..10cd9c8657 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -309,7 +309,7 @@ FUNCTION: bool check_sse2 ( ) ; check_sse2 ; "-no-sse2" (command-line) member? [ - optimizing-compiler compiler-impl [ { check_sse2 } compile ] with-variable + [ { check_sse2 } compile ] with-optimizer "Checking if your CPU supports SSE2..." print flush sse2? [ diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor index f485f1bec1..0776f8f158 100644 --- a/basis/documents/elements/elements.factor +++ b/basis/documents/elements/elements.factor @@ -79,6 +79,13 @@ M: one-word-elt next-elt drop [ f next-word ] modify-col ; +SINGLETON: word-start-elt + +M: word-start-elt prev-elt + drop one-word-elt prev-elt ; + +M: word-start-elt next-elt 2drop ; + SINGLETON: word-elt M: word-elt prev-elt diff --git a/basis/peg/peg-tests.factor b/basis/peg/peg-tests.factor index 683fa328d8..cae1e05dc8 100644 --- a/basis/peg/peg-tests.factor +++ b/basis/peg/peg-tests.factor @@ -199,10 +199,10 @@ IN: peg.tests USE: compiler -[ ] [ disable-compiler ] unit-test +[ ] [ disable-optimizer ] unit-test [ ] [ "" epsilon parse drop ] unit-test -[ ] [ enable-compiler ] unit-test +[ ] [ enable-optimizer ] unit-test [ [ ] ] [ "" epsilon [ drop [ [ ] ] call ] action parse ] unit-test diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index ad46a0d227..8113a662d6 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -19,7 +19,6 @@ IN: stack-checker.transforms rstate recursive-state [ word stack quot call-transformer ] with-variable [ - word inlined-dependency depends-on values [ length meta-d shorten-by ] [ #drop, ] bi rstate infer-quot ] [ word infer-word ] if* ; diff --git a/basis/tools/deploy/test/test.factor b/basis/tools/deploy/test/test.factor index eb780e40cc..f997a6eb3a 100644 --- a/basis/tools/deploy/test/test.factor +++ b/basis/tools/deploy/test/test.factor @@ -16,4 +16,5 @@ IN: tools.deploy.test : run-temp-image ( -- ) vm "-i=" "test.image" temp-file append - 2array try-process ; \ No newline at end of file + 2array + swap >>command +closed+ >>stdin try-process ; \ No newline at end of file diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index ba99a41eba..4b9a72a443 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -74,8 +74,6 @@ SYMBOL: failures SYMBOL: changed-vocabs -[ f changed-vocabs set-global ] "tools.vocabs" add-init-hook - : changed-vocab ( vocab -- ) dup vocab changed-vocabs get and [ dup changed-vocabs get set-at ] [ drop ] if ; @@ -287,3 +285,12 @@ MEMO: all-authors ( -- seq ) \ all-vocabs-seq reset-memoized \ all-authors reset-memoized \ all-tags reset-memoized ; + +SINGLETON: cache-observer + +M: cache-observer vocabs-changed drop reset-cache ; + +[ + f changed-vocabs set-global + cache-observer add-vocab-observer +] "tools.vocabs" add-init-hook \ No newline at end of file diff --git a/basis/ui/gadgets/sliders/sliders.factor b/basis/ui/gadgets/sliders/sliders.factor index 6cfb83a49a..80829d7b66 100644 --- a/basis/ui/gadgets/sliders/sliders.factor +++ b/basis/ui/gadgets/sliders/sliders.factor @@ -53,8 +53,8 @@ CONSTANT: min-thumb-dim 30 [ slider-max* 1 max ] bi / ; -: slider>screen ( m slider -- n ) slider-scale * elevator-padding + ; -: screen>slider ( m slider -- n ) [ elevator-padding - ] dip slider-scale / ; +: slider>screen ( m slider -- n ) slider-scale * ; +: screen>slider ( m slider -- n ) slider-scale / ; M: slider model-changed nip elevator>> relayout-1 ; @@ -133,7 +133,7 @@ elevator H{ swap >>orientation ; : thumb-loc ( slider -- loc ) - [ slider-value ] keep slider>screen ; + [ slider-value ] keep slider>screen elevator-padding + ; : layout-thumb-loc ( thumb slider -- ) [ thumb-loc ] [ orientation>> ] bi n*v diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index c7db0839d7..7e038ef2e0 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -310,16 +310,16 @@ HOOK: keysym>string os ( keysym -- string ) M: macosx keysym>string >upper ; -M: object keysym>string ; +M: object keysym>string dup length 1 = [ >lower ] when ; M: key-down gesture>string [ mods>> ] [ sym>> ] bi { { [ dup { [ length 1 = ] [ first LETTER? ] } 1&& ] [ [ S+ prefix ] dip ] } { [ dup " " = ] [ drop "SPACE" ] } - [ keysym>string ] + [ ] } cond - [ modifiers>string ] dip append ; + [ modifiers>string ] [ keysym>string ] bi* append ; M: button-up gesture>string [ diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor index a493d5d7d2..1b8af1dd03 100644 --- a/basis/ui/tools/browser/browser.factor +++ b/basis/ui/tools/browser/browser.factor @@ -25,7 +25,10 @@ M: browser-gadget set-history-value : show-help ( link browser-gadget -- ) [ >link ] dip - [ [ add-recent ] [ history>> add-history ] bi* ] + [ + 2dup model>> value>> = + [ 2drop ] [ [ add-recent ] [ history>> add-history ] bi* ] if + ] [ model>> set-model ] 2bi ; diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index 17216bd656..fdba400c3d 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -39,7 +39,7 @@ M: history-completion completion-quot drop '[ drop _ history-list ] ; GENERIC: completion-element ( completion-mode -- element ) -M: object completion-element drop one-word-elt ; +M: object completion-element drop word-start-elt ; M: history-completion completion-element drop one-line-elt ; GENERIC: completion-banner ( completion-mode -- string ) @@ -72,13 +72,13 @@ M: vocab-completion row-color drop vocab? COLOR: black COLOR: dark-gray ? ; : complete-IN:/USE:? ( tokens -- ? ) - 2 short tail* { "IN:" "USE:" } intersects? ; + 1 short head* 2 short tail* { "IN:" "USE:" } intersects? ; : chop-; ( seq -- seq' ) { ";" } split1-last [ ] [ ] ?if ; : complete-USING:? ( tokens -- ? ) - chop-; { "USING:" } intersects? ; + chop-; 1 short head* { "USING:" } intersects? ; : complete-CHAR:? ( tokens -- ? ) 2 short tail* "CHAR:" swap member? ; diff --git a/core/compiler/units/units-tests.factor b/core/compiler/units/units-tests.factor index da2dce128f..8dce12f411 100644 --- a/core/compiler/units/units-tests.factor +++ b/core/compiler/units/units-tests.factor @@ -19,7 +19,7 @@ IN: compiler.units.tests ] unit-test [ "A" "B" ] [ - disable-compiler + disable-optimizer gensym "a" set gensym "b" set @@ -33,7 +33,7 @@ IN: compiler.units.tests ] with-compilation-unit "b" get execute - enable-compiler + enable-optimizer ] unit-test ! Check that we notify observers diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index c4a137b2ba..f1f9131f08 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -43,6 +43,9 @@ HOOK: recompile compiler-impl ( words -- alist ) ! Non-optimizing compiler M: f recompile [ dup def>> ] { } map>assoc ; +: without-optimizer ( quot -- ) + [ f compiler-impl ] dip with-variable ; inline + ! Trivial compiler. We don't want to touch the code heap ! during stage1 bootstrap, it would just waste time. SINGLETON: dummy-compiler @@ -58,6 +61,10 @@ GENERIC: definitions-changed ( assoc obj -- ) [ V{ } clone definition-observers set-global ] "compiler.units" add-init-hook +! This goes here because vocabs cannot depend on init +[ V{ } clone vocab-observers set-global ] +"vocabs" add-init-hook + : add-definition-observer ( obj -- ) definition-observers get push ; diff --git a/core/init/init.factor b/core/init/init.factor index 5d8e88b85f..0140fcc0e8 100644 --- a/core/init/init.factor +++ b/core/init/init.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: continuations continuations.private kernel -kernel.private sequences assocs namespaces namespaces.private ; +kernel.private sequences assocs namespaces namespaces.private +continuations continuations.private ; IN: init SYMBOL: init-hooks diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 2b978e8666..6c12b7b325 100644 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -65,8 +65,22 @@ M: object vocab-main vocab vocab-main ; M: f vocab-main ; +SYMBOL: vocab-observers + +GENERIC: vocabs-changed ( obj -- ) + +: add-vocab-observer ( obj -- ) + vocab-observers get push ; + +: remove-vocab-observer ( obj -- ) + vocab-observers get delq ; + +: notify-vocab-observers ( -- ) + vocab-observers get [ vocabs-changed ] each ; + : create-vocab ( name -- vocab ) - dictionary get [ ] cache ; + dictionary get [ ] cache + notify-vocab-observers ; ERROR: no-vocab name ; @@ -99,7 +113,8 @@ M: string >vocab-link dup vocab [ ] [ ] ?if ; : forget-vocab ( vocab -- ) dup words forget-all - vocab-name dictionary get delete-at ; + vocab-name dictionary get delete-at + notify-vocab-observers ; M: vocab-spec forget* forget-vocab ; diff --git a/extra/bson/bson.factor b/extra/bson/bson.factor new file mode 100644 index 0000000000..a97b5029b0 --- /dev/null +++ b/extra/bson/bson.factor @@ -0,0 +1,6 @@ +USING: vocabs.loader ; + +IN: bson + +"bson.reader" require +"bson.writer" require diff --git a/extra/bson/constants/constants.factor b/extra/bson/constants/constants.factor new file mode 100644 index 0000000000..5148413b61 --- /dev/null +++ b/extra/bson/constants/constants.factor @@ -0,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 --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor new file mode 100644 index 0000000000..96cde41c2b --- /dev/null +++ b/extra/bson/reader/reader.factor @@ -0,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 --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor new file mode 100644 index 0000000000..1b9d45b124 --- /dev/null +++ b/extra/bson/writer/writer.factor @@ -0,0 +1,164 @@ +! 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 + + [ shared-buffer set ] keep ] unless* ; inline + +: >le-stream ( x n -- ) + 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|| ; \ No newline at end of file diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor new file mode 100644 index 0000000000..02dfa8add9 --- /dev/null +++ b/extra/mongodb/benchmark/benchmark.factor @@ -0,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 --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor new file mode 100644 index 0000000000..7477ee5486 --- /dev/null +++ b/extra/mongodb/connection/connection.factor @@ -0,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 ; \ No newline at end of file diff --git a/extra/mongodb/driver/authors.txt b/extra/mongodb/driver/authors.txt new file mode 100644 index 0000000000..5df962bfe0 --- /dev/null +++ b/extra/mongodb/driver/authors.txt @@ -0,0 +1 @@ +Sascha Matzke diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor new file mode 100644 index 0000000000..1086105306 --- /dev/null +++ b/extra/mongodb/driver/driver-docs.factor @@ -0,0 +1,288 @@ +! 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" } +} +{ $examples { $unchecked-example "USING: mongodb.driver ;" "\"mycollection\" t >>capped 1000000 >>max" "" } } +{ $description "Creates a new mdb-collection instance. Use this to create capped/limited collections." } ; + +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 + { $unchecked-example "USING: mongodb.driver ;" "\"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 + { $unchecked-example "USING: mongodb.driver ;" "\"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 + { "name" "a collection; e.g. mycollection " } +} +{ $description "ensures that the collection exists in the database" } ; + +HELP: ensure-index +{ $values + { "index-spec" "an index specification" } +} +{ $description "Ensures the existence of the given index. " + "For more information on MongoDB indexes see: " { $url "http://www.mongodb.org/display/DOCS/Indexes" } } +{ $examples + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec ensure-index ] with-db" "" } + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec unique-index ensure-index ] with-db" "" } } ; + +HELP: explain. +{ $values + { "mdb-query-msg" "a query message" } +} +{ $description "Prints the execution plan for the given query" } ; + +HELP: find +{ $values + { "selector" "a mdb-query or mdb-cursor" } + { "mdb-cursor/f" "a cursor (if there are more results) or f" } + { "seq" "a sequences of objects" } +} +{ $description "executes the given query" } +{ $examples + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" H{ { \"name\" \"Alfred\" } } find ] with-db" "" } } ; + +HELP: find-one +{ $values + { "mdb-query-msg" "a query" } + { "result/f" "a single object or f" } +} +{ $description "Executes the query and returns one object at most" } ; + +HELP: hint +{ $values + { "mdb-query-msg" "a query" } + { "index-hint" "a hint to an index" } + { "mdb-query-msg" "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 + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" H{ { \"name\" \"Alfred\" } { \"age\" 70 } } H{ { \"name\" 1 } } hint find ] with-db" "" } } ; + +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-msg" "a query" } + { "limit#" "number of objects that should be returned at most" } + { "mdb-query-msg" "modified query object" } +} +{ $description "Limits the number of returned objects to limit#" } +{ $examples + { $unchecked-example "USING: mongodb.driver ;" + "\"db\" \"127.0.0.1\" 27017 " + "[ \"mycollection\" H{ } 10 limit find ] with-db" "" } } ; + +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 "MongoDB collection" } ; + +HELP: mdb-cursor +{ $var-description "MongoDB cursor" } ; + +HELP: mdb-error +{ $values + { "msg" "error message" } +} +{ $description "error class" } ; + +HELP: r/ +{ $values + { "token" "a regexp string" } + { "mdbregexp" "a mdbregexp tuple instance" } +} +{ $description "creates a new mdbregexp instance" } ; + +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" "a collection" } + { "assoc" "object" } +} +{ $description "Save the object to the given collection without automatic error check" } ; + +HELP: skip +{ $values + { "mdb-query-msg" "a query message" } + { "skip#" "number of objects to skip" } + { "mdb-query-msg" "annotated query message" } +} +{ $description "annotates a query message with a number of objects to skip when returning the results" } ; + +HELP: sort +{ $values + { "mdb-query-msg" "a query message" } + { "sort-quot" "a quotation with sort specifiers" } + { "mdb-query-msg" "annotated query message" } +} +{ $description "annotates the query message for sort specifiers" } ; + +HELP: update +{ $values + { "mdb-update-msg" "a mdb-update message" } +} +{ $description "performs an update" } ; + +HELP: update-unsafe +{ $values + { "mdb-update-msg" "a mdb-update message" } +} +{ $description "performs an update without automatic error check" } ; + +HELP: validate. +{ $values + { "collection" "collection to validate" } +} +{ $description "validates the collection" } ; + +HELP: with-db +{ $values + { "mdb" "mdb instance" } + { "quot" "quotation to execute with the given mdb instance as context" } +} +{ $description "executes a quotation with the given mdb instance in its context" } ; + +ARTICLE: "mongodb.driver" "MongoDB factor driver" +{ $vocab-link "mongodb.driver" } +; + +ABOUT: "mongodb.driver" + diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor new file mode 100644 index 0000000000..a972d1c380 --- /dev/null +++ b/extra/mongodb/driver/driver.factor @@ -0,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-msg ) + +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 ( selector -- mdb-cursor/f 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 assoc -- ) +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 -- mdb-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 --git a/extra/mongodb/driver/summary.txt b/extra/mongodb/driver/summary.txt new file mode 100644 index 0000000000..2ac1f95c9c --- /dev/null +++ b/extra/mongodb/driver/summary.txt @@ -0,0 +1 @@ +A driver for the MongoDB document-oriented database (http://www.mongodb.org) diff --git a/extra/mongodb/driver/tags.txt b/extra/mongodb/driver/tags.txt new file mode 100644 index 0000000000..aa0d57e895 --- /dev/null +++ b/extra/mongodb/driver/tags.txt @@ -0,0 +1 @@ +database diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor new file mode 100644 index 0000000000..25c4c88203 --- /dev/null +++ b/extra/mongodb/mmm/mmm.factor @@ -0,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 bson.writer.private +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 \ No newline at end of file diff --git a/extra/mongodb/msg/msg.factor b/extra/mongodb/msg/msg.factor new file mode 100644 index 0000000000..dd8bae8438 --- /dev/null +++ b/extra/mongodb/msg/msg.factor @@ -0,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 --git a/extra/mongodb/operations/operations.factor b/extra/mongodb/operations/operations.factor new file mode 100644 index 0000000000..001e8443e4 --- /dev/null +++ b/extra/mongodb/operations/operations.factor @@ -0,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 --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor new file mode 100644 index 0000000000..a4f86cd6a3 --- /dev/null +++ b/extra/mongodb/tuple/collection/collection.factor @@ -0,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 --git a/extra/mongodb/tuple/index/index.factor b/extra/mongodb/tuple/index/index.factor new file mode 100644 index 0000000000..1e7a679df3 --- /dev/null +++ b/extra/mongodb/tuple/index/index.factor @@ -0,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 --git a/extra/mongodb/tuple/persistent/persistent.factor b/extra/mongodb/tuple/persistent/persistent.factor new file mode 100644 index 0000000000..061b27dd1b --- /dev/null +++ b/extra/mongodb/tuple/persistent/persistent.factor @@ -0,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 --git a/extra/mongodb/tuple/state/state.factor b/extra/mongodb/tuple/state/state.factor new file mode 100644 index 0000000000..21923637e5 --- /dev/null +++ b/extra/mongodb/tuple/state/state.factor @@ -0,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 --git a/extra/mongodb/tuple/tuple.factor b/extra/mongodb/tuple/tuple.factor new file mode 100644 index 0000000000..19281b769a --- /dev/null +++ b/extra/mongodb/tuple/tuple.factor @@ -0,0 +1,82 @@ +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 ] unless + find-one [ assoc>tuple ] [ f ] if* ; + +: select-tuples ( tuple/query -- cursor tuples/f ) + dup mdb-query-msg? [ tuple>query ] unless + find [ assoc>tuple ] map ; + +: count-tuples ( tuple/query -- n ) + dup mdb-query-msg? [ tuple>query ] unless count ;