diff --git a/basis/urls/encoding/encoding.factor b/basis/urls/encoding/encoding.factor index a5f5d62bfc..8e11dec431 100644 --- a/basis/urls/encoding/encoding.factor +++ b/basis/urls/encoding/encoding.factor @@ -37,7 +37,7 @@ IN: urls.encoding : push-utf8 ( ch -- ) 1string utf8 encode - [ CHAR: % , >hex 2 CHAR: 0 pad-head % ] each ; + [ CHAR: % , >hex >upper 2 CHAR: 0 pad-head % ] each ; PRIVATE> diff --git a/extra/bson/reader/reader.factor b/extra/bson/reader/reader.factor index 7e218fa79c..e6ae0060b6 100644 --- a/extra/bson/reader/reader.factor +++ b/extra/bson/reader/reader.factor @@ -1,6 +1,6 @@ -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 ; +USING: accessors assocs bson.constants calendar fry io io.binary +io.encodings io.encodings.utf8 kernel math math.bitwise namespaces +sequences serialize ; FROM: kernel.private => declare ; FROM: io.encodings.private => (read-until) ; @@ -44,20 +44,17 @@ 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 : read-int32 ( -- int32 ) - 4 read byte-array>number ; inline + 4 read signed-le> ; inline : read-longlong ( -- longlong ) - 8 read byte-array>number ; inline + 8 read signed-le> ; inline : read-double ( -- double ) - 8 read byte-array>number bits>double ; inline + 8 read le> bits>double ; inline : read-byte-raw ( -- byte-raw ) 1 read ; inline diff --git a/extra/bson/writer/writer.factor b/extra/bson/writer/writer.factor index 5d850929ab..f9bd0eb392 100644 --- a/extra/bson/writer/writer.factor +++ b/extra/bson/writer/writer.factor @@ -75,24 +75,23 @@ M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; : write-utf8-string ( string -- ) output-stream get '[ _ swap char>utf8 ] each ; inline -: write-byte ( byte -- ) CHAR-SIZE >le write ; inline : write-int32 ( int -- ) INT32-SIZE >le write ; inline : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline -: write-cstring ( string -- ) write-utf8-string 0 write-byte ; inline +: write-cstring ( string -- ) write-utf8-string 0 write1 ; inline : write-longlong ( object -- ) INT64-SIZE >le write ; inline -: write-eoo ( -- ) T_EOO write-byte ; inline -: write-type ( obj -- obj ) [ bson-type? write-byte ] keep ; inline +: write-eoo ( -- ) T_EOO write1 ; inline +: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline : write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline M: string bson-write ( obj -- ) '[ _ write-cstring ] with-length-prefix-excl ; M: f bson-write ( f -- ) - drop 0 write-byte ; + drop 0 write1 ; M: t bson-write ( t -- ) - drop 1 write-byte ; + drop 1 write1 ; M: integer bson-write ( num -- ) write-int32 ; @@ -105,7 +104,7 @@ M: timestamp bson-write ( timestamp -- ) M: byte-array bson-write ( binary -- ) [ length write-int32 ] keep - T_Binary_Bytes write-byte + T_Binary_Bytes write1 write ; M: oid bson-write ( oid -- ) @@ -134,7 +133,7 @@ M: assoc bson-write ( assoc -- ) : (serialize-code) ( code -- ) object>bytes [ length write-int32 ] keep - T_Binary_Custom write-byte + T_Binary_Custom write1 write ; M: quotation bson-write ( quotation -- ) diff --git a/extra/mongodb/benchmark/benchmark.factor b/extra/mongodb/benchmark/benchmark.factor index 5204846d03..ad8c501605 100644 --- a/extra/mongodb/benchmark/benchmark.factor +++ b/extra/mongodb/benchmark/benchmark.factor @@ -163,7 +163,7 @@ CONSTANT: DOC-LARGE H{ { "base_url" "http://www.example.com/test-me" } [ create-collection ] keep ; : prepare-index ( collection -- ) - "_x_idx" [ "x" asc ] key-spec unique-index ensure-index ; + "_x_idx" [ "x" asc ] key-spec t >>unique? ensure-index ; : insert ( doc-quot: ( i -- doc ) -- quot: ( -- ) ) prepare-collection diff --git a/extra/mongodb/connection/connection.factor b/extra/mongodb/connection/connection.factor index 7477ee5486..af54f2ebc5 100644 --- a/extra/mongodb/connection/connection.factor +++ b/extra/mongodb/connection/connection.factor @@ -1,6 +1,6 @@ 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 +constructors sequences splitting checksums checksums.md5 io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart arrays hashtables sequences.deep vectors locals ; @@ -39,16 +39,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ; mdb-connection get instance>> ; inline : index-collection ( -- ns ) - mdb-instance name>> "%s.system.indexes" sprintf ; inline + mdb-instance name>> "system.indexes" 2array "." join ; inline : namespaces-collection ( -- ns ) - mdb-instance name>> "%s.system.namespaces" sprintf ; inline + mdb-instance name>> "system.namespaces" 2array "." join ; inline : cmd-collection ( -- ns ) - mdb-instance name>> "%s.$cmd" sprintf ; inline + mdb-instance name>> "$cmd" 2array "." join ; inline : index-ns ( colname -- index-ns ) - [ mdb-instance name>> ] dip "%s.%s" sprintf ; inline + [ mdb-instance name>> ] dip 2array "." join ; inline : send-message ( message -- ) [ mdb-connection get handle>> ] dip '[ _ write-message ] with-stream* ; diff --git a/extra/mongodb/driver/driver-docs.factor b/extra/mongodb/driver/driver-docs.factor index 7dbf564df9..e8f726374c 100644 --- a/extra/mongodb/driver/driver-docs.factor +++ b/extra/mongodb/driver/driver-docs.factor @@ -131,7 +131,7 @@ HELP: ensure-index "\"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" "" } } ; + "\"db\" \"127.0.0.1\" 27017 " "[ \"mycollection\" nameIdx [ \"name\" asc ] keyspec t >>unique? ensure-index ] with-db" "" } } ; HELP: explain. { $values diff --git a/extra/mongodb/driver/driver.factor b/extra/mongodb/driver/driver.factor index 967d4f11c5..48f0aef4ff 100644 --- a/extra/mongodb/driver/driver.factor +++ b/extra/mongodb/driver/driver.factor @@ -1,8 +1,8 @@ -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 ; +USING: accessors arrays assocs bson.constants combinators +combinators.smart constructors destructors formatting fry hashtables +io io.pools io.sockets kernel linked-assocs math mongodb.connection +mongodb.msg parser prettyprint sequences sets splitting strings +tools.continuations uuid memoize locals ; IN: mongodb.driver @@ -23,9 +23,6 @@ TUPLE: index-spec CONSTRUCTOR: index-spec ( ns name key -- index-spec ) ; -: unique-index ( index-spec -- index-spec ) - t >>unique? ; - M: mdb-pool make-connection mdb>> mdb-open ; @@ -83,6 +80,15 @@ M: mdb-getmore-msg verify-query-result [ make-cursor ] 2tri swap objects>> ; +: make-collection-assoc ( collection assoc -- ) + [ [ 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 ; + PRIVATE> SYNTAX: r/ ( token -- mdbregexp ) @@ -100,23 +106,17 @@ SYNTAX: r/ ( token -- mdbregexp ) H{ } clone [ set-at ] keep [ verify-nodes ] keep ; -GENERIC: create-collection ( name -- ) +GENERIC: create-collection ( name/collection -- ) 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 ; - + [ [ cmd-collection ] dip + [ make-collection-assoc ] keep + 1 >>return# send-query-plain drop ] keep + [ ] [ name>> ] bi mdb-instance collections>> set-at ; + : load-collection-list ( -- collection-list ) namespaces-collection H{ } clone send-query-plain objects>> ; @@ -125,27 +125,36 @@ M: mdb-collection create-collection : ensure-valid-collection-name ( collection -- ) [ ";$." intersect length 0 > ] keep - '[ _ "%s contains invalid characters ( . $ ; )" sprintf throw ] when ; inline + '[ _ "contains invalid characters ( . $ ; )" 2array "." join 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 ; +: build-collection-map ( -- assoc ) + H{ } clone load-collection-list + [ [ "name" ] dip at "." split second ] map + over '[ [ ] [ name>> ] bi _ set-at ] each ; +: ensure-collection-map ( mdb-instance -- assoc ) + dup collections>> dup keys length 0 = + [ drop build-collection-map [ >>collections drop ] keep ] + [ nip ] if ; + +: (ensure-collection) ( collection mdb-instance -- collection ) + ensure-collection-map [ dup ] dip key? + [ ] [ [ ensure-valid-collection-name ] + [ create-collection ] + [ ] tri ] 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 ; + [let* | instance [ mdb-instance ] + instance-name [ instance name>> ] | + dup mdb-collection? [ name>> ] when + "." split1 over instance-name = + [ nip ] [ drop ] if + [ ] [ reserved-namespace? ] bi + [ instance (ensure-collection) ] unless + [ instance-name ] dip 2array "." join ] ; : fix-query-collection ( mdb-query -- mdb-query ) [ check-collection ] change-collection ; inline diff --git a/extra/mongodb/tuple/collection/collection.factor b/extra/mongodb/tuple/collection/collection.factor index 60b2d25764..6c2b89a571 100644 --- a/extra/mongodb/tuple/collection/collection.factor +++ b/extra/mongodb/tuple/collection/collection.factor @@ -88,7 +88,7 @@ GENERIC: mdb-index-map ( tuple -- sequence ) : user-defined-key-index ( class -- assoc ) mdb-slot-map user-defined-key [ drop [ "user-defined-key-index" 1 ] dip - H{ } clone [ set-at ] keep unique-index + H{ } clone [ set-at ] keep t >>unique? [ ] [ name>> ] bi H{ } clone [ set-at ] keep ] [ 2drop H{ } clone ] if ;