Skip to content
This repository
Browse code

added gridfs implementation, reworked mongodb commands, some minor pe…

…rformance improvements
  • Loading branch information...
commit 25ee2dbd0ee8e33dc5df9a61775f5d5343ffd631 1 parent be0655d
Sascha Matzke authored
7  extra/bson/bson-tests.factor
... ...
@@ -1,4 +1,4 @@
1  
-USING: bson.reader bson.writer byte-arrays io.encodings.binary
  1
+USING: bson.reader bson.writer bson.constants byte-arrays io.encodings.binary
2 2
 io.streams.byte-array tools.test literals calendar kernel math ;
3 3
 
4 4
 IN: bson.tests
@@ -17,6 +17,9 @@ IN: bson.tests
17 17
 [ H{ { "a quotation" [ 1 2 + ] } } ]
18 18
 [ H{ { "a quotation" [ 1 2 + ] } } turnaround ] unit-test
19 19
 
  20
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } ]
  21
+[ H{ { "ref" T{ dbref f "a" "b" "c" } } } turnaround ] unit-test
  22
+
20 23
 [ H{ { "a date" T{ timestamp { year 2009 }
21 24
                    { month 7 }
22 25
                    { day 11 }
@@ -34,10 +37,12 @@ IN: bson.tests
34 37
 ] unit-test
35 38
                    
36 39
 [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
  40
+     { "ref" T{ dbref f "a" "b" "c" } }
37 41
      { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
38 42
      { "quot" [ 1 2 + ] } }
39 43
 ]     
40 44
 [ H{ { "nested" H{ { "a" "a string" } { "b" H{ { "a" "a string" } } } } }
  45
+     { "ref" T{ dbref f "a" "b" "c" } }
41 46
      { "array" H{ { "a list" { 1 2.234 "hello world" } } } }
42 47
      { "quot" [ 1 2 + ] } } turnaround ] unit-test
43 48
      
2  extra/bson/bson.factor
... ...
@@ -1,3 +1,5 @@
  1
+! Copyright (C) 2010 Sascha Matzke.
  2
+! See http://factorcode.org/license.txt for BSD license.
1 3
 USING: vocabs.loader ;
2 4
 
3 5
 IN: bson
35  extra/bson/constants/constants.factor
... ...
@@ -1,5 +1,8 @@
1  
-USING: accessors constructors kernel strings uuid ;
2  
-
  1
+! Copyright (C) 2010 Sascha Matzke.
  2
+! See http://factorcode.org/license.txt for BSD license.
  3
+USING: accessors assocs calendar combinators
  4
+combinators.short-circuit constructors kernel linked-assocs
  5
+math math.bitwise random strings uuid ;
3 6
 IN: bson.constants
4 7
 
5 8
 : <objid> ( -- objid )
@@ -7,9 +10,33 @@ IN: bson.constants
7 10
 
8 11
 TUPLE: oid { a initial: 0 } { b initial: 0 } ;
9 12
 
10  
-TUPLE: objref ns objid ;
  13
+: <oid> ( -- oid )
  14
+    oid new
  15
+    now timestamp>micros >>a
  16
+    8 random-bits 16 shift HEX: FF0000 mask
  17
+    16 random-bits HEX: FFFF mask
  18
+    bitor >>b ;
  19
+
  20
+TUPLE: dbref ref id db ;
  21
+
  22
+CONSTRUCTOR: dbref ( ref id -- dbref ) ;
  23
+
  24
+: dbref>assoc ( dbref -- assoc )
  25
+    [ <linked-hash> ] dip over
  26
+    {
  27
+        [ [ ref>> "$ref" ] [ set-at ] bi* ]
  28
+        [ [ id>> "$id" ] [ set-at ] bi* ]
  29
+        [ over db>> [
  30
+                [ db>> "$db" ] [ set-at ] bi*
  31
+            ] [ 2drop ] if ]
  32
+    } 2cleave ; inline
  33
+
  34
+: assoc>dbref ( assoc -- dbref )
  35
+    [ "$ref" swap at ] [ "$id" swap at ] [ "$db" swap at ] tri
  36
+    dbref boa ; inline
11 37
 
12  
-CONSTRUCTOR: objref ( ns objid -- objref ) ;
  38
+: dbref-assoc? ( assoc -- ? )
  39
+    { [ "$ref" swap key? ] [ "$id" swap key? ] } 1&& ; inline
13 40
 
14 41
 TUPLE: mdbregexp { regexp string } { options string } ;
15 42
 
173  extra/bson/reader/reader.factor
... ...
@@ -1,10 +1,10 @@
1  
-USING: accessors assocs bson.constants calendar fry io io.binary
2  
-io.encodings io.encodings.utf8 kernel math math.bitwise namespaces
3  
-sequences serialize locals ;
4  
-
5  
-FROM: kernel.private => declare ;
6  
-FROM: io.encodings.private => (read-until) ;
7  
-
  1
+! Copyright (C) 2010 Sascha Matzke.
  2
+! See http://factorcode.org/license.txt for BSD license.
  3
+USING: accessors assocs bson.constants calendar combinators
  4
+combinators.short-circuit fry io io.binary kernel locals math
  5
+namespaces sequences serialize tools.continuations strings ;
  6
+FROM: io.encodings.binary => binary ;
  7
+FROM: io.streams.byte-array => with-byte-reader ;
8 8
 IN: bson.reader
9 9
 
10 10
 <PRIVATE
@@ -40,10 +40,6 @@ PREDICATE: bson-binary-function < integer T_Binary_Function = ;
40 40
 PREDICATE: bson-binary-uuid < integer T_Binary_UUID = ;
41 41
 PREDICATE: bson-binary-custom < integer T_Binary_Custom = ;
42 42
 
43  
-GENERIC: element-read ( type -- cont? )
44  
-GENERIC: element-data-read ( type -- object )
45  
-GENERIC: element-binary-read ( length type -- object )
46  
-
47 43
 : get-state ( -- state )
48 44
     state get ; inline
49 45
 
@@ -57,16 +53,16 @@ GENERIC: element-binary-read ( length type -- object )
57 53
     8 read le> bits>double ; inline
58 54
 
59 55
 : read-byte-raw ( -- byte-raw )
60  
-    1 read ; inline
  56
+    1 read ;
61 57
 
62 58
 : read-byte ( -- byte )
63 59
     read-byte-raw first ; inline
64 60
 
65 61
 : read-cstring ( -- string )
66  
-    "\0" read-until drop "" like ; inline
  62
+    "\0" read-until drop >string ; inline
67 63
 
68 64
 : read-sized-string ( length -- string )
69  
-    read 1 head-slice* "" like ; inline
  65
+    read 1 head-slice* >string ; inline
70 66
 
71 67
 : read-element-type ( -- type )
72 68
     read-byte ; inline
@@ -80,106 +76,75 @@ GENERIC: element-binary-read ( length type -- object )
80 76
 : peek-scope ( -- ht )
81 77
     get-state scope>> last ; inline
82 78
 
83  
-: read-elements ( -- )
84  
-    read-element-type
85  
-    element-read 
86  
-    [ read-elements ] when ; inline recursive
87  
-
88  
-GENERIC: fix-result ( assoc type -- result )
89  
-
90  
-M: bson-object fix-result ( assoc type -- result )
91  
-    drop ;
92  
-
93  
-M: bson-array fix-result ( assoc type -- result )
94  
-    drop values ;
95  
-
96  
-GENERIC: end-element ( type -- )
97  
-
98  
-M: bson-object end-element ( type -- )
99  
-    drop ;
100  
-
101  
-M: bson-array end-element ( type -- )
102  
-    drop ;
103  
-
104  
-M: object end-element ( type -- )
105  
-    pop-element 2drop ;
106  
-
107  
-M:: bson-eoo element-read ( type -- cont? )
  79
+: bson-object-data-read ( -- object )
  80
+    read-int32 drop get-state 
  81
+    [ exemplar>> clone ] [ scope>> ] bi
  82
+    [ push ] keep ; inline
  83
+
  84
+: bson-binary-read ( -- binary )
  85
+   read-int32 read-byte 
  86
+   bson-binary-bytes? [ read ] [ read bytes>object ] if ; inline
  87
+
  88
+: bson-regexp-read ( -- mdbregexp )
  89
+   mdbregexp new
  90
+   read-cstring >>regexp read-cstring >>options ; inline
  91
+
  92
+: bson-oid-read ( -- oid )
  93
+    read-longlong read-int32 oid boa ; inline
  94
+
  95
+: element-data-read ( type -- object )
  96
+    {
  97
+        { T_OID [ bson-oid-read ] }
  98
+        { T_String [ read-int32 read-sized-string ] }
  99
+        { T_Integer [ read-int32 ] }
  100
+        { T_Binary [ bson-binary-read ] }
  101
+        { T_Object [ bson-object-data-read ] }
  102
+        { T_Array [ bson-object-data-read ] }
  103
+        { T_Double [ read-double ] }
  104
+        { T_Boolean [ read-byte 1 = ] }
  105
+        { T_Date [ read-longlong millis>timestamp ] }
  106
+        { T_Regexp [ bson-regexp-read ] }
  107
+        { T_NULL [ f ] }
  108
+    } case ; inline
  109
+
  110
+: fix-result ( assoc type -- result )
  111
+    {
  112
+        { [ dup T_Array = ] [ drop values ] }
  113
+        {
  114
+            [ dup T_Object = ]
  115
+            [ drop dup dbref-assoc? [ assoc>dbref ] when ]
  116
+        }
  117
+    } cond ; inline
  118
+
  119
+: end-element ( type -- )
  120
+    { [ bson-object? ] [ bson-array? ] } 1||
  121
+    [ pop-element drop ] unless ; inline
  122
+
  123
+:: bson-eoo-element-read ( type -- cont? )
108 124
     pop-element :> element
109 125
     get-state scope>>
110 126
     [ pop element type>> fix-result ] [ empty? ] bi
111 127
     [ [ get-state ] dip >>result drop f ]
112  
-    [ element name>> peek-scope set-at t ] if ;
  128
+    [ element name>> peek-scope set-at t ] if ; inline
113 129
 
114  
-M:: bson-not-eoo element-read ( type -- cont? )
  130
+:: bson-not-eoo-element-read ( type -- cont? )
115 131
     peek-scope :> scope
116 132
     type read-cstring [ push-element ] 2keep
117 133
     [ [ element-data-read ] [ end-element ] bi ]
118  
-    [ scope set-at t ] bi* ;
119  
-
120  
-: [scope-changer] ( state -- state quot )
121  
-    dup exemplar>> '[ [ [ _ clone ] dip push ] keep ] ; inline
122  
-
123  
-: (object-data-read) ( type -- object )
124  
-    drop
125  
-    read-int32 drop
126  
-    get-state
127  
-    [scope-changer] change-scope
128  
-    scope>> last ; inline
129  
-    
130  
-M: bson-object element-data-read ( type -- object )
131  
-    (object-data-read) ;
132  
-
133  
-M: bson-string element-data-read ( type -- object )
134  
-    drop
135  
-    read-int32 read-sized-string ;
136  
-
137  
-M: bson-array element-data-read ( type -- object )
138  
-    (object-data-read) ;
139  
-    
140  
-M: bson-integer element-data-read ( type -- object )
141  
-    drop
142  
-    read-int32 ;
143  
-
144  
-M: bson-double element-data-read ( type -- double )
145  
-    drop
146  
-    read-double ;
147  
-
148  
-M: bson-boolean element-data-read ( type -- boolean )
149  
-   drop
150  
-   read-byte 1 = ;
151  
-
152  
-M: bson-date element-data-read ( type -- timestamp )
153  
-   drop
154  
-   read-longlong millis>timestamp ;
155  
-
156  
-M: bson-binary element-data-read ( type -- binary )
157  
-   drop
158  
-   read-int32 read-byte element-binary-read ;
159  
-
160  
-M: bson-regexp element-data-read ( type -- mdbregexp )
161  
-   drop mdbregexp new
162  
-   read-cstring >>regexp read-cstring >>options ;
163  
- 
164  
-M: bson-null element-data-read ( type -- bf  )
165  
-    drop f ;
166  
-
167  
-M: bson-oid element-data-read ( type -- oid )
168  
-    drop
169  
-    read-longlong
170  
-    read-int32 oid boa ;
171  
-
172  
-M: bson-binary-bytes element-binary-read ( size type -- bytes )
173  
-    drop read ;
174  
-
175  
-M: bson-binary-custom element-binary-read ( size type -- quot )
176  
-    drop read bytes>object ;
  134
+    [ scope set-at t ] bi* ; inline
177 135
 
178  
-PRIVATE>
  136
+: (element-read) ( type -- cont? )
  137
+    dup bson-not-eoo? 
  138
+    [ bson-not-eoo-element-read ]
  139
+    [ bson-eoo-element-read ] if ; inline
179 140
 
180  
-USE: tools.continuations
  141
+: read-elements ( -- )
  142
+    read-element-type
  143
+    (element-read) [ read-elements ] when ; inline recursive
  144
+
  145
+PRIVATE>
181 146
 
182 147
 : stream>assoc ( exemplar -- assoc )
183 148
     <state> dup state
184  
-    [ read-int32 >>size read-elements ] with-variable 
185  
-    result>> ; 
  149
+    [ read-int32 >>size read-elements ] with-variable
  150
+    result>> ; inline
2  extra/bson/summary.txt
... ...
@@ -1 +1 @@
1  
-BSON reader and writer
  1
+BSON (http://en.wikipedia.org/wiki/BSON) reader and writer
229  extra/bson/writer/writer.factor
... ...
@@ -1,154 +1,153 @@
1  
-! Copyright (C) 2008 Sascha Matzke.
  1
+! Copyright (C) 2010 Sascha Matzke.
2 2
 ! See http://factorcode.org/license.txt for BSD license.
3  
-USING: accessors assocs bson.constants byte-arrays byte-vectors
4  
-calendar fry io io.binary io.encodings io.encodings.binary
5  
-io.encodings.utf8 io.streams.byte-array kernel math math.parser
6  
-namespaces quotations sequences sequences.private serialize strings
7  
-words combinators.short-circuit literals ;
8  
-
9  
-FROM: io.encodings.utf8.private => char>utf8 ;
10  
-FROM: kernel.private => declare ;
11  
-
  3
+USING: accessors arrays assocs bson.constants byte-arrays
  4
+calendar combinators.short-circuit fry hashtables io io.binary
  5
+kernel linked-assocs literals math math.parser namespaces
  6
+quotations sequences serialize strings vectors dlists alien.accessors ;
  7
+FROM: words => word? word ;
  8
+FROM: typed => TYPED: ;
  9
+FROM: combinators => cond ;
12 10
 IN: bson.writer
13 11
 
14 12
 <PRIVATE
15 13
 
16  
-SYMBOL: shared-buffer 
17  
-
18 14
 CONSTANT: CHAR-SIZE  1
19 15
 CONSTANT: INT32-SIZE 4
20 16
 CONSTANT: INT64-SIZE 8
21 17
 
22  
-: (buffer) ( -- buffer )
23  
-    shared-buffer get
24  
-    [ BV{ } clone [ shared-buffer set ] keep ] unless*
25  
-    { byte-vector } declare ; inline 
26  
-    
27 18
 PRIVATE>
28 19
 
29  
-: reset-buffer ( buffer -- )
30  
-    0 >>length drop ; inline
31  
-
32  
-: ensure-buffer ( -- )
33  
-    (buffer) drop ; inline
34  
-
35  
-: with-buffer ( ..a quot: ( ..a -- ..b ) -- ..b byte-vector )
36  
-    [ (buffer) [ reset-buffer ] keep dup ] dip
37  
-    with-output-stream* ; inline
38  
-
39  
-: with-length ( ..a quot: ( ..a -- ..b ) -- ..b bytes-written start-index )
40  
-    [ (buffer) [ length ] keep ] dip
  20
+: with-length ( quot: ( -- ) -- bytes-written start-index )
  21
+    [ output-stream get [ length ] [ ] bi ] dip
41 22
     call length swap [ - ] keep ; inline
42 23
 
43 24
 : (with-length-prefix) ( ..a quot: ( ..a -- ..b ) length-quot: ( bytes-written -- length ) -- ..b )
44 25
     [ [ B{ 0 0 0 0 } write ] prepose with-length ] dip swap
45  
-    [ call ] dip (buffer) copy ; inline
  26
+    [ call output-stream get underlying>> ] dip set-alien-unsigned-4 ; inline
46 27
 
47  
-: with-length-prefix ( ..a quot: ( ..a -- ..b ) -- ..b )
48  
-    [ INT32-SIZE >le ] (with-length-prefix) ; inline
  28
+: with-length-prefix ( quot: ( -- ) -- )
  29
+    [ ] (with-length-prefix) ; inline
49 30
     
50  
-: with-length-prefix-excl ( ..a quot: ( ..a -- ..b ) -- ..b )
51  
-    [ INT32-SIZE [ - ] keep >le ] (with-length-prefix) ; inline
  31
+: with-length-prefix-excl ( quot: ( -- ) -- )
  32
+    [ INT32-SIZE - ] (with-length-prefix) ; inline
52 33
     
53 34
 <PRIVATE
54 35
 
55  
-GENERIC: bson-type? ( obj -- type ) 
56  
-GENERIC: bson-write ( obj -- ) 
57  
-
58  
-M: t bson-type? ( boolean -- type ) drop T_Boolean ; 
59  
-M: f bson-type? ( boolean -- type ) drop T_Boolean ; 
60  
-
61  
-M: string bson-type? ( string -- type ) drop T_String ; 
62  
-M: integer bson-type? ( integer -- type ) drop T_Integer ; 
63  
-M: assoc bson-type? ( assoc -- type ) drop T_Object ;
64  
-M: real bson-type? ( real -- type ) drop T_Double ; 
65  
-M: tuple bson-type? ( tuple -- type ) drop T_Object ;  
66  
-M: sequence bson-type? ( seq -- type ) drop T_Array ;
67  
-M: timestamp bson-type? ( timestamp -- type ) drop T_Date ;
68  
-M: mdbregexp bson-type? ( regexp -- type ) drop T_Regexp ;
69  
-
70  
-M: oid bson-type? ( word -- type ) drop T_OID ;
71  
-M: objref bson-type? ( objref -- type ) drop T_Binary ;
72  
-M: word bson-type? ( word -- type ) drop T_Binary ;
73  
-M: quotation bson-type? ( quotation -- type ) drop T_Binary ; 
74  
-M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ; 
75  
-
76 36
 : write-int32 ( int -- ) INT32-SIZE >le write ; inline
  37
+
77 38
 : write-double ( real -- ) double>bits INT64-SIZE >le write ; inline
  39
+
78 40
 : write-cstring ( string -- ) B{ } like write 0 write1 ; inline
  41
+
79 42
 : write-longlong ( object -- ) INT64-SIZE >le write ; inline
80 43
 
81 44
 : write-eoo ( -- ) T_EOO write1 ; inline
82  
-: write-type ( obj -- obj ) [ bson-type? write1 ] keep ; inline
83  
-: write-pair ( name object -- ) write-type [ write-cstring ] dip bson-write ; inline
84  
-
85  
-M: string bson-write ( obj -- )
86  
-    '[ _ write-cstring ] with-length-prefix-excl ;
87  
-
88  
-M: f bson-write ( f -- )
89  
-    drop 0 write1 ; 
90  
-
91  
-M: t bson-write ( t -- )
92  
-    drop 1 write1 ;
93  
-
94  
-M: integer bson-write ( num -- )
95  
-    write-int32 ;
96 45
 
97  
-M: real bson-write ( num -- )
98  
-    >float write-double ;
  46
+: write-header ( name object type -- object )
  47
+    write1 [ write-cstring ] dip ; inline
99 48
 
100  
-M: timestamp bson-write ( timestamp -- )
101  
-    timestamp>millis write-longlong ;
  49
+DEFER: write-pair
102 50
 
103  
-M: byte-array bson-write ( binary -- )
104  
-    [ length write-int32 ] keep
105  
-    T_Binary_Bytes write1
106  
-    write ; 
  51
+: write-byte-array ( binary -- )
  52
+    [ length write-int32 ]
  53
+    [ T_Binary_Bytes write1 write ] bi ; inline
107 54
 
108  
-M: oid bson-write ( oid -- )
109  
-    [ a>> write-longlong ] [ b>> write-int32 ] bi ;
110  
-       
111  
-M: mdbregexp bson-write ( regexp -- )
  55
+: write-mdbregexp ( regexp -- )
112 56
    [ regexp>> write-cstring ]
113  
-   [ options>> write-cstring ] bi ; 
114  
-    
115  
-M: sequence bson-write ( array -- )
116  
-    '[ _ [ [ write-type ] dip number>string
117  
-           write-cstring bson-write ] each-index
118  
-       write-eoo ] with-length-prefix ;
119  
-
120  
-: write-oid ( assoc -- )
121  
-    [ MDB_OID_FIELD ] dip at
122  
-    [ [ MDB_OID_FIELD ] dip write-pair ] when* ; inline
123  
-
124  
-: skip-field? ( name -- boolean )
125  
-   { $[ MDB_OID_FIELD MDB_META_FIELD ] } member? ; inline
126  
-
127  
-M: assoc bson-write ( assoc -- )
128  
-    '[
129  
-        _  [ write-oid ] keep
130  
-        [ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
131  
-        write-eoo
132  
-    ] with-length-prefix ;
133  
-
134  
-: (serialize-code) ( code -- )
135  
-    object>bytes [ length write-int32 ] keep
136  
-    T_Binary_Custom write1
137  
-    write ;
  57
+   [ options>> write-cstring ] bi ; inline
138 58
 
139  
-M: quotation bson-write ( quotation -- )
140  
-    (serialize-code) ;
141  
-    
142  
-M: word bson-write ( word -- )
143  
-    (serialize-code) ;
  59
+TYPED: write-sequence ( array: sequence -- )
  60
+   '[
  61
+        _ [ number>string swap write-pair ] each-index
  62
+        write-eoo
  63
+    ] with-length-prefix ; inline recursive
  64
+
  65
+TYPED: write-oid ( oid: oid -- )
  66
+    [ a>> write-longlong ] [ b>> write-int32 ] bi ; inline
  67
+
  68
+: write-oid-field ( assoc -- )
  69
+    [ MDB_OID_FIELD dup ] dip at
  70
+    [ dup oid? [ T_OID write-header write-oid ] [ write-pair ] if ] 
  71
+    [ drop ] if* ; inline
  72
+
  73
+: skip-field? ( name value -- name value boolean )
  74
+    over { [ MDB_OID_FIELD = ] [ MDB_META_FIELD = ] } 1|| ; inline
  75
+
  76
+UNION: hashtables hashtable linked-assoc ;
  77
+
  78
+TYPED: write-assoc ( assoc: hashtables -- )
  79
+    '[ _ [ write-oid-field ] [
  80
+            [ skip-field? [ 2drop ] [ write-pair ] if ] assoc-each 
  81
+         ] bi write-eoo
  82
