├── .gitignore ├── LICENSE ├── README ├── db ├── mongodb.rkt └── mongodb │ ├── basic │ ├── driver.rkt │ └── main.rkt │ ├── info.rkt │ ├── mongodb.scrbl │ ├── orm │ ├── dict.rkt │ ├── main.rkt │ └── struct.rkt │ ├── seq.rkt │ └── wire │ ├── driver.rkt │ ├── format.rkt │ └── main.rkt ├── info.rkt ├── net ├── bson.rkt └── bson │ ├── binio.rkt │ ├── driver.rkt │ ├── mapping.rkt │ ├── read.rkt │ ├── shared.rkt │ └── write.rkt ├── tests ├── db │ └── mongodb │ │ ├── basic.rkt │ │ ├── orm.rkt │ │ ├── quick-start.rkt │ │ ├── util.rkt │ │ └── wire.rkt └── net │ └── bson.rkt └── web-server └── dispatch └── mongodb.rkt /.gitignore: -------------------------------------------------------------------------------- 1 | # ignore compiled subdirs 2 | compiled/ 3 | # ignore doc subdir 4 | /doc/ 5 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This code is available according to same terms as Racket: 2 | 3 | http://download.racket-lang.org/license.html 4 | 5 | Copyright © Jay McCarthy 6 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | raw mongodb interface in Racket 2 | -------------------------------------------------------------------------------- /db/mongodb.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require net/bson 3 | "mongodb/basic/main.rkt" 4 | "mongodb/orm/main.rkt") 5 | (provide (all-from-out net/bson 6 | "mongodb/basic/main.rkt" 7 | "mongodb/orm/main.rkt")) 8 | -------------------------------------------------------------------------------- /db/mongodb/basic/driver.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract 3 | racket/match 4 | racket/list 5 | racket/port 6 | (only-in racket/tcp port-number?) 7 | db/mongodb/wire/main 8 | net/bson 9 | net/bson/driver 10 | net/bson/binio 11 | net/bson/mapping 12 | db/mongodb/seq) 13 | 14 | ;;; Structs 15 | 16 | (define-struct mongo (lock conn)) 17 | (define-struct mongo-db ([mongo #:mutable] name)) 18 | (define-struct mongo-collection (db name)) 19 | (provide/contract 20 | [mongo? (any/c . -> . boolean?)] 21 | [struct mongo-db ([mongo mongo?] 22 | [name string?])] 23 | [struct mongo-collection ([db mongo-db?] 24 | [name string?])]) 25 | 26 | ;;; Executor 27 | (define mongo-executor (make-will-executor)) 28 | ; XXX Figure out some way to batch a few kill cursors together 29 | (define executor-thread 30 | (thread 31 | (lambda () 32 | (let loop () 33 | (will-execute mongo-executor) 34 | (loop))))) 35 | 36 | ;;; Cursor operations 37 | ; XXX Figure out some way to get more at a time 38 | (define-struct mongo-cursor (mongo col cid [start #:mutable] [done? #:mutable]) 39 | #:property prop:sequence 40 | (lambda (mc) 41 | (define init (mongo-cursor-start mc)) 42 | (in-sequences 43 | ; Start with the vector from the first query 44 | init 45 | ; Then continue with more results 46 | (make-do-sequence 47 | (lambda () 48 | ; Forget the initial values 49 | (set-mongo-cursor-start! mc #f) 50 | (values (lambda (pos) 51 | (mongo-cursor-next mc)) 52 | (lambda (pos) (add1 pos)) 53 | (vector-length init) 54 | (lambda (pos) (mongo-cursor-done? mc)) 55 | (lambda (val) (not (void? val))) 56 | (lambda (pos val) #t))))))) 57 | 58 | (provide/contract 59 | [mongo-cursor? (any/c . -> . boolean?)] 60 | [mongo-cursor-done? (mongo-cursor? . -> . boolean?)]) 61 | 62 | (define (create-mongo-cursor mongo col cid start) 63 | (define mc (make-mongo-cursor mongo col cid start (not (zero? cid)))) 64 | (will-register mongo-executor mc mongo-cursor-kill!) 65 | mc) 66 | 67 | (provide/contract 68 | [mongo-cursor-kill! (mongo-cursor? . -> . void)]) 69 | 70 | (define (mongo-cursor-kill! mc) 71 | (match-define (struct mongo-cursor (m c cid _ done?)) mc) 72 | (define qid (new-msg-id)) 73 | (unless done? 74 | (mongo-send m (make-kill-cursors qid 0 (vector cid))) 75 | (set-mongo-cursor-done?! mc #t))) 76 | 77 | (define (mongo-cursor-next mc) 78 | (match-define (struct mongo-cursor (m c cid _ _)) mc) 79 | (define qid (new-msg-id)) 80 | (define response 81 | (mongo-send m (make-get-more qid 0 c 1 cid))) 82 | (match response 83 | [(struct reply (id to error? new-cid _from answers)) 84 | (unless (= to qid) 85 | (error 'mongo-get-one-more "Got an answer to a different query")) 86 | (when error? 87 | (error 'mongo-get-one-more "Get more failed: ~e" cid)) 88 | (match answers 89 | ; XXX Is this correct wrt tailable? 90 | [(vector) 91 | (set-mongo-cursor-done?! mc #t)] 92 | [(vector ans) 93 | ans] 94 | [_ 95 | (error 'mongo-get-one-more "Received too many answers: ~e" answers)])])) 96 | 97 | ;;; Mongo operations 98 | ; XXX Support other connection styles (master-slave, replica pair, etc) 99 | ; XXX Support automatic reconnection 100 | (define (mongo-send m msg) 101 | (match-define (struct mongo (lock conn)) m) 102 | (call-with-semaphore 103 | lock 104 | (lambda () 105 | (send-message conn msg)))) 106 | 107 | (provide/contract 108 | [create-mongo (() (#:host string? #:port port-number?) . ->* . mongo?)] 109 | [close-mongo! (mongo? . -> . void?)]) 110 | (define (create-mongo #:host [host "localhost"] #:port [port 27017]) 111 | (make-mongo (make-semaphore 1) (create-mongo-connection #:host host #:port port))) 112 | 113 | (define (close-mongo! m) 114 | (match-define (struct mongo (lock conn)) m) 115 | (call-with-semaphore 116 | lock 117 | (lambda () 118 | (close-mongo-connection! conn)))) 119 | 120 | (define (mongo-find m c q 121 | #:tailable? [tailable? #f] 122 | #:slave-okay? [slave-okay? #f] 123 | #:no-timeout? [no-timeout? #f] 124 | #:selector [selector #f] 125 | #:skip [skip 0] 126 | #:limit [limit #f]) 127 | (define qid (new-msg-id)) 128 | (define actual-limit 129 | (or limit 130 | ; The default limit is 2 because it is the smallest limit that returns a cursor. 131 | 2)) 132 | (define response 133 | (mongo-send 134 | m 135 | (make-query qid 0 c 136 | (append (if tailable? (list 'tailable-cursor) empty) 137 | (if slave-okay? (list 'slave-ok) empty) 138 | (if no-timeout? (list 'no-cursor-timeout) empty)) 139 | skip actual-limit 140 | q selector))) 141 | (match response 142 | [(struct reply (id to error? cid _from ans)) 143 | (unless (= to qid) 144 | (error 'mongo-find "Got an answer to a different query")) 145 | (when error? 146 | (error 'mongo-find "Query failed: ~e" q)) 147 | (create-mongo-cursor m c cid ans)])) 148 | 149 | (define (mongo-find-one m c q) 150 | (define ans-cursor 151 | (mongo-find m c q #:limit -1)) 152 | (sequence-ref ans-cursor 0)) 153 | 154 | (provide/contract 155 | [mongo-list-databases (mongo? . -> . (vectorof bson-document/c))] 156 | [mongo-db-names (mongo? . -> . (listof string?))]) 157 | 158 | (define (mongo-list-databases m) 159 | (hash-ref (mongo-db-execute-command! (make-mongo-db m "admin") `([listDatabases . 1])) 160 | 'databases)) 161 | 162 | (define (mongo-db-names m) 163 | (for/list ([d (in-vector (mongo-list-databases m))]) 164 | (hash-ref d 'name))) 165 | 166 | ;;; Database operations 167 | (provide/contract 168 | [mongo-db-execute-command! (mongo-db? bson-document/c . -> . bson-document/c)]) 169 | (define (mongo-db-execute-command! db cmd) 170 | (define ans 171 | (mongo-find-one (mongo-db-mongo db) (format "~a.$cmd" (mongo-db-name db)) cmd)) 172 | (if (and (hash? ans) 173 | (hash-has-key? ans 'errmsg)) 174 | (error 'mongo-db-execute-command! "~e returned ~e" cmd (hash-ref ans 'errmsg)) 175 | ans)) 176 | 177 | (provide/contract 178 | [mongo-db-collections (mongo-db? . -> . (listof string?))]) 179 | (define (mongo-db-collections db) 180 | (let ([collections (mongo-db-execute-command! db (list 181 | (cons 'listCollections 1) 182 | (cons 'filter null) 183 | (cons 'nameOnly #t) 184 | (cons 'authorizedCollections #t)))]) 185 | (cond 186 | [(empty? collections) '()] 187 | [else (let ([cursor (hash-ref collections 'cursor)]) 188 | (let ([firstBatch (hash-ref cursor 'firstBatch)]) 189 | (for/list ([c (in-vector firstBatch)]) 190 | (let ([colname (hash-ref c 'name)]) 191 | (cond 192 | [(symbol? colname) (symbol->string colname)] 193 | [else colname])))))]))) 194 | 195 | (provide/contract 196 | [mongo-db-create-collection! ((mongo-db? string? #:capped? boolean? #:size number?) 197 | (#:max (or/c false/c number?)) 198 | . ->* . mongo-collection?)]) 199 | (define (mongo-db-create-collection! db name 200 | #:capped? capped? 201 | #:size size 202 | #:max [max #f]) 203 | (mongo-db-execute-command! 204 | db 205 | (list* (cons 'create name) 206 | (cons 'capped capped?) 207 | (cons 'size size) 208 | (if max 209 | (list (cons 'max max)) 210 | empty))) 211 | (make-mongo-collection db name)) 212 | 213 | ; XXX parse answers 214 | (provide/contract 215 | [mongo-db-drop-collection! (mongo-db? string? . -> . bson-document/c)]) 216 | (define (mongo-db-drop-collection! db name) 217 | (mongo-db-execute-command! db `([drop . ,name]))) 218 | 219 | (provide/contract 220 | [mongo-db-drop (mongo-db? . -> . bson-document/c)]) 221 | (define (mongo-db-drop db) 222 | (mongo-db-execute-command! db `([dropDatabase . 1]))) 223 | 224 | (define-mappings (num->profiling profiling->num) 225 | [(0) 'none] 226 | [(1) 'low] 227 | [(2) 'all]) 228 | (define mongo-db-profiling/c (symbols 'none 'low 'all)) 229 | 230 | (provide/contract 231 | [mongo-db-profiling/c contract?] 232 | [mongo-db-profiling (mongo-db? . -> . mongo-db-profiling/c)] 233 | [set-mongo-db-profiling! (mongo-db? mongo-db-profiling/c . -> . boolean?)]) 234 | (define (mongo-db-profiling db) 235 | (hash-ref num->profiling 236 | (inexact->exact 237 | (hash-ref (mongo-db-execute-command! db `([profile . -1])) 238 | 'was)))) 239 | ; XXX error on fail 240 | (define (set-mongo-db-profiling! db level) 241 | (define level-n (hash-ref profiling->num level)) 242 | (= 1 243 | (hash-ref (mongo-db-execute-command! db `([profile . ,level-n])) 'ok))) 244 | 245 | (provide/contract 246 | [mongo-db-profiling-info (mongo-db? . -> . bson-document/c)] 247 | [mongo-db-valid-collection? (mongo-db? string? . -> . boolean?)]) 248 | (define (mongo-db-profiling-info db) 249 | (mongo-find-one (mongo-db-mongo db) (format "~a.system.profile" (mongo-db-name db)) empty)) 250 | 251 | (define (mongo-db-valid-collection? db c) 252 | (= 1 (hash-ref (mongo-db-execute-command! db `([validate . ,c])) 'ok))) 253 | 254 | ;;; Collection operations 255 | (provide/contract 256 | [mongo-collection-drop! (mongo-collection? . -> . void)] 257 | [mongo-collection-valid? (mongo-collection? . -> . boolean?)] 258 | [mongo-collection-full-name (mongo-collection? . -> . string?)]) 259 | (define (mongo-collection-drop! c) 260 | (match-define (struct mongo-collection (db name)) c) 261 | (mongo-db-drop-collection! db name)) 262 | 263 | (define (mongo-collection-valid? c) 264 | (match-define (struct mongo-collection (db name)) c) 265 | (mongo-db-valid-collection? db name)) 266 | 267 | (define (mongo-collection-full-name c) 268 | (match-define (struct mongo-collection (db col)) c) 269 | (match-define (struct mongo-db (m db-name)) db) 270 | (format "~a.~a" db-name col)) 271 | 272 | (provide/contract 273 | [mongo-collection-find 274 | (->* (mongo-collection? bson-document/c) 275 | (#:tailable? boolean? 276 | #:slave-okay? boolean? 277 | #:no-timeout? boolean? 278 | #:selector (or/c false/c bson-document/c) 279 | #:skip int32? 280 | #:limit (or/c false/c int32?)) 281 | mongo-cursor?)]) 282 | (define (mongo-collection-find c query 283 | #:tailable? [tailable? #f] 284 | #:slave-okay? [slave-okay? #f] 285 | #:no-timeout? [no-timeout? #f] 286 | #:selector [selector #f] 287 | #:skip [skip 0] 288 | #:limit [limit #f]) 289 | (match-define (struct mongo-collection (db col)) c) 290 | (match-define (struct mongo-db (m db-name)) db) 291 | (mongo-find m (mongo-collection-full-name c) 292 | query 293 | #:tailable? tailable? 294 | #:slave-okay? slave-okay? 295 | #:no-timeout? no-timeout? 296 | #:selector selector 297 | #:skip skip 298 | #:limit limit)) 299 | 300 | (provide/contract 301 | [mongo-collection-insert-docs! (mongo-collection? (sequenceof bson-document/c) . -> . void)] 302 | [mongo-collection-insert-one! (mongo-collection? bson-document/c . -> . void)] 303 | [mongo-collection-insert! ((mongo-collection?) () #:rest (listof bson-document/c) . ->* . void)]) 304 | (define (mongo-collection-insert-docs! c objs) 305 | (match-define (struct mongo-collection (db col)) c) 306 | (match-define (struct mongo-db (m db-name)) db) 307 | (define mid (new-msg-id)) 308 | (mongo-send m (make-insert mid 0 (mongo-collection-full-name c) objs)) 309 | (void)) 310 | 311 | (define (mongo-collection-insert-one! c obj) 312 | (mongo-collection-insert-docs! c (vector obj))) 313 | (define (mongo-collection-insert! c . objs) 314 | (mongo-collection-insert-docs! c objs)) 315 | 316 | (provide/contract 317 | [mongo-collection-remove! (mongo-collection? bson-document/c . -> . void)] 318 | [mongo-collection-modify! (mongo-collection? bson-document/c bson-document/c . -> . void)] 319 | [mongo-collection-replace! (mongo-collection? bson-document/c bson-document/c . -> . void)] 320 | [mongo-collection-repsert! (mongo-collection? bson-document/c bson-document/c . -> . void)]) 321 | (define (mongo-collection-remove! c sel) 322 | (match-define (struct mongo-collection (db col)) c) 323 | (match-define (struct mongo-db (m db-name)) db) 324 | (define mid (new-msg-id)) 325 | (mongo-send m (make-delete mid 0 (mongo-collection-full-name c) sel)) 326 | (void)) 327 | 328 | (define (mongo-collection-update! c flags sel mod) 329 | (match-define (struct mongo-collection (db col)) c) 330 | (match-define (struct mongo-db (m db-name)) db) 331 | (define mid (new-msg-id)) 332 | (mongo-send m (make-update mid 0 (mongo-collection-full-name c) flags sel mod)) 333 | (void)) 334 | 335 | (define (mongo-collection-modify! c sel mod) 336 | (mongo-collection-update! c '(multi-update) sel mod)) 337 | (define (mongo-collection-replace! c sel obj) 338 | (mongo-collection-update! c empty sel obj)) 339 | (define (mongo-collection-repsert! c sel obj) 340 | (mongo-collection-update! c '(upsert) sel obj)) 341 | 342 | (provide/contract 343 | [mongo-collection-count ((mongo-collection?) (bson-document/c) . ->* . exact-integer?)]) 344 | (define (mongo-collection-count c [q empty]) 345 | (sequence-count (mongo-collection-find c q))) 346 | 347 | ;;; Index 348 | (define (generate-index-name k) 349 | (with-output-to-string (lambda () (write k)))) 350 | 351 | (provide/contract 352 | [mongo-collection-index! ((mongo-collection? bson-document/c) (#:name string?) . ->* . void)] 353 | [mongo-collection-indexes (mongo-collection? . -> . mongo-cursor?)] 354 | [mongo-collection-drop-index! (mongo-collection? string? . -> . void)]) 355 | (define (mongo-collection-index! c key #:name [name (generate-index-name key)]) 356 | (match-define (struct mongo-collection (db col)) c) 357 | (define si-c (make-mongo-collection db "system.indexes")) 358 | (mongo-collection-insert-one! 359 | si-c 360 | (list (cons 'name name) 361 | (cons 'ns (mongo-collection-full-name c)) 362 | (cons 'key key)))) 363 | 364 | (define (mongo-collection-indexes c) 365 | (match-define (struct mongo-collection (db col)) c) 366 | (define si-c (make-mongo-collection db "system.indexes")) 367 | (mongo-collection-find si-c (list (cons 'ns (mongo-collection-full-name c))) 368 | #:limit 0)) 369 | 370 | (define (mongo-collection-drop-index! c name) 371 | (match-define (struct mongo-collection (db col)) c) 372 | (mongo-db-execute-command! 373 | db 374 | (list (cons 'deleteIndexes col) 375 | (cons 'index name)))) 376 | 377 | ; XXX explain, getOptions 378 | -------------------------------------------------------------------------------- /db/mongodb/basic/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "driver.rkt") 3 | (provide (all-from-out "driver.rkt")) 4 | -------------------------------------------------------------------------------- /db/mongodb/info.rkt: -------------------------------------------------------------------------------- 1 | #lang setup/infotab 2 | (define name "MongoDB") 3 | (define scribblings '(("mongodb.scrbl" (multi-page) ("Database")))) 4 | -------------------------------------------------------------------------------- /db/mongodb/mongodb.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/doc 2 | @(require scribble/manual 3 | (for-label racket 4 | (only-in srfi/19 5 | time? time-type time-utc) 6 | db/mongodb)) 7 | 8 | @title{MongoDB} 9 | @author{@(author+email "Jay McCarthy" "jay@racket-lang.org")} 10 | 11 | @defmodule[db/mongodb] 12 | 13 | This package provides an interface to @link["http://www.mongodb.org/"]{MongoDB}. It supports and exposes features of MongoDB 1.3, if you use it with an older version they may silently fail. 14 | 15 | @table-of-contents[] 16 | 17 | @section{Quickstart} 18 | 19 | Here's a little snippet that uses the API. 20 | 21 | @racketblock[ 22 | (define m (create-mongo)) 23 | (define d (make-mongo-db m "awesome-dot-com")) 24 | (current-mongo-db d) 25 | (define-mongo-struct post "posts" 26 | ([title #:required] 27 | [body #:required] 28 | [tags #:set-add #:pull] 29 | [comments #:push #:pull] 30 | [views #:inc])) 31 | 32 | (define p 33 | (make-post #:title "Welcome to my blog" 34 | #:body "This is my first entry, yay!")) 35 | (set-add-post-tags! p 'awesome) 36 | (inc-post-views! p) 37 | 38 | (set-post-comments! p (list "Can't wait!" "Another blog?")) 39 | (post-comments p) 40 | ] 41 | 42 | @section{BSON} 43 | 44 | @defmodule[net/bson] 45 | 46 | MongoDB depends on @link["http://bsonspec.org/"]{BSON}. This module contains an encoding of BSON values as Scheme values. 47 | 48 | A @deftech{BSON document} is a dictionary that maps symbols to @tech{BSON values}. 49 | 50 | A @deftech{BSON value} is either 51 | @itemlist[ 52 | @item{ An @racket[inexact?] @racket[real?] number } 53 | @item{ A @racket[string?] } 54 | @item{ A @tech{BSON document} } 55 | @item{ A @tech{BSON sequence} } 56 | @item{ A @racket[bson-binary?] or @racket[bytes?]} 57 | @item{ A @racket[bson-objectid?] } 58 | @item{ A @racket[boolean?] } 59 | @item{ A SRFI 19 @racket[time?] where @racket[time-type] equals @racket[time-utc] } 60 | @item{ A @racket[bson-null?] } 61 | @item{ A @racket[bson-regexp?] } 62 | @item{ A @racket[bson-javascript?] } 63 | @item{ A @racket[symbol?] } 64 | @item{ A @racket[bson-javascript/scope?] } 65 | @item{ A @racket[int32?] } 66 | @item{ A @racket[bson-timestamp?] } 67 | @item{ A @racket[int64?] } 68 | @item{ @racket[bson-min-key] } 69 | @item{ @racket[bson-max-key] } 70 | ] 71 | 72 | A @deftech{BSON sequence} is sequence of @tech{BSON values}. 73 | 74 | @defproc[(int32? [x any/c]) boolean?]{ A test for 32-bit integers.} 75 | @defproc[(int64? [x any/c]) boolean?]{ A test for 64-bit integers.} 76 | @defthing[bson-document/c contract?]{A contract for @tech{BSON documents}.} 77 | @defthing[bson-sequence/c contract?]{ A contract for @tech{BSON sequences}. } 78 | 79 | A few BSON types do not have equivalents in Scheme. 80 | 81 | @defproc[(bson-min-key? [x any/c]) boolean?]{ A test for @racket[bson-min-key]. } 82 | @defthing[bson-min-key bson-min-key?]{ The smallest BSON value. } 83 | @defproc[(bson-max-key? [x any/c]) boolean?]{ A test for @racket[bson-max-key]. } 84 | @defthing[bson-max-key bson-max-key?]{ The largest BSON value. } 85 | @defproc[(bson-null? [x any/c]) boolean?]{ A test for @racket[bson-null]. } 86 | @defthing[bson-null bson-null?]{ The missing BSON value. } 87 | @defstruct[bson-timestamp ([value int64?])]{ A value representing an internal MongoDB type. } 88 | @defproc[(bson-objectid? [x any/c]) boolean?]{ A test for BSON @link["http://www.mongodb.org/display/DOCS/Object+IDs"]{ObjectId}s, an internal MongoDB type. } 89 | @defproc[(new-bson-objectid) bson-objectid?]{ Returns a fresh ObjectId. } 90 | @defproc[(bson-objectid-timestamp [oid bson-objectid?]) exact-integer?]{ Returns the part of the ObjectID conventionally representing a timestamp. } 91 | 92 | A few BSON types have equivalents in Scheme, but because of additional tagging of them in BSON, we have to create structures to preserve the tagging. 93 | 94 | @defstruct[bson-javascript ([string string?])]{ A value representing Javascript code. } 95 | @defstruct[bson-javascript/scope ([string string?] [scope bson-document/c])]{ A value representing Javascript code and its scope. } 96 | @defstruct[bson-binary ([type (symbols 'function 'binary 'uuid 'md5 'user-defined)] [bs bytes?])]{ A value representing binary data. } 97 | @defstruct[bson-regexp ([pattern string?] [options string?])]{ A value representing a regular expression. } 98 | 99 | @subsection{Decoding Conventions} 100 | 101 | Only @racket[make-hasheq] dictionaries are returned as @tech{BSON documents}. 102 | 103 | A @racket[bson-binary?] where @racket[bson-binary-type] is equal to @racket['binary] is never returned. It is converted to @racket[bytes?]. 104 | 105 | Only @racket[vector] sequences are returned as @tech{BSON sequences}. 106 | 107 | @section{Basic Operations} 108 | 109 | @defmodule[db/mongodb/basic/main] 110 | 111 | The basic API of MongoDB is provided by this module. 112 | 113 | @subsection{Servers} 114 | 115 | @defproc[(mongo? [x any/c]) boolean?]{ A test for Mongo servers. } 116 | 117 | @defproc[(create-mongo [#:host host string "localhost"] 118 | [#:port port port-number? 27017]) 119 | mongo?]{ 120 | Creates a connection to the specified Mongo server. 121 | } 122 | 123 | @defproc[(close-mongo! [m mongo?]) void?]{ 124 | Closes the connection to the Mongo server. 125 | } 126 | 127 | @defproc[(mongo-list-databases [m mongo?]) 128 | (vectorof bson-document/c)]{ 129 | Returns information about the databases on a server. 130 | } 131 | 132 | @defproc[(mongo-db-names [m mongo?]) 133 | (listof string?)]{ 134 | Returns the names of the databases on the server. 135 | } 136 | 137 | @subsection{Databases} 138 | 139 | @defstruct[mongo-db ([mongo mongo?] [name string?])]{ A structure representing a Mongo database. The @racket[mongo] field is mutable. } 140 | 141 | @defproc[(mongo-db-execute-command! [db mongo-db?] [cmd bson-document/c]) 142 | bson-document/c]{ 143 | Executes command @racket[cmd] on the database @racket[db] and returns Mongo's response. Refer to @link["http://www.mongodb.org/display/DOCS/List+of+Database+Commands"]{List of Database Commands} for more details. 144 | } 145 | 146 | @defproc[(mongo-db-collections [db mongo-db?]) 147 | (listof string?)]{ 148 | Returns a list of collection names in the database. 149 | } 150 | 151 | @defproc[(mongo-db-create-collection! [db mongo-db?] 152 | [name string?] 153 | [#:capped? capped? boolean?] 154 | [#:size size number?] 155 | [#:max max (or/c false/c number?) #f]) 156 | mongo-collection?]{ 157 | Creates a new collection in the database and returns a handle to it. Refer to @link["http://www.mongodb.org/display/DOCS/Capped+Collections"]{Capped Collections} for details on the options. 158 | } 159 | 160 | @defproc[(mongo-db-drop-collection! [db mongo-db?] 161 | [name string?]) 162 | bson-document/c]{ 163 | Drops a collection from the database. 164 | } 165 | 166 | @defproc[(mongo-db-drop [db mongo-db?]) 167 | bson-document/c]{ 168 | Drops a database from its server. 169 | } 170 | 171 | @defthing[mongo-db-profiling/c contract?]{ Defined as @racket[(symbols 'none 'low 'all)]. } 172 | @defproc[(mongo-db-profiling [db mongo-db?]) mongo-db-profiling/c]{ Returns the profiling level of the database. } 173 | @defproc[(set-mongo-db-profiling! [db mongo-db?] [v mongo-db-profiling/c]) boolean?]{ Sets the profiling level of the database. Returns @racket[#t] on success. } 174 | 175 | @defproc[(mongo-db-profiling-info [db mongo-db?]) bson-document/c]{ Returns the profiling information from the database. Refer to @link["http://www.mongodb.org/display/DOCS/Database+Profiler"]{Database Profiler} for more details. } 176 | 177 | @defproc[(mongo-db-valid-collection? [db mongo-db?] [name string?]) boolean?]{ Returns @racket[#t] if @racket[name] is a valid collection. } 178 | 179 | @subsection{Collections} 180 | 181 | @defstruct[mongo-collection ([db mongo-db?] [name string?])]{ A structure representing a Mongo collection. } 182 | 183 | @defproc[(mongo-collection-drop! [mc mongo-collection?]) void]{ Drops the collection from its database. } 184 | @defproc[(mongo-collection-valid? [mc mongo-collection?]) boolean?]{ Returns @racket[#t] if @racket[mc] is a valid collection. } 185 | @defproc[(mongo-collection-full-name [mc mongo-collection?]) string?]{ Returns the full name of the collection. } 186 | @defproc[(mongo-collection-find [mc mongo-collection?] 187 | [query bson-document/c] 188 | [#:tailable? tailable? boolean? #f] 189 | [#:slave-okay? slave-okay? boolean? #f] 190 | [#:no-timeout? no-timeout? boolean? #f] 191 | [#:selector selector (or/c false/c bson-document/c) #f] 192 | [#:skip skip int32? 0] 193 | [#:limit limit (or/c false/c int32?) #f]) 194 | mongo-cursor?]{ 195 | Performs a query in the collection. Refer to @link["http://www.mongodb.org/display/DOCS/Querying"]{Querying} for more details. 196 | 197 | If @racket[limit] is @racket[#f], then a limit of @racket[2] is sent. This is the smallest limit that creates a server-side cursor, because @racket[1] is interpreted as @racket[-1]. 198 | } 199 | 200 | @defproc[(mongo-collection-insert-docs! [mc mongo-collection?] [docs (sequenceof bson-document/c)]) void]{ Inserts a sequence of documents into the collection. } 201 | @defproc[(mongo-collection-insert-one! [mc mongo-collection?] [doc bson-document/c]) void]{ Insert an document into the collection. } 202 | @defproc[(mongo-collection-insert! [mc mongo-collection?] [doc bson-document/c] ...) void]{ Inserts any number of documents into the collection. } 203 | 204 | @defproc[(mongo-collection-remove! [mc mongo-collection?] [sel bson-document/c]) void]{ Removes documents matching the selector. Refer to @link[ 205 | "http://www.mongodb.org/display/DOCS/Removing"]{Removing} for more details. } 206 | 207 | @defproc[(mongo-collection-modify! [mc mongo-collection?] [sel bson-document/c] [mod bson-document/c]) void]{ Modifies all documents matching the selector according to @racket[mod]. Refer to @link[ 208 | "http://www.mongodb.org/display/DOCS/Updating#Updating-ModifierOperations"]{Modifier Operations} for more details. } 209 | 210 | @defproc[(mongo-collection-replace! [mc mongo-collection?] [sel bson-document/c] [doc bson-document/c]) void]{ Replaces the first document matching the selector with @racket[obj]. } 211 | 212 | @defproc[(mongo-collection-repsert! [mc mongo-collection?] [sel bson-document/c] [doc bson-document/c]) void]{ If a document matches the selector, it is replaced; otherwise the document is inserted. Refer to @link[ 213 | "http://www.mongodb.org/display/DOCS/Updating#Updating-UpsertswithModifiers"]{Upserts with Modifiers} for more details on using modifiers. } 214 | 215 | @defproc[(mongo-collection-count [mc mongo-collection?] [query bson-document/c empty]) exact-integer?]{ Returns the number of documents matching the query. } 216 | 217 | @subsubsection{Indexing} 218 | 219 | Refer to @link["http://www.mongodb.org/display/DOCS/Indexes"]{Indexes} for more details on indexing. 220 | 221 | @defproc[(mongo-collection-index! [mc mongo-collection?] [spec bson-document/c] [name string? ....]) void]{ Creates an index of the collection. A name will be automatically generated if not specified. } 222 | @defproc[(mongo-collection-indexes [mc mongo-collection?]) mongo-cursor?]{ Queries for index information. } 223 | @defproc[(mongo-collection-drop-index! [mc mongo-collection?] [name string?]) void]{ Drops an index by name. } 224 | 225 | @subsection{Cursors} 226 | 227 | Query results are returned as @tech{Mongo cursors}. 228 | 229 | A @deftech{Mongo cursor} is a sequence of @tech{BSON documents}. 230 | 231 | @defproc[(mongo-cursor? [x any/c]) boolean?]{ A test for @tech{Mongo cursors}. } 232 | @defproc[(mongo-cursor-done? [mc mongo-cursor?]) boolean?]{ Returns @racket[#t] if the cursor has no more answers. @racket[#f] otherwise. } 233 | @defproc[(mongo-cursor-kill! [mc mongo-cursor?]) void]{ Frees the server resources for the cursor. } 234 | 235 | @section{ORM Operations} 236 | 237 | @defmodule[db/mongodb/orm/main] 238 | 239 | An "ORM" style API is built on the basic Mongo operations. 240 | 241 | @subsection{Dictionaries} 242 | 243 | @defmodule[db/mongodb/orm/dict] 244 | 245 | A @deftech{Mongo dictionary} is a dictionary backed by Mongo. 246 | 247 | @defproc[(create-mongo-dict [col string?]) mongo-dict?]{ Creates a new @tech{Mongo dictionary} in the @racket[col] collection of the @racket[(current-mongo-db)] database. } 248 | 249 | @defproc[(mongo-dict-query [col string?] [query bson-document/c]) (sequenceof mongo-dict?)]{ Queries the collection and returns @tech{Mongo dictionaries}. } 250 | 251 | @defproc[(mongo-dict? [x any/c]) boolean?]{ A test for @tech{Mongo dictionaries}. } 252 | @defparam[current-mongo-db db (or/c false/c mongo-db?)]{ The database used in @tech{Mongo dictionary} operations. } 253 | @defproc[(mongo-dict-ref [md mongo-dict?] [key symbol?] [fail any/c bson-null]) any/c]{ Like @racket[dict-ref] but for @tech{Mongo dictionaries}, returns @racket[bson-null] by default on errors or missing values. } 254 | @defproc[(mongo-dict-set! [md mongo-dict?] [key symbol?] [val any/c]) void]{ Like @racket[dict-set!] but for @tech{Mongo dictionaries}. } 255 | @defproc[(mongo-dict-remove! [md mongo-dict?] [key symbol?]) void]{ Like @racket[dict-remove!] but for @tech{Mongo dictionaries}. } 256 | @defproc[(mongo-dict-count [md mongo-dict?]) exact-nonnegative-integer?]{ Like @racket[dict-count] but for @tech{Mongo dictionaries}. } 257 | 258 | @defproc[(mongo-dict-inc! [md mongo-dict?] [key symbol?] [amt number? 1]) void]{ Increments @racket[key]'s value by @racket[amt] atomically. } 259 | @defproc[(mongo-dict-push! [md mongo-dict?] [key symbol?] [val any/c]) void]{ Pushes a value onto the sequence atomically. } 260 | @defproc[(mongo-dict-append! [md mongo-dict?] [key symbol?] [vals sequence?]) void]{ Pushes a sequence of values onto the sequence atomically. } 261 | @defproc[(mongo-dict-set-add! [md mongo-dict?] [key symbol?] [val any/c]) void]{ Adds a value to the sequence if it is not present atomically. } 262 | @defproc[(mongo-dict-set-add*! [md mongo-dict?] [key symbol?] [vals sequence?]) void]{ Adds a sequence of values to the sequence if they are not present atomically. } 263 | @defproc[(mongo-dict-pop! [md mongo-dict?] [key symbol?]) void]{ Pops a value off the sequence atomically. } 264 | @defproc[(mongo-dict-shift! [md mongo-dict?] [key symbol?]) void]{ Shifts a value off the sequence atomically. } 265 | @defproc[(mongo-dict-pull! [md mongo-dict?] [key symbol?] [val any/c]) void]{ Remove a value to the sequence if it is present atomically. } 266 | @defproc[(mongo-dict-pull*! [md mongo-dict?] [key symbol?] [vals sequence?]) void]{ Removes a sequence of values to the sequence if they are present atomically. } 267 | 268 | @subsection{Structures} 269 | 270 | @defmodule[db/mongodb/orm/struct] 271 | 272 | @racket[define-mongo-struct] is a macro to create some convenience functions for @tech{Mongo dictionaries}. 273 | 274 | @defform/subs[(define-mongo-struct struct collection 275 | ([field opt ...] 276 | ...)) 277 | ([opt #:required #:immutable 278 | #:ref #:set! #:inc #:null #:push #:append #:set-add #:set-add* #:pop #:shift #:pull #:pull*]) 279 | #:contracts ([struct identifier?] 280 | [collection string?] 281 | [field identifier?])]{ 282 | Defines @racket[make-struct] and a set of operations for the fields. 283 | 284 | Every field implicitly has the @racket[#:ref] option. Every mutable field implicitly has the @racket[#:set!] option. Every immutable field implicitly has the @racket[#:required] option. It is an error for an immutable field to have any options other than @racket[#:required] and @racket[#:ref], which are both implicit. 285 | 286 | @racket[make-struct] takes one keyword argument per field. If the field does not have the @racket[#:required] option, the argument is optional and the instance will not contain a value for the field. @racket[make-struct] returns a @racket[mongo-dict?]. 287 | 288 | If a field has the @racket[#:ref] option, then @racket[struct-field] is defined. It is implemented with @racket[mongo-dict-ref]. 289 | 290 | If a field has the @racket[#:set] option, then @racket[set-struct-field!] is defined. It is implemented with @racket[mongo-dict-set!]. 291 | 292 | If a field has the @racket[#:inc] option, then @racket[inc-struct-field!] is defined. It is implemented with @racket[mongo-dict-inc!]. 293 | 294 | If a field has the @racket[#:null] option, then @racket[null-struct-field!] is defined. It is implemented with @racket[mongo-dict-remove!]. 295 | 296 | If a field has the @racket[#:push] option, then @racket[push-struct-field!] is defined. It is implemented with @racket[mongo-dict-push!]. 297 | 298 | If a field has the @racket[#:append] option, then @racket[append-struct-field!] is defined. It is implemented with @racket[mongo-dict-append!]. 299 | 300 | If a field has the @racket[#:set-add] option, then @racket[set-add-struct-field!] is defined. It is implemented with @racket[mongo-dict-set-add!]. 301 | 302 | If a field has the @racket[#:set-add*] option, then @racket[set-add*-struct-field!] is defined. It is implemented with @racket[mongo-dict-set-add*!]. 303 | 304 | If a field has the @racket[#:pop] option, then @racket[pop-struct-field!] is defined. It is implemented with @racket[mongo-dict-pop!]. 305 | 306 | If a field has the @racket[#:shift] option, then @racket[shift-struct-field!] is defined. It is implemented with @racket[mongo-dict-shift!]. 307 | 308 | If a field has the @racket[#:pull] option, then @racket[pull-struct-field!] is defined. It is implemented with @racket[mongo-dict-pull!]. 309 | 310 | If a field has the @racket[#:pull*] option, then @racket[pull*-struct-field!] is defined. It is implemented with @racket[mongo-dict-pull*!]. 311 | 312 | } 313 | 314 | @section{Other} 315 | 316 | @subsection{Dispatch Rules} 317 | 318 | @(require (for-label web-server/dispatch/mongodb)) 319 | 320 | @defmodule[web-server/dispatch/mongodb] 321 | 322 | @defform[(mongo-dict-arg col) #:contracts ([col string?])]{ 323 | A bi-directional match expander for @racketmodname[web-server/dispatch] that serializes to and from @tech{Mongo dictionaries} from the @racket[col] collection. 324 | } 325 | 326 | 327 | -------------------------------------------------------------------------------- /db/mongodb/orm/dict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/dict 4 | racket/contract 5 | racket/serialize 6 | net/bson 7 | db/mongodb/seq 8 | db/mongodb/basic/main) 9 | 10 | (define current-mongo-db (make-parameter #f)) 11 | 12 | (define (create-mongo-dict col) 13 | (define id (new-bson-objectid)) 14 | (define c (make-mongo-collection (current-mongo-db) col)) 15 | ; XXX Delay committing 16 | (mongo-collection-insert! c (list (cons '_id id))) 17 | (make-mongo-dict col id)) 18 | 19 | (define (mongo-dict-query col query) 20 | (define c (make-mongo-collection (current-mongo-db) col)) 21 | (sequence-map 22 | (lambda (ans) 23 | (define id (hash-ref ans '_id)) 24 | (make-mongo-dict col id)) 25 | (mongo-collection-find 26 | c query 27 | #:selector (list (cons '_id 1))))) 28 | 29 | (define (mongo-dict-find md sel) 30 | (match-define (struct mongo-dict (col-name id)) md) 31 | (define c (make-mongo-collection (current-mongo-db) col-name)) 32 | (define query (list (cons '_id id))) 33 | (define cur 34 | (mongo-collection-find c query 35 | #:selector sel 36 | #:limit -1)) 37 | (sequence-ref cur 0)) 38 | 39 | (define (mongo-dict-ref md key [fail bson-null]) 40 | (with-handlers ([exn:fail? 41 | (lambda (x) 42 | (if (procedure? fail) (fail) 43 | fail))]) 44 | (hash-ref (mongo-dict-find md (list (cons key 1))) key))) 45 | 46 | (define (mongo-dict-replace! md mod) 47 | (match-define (struct mongo-dict (col-name id)) md) 48 | (define c (make-mongo-collection (current-mongo-db) col-name)) 49 | (define query (list (cons '_id id))) 50 | (hash-remove! MONGO-DICT-CACHE md) 51 | (mongo-collection-modify! 52 | c query mod)) 53 | 54 | (define (mongo-dict-set! md key val) 55 | (mongo-dict-replace! md (list (cons '$set (list (cons key val)))))) 56 | ; XXX set*! 57 | (define (mongo-dict-remove! md key) 58 | (mongo-dict-replace! md (list (cons '$unset (list (cons key 1)))))) 59 | 60 | (define (mongo-dict->dict md) 61 | (define ans (mongo-dict-find md #f)) 62 | (hash-remove! ans '_id) 63 | ans) 64 | 65 | (define MONGO-DICT-CACHE (make-weak-hasheq)) 66 | (define (make-mongo-dict-wrapper dict-fun) 67 | (lambda (md . args) 68 | (define dict-box 69 | (hash-ref! MONGO-DICT-CACHE md (lambda () (make-weak-box (mongo-dict->dict md))))) 70 | (define dict-val 71 | (match (weak-box-value dict-box) 72 | [#f 73 | (define v (mongo-dict->dict md)) 74 | (hash-set! MONGO-DICT-CACHE md (make-weak-box v)) 75 | v] 76 | [e e])) 77 | (apply dict-fun dict-val args))) 78 | 79 | (define mongo-dict-count (make-mongo-dict-wrapper dict-count)) 80 | (define mongo-dict-iterate-first (make-mongo-dict-wrapper dict-iterate-first)) 81 | (define mongo-dict-iterate-next (make-mongo-dict-wrapper dict-iterate-next)) 82 | (define mongo-dict-iterate-key (make-mongo-dict-wrapper dict-iterate-key)) 83 | (define mongo-dict-iterate-value (make-mongo-dict-wrapper dict-iterate-value)) 84 | 85 | (define (mongo-dict-inc! md key [inc 1]) 86 | (mongo-dict-replace! md (list (cons '$inc (list (cons key inc)))))) 87 | (define (mongo-dict-push! md key val) 88 | (mongo-dict-replace! md (list (cons '$push (list (cons key val)))))) 89 | (define (mongo-dict-append! md key vals) 90 | (mongo-dict-replace! md (list (cons '$pushAll (list (cons key vals)))))) 91 | (define (mongo-dict-set-add! md key val) 92 | (mongo-dict-replace! md (list (cons '$addToSet (list (cons key val)))))) 93 | (define (mongo-dict-set-add*! md key vals) 94 | (mongo-dict-replace! md (list (cons '$addToSet (list (cons key (list (cons '$each vals)))))))) 95 | (define (mongo-dict-pop! md key) 96 | (mongo-dict-replace! md (list (cons '$pop (list (cons key 1)))))) 97 | (define (mongo-dict-shift! md key) 98 | (mongo-dict-replace! md (list (cons '$pop (list (cons key -1)))))) 99 | (define (mongo-dict-pull! md key val) 100 | (mongo-dict-replace! md (list (cons '$pull (list (cons key val)))))) 101 | (define (mongo-dict-pull*! md key vals) 102 | (mongo-dict-replace! md (list (cons '$pullAll (list (cons key vals)))))) 103 | 104 | (define-serializable-struct mongo-dict (collection-name id) 105 | #:transparent 106 | #:property prop:sequence 107 | (lambda (md) 108 | (mongo-dict->dict md)) 109 | #:property prop:dict 110 | (vector mongo-dict-ref 111 | mongo-dict-set! 112 | #f 113 | mongo-dict-remove! 114 | #f 115 | mongo-dict-count 116 | mongo-dict-iterate-first 117 | mongo-dict-iterate-next 118 | mongo-dict-iterate-key 119 | mongo-dict-iterate-value)) 120 | 121 | (provide/contract 122 | [struct mongo-dict ([collection-name string?] 123 | [id bson-objectid?])] 124 | [current-mongo-db (parameter/c (or/c false/c mongo-db?))] 125 | [create-mongo-dict (string? . -> . mongo-dict?)] 126 | [mongo-dict-query (string? bson-document/c . -> . sequence?)] 127 | [mongo-dict-ref ((mongo-dict? symbol?) (any/c) . ->* . any/c)] 128 | [mongo-dict-set! (mongo-dict? symbol? any/c . -> . void)] 129 | [mongo-dict-remove! (mongo-dict? symbol? . -> . void)] 130 | [mongo-dict-count (mongo-dict? . -> . exact-nonnegative-integer?)] 131 | [mongo-dict-inc! ((mongo-dict? symbol?) (number?) . ->* . void)] 132 | [mongo-dict-push! (mongo-dict? symbol? any/c . -> . void)] 133 | [mongo-dict-append! (mongo-dict? symbol? sequence? . -> . void)] 134 | [mongo-dict-set-add! (mongo-dict? symbol? any/c . -> . void)] 135 | [mongo-dict-set-add*! (mongo-dict? symbol? sequence? . -> . void)] 136 | [mongo-dict-pop! (mongo-dict? symbol? . -> . void)] 137 | [mongo-dict-shift! (mongo-dict? symbol? . -> . void)] 138 | [mongo-dict-pull! (mongo-dict? symbol? any/c . -> . void)] 139 | [mongo-dict-pull*! (mongo-dict? symbol? sequence? . -> . void)]) 140 | -------------------------------------------------------------------------------- /db/mongodb/orm/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "dict.rkt" 3 | "struct.rkt") 4 | (provide (all-from-out "dict.rkt" 5 | "struct.rkt")) 6 | -------------------------------------------------------------------------------- /db/mongodb/orm/struct.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (for-syntax racket/base 3 | syntax/parse 4 | racket/list 5 | syntax/stx 6 | racket/syntax) 7 | "dict.rkt") 8 | 9 | (define-syntax (define-mongo-struct stx) 10 | (syntax-parse 11 | stx 12 | [(_ struct:id collection:str 13 | ([field:id given-opt:keyword ...] 14 | ...)) 15 | (with-syntax* 16 | ([make-struct 17 | (format-id #'struct "make-~a" #'struct)] 18 | [((required? opt ...) ...) 19 | (stx-map (lambda (opts-stx) 20 | (define opts (syntax->list opts-stx)) 21 | (define immutable? 22 | (findf (lambda (stx) 23 | (syntax-parse 24 | stx 25 | [#:immutable #t] 26 | [_ #f])) 27 | opts)) 28 | (define required? 29 | (or immutable? 30 | (findf (lambda (stx) 31 | (syntax-parse 32 | stx 33 | [#:required #t] 34 | [_ #f])) 35 | opts))) 36 | (define null? 37 | (findf (lambda (stx) 38 | (syntax-parse 39 | stx 40 | [#:null #t] 41 | [_ #f])) 42 | opts)) 43 | (define base-opts 44 | (filter (lambda (stx) 45 | (syntax-parse 46 | stx 47 | [#:required #f] 48 | [#:immutable #f] 49 | [#:ref #f] 50 | [_ #t])) 51 | opts)) 52 | (define ref-opts 53 | (list* #'#:ref base-opts)) 54 | (define set-opts 55 | (if immutable? 56 | ref-opts 57 | (list* #'#:set! ref-opts))) 58 | (when (and immutable? (not (zero? (length base-opts)))) 59 | (raise-syntax-error 'define-mongo-struct "Immutable fields cannot have mutation operators" opts-stx (first base-opts))) 60 | (when (and required? null?) 61 | (raise-syntax-error 'define-mongo-struct "Required fields cannot have a null operator" opts-stx null?)) 62 | (cons (and required? #t) set-opts)) 63 | #'((given-opt ...) ...))] 64 | [(field-kw ...) 65 | (stx-map (lambda (field) 66 | (datum->syntax field (string->keyword (symbol->string (syntax->datum field))))) 67 | #'(field ...))] 68 | [(field-arg ...) 69 | (for/fold ([arg-stx #'()]) 70 | ([field (in-list (syntax->list #'(field ...)))] 71 | [required? (in-list (syntax->list #'(required? ...)))] 72 | [field-kw (in-list (syntax->list #'(field-kw ...)))]) 73 | (if (syntax->datum required?) 74 | (quasisyntax/loc stx 75 | (#,field-kw #,field #,@arg-stx)) 76 | (quasisyntax/loc stx 77 | (#,field-kw [#,field (void)] #,@arg-stx))))]) 78 | (syntax/loc stx 79 | (begin 80 | (define the-collection collection) 81 | (define (make-struct field-arg ...) 82 | (define the-struct 83 | (create-mongo-dict the-collection)) 84 | (unless (void? field) 85 | (mongo-dict-set! the-struct 'field field)) 86 | ... 87 | the-struct) 88 | (define-mongo-struct-field struct field (opt ...)) 89 | ...)))])) 90 | 91 | (define-syntax (define-mongo-struct-field stx) 92 | (syntax-parse 93 | stx 94 | [(_ struct:id field:id (opt:keyword ...)) 95 | (with-syntax 96 | ([((name fun) ...) 97 | (filter-map 98 | (lambda (stx) 99 | (syntax-parse 100 | stx 101 | [#:ref 102 | (list (format-id #'struct "~a-~a" #'struct #'field) 103 | #'mongo-dict-ref)] 104 | [#:set! 105 | (list (format-id #'struct "set-~a-~a!" #'struct #'field) 106 | #'mongo-dict-set!)] 107 | [#:inc 108 | (list (format-id #'struct "inc-~a-~a!" #'struct #'field) 109 | #'mongo-dict-inc!)] 110 | [#:null 111 | (list (format-id #'struct "null-~a-~a!" #'struct #'field) 112 | #'mongo-dict-remove!)] 113 | [#:push 114 | (list (format-id #'struct "push-~a-~a!" #'struct #'field) 115 | #'mongo-dict-push!)] 116 | [#:append 117 | (list (format-id #'struct "append-~a-~a!" #'struct #'field) 118 | #'mongo-dict-append!)] 119 | [#:set-add 120 | (list (format-id #'struct "set-add-~a-~a!" #'struct #'field) 121 | #'mongo-dict-set-add!)] 122 | [#:set-add* 123 | (list (format-id #'struct "set-add*-~a-~a!" #'struct #'field) 124 | #'mongo-dict-set-add*!)] 125 | [#:pop 126 | (list (format-id #'struct "pop-~a-~a!" #'struct #'field) 127 | #'mongo-dict-pop!)] 128 | [#:shift 129 | (list (format-id #'struct "shift-~a-~a!" #'struct #'field) 130 | #'mongo-dict-shift!)] 131 | [#:pull 132 | (list (format-id #'struct "pull-~a-~a!" #'struct #'field) 133 | #'mongo-dict-pull!)] 134 | [#:pull* 135 | (list (format-id #'struct "pull*-~a-~a!" #'struct #'field) 136 | #'mongo-dict-pull*!)] 137 | [_ 138 | (raise-syntax-error 'define-mongo-struct "Invalid field option" stx)])) 139 | (syntax->list #'(opt ...)))]) 140 | (syntax/loc stx 141 | (begin 142 | (define-mongo-struct-field* field name fun) 143 | ...)))])) 144 | 145 | (define-syntax (define-mongo-struct-field* stx) 146 | (syntax-parse 147 | stx 148 | [(_ field:id name:id opt-fun:id) 149 | (syntax/loc stx 150 | (define (name the-struct . args) 151 | (apply opt-fun the-struct 'field args)))])) 152 | 153 | (provide define-mongo-struct) 154 | -------------------------------------------------------------------------------- /db/mongodb/seq.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define (sequence-ref s i) 4 | (define-values (more? get) (sequence-generate s)) 5 | (let loop ([n i]) 6 | (if (more?) 7 | (if (zero? n) 8 | (get) 9 | (begin 10 | (get) 11 | (loop (sub1 n)))) 12 | (error 'sequence-ref "Sequence does not contain ~e elements" i)))) 13 | 14 | (define (sequence-count s) 15 | (define-values (more? get) (sequence-generate s)) 16 | (let loop ([i 0]) 17 | (if (more?) 18 | (begin (get) (loop (add1 i))) 19 | i))) 20 | 21 | (define (sequence->list s) 22 | (for/list ([e s]) e)) 23 | 24 | (define (sequence-map f s) 25 | (make-do-sequence 26 | (lambda () 27 | (define-values (more? get) (sequence-generate s)) 28 | (values 29 | (lambda (pos) 30 | (call-with-values get f)) 31 | (lambda (pos) pos) 32 | 0 33 | (lambda (pos) (more?)) 34 | (lambda (val) #t) 35 | (lambda (pos val) #t))))) 36 | 37 | ; XXX 38 | (define (sequenceof c) 39 | sequence?) 40 | 41 | (provide/contract 42 | [sequence->list (sequence? . -> . list?)] 43 | [sequence-ref (sequence? exact-nonnegative-integer? . -> . any/c)] 44 | [sequence-count (sequence? . -> . exact-nonnegative-integer?)] 45 | [sequence-map (procedure? sequence? . -> . sequence?)] 46 | [sequenceof (contract? . -> . contract?)]) -------------------------------------------------------------------------------- /db/mongodb/wire/driver.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/tcp 3 | racket/match 4 | racket/local 5 | racket/contract 6 | net/bson/binio 7 | "format.rkt") 8 | 9 | (define-struct mongo-connection (input output)) 10 | 11 | (define (create-mongo-connection #:host [hostname "localhost"] 12 | #:port [port 27017]) 13 | (call-with-values (lambda () (tcp-connect hostname port)) 14 | make-mongo-connection)) 15 | (define close-mongo-connection! 16 | (match-lambda 17 | [(struct mongo-connection (ip op)) 18 | (close-input-port ip) 19 | (close-output-port op)])) 20 | 21 | (define (msg-has-response? m) 22 | (or (query? m) 23 | (get-more? m))) 24 | 25 | (define (send-message c m) 26 | (match-define (struct mongo-connection (ip op)) c) 27 | (write-msg m op) 28 | (if (msg-has-response? m) 29 | (read-msg ip) 30 | #f)) 31 | 32 | (define new-msg-id 33 | (local [(define c 0)] 34 | (lambda () 35 | (unless (int32? c) 36 | (set! c 0)) 37 | (begin0 c (set! c (add1 c)))))) 38 | 39 | (provide/contract 40 | [mongo-connection? contract?] 41 | [create-mongo-connection (() (#:host string? #:port port-number?) . ->* . mongo-connection?)] 42 | [close-mongo-connection! (mongo-connection? . -> . void)] 43 | [send-message (mongo-connection? msg? . -> . (or/c false/c reply?))] 44 | [new-msg-id (-> int32?)]) 45 | -------------------------------------------------------------------------------- /db/mongodb/wire/format.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/function 4 | racket/contract 5 | net/bson 6 | net/bson/driver 7 | net/bson/binio 8 | net/bson/mapping 9 | db/mongodb/seq) 10 | 11 | ;;; Structs 12 | (define-struct msg (id response-to) #:transparent) 13 | (define-struct (reply msg) (error? cursor-id starting-from documents) #:transparent) 14 | 15 | (define-struct (update msg) (collection flags selector document) #:transparent) 16 | (define-struct (insert msg) (collection documents) #:transparent) 17 | (define-struct (query msg) (collection options to-skip to-return query selector) #:transparent) 18 | (define-struct (get-more msg) (collection to-return cursor-id) #:transparent) 19 | (define-struct (delete msg) (collection selector) #:transparent) 20 | (define-struct (kill-cursors msg) (cursor-ids) #:transparent) 21 | 22 | ;;; Op codes 23 | (define (not-supported x) #f) 24 | (define-mappings/pred (op-code->tag tag->op-code v->tag) 25 | "Invalid msg: ~e" 26 | [(1) 'OP_REPLY reply?] 27 | [(1000) 'OP_MSG not-supported] 28 | [(2001) 'OP_UPDATE update?] 29 | [(2002) 'OP_INSERT insert?] 30 | [(2003) 'RESERVED not-supported] 31 | [(2004) 'OP_QUERY query?] 32 | [(2005) 'OP_GET_MORE get-more?] 33 | [(2006) 'OP_DELETE delete?] 34 | [(2007) 'OP_KILL_CURSORS kill-cursors?]) 35 | 36 | ;;; Writers 37 | (define (write-msg m p) 38 | (define-values (body-size write-body) 39 | (prepare-body m)) 40 | (write-header body-size m p) 41 | (write-body p) 42 | (flush-output p)) 43 | 44 | (define (write-header body-size m p) 45 | (match-define (struct msg (id response-to)) m) 46 | (define op-code 47 | (hash-ref tag->op-code (v->tag m))) 48 | (write-int32 p (+ int32-size int32-size int32-size int32-size body-size)) 49 | (write-int32 p id) 50 | (write-int32 p response-to) 51 | (write-int32 p op-code)) 52 | 53 | (define (prepare-vector prepare-e v) 54 | (for/fold ([size 0] 55 | [write-before void]) 56 | ([d v]) 57 | (define-values (d-size write-d) (prepare-e d)) 58 | (values (+ size d-size) 59 | (lambda (p) 60 | (write-before p) 61 | (write-d p))))) 62 | 63 | (define prepare-bson* (curry prepare-vector prepare-bson)) 64 | 65 | (define (maybe-prepare-bson mb) 66 | (if mb 67 | (prepare-bson mb) 68 | (values 0 void))) 69 | 70 | (define-syntax-rule (define-set->int32 f 71 | contract/c 72 | [symbol bit] 73 | ...) 74 | (begin (define contract/c 75 | (listof (symbols 'symbol ...))) 76 | (define (f s) 77 | (+ (if (member 'symbol s) 78 | bit 0) 79 | ...)))) 80 | 81 | (define-set->int32 update-flag-set->flags 82 | update-flags/c 83 | [upsert 1] 84 | [multi-update 2]) 85 | 86 | (define-set->int32 query-opt-set->opts 87 | query-opts/c 88 | [tailable-cursor 2] 89 | [slave-ok 4] 90 | #;[oplog-replay 8] ; (internal replication use only - drivers should not implement) 91 | [no-cursor-timeout 16]) 92 | 93 | (define prepare-body 94 | (match-lambda 95 | [(struct update (_ _ col flag-set sel doc)) 96 | (define flags (update-flag-set->flags flag-set)) 97 | (define-values (col-size write-col) (prepare-cstring col)) 98 | (define-values (sel-size write-sel) (prepare-bson sel)) 99 | (define-values (doc-size write-doc) (prepare-bson doc)) 100 | (values (+ int32-size col-size int32-size sel-size doc-size) 101 | (lambda (p) 102 | (write-int32 p 0) 103 | (write-col p) 104 | (write-int32 p flags) 105 | (write-sel p) 106 | (write-doc p)))] 107 | [(struct insert (_ _ col docs)) 108 | (define-values (col-size write-col) (prepare-cstring col)) 109 | (define-values (docs-size write-docs) (prepare-bson* docs)) 110 | (values (+ int32-size col-size docs-size) 111 | (lambda (p) 112 | (write-int32 p 0) 113 | (write-col p) 114 | (write-docs p)))] 115 | [(struct query (_ _ col opt-set to-skip to-return query sel)) 116 | (define opts (query-opt-set->opts opt-set)) 117 | (define-values (col-size write-col) (prepare-cstring col)) 118 | (define-values (query-size write-query) (prepare-bson query)) 119 | (define-values (sel-size write-sel) (maybe-prepare-bson sel)) 120 | (values (+ int32-size col-size int32-size int32-size query-size sel-size) 121 | (lambda (p) 122 | (write-int32 p opts) 123 | (write-col p) 124 | (write-int32 p to-skip) 125 | (write-int32 p to-return) 126 | (write-query p) 127 | (write-sel p)))] 128 | [(struct get-more (_ _ col to-return cursor-id)) 129 | (define-values (col-size write-col) (prepare-cstring col)) 130 | (values (+ int32-size col-size int32-size int64-size) 131 | (lambda (p) 132 | (write-int32 p 0) 133 | (write-col p) 134 | (write-int32 p to-return) 135 | (write-int64 p cursor-id)))] 136 | [(struct delete (_ _ col sel)) 137 | (define-values (col-size write-col) (prepare-cstring col)) 138 | (define-values (sel-size write-sel) (prepare-bson sel)) 139 | (values (+ int32-size col-size int32-size sel-size) 140 | (lambda (p) 141 | (write-int32 p 0) 142 | (write-col p) 143 | (write-int32 p 0) 144 | (write-sel p)))] 145 | [(struct kill-cursors (_ _ cursor-ids)) 146 | (define-values (cs-size write-cs) (prepare-vector prepare-int64 cursor-ids)) 147 | (values (+ int32-size int32-size cs-size) 148 | (lambda (p) 149 | (write-int32 p 0) 150 | (write-int32 p (vector-length cursor-ids)) 151 | (write-cs p)))])) 152 | 153 | 154 | ;;; Readers 155 | (define (read-msg p) 156 | (define-values (len id response-to op-code) 157 | (read-header p)) 158 | (define tag 159 | (hash-ref op-code->tag op-code 160 | (lambda () 161 | (error 'read-msg "Invalid op code: ~e" op-code)))) 162 | (case tag 163 | [(OP_REPLY) 164 | (read-reply id response-to p)] 165 | [else 166 | (error 'read-msg "Unsupported op code: ~e" tag)])) 167 | 168 | (define (read-header p) 169 | (define len (read-int32 p)) 170 | (define id (read-int32 p)) 171 | (define response-to (read-int32 p)) 172 | (define op-code (read-int32 p)) 173 | (values len id response-to op-code)) 174 | 175 | (define (reply-flag->error? flag) 176 | (case flag 177 | [(0 8) #f] 178 | [else #t])) 179 | 180 | (define (read-reply id response-to p) 181 | (define flag (read-int32 p)) 182 | (define cursor-id (read-int64 p)) 183 | (define starting-from (read-int32 p)) 184 | (define number-returned (read-int32 p)) 185 | (define documents 186 | (build-vector number-returned 187 | (lambda (i) (read-bson p)))) 188 | (make-reply id response-to (reply-flag->error? flag) cursor-id starting-from documents)) 189 | 190 | ;;; Exports w/ contracts 191 | (provide/contract 192 | [read-msg (input-port? . -> . msg?)] 193 | [write-msg (msg? output-port? . -> . void)] 194 | 195 | [update-flags/c contract?] 196 | [query-opts/c contract?] 197 | 198 | [struct msg 199 | ([id int32?] 200 | [response-to int32?])] 201 | [struct (reply msg) 202 | ([id int32?] 203 | [response-to int32?] 204 | [error? boolean?] 205 | [cursor-id int64?] 206 | [starting-from int32?] 207 | [documents (vectorof bson-document/c)])] 208 | 209 | [struct (update msg) 210 | ([id int32?] 211 | [response-to int32?] 212 | [collection string?] 213 | [flags update-flags/c] 214 | [selector bson-document/c] 215 | [document bson-document/c])] 216 | [struct (insert msg) 217 | ([id int32?] 218 | [response-to int32?] 219 | [collection string?] 220 | [documents (sequenceof bson-document/c)])] 221 | [struct (query msg) 222 | ([id int32?] 223 | [response-to int32?] 224 | [collection string?] 225 | [options query-opts/c] 226 | [to-skip int32?] 227 | [to-return int32?] 228 | [query bson-document/c] 229 | [selector (or/c false/c bson-document/c)])] 230 | [struct (get-more msg) 231 | ([id int32?] 232 | [response-to int32?] 233 | [collection string?] 234 | [to-return int32?] 235 | [cursor-id int64?])] 236 | [struct (delete msg) 237 | ([id int32?] 238 | [response-to int32?] 239 | [collection string?] 240 | [selector bson-document/c])] 241 | [struct (kill-cursors msg) 242 | ([id int32?] 243 | [response-to int32?] 244 | [cursor-ids (vectorof int64?)])]) 245 | 246 | -------------------------------------------------------------------------------- /db/mongodb/wire/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "format.rkt" 3 | "driver.rkt") 4 | (provide (all-from-out "format.rkt" 5 | "driver.rkt")) 6 | -------------------------------------------------------------------------------- /info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection 'multi) 3 | (define license '(Apache-2.0 OR MIT)) 4 | (define deps '(("base" #:version "6.2.900.15") "web-server-lib" "srfi-lite-lib")) 5 | (define build-deps '("eli-tester" "racket-doc" "scribble-lib" "srfi-doc" "web-server-doc")) 6 | -------------------------------------------------------------------------------- /net/bson.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require net/bson/shared 3 | net/bson/binio 4 | racket/contract) 5 | 6 | (define bson-document/c 7 | bson-dict?) 8 | (define bson-sequence/c 9 | bson-sequence?) 10 | 11 | (provide 12 | int32? 13 | int64?) 14 | (provide/contract 15 | [bson-document/c contract?] 16 | 17 | [bson-min-key? contract?] 18 | [bson-min-key bson-min-key?] 19 | 20 | [bson-max-key? contract?] 21 | [bson-max-key bson-max-key?] 22 | 23 | [bson-null? contract?] 24 | [bson-null bson-null?] 25 | 26 | [struct bson-timestamp ([value int64?])] 27 | [struct bson-javascript ([string string?])] 28 | [struct bson-javascript/scope ([string string?] 29 | [scope bson-document/c])] 30 | [struct bson-binary ([type (symbols 'function 'binary 'uuid 'md5 'user-defined)] 31 | [bs bytes?])] 32 | [struct bson-regexp ([pattern string?] 33 | ; XXX more constraints on this 34 | [options string?])] 35 | 36 | [bson-objectid? contract?] 37 | [string->bson-objectid (string? . -> . bson-objectid?)] 38 | [bson-objectid->string (bson-objectid? . -> . string?)] 39 | [new-bson-objectid (-> bson-objectid?)] 40 | [bson-objectid-timestamp (bson-objectid? . -> . exact-integer?)] 41 | 42 | [bson-sequence/c contract?]) 43 | -------------------------------------------------------------------------------- /net/bson/binio.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (define int32-size 4) 4 | (define int64-size 8) 5 | 6 | (define (read-int32 p) 7 | (define bs (read-bytes int32-size p)) 8 | (integer-bytes->integer bs #t #f)) 9 | (define (read-int64 p) 10 | (define bs (read-bytes int64-size p)) 11 | (integer-bytes->integer bs #t #f)) 12 | 13 | (define (write-int32 p n) 14 | (write-bytes (integer->integer-bytes n int32-size #t #f) p)) 15 | (define (write-int64 p n) 16 | (write-bytes (integer->integer-bytes n int64-size #t #f) p)) 17 | 18 | (define (int32? x) 19 | (and (integer? x) 20 | (<= (* -1 2147483648) x +2147483647))) 21 | (define (int64? x) 22 | (and (integer? x) 23 | (<= (* -1 9223372036854775808) x +9223372036854775807))) 24 | 25 | (define (prepare-cstring s) 26 | (values (add1 (string-utf-8-length s)) 27 | (lambda (p) 28 | (write-string s p) 29 | (write-null-byte p)))) 30 | (define (prepare-int32 v) 31 | (values int32-size 32 | (lambda (p) 33 | (write-int32 p v)))) 34 | (define (prepare-int64 v) 35 | (values int64-size 36 | (lambda (p) 37 | (write-int64 p v)))) 38 | 39 | (define (write-null-byte p) 40 | (write-byte 0 p)) 41 | 42 | (provide (all-defined-out)) -------------------------------------------------------------------------------- /net/bson/driver.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract 3 | "read.rkt" 4 | "write.rkt" 5 | net/bson) 6 | 7 | (provide/contract 8 | [read-bson (input-port? . -> . bson-document/c)] 9 | [read-bson/bytes (bytes? . -> . bson-document/c)] 10 | [rename prepare-document prepare-bson (bson-document/c . -> . (values exact-integer? (output-port? . -> . void)))] 11 | [write-bson (bson-document/c output-port? . -> . void)] 12 | [write-bson/bytes (bson-document/c . -> . bytes?)]) 13 | -------------------------------------------------------------------------------- /net/bson/mapping.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | 4 | (define-syntax-rule (define-mappings (lhs->rhs rhs->lhs) 5 | [(lhs) rhs] ...) 6 | (begin (define lhs->rhs 7 | (make-hasheq (list (cons lhs rhs) ...))) 8 | (define rhs->lhs 9 | (make-hasheq (list (cons rhs lhs) ...))))) 10 | (define-syntax-rule (define-mappings/pred (lhs->rhs rhs->lhs value->rhs) 11 | error-msg 12 | [(lhs) rhs pred] ...) 13 | (begin (define-mappings (lhs->rhs rhs->lhs) 14 | [(lhs) rhs] ...) 15 | (define (value->rhs x) 16 | (cond 17 | [(pred x) rhs] 18 | ... 19 | [else 20 | (error 'value->rhs error-msg x)])))) 21 | 22 | 23 | (provide (all-defined-out)) -------------------------------------------------------------------------------- /net/bson/read.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require (prefix-in racket: racket/base) 3 | racket/list 4 | racket/function 5 | "shared.rkt" 6 | "binio.rkt") 7 | 8 | (provide read-bson read-bson/bytes) 9 | 10 | (define (read-document p) 11 | (define total-bytes (read-int32 p)) 12 | (define ht (make-hasheq)) 13 | (read-into-hash ht p read-element-into-hash) 14 | ht) 15 | 16 | (define (read-into-hash ht p reader) 17 | (define t (read-type-tag p)) 18 | (case t 19 | [(eof) (void)] 20 | [else 21 | (reader ht t p) 22 | (read-into-hash ht p reader)])) 23 | 24 | (define (read-element-into-hash ht type p) 25 | (define name (read-element-name p)) 26 | (hash-set! ht name (read-type type p))) 27 | 28 | (define (read-boolean p) 29 | (case (read-byte p) 30 | [(#x00) #f] 31 | [(#x01) #t])) 32 | 33 | (define (read-javascript-code/scope p) 34 | (define total-size (read-int32 p)) 35 | (define code (read-string p)) 36 | (define scope (read-document p)) 37 | (make-bson-javascript/scope code scope)) 38 | 39 | (define (read-binary p) 40 | (define array-size (read-int32 p)) 41 | (define subtype-b (read-byte p)) 42 | (define subtype (hash-ref binary-byte->tag subtype-b)) 43 | (case subtype 44 | [(binary) 45 | (let ([bytes-size (read-int32 p)]) 46 | (read-bytes bytes-size p))] 47 | [else 48 | (make-bson-binary subtype (read-bytes array-size p))])) 49 | 50 | (define (read-oid p) 51 | (make-bson-objectid (read-bytes 12 p))) 52 | 53 | (define (read-regexp p) 54 | (define pat (read-cstring p)) 55 | (define opts (read-cstring p)) 56 | (make-bson-regexp pat opts)) 57 | 58 | (define (read-type t p) 59 | (case t 60 | [(floating-point) (read-double p)] 61 | [(utf8-string) (read-string p)] 62 | [(document) (read-document p)] 63 | [(array) (document->array (read-document p))] 64 | [(binary) (read-binary p)] 65 | [(undefined) 66 | (error 'read-type "Undefined is deprecated")] 67 | [(objectid) (read-oid p)] 68 | [(boolean) (read-boolean p)] 69 | [(utc-datetime) (make-bson-utc-datetime (read-int64 p))] 70 | [(null) bson-null] 71 | [(regexp) (read-regexp p)] 72 | [(db-pointer) 73 | (error 'read-type "Database pointers are deprecated")] 74 | [(javascript-code) (make-bson-javascript (read-string p))] 75 | [(symbol) (string->symbol (read-string p))] 76 | [(javascript-code/scope) (read-javascript-code/scope p)] 77 | [(int32) (read-int32 p)] 78 | [(timestamp) (make-bson-timestamp (read-int64 p))] 79 | [(int64) (read-int64 p)] 80 | [(min-key) bson-min-key] 81 | [(max-key) bson-max-key] 82 | [else 83 | (error 'read-type "Unknown tag: ~a" t)])) 84 | 85 | (define (document->array d) 86 | (define max (hash-count d)) 87 | (define vec (make-vector max #f)) 88 | (for ([(k v) d]) 89 | (vector-set! vec (symbol->number k) v)) 90 | vec) 91 | 92 | (define (read-until p reader until?) 93 | (define c (reader p)) 94 | (if (until? c) 95 | empty 96 | (list* c (read-until p reader until?)))) 97 | 98 | (define (read-string p) 99 | (define amt+1 (read-int32 p)) 100 | (begin0 (bytes->string/utf-8 (racket:read-bytes (sub1 amt+1) p)) 101 | (read-char p))) 102 | 103 | (define (read-cstring p) 104 | (apply string (read-until p read-char (curry char=? #\nul)))) 105 | 106 | (define (read-double p) 107 | (define bs (read-bytes 8 p)) 108 | (floating-point-bytes->real bs #f)) 109 | 110 | (define read-element-name (compose string->symbol read-cstring)) 111 | 112 | (define (read-type-tag p) 113 | (define b (read-byte p)) 114 | (hash-ref byte->tag b 115 | (lambda () 116 | (error 'read-type-tag "Unknown tag: ~a" b)))) 117 | 118 | ;;;; 119 | (define (read-bson/bytes bs) 120 | (read-document (open-input-bytes bs))) 121 | (define read-bson read-document) 122 | -------------------------------------------------------------------------------- /net/bson/shared.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/function 3 | racket/local 4 | racket/dict 5 | srfi/19 6 | net/bson/mapping 7 | net/bson/binio) 8 | 9 | (define (not-represented x) #f) 10 | (define (deprecated x) #f) 11 | 12 | (define ((and-pred fst snd) x) 13 | (and (fst x) (snd x))) 14 | (define ((or-pred fst snd) x) 15 | (or (fst x) (snd x))) 16 | 17 | (define-struct bson-token ()) 18 | (define bson-min-key (make-bson-token)) 19 | (define bson-max-key (make-bson-token)) 20 | (define bson-null (make-bson-token)) 21 | 22 | (define bson-min-key? (curry eq? bson-min-key)) 23 | (define bson-max-key? (curry eq? bson-max-key)) 24 | (define bson-null? (curry eq? bson-null)) 25 | 26 | (define-struct bson-timestamp (value) #:prefab) 27 | (define-struct bson-javascript (string) #:prefab) 28 | (define-struct bson-javascript/scope (string scope) #:prefab) 29 | (define-struct bson-binary (type bs) #:prefab) 30 | (define-struct bson-objectid (v) #:prefab) 31 | 32 | (define (bson-utc-datetime? x) 33 | (and (time? x) 34 | (eq? (time-type x) time-utc))) 35 | (define (bson-utc-datetime-ms t) 36 | (+ (sec->ms (time-second t)) 37 | (ns->ms (time-nanosecond t)))) 38 | (define (make-bson-utc-datetime ms) 39 | (define-values (s ns) (split-ms ms)) 40 | (make-time time-utc ns s)) 41 | (define (sec->ms s) 42 | (* 1000 s)) 43 | (define (ns->ms ns) 44 | (* ns (expt 10 -6))) 45 | (define (split-ms ms) 46 | (define s (floor (/ ms 1000))) 47 | (define ms-after-s (modulo ms 1000)) 48 | (define ns (* (expt 10 6) ms-after-s)) 49 | (values s ns)) 50 | 51 | (define new-bson-objectid 52 | (local [(define count 0) 53 | (define fuzz (random))] 54 | (lambda () 55 | (begin0 56 | (make-bson-objectid 57 | (bytes-append (integer->integer-bytes (current-seconds) 4 #t #t) 58 | (real->floating-point-bytes fuzz 4 #t) 59 | (integer->integer-bytes count 4 #t #t))) 60 | (set! count (add1 count)))))) 61 | (define (bson-objectid-timestamp v) 62 | (integer-bytes->integer (bson-objectid-v v) #t #t 0 4)) 63 | (require net/base64) 64 | (define (string->bson-objectid s) 65 | (define b (base64-decode (string->bytes/utf-8 s))) 66 | (if (= 12 (bytes-length b)) 67 | (make-bson-objectid b) 68 | (error 'string->bson-objectid "invalid object id, does not base64-decode to 12 bytes: ~e -> ~e" s b))) 69 | (define (bson-objectid->string b) 70 | (bytes->string/utf-8 (base64-encode (bson-objectid-v b)))) 71 | 72 | (define-struct bson-regexp (pattern options) #:prefab) 73 | 74 | (define type-tag-size 1) 75 | 76 | (define-mappings (binary-byte->tag tag->binary-byte) 77 | [(#x01) 'function] 78 | [(#x02) 'binary] 79 | [(#x03) 'uuid] 80 | [(#x05) 'md5] 81 | [(#x80) 'user-defined]) 82 | 83 | (define (bson-dict? d) 84 | (and (dict? d) 85 | (not (or (vector? d))))) 86 | (define (bson-sequence? s) 87 | (and (sequence? s) 88 | (not (or (string? s) 89 | (bson-dict? s) 90 | (bytes? s) 91 | (int32? s) 92 | (int64? s))))) 93 | 94 | (define-mappings/pred (byte->tag tag->byte value->tag) 95 | "Invalid BSON value: ~e" 96 | [(#x00) 'eof not-represented] 97 | [(#x01) 'floating-point (and-pred real? inexact?)] 98 | [(#x02) 'utf8-string string?] 99 | [(#x03) 'document bson-dict?] 100 | [(#x05) 'binary (or-pred bytes? bson-binary?)] 101 | [(#x06) 'undefined deprecated] ; Deprecated 102 | [(#x07) 'objectid bson-objectid?] 103 | [(#x08) 'boolean boolean?] 104 | [(#x09) 'utc-datetime bson-utc-datetime?] 105 | [(#x0A) 'null bson-null?] 106 | [(#x0B) 'regexp bson-regexp?] 107 | [(#x0C) 'db-pointer deprecated] ; Deprecated 108 | [(#x0D) 'javascript-code bson-javascript?] 109 | [(#x0E) 'symbol symbol?] 110 | [(#x0F) 'javascript-code/scope bson-javascript/scope?] 111 | [(#x10) 'int32 int32?] 112 | [(#x11) 'timestamp bson-timestamp?] 113 | [(#x12) 'int64 int64?] 114 | [(#xFF) 'min-key bson-min-key?] 115 | [(#x7F) 'max-key bson-max-key?] 116 | ;; moved down so it doesn't suck up other things: 117 | [(#x04) 'array bson-sequence?]) 118 | 119 | (define symbol->number 120 | (compose string->number symbol->string)) 121 | (define number->symbol 122 | (compose string->symbol number->string)) 123 | 124 | (provide (all-defined-out)) 125 | -------------------------------------------------------------------------------- /net/bson/write.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/dict 3 | racket/match 4 | racket/bool 5 | "shared.rkt" 6 | "binio.rkt") 7 | 8 | (provide write-bson write-bson/bytes prepare-document) 9 | 10 | (define (prepare-document d) 11 | (define-values (almost-total-size write-body) 12 | (prepare-document-body d)) 13 | (define total-size 14 | (+ almost-total-size int32-size 1)) 15 | (values total-size 16 | (lambda (p) 17 | (write-int32 p total-size) 18 | (write-body p) 19 | (write-null-byte p)))) 20 | 21 | (define (prepare-document-body d) 22 | (for/fold ([size 0] 23 | [write void]) 24 | ([(k v) (in-dict d)]) 25 | (define-values (element-size write-element) 26 | (prepare-element k v)) 27 | (values (+ size element-size) 28 | (write-then write write-element)))) 29 | 30 | (define (prepare-element k v) 31 | (define type-tag (value->tag v)) 32 | (define-values (name-size write-name) 33 | (prepare-element-name k)) 34 | (define-values (value-size write-value) 35 | (prepare-value type-tag v)) 36 | (values (+ type-tag-size name-size value-size) 37 | (lambda (p) 38 | (write-type-tag p type-tag) 39 | (write-name p) 40 | (write-value p)))) 41 | 42 | (define prepare-element-name (compose prepare-cstring symbol->string)) 43 | 44 | (define (prepare-double v) 45 | (values 8 46 | (lambda (p) 47 | (write-bytes (real->floating-point-bytes v 8) p)))) 48 | 49 | (define (prepare-string v) 50 | (define-values (str-len write-str) 51 | (prepare-cstring v)) 52 | (values (+ int32-size str-len) 53 | (lambda (p) 54 | (write-int32 p str-len) 55 | (write-str p)))) 56 | 57 | (define (array->document vec) 58 | (for/list ([i (in-naturals)] 59 | [v vec]) 60 | (cons (number->symbol i) v))) 61 | 62 | (define (prepare-boolean v) 63 | (values 1 64 | (lambda (p) 65 | (if v 66 | (write-byte 1 p) 67 | (write-byte 0 p))))) 68 | 69 | (define (no-printing) 70 | (values 0 void)) 71 | 72 | (define prepare-javascript/scope 73 | (match-lambda 74 | [(struct bson-javascript/scope (s d)) 75 | (define-values (s-len write-s) 76 | (prepare-string s)) 77 | (define-values (d-len write-d) 78 | (prepare-document d)) 79 | (define total-size 80 | (+ int32-size s-len d-len)) 81 | (values total-size 82 | (lambda (p) 83 | (write-int32 p total-size) 84 | (write-s p) 85 | (write-d p)))])) 86 | 87 | (define (ensure-binary v) 88 | (if (bytes? v) 89 | (make-bson-binary 'bytes v) 90 | v)) 91 | 92 | (define prepare-binary 93 | (match-lambda 94 | [(struct bson-binary (t bs)) 95 | (define byte-array-size 96 | (+ (if (symbol=? t 'bytes) int32-size 0) 97 | (bytes-length bs))) 98 | (define total-size 99 | (+ int32-size 1 byte-array-size)) 100 | (define rt 101 | (if (symbol=? t 'bytes) 102 | 'binary t)) 103 | (values total-size 104 | (lambda (p) 105 | (write-int32 p byte-array-size) 106 | (write-byte (hash-ref tag->binary-byte rt) p) 107 | (when (symbol=? t 'bytes) 108 | (write-int32 p (bytes-length bs))) 109 | (write-bytes bs p)))])) 110 | 111 | (define (prepare-oid o) 112 | (values 12 113 | (lambda (p) 114 | (write-bytes (bson-objectid-v o) p)))) 115 | 116 | (define prepare-regexp 117 | (match-lambda 118 | [(struct bson-regexp (pat opts)) 119 | (define-values (ps p!) (prepare-cstring pat)) 120 | (define-values (os o!) (prepare-cstring opts)) 121 | (values (+ ps os) 122 | (write-then p! o!))])) 123 | 124 | (define (prepare-value t v) 125 | (case t 126 | [(floating-point) (prepare-double v)] 127 | [(utf8-string) (prepare-string v)] 128 | [(document) (prepare-document v)] 129 | [(array) (prepare-document (array->document v))] 130 | [(binary) (prepare-binary (ensure-binary v))] 131 | [(undefined) 132 | (error 'prepare-value "Undefined is deprecated")] 133 | [(objectid) (prepare-oid v)] 134 | [(boolean) (prepare-boolean v)] 135 | [(utc-datetime) (prepare-int64 (bson-utc-datetime-ms v))] 136 | [(null) (no-printing)] 137 | [(regexp) (prepare-regexp v)] 138 | [(db-pointer) 139 | (error 'prepare-value "Database pointers are deprecated")] 140 | [(javascript-code) (prepare-string (bson-javascript-string v))] 141 | [(symbol) (prepare-string (symbol->string v))] 142 | [(javascript-code/scope) (prepare-javascript/scope v)] 143 | [(int32) (prepare-int32 v)] 144 | [(timestamp) (prepare-int64 (bson-timestamp-value v))] 145 | [(int64) (prepare-int64 v)] 146 | [(min-key) (no-printing)] 147 | [(max-key) (no-printing)] 148 | [else 149 | (error 'prepare-value "Unknown tag: ~a" t)])) 150 | 151 | ;;; 152 | (define (write-type-tag p t) 153 | (write-byte (hash-ref tag->byte t) p)) 154 | 155 | ;;; 156 | 157 | (define ((write-then fst snd) p) 158 | (begin (fst p) 159 | (snd p))) 160 | 161 | ;;; 162 | 163 | (define (write-bson d p) 164 | (define-values (_ write-it!) 165 | (prepare-document d)) 166 | (write-it! p)) 167 | 168 | (define (write-bson/bytes d) 169 | (define ob (open-output-bytes)) 170 | (write-bson d ob) 171 | (get-output-bytes ob)) 172 | -------------------------------------------------------------------------------- /tests/db/mongodb/basic.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require db/mongodb 3 | racket/list 4 | net/bson 5 | "util.rkt" 6 | db/mongodb/seq 7 | tests/eli-tester) 8 | 9 | (module+ test 10 | (when mongod-p 11 | (test 12 | (with-mongod 13 | (define m (create-mongo)) 14 | 15 | (test 16 | (mongo-db-names m) 17 | => 18 | (list "local")) 19 | 20 | ;; added test for mongo-list-databases: 2011-01-20, JBC 21 | (test 22 | (for/list ([d (in-vector (mongo-list-databases m))]) 23 | (hash-ref d 'name)) 24 | => 25 | (list "local")) 26 | 27 | (define d (make-mongo-db m "test")) 28 | 29 | (test 30 | (mongo-db-name d) 31 | => 32 | "test" 33 | 34 | (mongo-db-collections d) 35 | => 36 | empty 37 | 38 | (mongo-db-create-collection! d "test1" #:capped? #f #:size 100) 39 | (mongo-db-create-collection! d "test2" #:capped? #f #:size 100 #:max 20) 40 | 41 | (mongo-db-collections d) 42 | => 43 | (list "test2" "test1" "system.indexes") 44 | 45 | (mongo-db-drop-collection! d "test2") 46 | 47 | (mongo-db-collections d) 48 | => 49 | (list "test1" "system.indexes") 50 | 51 | (mongo-db-create-collection! d "test2" #:capped? #f #:size 100 #:max 20) 52 | 53 | (mongo-db-collections d) 54 | => 55 | (list "test2" "test1" "system.indexes") 56 | 57 | (mongo-collection-drop! (make-mongo-collection d "test2")) 58 | 59 | (mongo-db-collections d) 60 | => 61 | (list "test1" "system.indexes") 62 | 63 | (mongo-db-drop d) 64 | 65 | (mongo-db-collections d) 66 | => 67 | empty 68 | 69 | (mongo-db-create-collection! d "test1" #:capped? #f #:size 100) 70 | 71 | (mongo-db-collections d) 72 | => 73 | (list "test1" "system.indexes") 74 | 75 | (mongo-db-profiling d) 76 | => 77 | 'none 78 | 79 | (set-mongo-db-profiling! d 'all) 80 | (mongo-db-profiling d) 81 | => 82 | 'all 83 | 84 | (set-mongo-db-profiling! d 'low) 85 | (mongo-db-profiling d) 86 | => 87 | 'low 88 | 89 | (set-mongo-db-profiling! d 'none) 90 | (mongo-db-profiling d) 91 | => 92 | 'none 93 | 94 | (mongo-db-profiling-info d) 95 | 96 | (mongo-db-valid-collection? d "test1") 97 | => 98 | #t 99 | 100 | (mongo-db-valid-collection? d "zog") 101 | =error> 102 | "ns not found" 103 | ) 104 | 105 | 106 | (define c (make-mongo-collection d "test1")) 107 | (define ELEMENTS 100) 108 | 109 | (test 110 | (mongo-collection-valid? c) => 111 | #t 112 | 113 | (mongo-collection-drop! c) 114 | 115 | (for ([i (in-range ELEMENTS)]) 116 | (mongo-collection-insert! c (list (cons 'i i) (cons 'data (random ELEMENTS))))) 117 | 118 | (for/list ([e (mongo-collection-find c (list (cons 'i 0)))]) (hash-ref e 'i)) 119 | => 120 | (list 0) 121 | 122 | (mongo-collection-remove! c (list (cons 'i 0))) 123 | 124 | (for/list ([e (mongo-collection-find c (list (cons 'i 0)))]) (hash-ref e 'i)) 125 | => 126 | empty 127 | 128 | (mongo-collection-insert! c (list (cons 'i 1) (cons 'data (random ELEMENTS)))) 129 | (mongo-collection-modify! c (list (cons 'i 1)) (list (cons '$set (list (cons 'data 5))))) 130 | 131 | (for/list ([e (mongo-collection-find c (list (cons 'i 1)))]) (hash-ref e 'data)) 132 | => 133 | (list 5 5) 134 | 135 | (for/list ([e (mongo-collection-find c (list (cons 'i 1)) 136 | #:selector (list (cons 'data 1)))]) 137 | (hash-ref e 'data)) 138 | => 139 | (list 5 5) 140 | 141 | (mongo-collection-replace! c (list (cons 'i 1)) (list (cons 'i 1) (cons 'data 6))) 142 | 143 | (for/list ([e (mongo-collection-find c (list (cons 'i 1)))]) (hash-ref e 'data)) 144 | => 145 | (list 6 5) 146 | 147 | (mongo-collection-repsert! c (list (cons 'i (add1 ELEMENTS))) 148 | (list (cons 'i (add1 ELEMENTS)) 149 | (cons 'data 0))) 150 | 151 | (for/list ([e (mongo-collection-find c (list (cons 'i (add1 ELEMENTS))))]) (hash-ref e 'data)) 152 | => 153 | (list 0) 154 | 155 | (mongo-collection-repsert! c 156 | (list (cons 'i (add1 ELEMENTS))) 157 | (list (cons 'i (add1 ELEMENTS)) 158 | (cons 'data 1))) 159 | 160 | (for/list ([e (mongo-collection-find c (list (cons 'i (add1 ELEMENTS))))]) (hash-ref e 'data)) 161 | => 162 | (list 1) 163 | 164 | (mongo-collection-count c) 165 | => 166 | (+ ELEMENTS 1) 167 | 168 | (mongo-collection-count c (list (cons 'i 0))) 169 | => 170 | 0 171 | 172 | (mongo-collection-count c (list (cons 'i 1))) 173 | => 174 | 2 175 | 176 | (sequence-count (mongo-collection-indexes c)) => 1 177 | 178 | (mongo-collection-index! c (list (cons 'i 1))) 179 | 180 | (sequence-count (mongo-collection-indexes c)) => 2 181 | 182 | (mongo-collection-index! c (list (cons 'i 2)) 183 | #:name "i-index") 184 | 185 | (sequence-count (mongo-collection-indexes c)) => 3 186 | 187 | (rest 188 | (for/list ([e (mongo-collection-indexes c)]) 189 | (cons (hash-ref e 'name) (hash-ref e 'key #f)))) 190 | => 191 | (list (cons "((i . 1))" (make-hasheq (list (cons 'i 1)))) 192 | (cons "i-index" (make-hasheq (list (cons 'i 2))))) 193 | 194 | 195 | (mongo-collection-drop-index! c "i-index") 196 | 197 | (rest 198 | (for/list ([e (mongo-collection-indexes c)]) 199 | (cons (hash-ref e 'name) (hash-ref e 'key)))) 200 | => 201 | (list (cons "((i . 1))" (make-hasheq (list (cons 'i 1))))) 202 | 203 | ;; Track 413 204 | (mongo-collection-find c 205 | (hasheq '_id (string->bson-objectid "test"))) 206 | =error> 207 | "invalid object id"))))) 208 | -------------------------------------------------------------------------------- /tests/db/mongodb/orm.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require db/mongodb/orm/main 3 | racket/local 4 | db/mongodb/basic/main 5 | net/bson 6 | "util.rkt" 7 | db/mongodb/seq 8 | racket/set 9 | racket/serialize 10 | racket/dict 11 | racket/list 12 | tests/eli-tester) 13 | 14 | (module+ test 15 | (when mongod-p 16 | (test 17 | (with-mongod 18 | (define m (create-mongo)) 19 | (define d (make-mongo-db m "test")) 20 | 21 | (current-mongo-db d) 22 | 23 | (define obj (create-mongo-dict "cons")) 24 | 25 | (define (test-obj obj) 26 | (test 27 | (mongo-dict-ref obj 'car) => bson-null 28 | (mongo-dict-ref obj 'car #f) => #f 29 | (mongo-dict-ref obj 'car (lambda () 2)) => 2 30 | (mongo-dict-set! obj 'car 1) => (void) 31 | (mongo-dict-ref obj 'car) => 1 32 | (mongo-dict-remove! obj 'car) => (void) 33 | (mongo-dict-ref obj 'car) => bson-null 34 | (mongo-dict-count obj) => 0 35 | (mongo-dict-set! obj 'car 1) => (void) 36 | (mongo-dict-count obj) => 1 37 | (dict-map obj cons) => (list (cons 'car 1)) 38 | (for/list ([(k v) obj]) (cons k v)) => (list (cons 'car 1)) 39 | (mongo-dict-inc! obj 'car) => (void) 40 | (mongo-dict-ref obj 'car) => 2 41 | (mongo-dict-inc! obj 'car 2) => (void) 42 | (mongo-dict-ref obj 'car) => 4 43 | (mongo-dict-push! obj 'cdr 3) => (void) 44 | (mongo-dict-ref obj 'cdr) => (vector 3) 45 | (mongo-dict-push! obj 'cdr 4) => (void) 46 | (mongo-dict-ref obj 'cdr) => (vector 3 4) 47 | (mongo-dict-append! obj 'cdr (vector 5 6)) => (void) 48 | (mongo-dict-ref obj 'cdr) => (vector 3 4 5 6) 49 | (mongo-dict-append! obj 'cdr (list 7 8)) => (void) 50 | (mongo-dict-ref obj 'cdr) => (vector 3 4 5 6 7 8) 51 | (mongo-dict-set-add! obj 'cdr 3) => (void) 52 | (mongo-dict-ref obj 'cdr) => (vector 3 4 5 6 7 8) 53 | (mongo-dict-set-add! obj 'cdr 9) => (void) 54 | (mongo-dict-ref obj 'cdr) => (vector 3 4 5 6 7 8 9) 55 | (mongo-dict-set-add*! obj 'cdr (vector 10 11)) => (void) 56 | (mongo-dict-ref obj 'cdr) => (vector 3 4 5 6 7 8 9 10 11) 57 | (mongo-dict-pop! obj 'cdr) => (void) 58 | (mongo-dict-ref obj 'cdr) => (vector 3 4 5 6 7 8 9 10) 59 | (mongo-dict-shift! obj 'cdr) => (void) 60 | (mongo-dict-ref obj 'cdr) => (vector 4 5 6 7 8 9 10) 61 | (mongo-dict-pull! obj 'cdr 5) => (void) 62 | (mongo-dict-ref obj 'cdr) => (vector 4 6 7 8 9 10) 63 | (mongo-dict-push! obj 'cdr 7) => (void) 64 | (mongo-dict-ref obj 'cdr) => (vector 4 6 7 8 9 10 7) 65 | (mongo-dict-pull! obj 'cdr 7) => (void) 66 | (mongo-dict-ref obj 'cdr) => (vector 4 6 8 9 10) 67 | (mongo-dict-pull*! obj 'cdr (vector 8 9)) => (void) 68 | (mongo-dict-ref obj 'cdr) => (vector 4 6 10) 69 | (mongo-dict-count obj) => 2 70 | 71 | (for/fold ([s (set)]) 72 | ([(k v) (in-dict obj)]) 73 | (set-add s (cons k v))) 74 | => 75 | (set (cons 'cdr (vector 4 6 10)) 76 | (cons 'car 4)) 77 | 78 | (mongo-dict-ref (deserialize (serialize obj)) 'car) => 4 79 | )) 80 | 81 | (test-obj obj) 82 | (test 83 | (for/list ([c (mongo-dict-query "cons" empty)]) 84 | (cons (mongo-dict-ref c 'car) 85 | (mongo-dict-ref c 'cdr))) 86 | => 87 | (list (cons 4 (vector 4 6 10)))) 88 | 89 | #;(exit 0) 90 | 91 | (local 92 | [(define-mongo-struct cons "cons" 93 | ([car] 94 | [cdr])) 95 | (define x (make-cons #:car 1 96 | #:cdr 2)) 97 | (define y (make-cons #:car 1))] 98 | (test 99 | (cons-car obj) => 4 100 | (cons-cdr obj) => (vector 4 6 10) 101 | (cons-car x) => 1 102 | (cons-cdr x) => 2 103 | (cons-car y) => 1 104 | (cons-cdr y) => bson-null 105 | 106 | ; You can go right through 107 | (test-obj (make-cons)))) 108 | 109 | (local 110 | [(define-mongo-struct cons "cons" 111 | ([car #:inc #:null] 112 | [cdr #:push #:append #:set-add #:set-add* #:pop #:shift #:pull #:pull*])) 113 | (define obj (make-cons))] 114 | (test 115 | 116 | (cons-car obj) => bson-null 117 | (set-cons-car! obj 1) => (void) 118 | (cons-car obj) => 1 119 | (null-cons-car! obj) => (void) 120 | (cons-car obj) => bson-null 121 | (set-cons-car! obj 1) => (void) 122 | (inc-cons-car! obj) => (void) 123 | (cons-car obj) => 2 124 | (inc-cons-car! obj 2) => (void) 125 | (cons-car obj) => 4 126 | (push-cons-cdr! obj 3) => (void) 127 | (cons-cdr obj) => (vector 3) 128 | (push-cons-cdr! obj 4) => (void) 129 | (cons-cdr obj) => (vector 3 4) 130 | (append-cons-cdr! obj (vector 5 6)) => (void) 131 | (cons-cdr obj) => (vector 3 4 5 6) 132 | (append-cons-cdr! obj (list 7 8)) => (void) 133 | (cons-cdr obj) => (vector 3 4 5 6 7 8) 134 | (set-add-cons-cdr! obj 3) => (void) 135 | (cons-cdr obj) => (vector 3 4 5 6 7 8) 136 | (set-add-cons-cdr! obj 9) => (void) 137 | (cons-cdr obj) => (vector 3 4 5 6 7 8 9) 138 | (set-add*-cons-cdr! obj (vector 10 11)) => (void) 139 | (cons-cdr obj) => (vector 3 4 5 6 7 8 9 10 11) 140 | (pop-cons-cdr! obj) => (void) 141 | (cons-cdr obj) => (vector 3 4 5 6 7 8 9 10) 142 | (shift-cons-cdr! obj) => (void) 143 | (cons-cdr obj) => (vector 4 5 6 7 8 9 10) 144 | (pull-cons-cdr! obj 5) => (void) 145 | (cons-cdr obj) => (vector 4 6 7 8 9 10) 146 | (push-cons-cdr! obj 7) => (void) 147 | (cons-cdr obj) => (vector 4 6 7 8 9 10 7) 148 | (pull-cons-cdr! obj 7) => (void) 149 | (cons-cdr obj) => (vector 4 6 8 9 10) 150 | (pull*-cons-cdr! obj (vector 8 9)) => (void) 151 | (cons-cdr obj) => (vector 4 6 10) 152 | 153 | (cons-car (deserialize (serialize obj))) => 4 154 | )) 155 | 156 | (local 157 | [(define-mongo-struct cons "cons" 158 | ([car #:required] 159 | [cdr]))] 160 | (test 161 | (make-cons #:car 1) 162 | (make-cons) =error> "require" 163 | (make-cons #:cdr 1) =error> "require")) 164 | 165 | (local 166 | [(define-mongo-struct cons "cons" 167 | ([car #:immutable] 168 | [cdr]))] 169 | (test 170 | (make-cons #:car 1) 171 | (make-cons) =error> "require" 172 | (make-cons #:cdr 1) =error> "require" 173 | (set-cons-car! (make-cons #:car 1) 2) =error> "unbound")) 174 | 175 | (local 176 | [(define-mongo-struct cons "cons" 177 | ([car #:immutable #:ref] 178 | [cdr]))] 179 | (test 180 | (make-cons #:car 1) 181 | (make-cons) =error> "require" 182 | (make-cons #:cdr 1) =error> "require" 183 | (set-cons-car! (make-cons #:car 1) 2) =error> "unbound")) 184 | 185 | (test 186 | (define-mongo-struct cons "cons" 187 | ([car #:immutable #:null] 188 | [cdr])) 189 | =error> "Immutable" 190 | 191 | (define-mongo-struct cons "cons" 192 | ([car #:required #:null] 193 | [cdr])) 194 | =error> "Required" 195 | 196 | (define-mongo-struct cons "cons" 197 | ([car #:frozzle] 198 | [cdr])) 199 | =error> "valid") 200 | 201 | )))) 202 | -------------------------------------------------------------------------------- /tests/db/mongodb/quick-start.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require db/mongodb 3 | "util.rkt") 4 | 5 | (module+ test 6 | (when mongod-p 7 | (with-mongod 8 | (define m (create-mongo)) 9 | (define d (make-mongo-db m "awesome-dot-com")) 10 | (current-mongo-db d) 11 | (define-mongo-struct post "posts" 12 | ([title #:required] 13 | [body #:required] 14 | [tags #:set-add #:pull] 15 | [comments #:push #:pull] 16 | [views #:inc])) 17 | 18 | (define p 19 | (make-post #:title "Welcome to my blog" 20 | #:body "This is my first entry, yay!")) 21 | (set-add-post-tags! p 'awesome) 22 | (inc-post-views! p) 23 | 24 | (set-post-comments! p (list "Can't wait!" "Another blog?")) 25 | (post-comments p)))) 26 | -------------------------------------------------------------------------------- /tests/db/mongodb/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/runtime-path 3 | racket/path 4 | racket/port 5 | racket/file) 6 | 7 | (define-syntax-rule (with-mongod e ...) 8 | (with-mongod* (lambda () e ...))) 9 | 10 | (define-runtime-path test-dir "../test.db") 11 | 12 | (define mongod-p (find-executable-path "mongod")) 13 | (define (with-mongod* thnk) 14 | (define dbpath 15 | test-dir 16 | #;(make-temporary-file "db~a" 'directory)) 17 | (define sp #f) 18 | (dynamic-wind 19 | (lambda () 20 | (define _ (make-directory* test-dir)) 21 | (define-values (the-sp stdout stdin stderr) 22 | (subprocess (current-output-port) #f (current-error-port) 23 | ;; #f #f #f 24 | mongod-p 25 | ;; "-v" 26 | "--quiet" 27 | "--nojournal" 28 | "--noprealloc" 29 | "--dbpath" (path->string dbpath) 30 | "--nohttpinterface" 31 | "--noauth")) 32 | (set! sp the-sp) 33 | (sleep 3)) 34 | thnk 35 | (lambda () 36 | (subprocess-kill sp #t) 37 | (delete-directory/files dbpath)))) 38 | 39 | (provide mongod-p with-mongod) 40 | -------------------------------------------------------------------------------- /tests/db/mongodb/wire.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/local 3 | racket/match 4 | racket/list 5 | racket/function 6 | "util.rkt" 7 | db/mongodb/wire/main 8 | tests/eli-tester) 9 | 10 | (define ELEMENTS 100) 11 | 12 | (module+ test 13 | (when mongod-p 14 | (test 15 | (with-mongod 16 | (define c (create-mongo-connection)) 17 | (define the-collect "db.test") 18 | (define (make-a-thing i [v (random 100)]) 19 | (make-hasheq (list (cons 'i i) 20 | (cons 'data v)))) 21 | 22 | ;; Create some stuff on the server 23 | (define stuff-we-made (make-hasheq)) 24 | (for ([i (in-range ELEMENTS)]) 25 | (define thing (make-a-thing i i)) 26 | (test 27 | (send-message 28 | c 29 | (make-insert (new-msg-id) 0 the-collect 30 | (vector thing))) 31 | => 32 | #f) 33 | (hash-set! stuff-we-made i thing)) 34 | 35 | ;; Update a few of them 36 | (for ([j (in-range (/ ELEMENTS 4))]) 37 | (define i (random ELEMENTS)) 38 | (define new-thing (make-a-thing i)) 39 | (hash-set! stuff-we-made i new-thing) 40 | (test 41 | (send-message 42 | c 43 | (make-update (new-msg-id) 0 the-collect 44 | empty 45 | (make-hasheq (list (cons 'i i))) 46 | new-thing)) 47 | => 48 | #f)) 49 | 50 | ;; Query a few 51 | (for ([j (in-range (/ ELEMENTS 4))]) 52 | (define i (random ELEMENTS)) 53 | (define query-id (new-msg-id)) 54 | (test 55 | (match 56 | (send-message 57 | c 58 | (make-query query-id 0 the-collect 59 | empty 0 0 60 | (make-hasheq (list (cons 'i i))) 61 | #f)) 62 | [(struct reply (_id (? (curry = query-id)) #f _cursor-id 0 63 | (vector v))) 64 | (hash-remove! v '_id) 65 | (equal? v (hash-ref stuff-we-made i))] 66 | [r 67 | r]) 68 | => 69 | #t)) 70 | 71 | ;; Delete something 72 | (local [(define gonna-die (random ELEMENTS)) 73 | (define query-id (new-msg-id))] 74 | (test 75 | (send-message 76 | c 77 | (make-delete (new-msg-id) 0 the-collect 78 | (make-hasheq (list (cons 'i gonna-die))))) 79 | => 80 | #f 81 | 82 | (match 83 | (send-message 84 | c 85 | (make-query query-id 0 the-collect 86 | empty 0 0 87 | (make-hasheq (list (cons 'i gonna-die))) 88 | #f)) 89 | [(struct reply (_id (? (curry = query-id)) #f _cursor-id 0 (vector))) 90 | #t] 91 | [r r]) 92 | => 93 | #t 94 | 95 | (send-message 96 | c 97 | (make-insert (new-msg-id) 0 the-collect 98 | (vector (make-a-thing gonna-die)))) 99 | => 100 | #f)) 101 | 102 | ;; Duplicate something, then use cursors 103 | (local [(define dup (random ELEMENTS)) 104 | (define query-id0 (new-msg-id)) 105 | (define query-id (new-msg-id)) 106 | (define get-more-id (new-msg-id)) 107 | (define get-more-id2 (new-msg-id)) 108 | (define the-cursor 999)] 109 | 110 | (test 111 | ; Add the duplicates 112 | (send-message 113 | c 114 | (make-insert (new-msg-id) 0 the-collect 115 | (vector (make-a-thing dup)))) 116 | => 117 | #f 118 | (send-message 119 | c 120 | (make-insert (new-msg-id) 0 the-collect 121 | (vector (make-a-thing dup)))) 122 | => 123 | #f 124 | 125 | ; Query them all 126 | (match 127 | (send-message 128 | c 129 | (make-query query-id0 0 the-collect 130 | empty 0 3 131 | (make-hasheq (list (cons 'i dup))) 132 | #f)) 133 | [(struct reply (_id (? (curry = query-id0)) #f _cid 0 134 | (vector v1 v2 v3))) 135 | #t] 136 | [r 137 | r]) 138 | => 139 | #t 140 | 141 | ; Query the first and second 142 | (match 143 | (send-message 144 | c 145 | (make-query query-id 0 the-collect 146 | empty 0 2 147 | (make-hasheq (list (cons 'i dup))) 148 | #f)) 149 | [(struct reply (_id (? (curry = query-id)) #f cursor-id 0 150 | (vector v1 v2))) 151 | (set! the-cursor cursor-id) 152 | #t] 153 | [r 154 | r]) 155 | => 156 | #t 157 | 158 | ; Query the third 159 | (match 160 | (send-message 161 | c 162 | (make-get-more get-more-id 0 the-collect 163 | 0 the-cursor)) 164 | [(struct reply (_id (? (curry = get-more-id)) #f 0 2 165 | (vector v))) 166 | #t] 167 | [r r]) 168 | => 169 | #t 170 | 171 | ; Delete the cursor 172 | (send-message 173 | c 174 | (make-kill-cursors (new-msg-id) 0 (vector the-cursor))) 175 | => 176 | #f 177 | 178 | ; Try to use the cursor again (and fail) 179 | (match 180 | (send-message 181 | c 182 | (make-get-more get-more-id2 0 the-collect 183 | 1 the-cursor)) 184 | [(struct reply (_id (? (curry = get-more-id2)) #t 0 0 185 | (vector))) 186 | #t] 187 | [r r]) 188 | => 189 | #t)) 190 | 191 | ; Test bytes 192 | (local [(define the-bytes #"1")] 193 | (test 194 | (send-message 195 | c 196 | (make-insert (new-msg-id) 0 the-collect 197 | (vector (make-hasheq (list (cons 'name 'foo) (cons 'bytes the-bytes)))))) 198 | => 199 | #f 200 | 201 | (match 202 | (send-message 203 | c 204 | (make-query (new-msg-id) 0 the-collect 205 | empty 0 0 206 | (make-hasheq (list (cons 'name 'foo))) 207 | #f)) 208 | [(struct reply (_id _mid #f _cursor-id 0 209 | (vector v))) 210 | (equal? the-bytes (hash-ref v 'bytes))] 211 | [r 212 | r]) 213 | => 214 | #t)) 215 | 216 | (close-mongo-connection! c) 217 | 218 | )))) 219 | -------------------------------------------------------------------------------- /tests/net/bson.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require net/bson 3 | net/bson/read 4 | net/bson/write 5 | (only-in net/bson/shared 6 | make-bson-utc-datetime) 7 | srfi/19 8 | tests/eli-tester) 9 | 10 | (define (id-test v) 11 | (test 12 | (read-bson/bytes (write-bson/bytes v)) => v)) 13 | 14 | (module+ test 15 | (test 16 | (read-bson/bytes #"\x16\x00\x00\x00\x02hello\x00\x06\x00\x00\x00world\x00\x00") 17 | => 18 | (make-hasheq '([hello . "world"])) 19 | 20 | (read-bson/bytes #"1\x00\x00\x00\x04BSON\x00&\x00\x00\x00\x020\x00\x08\x00\x00\x00awesome\x00\x011\x00333333\x14@\x102\x00\xc2\x07\x00\x00\x00\x00") 21 | => 22 | (make-hasheq '([BSON . #("awesome" 5.05 1986)])) 23 | 24 | (write-bson/bytes (make-hasheq '([hello . "world"]))) 25 | => 26 | #"\x16\x00\x00\x00\x02hello\x00\x06\x00\x00\x00world\x00\x00" 27 | 28 | (write-bson/bytes (make-hasheq '([BSON . #("awesome" 5.05 1986)]))) 29 | => 30 | #"1\x00\x00\x00\x04BSON\x00&\x00\x00\x00\x020\x00\x08\x00\x00\x00awesome\x00\x011\x00333333\x14@\x102\x00\xc2\x07\x00\x00\x00\x00" 31 | 32 | (id-test (make-hasheq '([hello . "world"]))) 33 | (id-test (make-hasheq '([BSON . #("awesome" 5.05 1986)]))) 34 | 35 | (id-test (make-hasheq (list (cons 'double 3.14)))) 36 | (id-test (make-hasheq (list (cons 'utf8 "λ")))) 37 | (id-test (make-hasheq (list (cons 'embedded (make-hasheq (list (cons 'utf8 "λ"))))))) 38 | (id-test (make-hasheq (list (cons 'vector (vector 1 2 3))))) 39 | 40 | (read-bson/bytes (write-bson/bytes (make-hasheq (list (cons 'seq (list 1 2 3)))))) 41 | => 42 | (make-hasheq (list (cons 'seq (vector 1 2 3)))) 43 | 44 | (read-bson/bytes (write-bson/bytes (list (cons 'seq (list 1 2 3))))) 45 | => 46 | (make-hasheq (list (cons 'seq (vector 1 2 3)))) 47 | 48 | (id-test (make-hasheq (list (cons 'binary (make-bson-binary 'function #"blob"))))) 49 | (id-test (make-hasheq (list (cons 'binary #"blob")))) 50 | 51 | (read-bson/bytes (write-bson/bytes (make-hasheq (list (cons 'binary (make-bson-binary 'binary #"\4\0\0\0blob")))))) 52 | => 53 | (make-hasheq (list (cons 'binary #"blob"))) 54 | 55 | (bson-objectid-timestamp (new-bson-objectid)) 56 | 57 | (id-test (make-hasheq (list (cons 'binary (make-bson-binary 'uuid #"blob"))))) 58 | (id-test (make-hasheq (list (cons 'binary (make-bson-binary 'md5 #"blob"))))) 59 | (id-test (make-hasheq (list (cons 'binary (make-bson-binary 'user-defined #"blob"))))) 60 | ; undefined 61 | (id-test (make-hasheq (list (cons 'oid (new-bson-objectid))))) 62 | (id-test (make-hasheq (list (cons 'true #t)))) 63 | (id-test (make-hasheq (list (cons 'false #f)))) 64 | (id-test (make-hasheq (list (cons 'utc-datetime (make-bson-utc-datetime (current-milliseconds)))))) 65 | (id-test (make-hasheq (list (cons 'utc-datetime (current-time))))) 66 | (id-test (make-hasheq (list (cons 'null bson-null)))) 67 | (id-test (make-hasheq (list (cons 'regexp (make-bson-regexp "something" "i" ))))) 68 | ; db-pointer 69 | (id-test (make-hasheq (list (cons 'js (make-bson-javascript "int x = 1;"))))) 70 | (id-test (make-hasheq (list (cons 'symbol 'symbol)))) 71 | (id-test (make-hasheq (list (cons 'js (make-bson-javascript/scope "int x = a;" 72 | (make-hasheq (list (cons 'a 1)))))))) 73 | (id-test (make-hasheq (list (cons 'int32 4)))) 74 | (id-test (make-hasheq (list (cons 'timestamp (make-bson-timestamp 132767))))) 75 | (id-test (make-hasheq (list (cons 'int64 132767)))) 76 | (id-test (make-hasheq (list (cons 'min-key bson-min-key)))) 77 | (id-test (make-hasheq (list (cons 'max-key bson-max-key)))) 78 | 79 | (id-test (make-hasheq (list (cons 'utf8 (bytes->string/utf-8 (bytes 195 167 195 176 195 182 194 163)))))) 80 | 81 | )) 82 | -------------------------------------------------------------------------------- /web-server/dispatch/mongodb.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require web-server/dispatch/extend 3 | racket/match 4 | racket/function 5 | db/mongodb) 6 | 7 | (define-match-expander mongo-dict/string 8 | (syntax-rules () 9 | [(_ col d) 10 | (? string? (app (compose (curry make-mongo-dict col) string->bson-objectid) d))])) 11 | 12 | (define-match-expander string/mongo-dict 13 | (syntax-rules () 14 | [(_ col s) 15 | (? mongo-dict? (app (compose bson-objectid->string mongo-dict-id) s))])) 16 | 17 | (define-bidi-match-expander mongo-dict-arg mongo-dict/string string/mongo-dict) 18 | 19 | (provide mongo-dict-arg) 20 | --------------------------------------------------------------------------------