+    ] with-length-prefix ; inline recursive
  83
+
  84
+UNION: code word quotation ;
  85
+
  86
+TYPED: (serialize-code) ( code: code -- )
  87
+  object>bytes 
  88
+  [ length write-int32 ]
  89
+  [ T_Binary_Custom write1 write ] bi ; inline
  90
+
  91
+TYPED: write-string ( string: string -- )
  92
+    '[ _ write-cstring ] with-length-prefix-excl ; inline
  93
+
  94
+TYPED: write-boolean ( bool: boolean -- )
  95
+    [ 1 write1 ] [ 0 write1 ] if ; inline
  96
+
  97
+: write-pair ( name obj -- )
  98
+    {
  99
+        {
  100
+            [ dup { [ hashtable? ] [ linked-assoc? ] } 1|| ]
  101
+            [ T_Object write-header write-assoc ]
  102
+        } {
  103
+            [ dup { [ array? ] [ vector? ] [ dlist? ] } 1|| ]
  104
+            [ T_Array write-header write-sequence ]
  105
+        } {
  106
+            [ dup byte-array? ]
  107
+            [ T_Binary write-header write-byte-array ]
  108
+        } {
  109
+            [ dup string? ]
  110
+            [ T_String write-header write-string ]
  111
+        } {
  112
+            [ dup oid? ]
  113
+            [ T_OID write-header write-oid ]
  114
+        } {
  115
+            [ dup integer? ]
  116
+            [ T_Integer write-header write-int32 ]
  117
+        } {
  118
+            [ dup boolean? ] 
  119
+            [ T_Boolean write-header write-boolean ]
  120
+        } {
  121
+            [ dup real? ]
  122
+            [ T_Double write-header >float write-double ]
  123
+        } {
  124
+            [ dup timestamp? ]
  125
+            [ T_Date write-header timestamp>millis write-longlong ]
  126
+        } {
  127
+            [ dup mdbregexp? ]
  128
+            [ T_Regexp write-header write-mdbregexp ]
  129
+        } {
  130
+            [ dup quotation? ]
  131
+            [ T_Binary write-header (serialize-code) ]
  132
+        } {
  133
+            [ dup word? ]
  134
+            [ T_Binary write-header (serialize-code) ]
  135
+        } {
  136
+            [ dup dbref? ]
  137
+            [ T_Object write-header dbref>assoc write-assoc ]
  138
+        } {
  139
+            [ dup f = ]
  140
+            [ T_NULL write-header drop ]
  141
+        }
  142
+    } cond ;
144 143
 
145 144
 PRIVATE>
146 145
 
147  
-: assoc>bv ( assoc -- byte-vector )
148  
-    [ '[ _ bson-write ] with-buffer ] with-scope ; inline
  146
+TYPED: assoc>bv ( assoc: hashtables -- byte-vector )
  147
+    [ BV{  } clone dup ] dip '[ _ write-assoc ] with-output-stream* ; inline
149 148
 
150  
-: assoc>stream ( assoc -- )
151  
-    { assoc } declare bson-write ; inline
  149
+TYPED: assoc>stream ( assoc: hashtables -- )
  150
+    write-assoc ; inline
152 151
 
153 152
 : mdb-special-value? ( value -- ? )
154 153
    { [ timestamp? ] [ quotation? ] [ mdbregexp? ]
132  extra/mongodb/cmd/cmd.factor
... ...
@@ -0,0 +1,132 @@
  1
+USING: accessors assocs hashtables kernel linked-assocs strings ;
  2
+IN: mongodb.cmd
  3
+
  4
+<PRIVATE
  5
+
  6
+TUPLE: mongodb-cmd 
  7
+    { name string }
  8
+    { const? boolean }
  9
+    { admin? boolean }
  10
+    { auth? boolean }
  11
+    { assoc assoc }
  12
+    { norep? boolean } ;
  13
+
  14
+PRIVATE>
  15
+
  16
+CONSTANT: buildinfo-cmd 
  17
+    T{ mongodb-cmd f "buildinfo" t t f H{ { "buildinfo" 1 } } }
  18
+
  19
+CONSTANT: list-databases-cmd
  20
+    T{ mongodb-cmd f "listDatabases" t t f H{ { "listDatabases" 1 } } }
  21
+
  22
+! Options: { "async" t }
  23
+CONSTANT: fsync-cmd
  24
+    T{ mongodb-cmd f "fsync" f t f H{ { "fsync" 1 } } }
  25
+
  26
+! Value: { "clone" from_host }
  27
+CONSTANT: clone-db-cmd
  28
+    T{ mongodb-cmd f "clone" f f t H{ { "clone" f } } }
  29
+
  30
+! Options { { "fromdb" db } { "todb" db } { fromhost host } }
  31
+CONSTANT: copy-db-cmd
  32
+    T{ mongodb-cmd f "copydb" f f f H{ { "copydb" 1 } } }
  33
+
  34
+CONSTANT: shutdown-cmd
  35
+    T{ mongodb-cmd f "shutdown" t t t H{ { "shutdown" 1 } } t }
  36
+
  37
+CONSTANT: reseterror-cmd
  38
+    T{ mongodb-cmd f "reseterror" t f f H{ { "reseterror" 1 } } }
  39
+
  40
+CONSTANT: getlasterror-cmd
  41
+    T{ mongodb-cmd f "getlasterror" t f f H{ { "getlasterror" 1 } } }
  42
+
  43
+CONSTANT: getpreverror-cmd
  44
+    T{ mongodb-cmd f "getpreverror" t f f H{ { "getpreverror" 1 } } }
  45
+
  46
+CONSTANT: forceerror-cmd
  47
+    T{ mongodb-cmd f "forceerror" t f f H{ { "forceerror" 1 } } }
  48
+
  49
+CONSTANT: drop-db-cmd
  50
+    T{ mongodb-cmd f "dropDatabase" t f f H{ { "dropDatabase" 1 } } }
  51
+
  52
+! Options { { "preserveClonedFilesOnFailure" t/f } { "backupOriginalFiles" t/f } }
  53
+CONSTANT: repair-db-cmd
  54
+    T{ mongodb-cmd f "repairDatabase" f f f H{ { "repairDatabase" 1 } } }
  55
+
  56
+! Options: -1 gets the current profile level; 0-2 set the profile level
  57
+CONSTANT: profile-cmd 
  58
+    T{ mongodb-cmd f "profile" f f f H{ { "profile" 0 } } }
  59
+
  60
+CONSTANT: server-status-cmd
  61
+    T{ mongodb-cmd f "serverStatus" t f f H{ { "serverStatus" 1 } } }
  62
+
  63
+CONSTANT: assertinfo-cmd
  64
+    T{ mongodb-cmd f "assertinfo" t f f H{ { "assertinfo" 1 } } }
  65
+
  66
+CONSTANT: getoptime-cmd
  67
+    T{ mongodb-cmd f "getoptime" t f f H{ { "getoptime" 1 } } }
  68
+
  69
+CONSTANT: oplog-cmd
  70
+    T{ mongodb-cmd f "opLogging" t f f H{ { "opLogging" 1 } } }
  71
+
  72
+! Value: { "deleteIndexes" collection-name }
  73
+! Options: { "index" index_name or "*" }
  74
+CONSTANT: delete-index-cmd
  75
+    T{ mongodb-cmd f "deleteIndexes" f f f H{ { "deleteIndexes" f } } }
  76
+
  77
+! Value: { "create" collection-name }
  78
+! Options: { { "capped" t } { "size" size_in_bytes } { "max" max_number_of_objects } { "autoIndexId" t/f } }
  79
+CONSTANT: create-cmd
  80
+    T{ mongodb-cmd f "drop" f f f H{ { "create" f } } }
  81
+
  82
+! Value { "drop" collection-name }
  83
+CONSTANT: drop-cmd
  84
+    T{ mongodb-cmd f "drop" f f f H{ { "drop" f } } }
  85
+
  86
+! Value { "count" collection-name }
  87
+! Options: { "query" query-object }
  88
+CONSTANT: count-cmd
  89
+    T{ mongodb-cmd f "count" f f f H{ { "count" f } } }
  90
+
  91
+! Value { "validate" collection-name }
  92
+CONSTANT: validate-cmd
  93
+    T{ mongodb-cmd f "validate" f f f H{ { "validate" f } } }
  94
+
  95
+! Value { "collstats" collection-name }
  96
+CONSTANT: collstats-cmd
  97
+    T{ mongodb-cmd f "collstats" f f f H{ { "collstats" f } } }
  98
+
  99
+! Value: { "distinct" collection-name }
  100
+! Options: { "key" key-name }
  101
+CONSTANT: distinct-cmd
  102
+    T{ mongodb-cmd f "distinct" f f f H{ { "distinct" f } } }
  103
+
  104
+! Value: { "filemd5" oid }
  105
+! Options: { "root" bucket-name }
  106
+CONSTANT: filemd5-cmd
  107
+    T{ mongodb-cmd f "filemd5" f f f H{ { "filemd5" f } } }
  108
+
  109
+CONSTANT: getnonce-cmd
  110
+    T{ mongodb-cmd f "getnonce" t f f H{ { "getnonce" 1 } } }
  111
+
  112
+! Options: { { "user" username } { "nonce" nonce } { "key" digest } }
  113
+CONSTANT: authenticate-cmd
  114
+    T{ mongodb-cmd f "authenticate" f f f H{ { "authenticate" 1 } } }
  115
+
  116
+CONSTANT: logout-cmd
  117
+    T{ mongodb-cmd f "logout" t f f H{ { "logout" 1 } } }
  118
+
  119
+! Value: { "findandmodify" collection-name }
  120
+! Options: { { "query" selector } { "sort" sort-spec } 
  121
+!            { "remove" t/f } { "update" modified-object } 
  122
+!            { "new" t/f } }
  123
+CONSTANT: findandmodify-cmd
  124
+    T{ mongodb-cmd f "findandmodify" f f f H{ { "findandmodify" f } } }
  125
+
  126
+: make-cmd ( cmd-stub -- cmd-assoc )
  127
+    dup const?>> [  ] [  
  128
+        clone [ clone <linked-assoc> ] change-assoc
  129
+    ] if ; inline
  130
+
  131
+: set-cmd-opt ( cmd value key -- cmd )
  132
+    pick assoc>> set-at ; inline
55  extra/mongodb/connection/connection.factor
... ...
@@ -1,9 +1,9 @@
1  
-USING: accessors assocs fry io.encodings.binary io.sockets kernel math
2  
-math.parser mongodb.msg mongodb.operations namespaces destructors
3  
-constructors sequences splitting checksums checksums.md5 
4  
-io.streams.duplex io.encodings.utf8 io.encodings.string combinators.smart
5  
-arrays hashtables sequences.deep vectors locals ;
6  
-
  1
+USING: accessors arrays assocs byte-vectors checksums
  2
+checksums.md5 constructors destructors fry hashtables
  3
+io.encodings.binary io.encodings.string io.encodings.utf8
  4
+io.sockets io.streams.duplex kernel locals math math.parser
  5
+mongodb.cmd mongodb.msg namespaces sequences
  6
+splitting ;
7 7
 IN: mongodb.connection
8 8
 
9 9
 : md5-checksum ( string -- digest )
@@ -15,7 +15,12 @@ TUPLE: mdb-node master? { address inet } remote ;
15 15
 
16 16
 CONSTRUCTOR: mdb-node ( address master? -- mdb-node ) ;
17 17
 
18  
-TUPLE: mdb-connection instance node handle remote local ;
  18
+TUPLE: mdb-connection instance node handle remote local buffer ;
  19
+
  20
+: connection-buffer ( -- buffer )
  21
+    mdb-connection get buffer>> 0 >>length ; inline
  22
+
  23
+USE: mongodb.operations
19 24
 
20 25
 CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
21 26
 
@@ -33,7 +38,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
33 38
     nodes>> f swap at ;
34 39
 
35 40
 : with-connection ( connection quot -- * )
36  
-    [ mdb-connection set ] prepose with-scope ; inline
  41
+    [ mdb-connection ] dip with-variable ; inline
37 42
     
38 43
 : mdb-instance ( -- mdb )
39 44
     mdb-connection get instance>> ; inline
@@ -44,8 +49,9 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
44 49
 : namespaces-collection ( -- ns )
45 50
     mdb-instance name>> "system.namespaces" "." glue ; inline
46 51
 
47  
-: cmd-collection ( -- ns )
48  
-    mdb-instance name>> "$cmd" "." glue ; inline
  52
+: cmd-collection ( cmd -- ns )
  53
+    admin?>> [ "admin"  ] [ mdb-instance name>> ] if
  54
+    "$cmd" "." glue ; inline
49 55
 
50 56
 : index-ns ( colname -- index-ns )
51 57
     [ mdb-instance name>> ] dip "." glue ; inline
@@ -58,15 +64,16 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
58 64
     '[ _ write-message read-message ] with-stream* ;
59 65
 
60 66
 : send-query-1result ( collection assoc -- result )
61  
-    <mdb-query-msg>
62  
-        1 >>return#
63  
-    send-query-plain objects>>
64  
-    [ f ] [ first ] if-empty ;
  67
+    <mdb-query-msg> -1 >>return# send-query-plain
  68
+    objects>> [ f ] [ first ] if-empty ;
  69
+
  70
+: send-cmd ( cmd -- result )
  71
+    [ cmd-collection ] [ assoc>> ] bi send-query-1result ; inline
65 72
 
66 73
 <PRIVATE
67 74
 
68 75
 : get-nonce ( -- nonce )
69  
-    cmd-collection H{ { "getnonce" 1 } } send-query-1result 
  76
+    getnonce-cmd make-cmd send-cmd
70 77
     [ "nonce" swap at ] [ f ] if* ;
71 78
 
72 79
 : auth? ( mdb -- ? )
@@ -78,16 +85,14 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
78 85
     [ pwd-digest>> ] bi
79 86
     3array concat md5-checksum ; inline
80 87
 
81  
-: build-auth-query ( -- query-assoc )
82  
-    { "authenticate" 1 }
83  
-    "user"  mdb-instance username>> 2array
84  
-    "nonce" get-nonce 2array
85  
-    3array >hashtable
86  
-    [ [ "nonce" ] dip at calculate-key-digest "key" ] keep
87  
-    [ set-at ] keep ; 
  88
+: build-auth-cmd ( cmd -- cmd )
  89
+    mdb-instance username>> "user" set-cmd-opt
  90
+    get-nonce [ "nonce" set-cmd-opt ] [ ] bi
  91
+    calculate-key-digest "key" set-cmd-opt ; inline
88 92
     
89 93
 : perform-authentication ( --  )
90  
-    cmd-collection build-auth-query send-query-1result
  94
+    authenticate-cmd make-cmd
  95
+    build-auth-cmd send-cmd
91 96
     check-ok [ drop ] [ throw ] if ; inline
92 97
 
93 98
 : authenticate-connection ( mdb-connection -- )
@@ -98,7 +103,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
98 103
 : open-connection ( mdb-connection node -- mdb-connection )
99 104
    [ >>node ] [ address>> ] bi
100 105
    [ >>remote ] keep binary <client>
101  
-   [ >>handle ] dip >>local ;
  106
+   [ >>handle ] dip >>local 4096 <byte-vector> >>buffer ;
102 107
 
103 108
 : get-ismaster ( -- result )
104 109
     "admin.$cmd" H{ { "ismaster" 1 } } send-query-1result ; 
@@ -119,7 +124,7 @@ CONSTRUCTOR: mdb-connection ( instance -- mdb-connection ) ;
119 124
 
120 125
 : nodelist>table ( seq -- assoc )
121 126
    [ [ master?>> ] keep 2array ] map >hashtable ;
122  
-   
  127
+
123 128
 PRIVATE>
124 129
 
125 130
 :: verify-nodes ( mdb -- )
105  extra/mongodb/driver/driver.factor
... ...
@@ -1,10 +1,10 @@
1 1
 USING: accessors arrays assocs bson.constants combinators
2  
-combinators.smart constructors destructors formatting fry hashtables
3  
-io io.pools io.sockets kernel linked-assocs math mongodb.connection
4  
-mongodb.msg parser prettyprint prettyprint.custom prettyprint.sections
5  
-sequences sets splitting strings
6  
-tools.continuations uuid memoize locals ;
7  
-
  2
+combinators.smart constructors destructors fry hashtables io
  3
+io.pools io.sockets kernel linked-assocs locals math
  4
+mongodb.cmd mongodb.connection mongodb.msg namespaces parser
  5
+prettyprint prettyprint.custom prettyprint.sections sequences
  6
+sets splitting strings ;
  7
+FROM: ascii => ascii? ;
8 8
 IN: mongodb.driver
9 9
 
10 10
 TUPLE: mdb-pool < pool mdb ;
@@ -13,9 +13,9 @@ TUPLE: mdb-cursor id query ;
13 13
 
14 14
 TUPLE: mdb-collection
15 15
 { name string }
16  
-{ capped boolean initial: f }
17  
-{ size integer initial: -1 }
18  
-{ max integer initial: -1 } ;
  16
+{ capped boolean }
  17
+{ size integer }
  18
+{ max integer } ;
19 19
 
20 20
 CONSTRUCTOR: mdb-collection ( name -- collection ) ;
21 21
 
@@ -61,7 +61,7 @@ M: mdb-getmore-msg update-query
61 61
     query>> update-query ; 
62 62
       
63 63
 : make-cursor ( mdb-result-msg mdb-query-msg/mdb-getmore-msg -- mdb-cursor/f )
64  
-    over cursor>> 0 > 
  64
+    over cursor>> 0 >
65 65
     [ [ update-query ]
66 66
       [ [ cursor>> ] dip <mdb-cursor> ] 2bi
67 67
     ] [ 2drop f ] if ;
@@ -84,23 +84,23 @@ M: mdb-getmore-msg verify-query-result
84 84
     [ make-cursor ] 2tri
85 85
     swap objects>> ;
86 86
 
87  
-: make-collection-assoc ( collection assoc -- )
88  
-    [ [ name>> "create" ] dip set-at ]
89  
-    [ [ [ capped>> ] keep ] dip
90  
-      '[ _ _
91  
-         [ [ drop t "capped" ] dip set-at ]
92  
-         [ [ size>> "size" ] dip set-at ]
93  
-         [ [ max>> "max" ] dip set-at ] 2tri ] when
94  
-    ] 2bi ; 
95 87
 
96 88
 PRIVATE>
97 89
 
98 90
 SYNTAX: r/ ( token -- mdbregexp )
99 91
     \ / [ >mdbregexp ] parse-literal ; 
100 92
 
101  
-: with-db ( mdb quot -- * )
  93
+: with-db ( mdb quot -- )
102 94
     '[ _ mdb-open &dispose _ with-connection ] with-destructors ; inline
103  
-  
  95
+
  96
+: with-mdb ( mdb quot -- )
  97
+    [ <mdb-pool> ] dip
  98
+    [ mdb-pool swap with-variable ] curry with-disposal ; inline
  99
+
  100
+: with-mdb-connection ( quot -- )
  101
+    [ mdb-pool get ] dip 
  102
+    '[ _ with-connection ] with-pooled-connection ; inline
  103
+
104 104
 : >id-selector ( assoc -- selector )
105 105
     [ MDB_OID_FIELD swap at ] keep
106 106
     H{ } clone [ set-at ] keep ;
@@ -115,11 +115,16 @@ GENERIC: create-collection ( name/collection -- )
115 115
 M: string create-collection
116 116
     <mdb-collection> create-collection ;
117 117
 
118  
-M: mdb-collection create-collection
119  
-    [ [ cmd-collection ] dip
120  
-      <linked-hash> [ make-collection-assoc ] keep
121  
-      <mdb-query-msg> 1 >>return# send-query-plain drop ] keep
122  
-      [ ] [ name>> ] bi mdb-instance collections>> set-at ;
  118
+M: mdb-collection create-collection ( collection -- )
  119
+    create-cmd make-cmd over
  120
+    {
  121
+        [ name>> "create" set-cmd-opt ]
  122
+        [ capped>> [ "capped" set-cmd-opt ] when* ]
  123
+        [ max>> [ "max" set-cmd-opt ] when* ]
  124
+        [ size>> [ "size" set-cmd-opt ] when* ]
  125
+    } cleave send-cmd check-ok
  126
+    [ drop [ ] [ name>> ] bi mdb-instance collections>> set-at ]
  127
+    [ throw ] if ;
123 128
   
124 129
 : load-collection-list ( -- collection-list )
125 130
     namespaces-collection
@@ -128,8 +133,12 @@ M: mdb-collection create-collection
128 133
 <PRIVATE
129 134
 
130 135
 : ensure-valid-collection-name ( collection -- )
131  
-    [ ";$." intersect length 0 > ] keep
132  
-    '[ _ "contains invalid characters ( . $ ; )" "." glue throw ] when ; inline
  136
+    [
  137
+        [ ";$." intersect length 0 > ] keep
  138
+        '[ _ "contains invalid characters ( . $ ; )" ":" glue throw ] when
  139
+    ] [
  140
+        [ ascii? ] all? [ "collection names must only contain ascii characters" throw ] unless
  141
+    ] bi ; inline
133 142
 
134 143
 : build-collection-map ( -- assoc )
135 144
     H{ } clone load-collection-list      
@@ -215,21 +224,21 @@ M: mdb-cursor find
215 224
     dup empty? [ drop f ] [ first ] if ;
216 225
 
217 226
 : count ( mdb-query-msg -- result )
218  
-    [ collection>> "count" H{ } clone [ set-at ] keep ] keep
219  
-    query>> [ over [ "query" ] dip set-at ] when*
220  
-    [ cmd-collection ] dip <mdb-query-msg> find-one 
  227
+    [ count-cmd make-cmd ] dip
  228
+    [ collection>> "count" set-cmd-opt ]
  229
+    [ query>> "query" set-cmd-opt ] bi send-cmd 
221 230
     [ check-ok nip ] keep '[ "n" _ at >fixnum ] [ f ] if ;
222 231
 
223 232
 : lasterror ( -- error )
224  
-    cmd-collection H{ { "getlasterror" 1 } } <mdb-query-msg>
225  
-    find-one [ "err" ] dip at ;
  233
+    getlasterror-cmd make-cmd send-cmd
  234
+    [ "err" ] dip at ;
226 235
 
227 236
 GENERIC: validate. ( collection -- )
228 237
 
229 238
 M: string validate.
230  
-    [ cmd-collection ] dip
231  
-    "validate" H{ } clone [ set-at ] keep
232  
-    <mdb-query-msg> find-one [ check-ok nip ] keep
  239
+    [ validate-cmd make-cmd ] dip
  240
+    "validate" set-cmd-opt send-cmd
  241
+    [ check-ok nip ] keep
233 242
     '[ "result" _ at print ] [  ] if ;
234 243
 
235 244
 M: mdb-collection validate.
@@ -251,7 +260,7 @@ PRIVATE>
251 260
     <mdb-insert-msg> send-message ;
252 261
 
253 262
 : ensure-index ( index-spec -- )
254  
-    <linked-hash> [ [ uuid1 "_id" ] dip set-at ] keep
  263
+    <linked-hash> [ [ <oid> "_id" ] dip set-at ] keep
255 264
     [ { [ [ name>> "name" ] dip set-at ]
256 265
         [ [ ns>> index-ns "ns" ] dip set-at ]
257 266
         [ [ key>> "key" ] dip set-at ]
@@ -261,11 +270,9 @@ PRIVATE>
261 270
     [ index-collection ] dip save ;
262 271
 
263 272
 : drop-index ( collection name -- )
264  
-    H{ } clone
265  
-    [ [ "index" ] dip set-at ] keep
266  
-    [ [ "deleteIndexes" ] dip set-at ] keep
267  
-    [ cmd-collection ] dip <mdb-query-msg>
268  
-    find-one drop ;
  273
+    [ delete-index-cmd make-cmd ] 2dip
  274
+    [ "deleteIndexes" set-cmd-opt ]
  275
+    [ "index" set-cmd-opt ] bi* send-cmd drop ;
269 276
 
270 277
 : <update> ( collection selector object -- mdb-update-msg )
271 278
     [ check-collection ] 2dip <mdb-update-msg> ;
@@ -278,7 +285,16 @@ PRIVATE>
278 285
 
279 286
 : update-unsafe ( mdb-update-msg -- )
280 287
     send-message ;
281  
- 
  288
+
  289
+: find-and-modify ( collection selector modifier -- mongodb-cmd )
  290
+    [ findandmodify-cmd make-cmd ] 3dip
  291
+    [ "findandmodify" set-cmd-opt ]
  292
+    [ "query" set-cmd-opt ]
  293
+    [ "update" set-cmd-opt ] tri* ; inline
  294
+
  295
+: run-cmd ( cmd -- result )
  296
+    send-cmd ; inline
  297
+
282 298
 : delete ( collection selector -- )
283 299
     [ check-collection ] dip
284 300
     <mdb-delete-msg> send-message-check-error ;
@@ -298,8 +314,7 @@ PRIVATE>
298 314
     check-collection drop ;
299 315
 
300 316
 : drop-collection ( name -- )
301  
-    [ cmd-collection ] dip
302  
-    "drop" H{ } clone [ set-at ] keep
303  
-    <mdb-query-msg> find-one drop ;
  317
+    [ drop-cmd make-cmd ] dip
  318
+    "drop" set-cmd-opt send-cmd drop ;
304 319
 
305 320
 
285  extra/mongodb/gridfs/gridfs.factor
... ...
@@ -0,0 +1,285 @@
  1
+USING: accessors arrays assocs base64 bson.constants
  2
+byte-arrays byte-vectors calendar combinators
  3
+combinators.short-circuit destructors formatting fry hashtables
  4
+io kernel linked-assocs locals math math.parser mongodb.cmd
  5
+mongodb.connection mongodb.driver mongodb.msg namespaces
  6
+sequences splitting strings ;
  7
+FROM: mongodb.driver => update ;
  8
+IN: mongodb.gridfs
  9
+
  10
+CONSTANT: default-chunk-size 262144
  11
+
  12
+TUPLE: gridfs 
  13
+    { bucket string } 
  14
+    { files string }
  15
+    { chunks string } ;
  16
+
  17
+
  18
+<PRIVATE
  19
+
  20
+: gridfs> ( -- gridfs )
  21
+    gridfs get ; inline
  22
+
  23
+: files-collection ( -- str ) gridfs> files>> ; inline
  24
+: chunks-collection ( -- str ) gridfs> chunks>> ; inline
  25
+
  26
+
  27
+: init-gridfs ( gridfs -- )
  28
+    chunks>> "ChunkIdx" H{ { "files_id" 1 } { "n" 1 } } 
  29
+    <index-spec> ensure-index ; inline
  30
+
  31
+PRIVATE>
  32
+
  33
+: <gridfs> ( bucket -- gridfs )
  34
+    [  ] 
  35
+    [ "files" "%s.%s" sprintf  ] 
  36
+    [ "chunks" "%s.%s" sprintf ] tri
  37
+    gridfs boa [ init-gridfs ] keep ;
  38
+
  39
+: with-gridfs ( gridfs quot -- * )
  40
+    [ gridfs ] dip with-variable ; inline
  41
+
  42
+TUPLE: entry 
  43
+    { id oid }
  44
+    { filename string }
  45
+    { content-type string }
  46
+    { length integer }
  47
+    { chunk-size integer }
  48
+    { created timestamp }
  49
+    { aliases array }
  50
+    { metadata hashtable }
  51
+    { md5 string } ;
  52
+
  53
+<PRIVATE
  54
+
  55
+: id>base64 ( id -- str )
  56
+    [ a>> >hex ] [ b>> >hex ] bi 
  57
+    2array "#" join >base64 >string ; inline
  58
+
  59
+: base64>id ( str -- objid )
  60
+    base64> >string "#" split 
  61
+    [ first ] [ second ] bi 
  62
+    [ hex> ] bi@ oid boa ; inline
  63
+    
  64
+PRIVATE>
  65
+
  66
+: <entry> ( name content-type -- entry )
  67
+    entry new 
  68
+    swap >>content-type swap >>filename 
  69
+    <oid> >>id 0 >>length default-chunk-size >>chunk-size 
  70
+    now >>created ; inline
  71
+
  72
+<PRIVATE 
  73
+
  74
+TUPLE: chunk 
  75
+    { id oid }
  76
+    { fileid oid }
  77
+    { n integer }
  78
+    { data byte-array } ;
  79
+
  80
+: at> ( assoc key -- value/f )
  81
+    swap at ; inline
  82
+
  83
+:: >set-at ( assoc value key -- )
  84
+    value key assoc set-at ; inline
  85
+
  86
+: (update-file) ( entry assoc -- entry )
  87
+    { 
  88
+        [ "_id" at> >>id ]
  89
+        [ "filename" at> >>filename ]
  90
+        [ "contentType" at> >>content-type ]
  91
+        [ "length" at> >>length ]
  92
+        [ "chunkSize" at> >>chunk-size ]
  93
+        [ "uploadDate" at> >>created ]
  94
+        [ "aliases" at> >>aliases ]
  95
+        [ "metadata" at> >>metadata ]
  96
+        [ "md5" at> >>md5 ]
  97
+    } cleave ; inline
  98
+
  99
+: assoc>chunk ( assoc -- chunk )
  100
+    [ chunk new ] dip
  101
+    {  
  102
+        [ "_id" at> >>id ]
  103
+        [ "files_id" at> >>fileid ]
  104
+        [ "n" at> >>n ]
  105
+        [ "data" at> >>data ]
  106
+    } cleave ;
  107
+
  108
+: assoc>entry ( assoc -- entry )
  109
+    [ entry new ] dip (update-file) ;