Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

work in progress

  • Loading branch information...
commit 084ad77bb93d95816433de3a4fd1877aef4b971c 1 parent 28b8fff
@archimag authored
View
44 mongo-cl-driver.asd
@@ -6,27 +6,31 @@
;;;; Author: Moskvitin Andrey <archimag@gmail.com>
(defsystem #:mongo-cl-driver
- :depends-on (#:iterate #:babel #:ieee-floats #:camel-case #:closer-mop #:iolib.sockets
- #:bordeaux-threads #:local-time #:ironclad)
+ :depends-on (#:iterate #:closer-mop #:local-time
+ #:babel #:ieee-floats #:ironclad
+ #:bordeaux-threads #:iolib.sockets)
+ :pathname "src/"
+ :serial t
:components
- ((:module "src"
- :components
- ((:file "packages")
- (:module "bson"
- :components
- ((:file "types")
- (:file "bson" :depends-on ("types")))
- :depends-on ("packages"))
- (:module "wire"
- :components
- ((:file "protocol")
- (:file "bucket-brigade")
- (:file "connection" :depends-on ("protocol" "bucket-brigade")))
- :depends-on ("bson"))
- (:file "database" :depends-on ("wire"))
- (:file "cursor" :depends-on ("wire"))
- (:file "collection" :depends-on ("cursor"))
- (:file "son-sugar" :depends-on ("packages"))))))
+ ((:module "bson"
+ :pathname "bson/"
+ :serial t
+ :components ((:file "package")
+ (:file "types")
+ (:file "bson")))
+ (:module "wire"
+ :pathname "wire/"
+ :serial t
+ :components ((:file "package")
+ (:file "protocol")
+ (:file "bucket-brigade")
+ (:file "connection"))
+ :depends-on ("bson"))
+ (:file "packages" :depends-on ("wire"))
+ (:file "database" :depends-on ("packages"))
+ (:file "cursor" :depends-on ("packages"))
+ (:file "collection" :depends-on ("cursor"))
+ (:file "son-sugar" :depends-on ("packages"))))
(defsystem #:mongo-cl-driver-test
:depends-on (#:mongo-cl-driver #:lift)
View
340 src/bson/bson.lisp
@@ -7,26 +7,31 @@
(in-package #:mongo-cl-driver.bson)
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; BSON target replace interface
+;;; Terminals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defvar *encoded-bytes-count*)
+(defvar *decoded-bytes-count*)
+
+(defgeneric encode-byte (byte target)
+ (:documentation "Encode BYTE to TARGET"))
+
+(defgeneric decode-byte (source)
+ (:documentation "Decode byte from SOURCE"))
+
+(defmacro with-count-encoded-bytes (&body body)
+ (let ((encode-bytes-count (gensym)))
+ `(let ((,encode-bytes-count *encoded-bytes-count*))
+ ,@body
+ (- *encoded-bytes-count* ,encode-bytes-count))))
+
(defgeneric bson-target-replace (target sequence start)
(:documentation "Destructively modifies target by replacing the elements of target from start with the elements of subsequence"))
(defmethod bson-target-replace ((target vector) sequence start)
(replace target sequence :start1 start))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Encode/decode byte
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defvar *encoded-bytes-count*)
-(defvar *decoded-bytes-count*)
-
-(defgeneric encode-byte (byte target)
- (:documentation "Encode BYTE to TARGET"))
(defmethod encode-byte :around (byte target)
(check-type byte (unsigned-byte 8))
@@ -37,9 +42,6 @@
(check-type target (and (vector (unsigned-byte 8)) (not simple-array)))
(vector-push-extend byte target))
-(defgeneric decode-byte (source)
- (:documentation "Decode byte from SOURCE"))
-
(defmethod decode-byte :after (source)
(incf *decoded-bytes-count*))
@@ -48,17 +50,7 @@
(defmethod decode-byte ((source vector))
(aref source *decoded-bytes-count*))
-
-(defmacro with-count-encoded-bytes (&body body)
- (let ((encode-bytes-count (gensym)))
- `(let ((,encode-bytes-count *encoded-bytes-count*))
- ,@body
- (- *encoded-bytes-count* ,encode-bytes-count))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; int32
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-int32 (i32 target)
"Encode 32-bit integer to TARGET"
(iter (for i from 0 below 32 by 8)
@@ -75,10 +67,6 @@
(1- (- (logandc2 #xFFFFFFFF ui32)))
ui32)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; int64
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-int64 (i64 target)
"Encode 64-bit integer to TARGET"
(iter (for i from 0 below 64 by 8)
@@ -94,22 +82,19 @@
(1- (- (logandc2 #xFFFFFFFFFFFFFFFF ui64)))
ui64)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; 64-bit IEEE 754 floating point
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun encode-double (double source)
+(defun encode-double (double target)
+ "Encode 64-bit IEEE 754 floating point to TARGE"
(encode-int64 (ieee-floats:encode-float64 double)
- source))
+ target))
(defun decode-double (source)
"Decode 64-bit IEEE 754 floating point from SOURCE"
(ieee-floats:decode-float64 (decode-int64 source)))
-
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; strings
+;;; Non-terminals
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
+
(defun encode-string (string target)
"Encode BSTR-style string"
(let ((octets (babel:string-to-octets string :encoding :utf-8)))
@@ -148,32 +133,11 @@
(vector-push-extend octet octets))
(babel:octets-to-string octets :encoding :utf-8)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; ename
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defparameter *lisp-identifier-name-to-bson* #'camel-case:lisp-to-camel-case)
-;;(defparameter *bson-identifier-name-to-lisp* #'camel-case:camel-case-to-lisp)
-(defparameter *bson-identifier-name-to-lisp* nil)
-
(defun encode-ename (name target)
- (typecase name
- (string (encode-cstring name target))
- (keyword (encode-cstring (funcall *lisp-identifier-name-to-bson*
- (symbol-name name))
- target))
- (otherwise (error "Bad type of ~A" name))))
+ (encode-cstring name target))
(defun decode-ename (source)
- (if *bson-identifier-name-to-lisp*
- (intern (funcall *bson-identifier-name-to-lisp*
- (decode-cstring source))
- :keyword)
- (decode-cstring source)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; boolean
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (decode-cstring source))
(defun encode-boolean (flag target)
(encode-byte (if flag #x01 #x00)
@@ -185,10 +149,6 @@
(#x00 nil)
(otherwise (error "Bad format: ~A is not boolean byte" byte)))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; object-id
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-object-id (id target)
(iter (for byte in-vector (slot-value id 'raw))
(encode-byte byte target)))
@@ -202,10 +162,6 @@
(decode-byte source)))
id))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; array
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-array (array target
&aux (index *encoded-bytes-count*))
(let ((count (with-count-encoded-bytes
@@ -232,7 +188,7 @@
(prog1
(iter (for i from 0)
(while (< *decoded-bytes-count* end))
- (let ((key-value (decode-element source :identifier-to-lisp nil)))
+ (let ((key-value (decode-element source)))
(unless (= i (if (stringp (car key-value))
(parse-integer (car key-value))
(car key-value)))
@@ -242,10 +198,6 @@
(error "Bad format"))
(decode-byte source))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; UTC datetime
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-utc-datetime (timestamp target)
(encode-int64 (* (local-time:timestamp-to-unix timestamp) 1000)
target))
@@ -253,10 +205,6 @@
(defun decode-utc-dateime (source)
(local-time:unix-to-timestamp (floor (decode-int64 source) 1000)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; binary data
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-binary-data (binary target)
(encode-int32 (length (binary-data-octets binary)) target)
(encode-byte (case (binary-data-subtype binary)
@@ -277,18 +225,14 @@
(setf (aref data i)
(decode-byte source)))
(make-instance 'binary-data
- :type (case subtype
- ((#x00 #x02) :generic)
- (#x01 :function)
- (#x03 :uuid)
- (#x05 :md5)
- (#x80 :user-defined))
+ :subtype (case subtype
+ ((#x00 #x02) :generic)
+ (#x01 :function)
+ (#x03 :uuid)
+ (#x05 :md5)
+ (#x80 :user-defined))
:octets data)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; Regexs
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
(defun encode-regex (regex target)
(encode-cstring (regex-pattern regex) target)
(encode-cstring (regex-options regex) target))
@@ -298,11 +242,7 @@
:pattern (decode-cstring source)
:options (decode-cstring source)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; JavaScript w/ scope
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defun encode-javascript-w-scope (js target &aux (index *encoded-bytes-count*))
+(defun encode-javascript (js target &aux (index *encoded-bytes-count*))
(let ((count (prog1 (with-count-encoded-bytes
(dotimes (i 4)
(encode-byte 0 target))
@@ -313,20 +253,23 @@
(encode-int32 count arr)
(bson-target-replace target arr index)))
+(defun decode-javascript (source)
+ (let ((end (+ *decoded-bytes-count* (decode-int32 source)))
+ (code (decode-string source)))
+ (unless (= end *decoded-bytes-count*)
+ (error "Bad format"))
+ (make-instance 'javascript
+ :code code)))
+
(defun decode-javascript-w-scope (source)
(let ((end (+ *decoded-bytes-count* (decode-int32 source)))
(code (decode-string source))
(scope (decode-document source)))
(unless (= end *decoded-bytes-count*)
(error "Bad format"))
- (make-instance 'javascript-w-scope
+ (make-instance 'javascript
:code code
- :scope scope)))
-
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; MongoDB internal timestamp
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ :scope scope)))
(defun encode-mongo-timestamp (timestamp target)
(encode-int64 (mongo-timestamp-value timestamp)
@@ -337,73 +280,7 @@
:value (decode-int64 source)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; document
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro for-each-element (obj (key value) &body body)
- (let ((doc (gensym))
- (item (gensym)))
- `(let ((,doc ,obj))
- (typecase ,doc
- (hash-table (iter (for (,key ,value) in-hashtable ,doc)
- ,@body))
- (cons (cond
- ((keywordp (car ,doc))
- (iter (for ,item on ,doc by #'cddr)
- (let ((,key (first ,item))
- (,value (second ,item)))
- ,@body)))
- (t (iter (for (,key . ,value) in ,doc)
- ,@body))))))))
-
-(defun encode-document (obj target
- &aux (index *encoded-bytes-count*))
- "Encode OBJ as BSON to target"
- (let ((count (prog1 (with-count-encoded-bytes
- (dotimes (i 4)
- (encode-byte 0 target))
- (for-each-element obj (key value)
- (encode-element key value target))
- (encode-byte #x00 target))))
- (arr (make-array 4 :element-type '(unsigned-byte 8) :fill-pointer 0))
- (*encoded-bytes-count* 0))
- (encode-int32 count arr)
- (bson-target-replace target arr index)))
-
-(defun decode-document-to-alist (source end)
- (iter (while (< *decoded-bytes-count* end))
- (collect (decode-element source))))
-
-(defun decode-document-to-plist (source end)
- (iter (while (< *decoded-bytes-count* end))
- (for (key . value) = (decode-element source))
- (collect key)
- (collect value)))
-
-(defun decode-document-to-hashtable (source end)
- (iter (with hash = (make-hash-table :test 'equal))
- (while (< *decoded-bytes-count* end))
- (for (key . value) = (decode-element source))
- (setf (gethash key hash) value)
- (finally (return hash))))
-
-(defparameter *convert-bson-document-to-lisp* #'decode-document-to-hashtable)
-
-(defun decode-document (source)
- "Decode BSON document from SOURCE"
- (let* ((end (+ *decoded-bytes-count*
- (decode-int32 source)
- -1)))
- (prog1
- (funcall *convert-bson-document-to-lisp*
- source
- end)
- (unless (= end *decoded-bytes-count*)
- (error "Bad format"))
- (decode-byte source))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;; elements
+;;;; Document
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defgeneric encode-element (key value target)
@@ -419,23 +296,26 @@
(encode-ename key target)
(encode-boolean value target))
+(defmethod encode-element (key (value (eql +min-key+)) target)
+ (encode-byte #xFF target)
+ (encode-ename key target))
+
+(defmethod encode-element (key (value (eql +max-key+)) target)
+ (encode-byte #x7F target)
+ (encode-ename key target))
+
(defmethod encode-element (key (value integer) target)
+ (check-type value (integer #x-8000000000000000 #x7FFFFFFFFFFFFFFF))
(cond
- ((and (>= value #x-80000000)
- (<= value #x7FFFFFFF))
+ ((and (>= value #x-80000000) (<= value #x7FFFFFFF))
(encode-byte #x10 target)
(encode-ename key target)
(encode-int32 value target))
- ((and (>= value #x-8000000000000000)
- (<= value #x7FFFFFFFFFFFFFFF))
+ (t
(encode-byte #x12 target)
(encode-ename key target)
- (encode-int64 value target))
-
- (t (encode-element key
- (coerce value 'double-float)
- target))))
+ (encode-int64 value target))))
(defmethod encode-element (key (value number) target)
(encode-byte #x01 target)
@@ -458,17 +338,9 @@
(encode-document value target))
(defmethod encode-element (key (value list) target)
- (cond
- ((or (keywordp (car value))
- (keywordp (caar value)))
- (encode-byte #x03 target)
- (encode-ename key target)
- (encode-document value target))
-
- (t
- (encode-byte #x04 target)
- (encode-ename key target)
- (encode-array value target))))
+ (encode-byte #x04 target)
+ (encode-ename key target)
+ (encode-array value target))
(defmethod encode-element (key (value object-id) target)
(encode-byte #x07 target)
@@ -490,58 +362,82 @@
(encode-ename key target)
(encode-regex value target))
-(defmethod encode-element (key (value javascript-w-scope) target)
+(defmethod encode-element (key (value javascript) target)
(encode-byte #x0F target)
(encode-ename key target)
- (encode-javascript-w-scope value target))
+ (encode-javascript value target))
(defmethod encode-element (key (value mongo-timestamp) target)
(encode-byte #x11 target)
(encode-ename key target)
(encode-mongo-timestamp value target))
-(defmethod encode-element (key (value (eql +min-key+)) target)
- (encode-byte #xFF target)
- (encode-ename key target))
-
-(defmethod encode-element (key (value (eql +max-key+)) target)
- (encode-byte #x7F target)
- (encode-ename key target))
-
-(defun decode-element (source &key (identifier-to-lisp *bson-identifier-name-to-lisp*))
+(defun decode-element (source)
(declare (optimize (debug 3)))
(flet ((constant-decoder (val)
(lambda (src)
(declare (ignore src))
val))
- (unimplemented (src)
- (declare (ignore src))
- (error "Unimplemented decoder (")))
+ (unimplemented-decoder (code)
+ (lambda (src)
+ (declare (ignore src))
+ (error "Decoder for code '#x~2,'0X' unimplemented" code))))
(let* ((code (decode-byte source))
(decoder (case code
- (#x01 #'decode-double)
- (#x02 #'decode-string)
- (#x03 #'decode-document)
- (#x04 #'decode-array)
- (#x05 #'decode-binary-data)
- (#x06 (constant-decoder :undefined))
- (#x07 #'decode-object-id)
- (#x08 #'decode-boolean)
- (#x09 #'decode-utc-dateime)
- (#x0A (constant-decoder nil))
- (#x0B #'decode-regex)
- (#x0C #'unimplemented)
- (#x0D #'decode-javascript-w-scope)
- (#x0E #'unimplemented)
- (#x0F #'unimplemented)
- (#x10 #'decode-int32)
- (#x11 #'decode-javascript-w-scope)
- (#x12 #'decode-int64)
- (#xFF (constant-decoder +min-key+))
- (#x7F (constant-decoder +max-key+)))))
- (cons (let ((*bson-identifier-name-to-lisp* identifier-to-lisp))
- (decode-ename source))
+ (#x01 #'decode-double)
+ (#x02 #'decode-string)
+ (#x03 #'decode-document)
+ (#x04 #'decode-array)
+ (#x05 #'decode-binary-data)
+ (#x06 (constant-decoder :undefined))
+ (#x07 #'decode-object-id)
+ (#x08 #'decode-boolean)
+ (#x09 #'decode-utc-dateime)
+ (#x0A (constant-decoder nil))
+ (#x0B #'decode-regex)
+ (#x0C (unimplemented-decoder #x0C))
+ (#x0D #'decode-javascript)
+ (#x0E (unimplemented-decoder #x0E))
+ (#x0F #'decode-javascript-w-scope)
+ (#x10 #'decode-int32)
+ (#x11 #'decode-mongo-timestamp)
+ (#x12 #'decode-int64)
+ (#xFF (constant-decoder +min-key+))
+ (#x7F (constant-decoder +max-key+))
+ (otherwise (unimplemented-decoder code)))))
+ (cons (decode-ename source)
(funcall decoder source)))))
+
+(defun encode-document (document target
+ &aux (index *encoded-bytes-count*))
+ "Encode DOCUMENT as BSON to target"
+ (declare (optimize (debug 3)))
+ (check-type document hash-table)
+ (let ((count (prog1 (with-count-encoded-bytes
+ (dotimes (i 4)
+ (encode-byte 0 target))
+ (iter (for (key value) in-hashtable document)
+ (encode-element key value target))
+ (encode-byte #x00 target))))
+ (arr (make-array 4 :element-type '(unsigned-byte 8) :fill-pointer 0))
+ (*encoded-bytes-count* 0))
+ (encode-int32 count arr)
+ (bson-target-replace target arr index)))
+
+(defun decode-document (source)
+ "Decode BSON document from SOURCE"
+ (let ((end (+ *decoded-bytes-count* (decode-int32 source) -1))
+ (son (make-hash-table :test 'equal)))
+ (iter (while (< *decoded-bytes-count* end))
+ (for (key . value) = (decode-element source))
+ (setf (gethash key son)
+ value))
+ (unless (= end *decoded-bytes-count*)
+ (error "Bad format"))
+ (unless (= (decode-byte source) #x00)
+ (error "Bad format"))
+ son))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; main interface
View
47 src/bson/package.lisp
@@ -0,0 +1,47 @@
+;;;; package.lisp
+;;;;
+;;;; This file is part of the MONGO-CL-DRIVER library, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Author: Moskvitin Andrey <archimag@gmail.com>
+
+(defpackage #:mongo-cl-driver.bson
+ (:nicknames #:mongo.bson)
+ (:use #:cl #:iter)
+ (:export #:encode
+ #:decode
+
+ #:ub8
+ #:ub8-sarray
+ #:ub8-vector
+
+ #:object-id
+ #:+min-key+
+ #:+max-key+
+ #:binary-data
+ #:binary-data-subtype
+ #:binary-data-octets
+ #:regex
+ #:regex-pattern
+ #:regex-options
+ #:javascript
+ #:javascript-code
+ #:javascript-scope
+ #:mongo-timestamp
+ #:mongo-timestamp-value
+
+ #:encode-byte
+ #:decode-byte
+ #:encode-int32
+ #:decode-int32
+ #:encode-int64
+ #:decode-int64
+ #:encode-cstring
+ #:decode-cstring
+ #:encode-document
+ #:decode-document
+
+ #:with-count-encoded-bytes
+ #:*encoded-bytes-count*
+ #:*decoded-bytes-count*
+ #:bson-target-replace))
View
13 src/bson/types.lisp
@@ -18,9 +18,7 @@
(defconstant +min-key+ '+min-key+)
(defconstant +max-key+ '+max-key+)
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; ObjectId
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass object-id ()
((raw :initform (make-array 12 :element-type '(unsigned-byte 8)))))
@@ -34,9 +32,7 @@
(iter (for ch in-vector (slot-value id 'raw))
(format stream "~2,'0X" ch))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Binary data
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass binary-data ()
((subtype :initarg :subtype :initform :generic :accessor binary-data-subtype)
@@ -54,26 +50,19 @@
(binary-data-subtype data)
(length (binary-data-octets data)))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Regular expressions
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass regex ()
((pattern :initarg :pattern :initform "" :reader regex-pattern)
(options :initarg :options :initform "" :reader regex-options)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; JavaScript w/ scope
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defclass javascript-w-scope ()
+(defclass javascript ()
((code :initarg :code :reader javascript-code)
(scope :initarg :scope :initform (make-hash-table :test 'equal) :reader javascript-scope)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; timestamp
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass mongo-timestamp ()
((value :initarg :value :reader mongo-timestamp-value)))
-
View
4 src/database.lisp
@@ -7,10 +7,6 @@
(in-package #:mongo-cl-driver)
-(defmacro with-alist-converter (&body body)
- `(let ((mongo-cl-driver.bson:*convert-bson-document-to-lisp* #'mongo-cl-driver.bson:decode-document-to-alist))
- ,@body))
-
(defgeneric connection (obj)
(:documentation "Get connection associated with OBJ"))
View
77 src/packages.lisp
@@ -5,69 +5,6 @@
;;;;
;;;; Author: Moskvitin Andrey <archimag@gmail.com>
-(defpackage #:mongo-cl-driver.bson
- (:nicknames #:mongo.bson)
- (:use #:cl #:iter)
- (:export #:encode
- #:decode
-
- #:object-id
-
- #:encode-byte
- #:decode-byte
- #:encode-int32
- #:decode-int32
- #:encode-int64
- #:decode-int64
- #:encode-cstring
- #:decode-cstring
- #:encode-document
- #:decode-document
-
- #:with-count-encoded-bytes
- #:*encoded-bytes-count*
- #:*decoded-bytes-count*
-
- #:bson-target-replace
-
- #:*lisp-identifier-name-to-bson*
- #:*bson-identifier-name-to-lisp*
-
- #:*convert-bson-document-to-lisp*
- #:decode-document-to-alist
- #:decode-document-to-plist
- #:decode-document-to-hashtable))
-
-(defpackage #:mongo-cl-driver.wire
- (:nicknames #:mongo.wire)
- (:use #:iter #:mongo-cl-driver.bson #:closer-common-lisp)
- (:export #:brigade
- #:brigade-extend
- #:brigade-free-buckets
- #:brigade-ref
-
- #:connection
- #:close-connection
- #:send-message-sync
- #:send-message-async
- #:send-and-read-sync
- #:send-and-read-async
-
- #:op-update
- #:op-insert
- #:op-query
- #:op-getmore
- #:op-delete
- #:op-kill-cursors
- #:encode-protocol-message
-
- #:op-reply
- #:op-reply-response-flags
- #:op-reply-cursor-id
- #:op-reply-starting-from
- #:op-reply-number-returned
- #:op-reply-documents))
-
(defpackage #:mongo-cl-driver
(:nicknames #:mongo)
(:use #:cl
@@ -77,6 +14,20 @@
(:export #:connection
#:object-id
+ #:+min-key+
+ #:+max-key+
+ #:binary-data
+ #:binary-data-subtype
+ #:binary-data-octets
+ #:regex
+ #:regex-pattern
+ #:regex-options
+ #:javascript-w-scope
+ #:javascript-code
+ #:javascript-scope
+ #:mongo-timestamp
+ #:mongo-timestamp-value
+
#:database
#:close-database
View
5 src/son-sugar.lisp
@@ -13,10 +13,7 @@
(let ((son (make-hash-table :test 'equal)))
(iter (for item on args by #'cddr)
(for key = (first item))
- (setf (gethash (if (symbolp key)
- (camel-case:lisp-to-camel-case (symbol-name (first item)))
- key)
- son)
+ (setf (gethash key son)
(second item)))
son))
View
40 src/wire/package.lisp
@@ -0,0 +1,40 @@
+;;;; package.lisp
+;;;;
+;;;; This file is part of the MONGO-CL-DRIVER library, released under Lisp-LGPL.
+;;;; See file COPYING for details.
+;;;;
+;;;; Author: Moskvitin Andrey <archimag@gmail.com>
+
+(defpackage #:mongo-cl-driver.wire
+ (:nicknames #:mongo.wire)
+ (:use #:iter #:mongo-cl-driver.bson #:closer-common-lisp)
+ (:export #:brigade
+ #:brigade-extend
+ #:brigade-free-buckets
+ #:brigade-ref
+
+ #:connection
+ #:close-connection
+ #:send-message-sync
+ #:send-message-async
+ #:send-and-read-sync
+ #:send-and-read-async
+
+ #:op-update
+ #:op-insert
+ #:op-query
+ #:op-getmore
+ #:op-delete
+ #:op-kill-cursors
+ #:encode-protocol-message
+ #:decode-op-reply
+
+ #:op-reply
+ #:op-reply-response-flags
+ #:op-reply-cursor-id
+ #:op-reply-starting-from
+ #:op-reply-number-returned
+ #:op-reply-documents
+ #:cursor-not-found-p
+ #:query-failure-p
+ #:await-capable-p))
View
28 src/wire/protocol.lisp
@@ -153,7 +153,6 @@
(define-protocol-message op-query +op-query+
(flags
- :initarg :flags
:initform 0
:bson-type :int32)
(full-collection-name
@@ -173,9 +172,25 @@
:bson-type :document)
(return-field-selector
:initarg :return-field-selector
- :initform nil
+ :initform (make-hash-table :test 'equal)
:bson-type :document))
+(defmethod shared-initialize :after ((query op-query) slot-names &key
+ tailable-cursor slave-ok no-cursor-timeout
+ await-data exhaust partial)
+ (let ((bits nil))
+ (when tailable-cursor (push 1 bits))
+ (when slave-ok (push 2 bits))
+ (when no-cursor-timeout (push 4 bits))
+ (when await-data (push 5 bits))
+ (when exhaust (push 6 bits))
+ (when partial (push 7 bits))
+
+ (dolist (bit bits)
+ (setf (ldb (byte 1 bit)
+ (slot-value query 'flags))
+ 1))))
+
(define-protocol-message op-getmore +op-get-more+
(zero
:initform 0
@@ -246,7 +261,16 @@
:initform nil
:bson-type :document
:list-p t))
+
+(defmacro define-reply-flag-predicate (name bitnum)
+ `(defun ,name (reply)
+ (= (ldb (byte 1 ,bitnum)
+ (op-reply-response-flags reply))
+ 1)))
+(define-reply-flag-predicate cursor-not-found-p 0)
+(define-reply-flag-predicate query-failure-p 1)
+(define-reply-flag-predicate await-capable-p 3)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; encode protocol message
View
131 t/bson.lisp
@@ -9,9 +9,13 @@
(deftestsuite mongo-bson-test (mogno-cl-driver-test) ())
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; encode-basic-test
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(addtest (mongo-bson-test)
encode-basic-test-1
- (ensure-same (encode () :list)
+ (ensure-same (encode (son) :list)
'(#x05 #x00 #x00 #x00 #x00)))
(addtest (mongo-bson-test)
@@ -58,6 +62,40 @@
(addtest (mongo-bson-test)
encode-basic-test-9
+ (ensure-same (encode (son "test" (make-instance 'binary-data
+ :octets (babel:string-to-octets "test" :encoding :utf-8)))
+ :list)
+ (list #x14 #x00 #x00 #x00 #x05 #x74 #x65 #x73 #x74 #x00 #x04 #x00 #x00
+ #x00 #x00 #x74 #x65 #x73 #x74 #x00)))
+
+(addtest (mongo-bson-test)
+ encode-basic-test-10
+ (ensure-same (encode (son "test" (make-instance 'binary-data
+ :octets (babel:string-to-octets "test" :encoding :utf-8)
+ :subtype :user-defined))
+ :list)
+ (list #x14 #x00 #x00 #x00 #x05 #x74 #x65 #x73 #x74 #x00 #x04 #x00 #x00
+ #x00 #x80 #x74 #x65 #x73 #x74 #x00)))
+
+(addtest (mongo-bson-test)
+ encode-basic-test-11
+ (ensure-same (encode (son "regex" (make-instance 'regex
+ :pattern "a*b"
+ :options "i"))
+ :list)
+ (list #x12 #x00 #x00 #x00 #x0B #x72 #x65 #x67 #x65 #x78 #x00 #x61 #x2A
+ #x62 #x00 #x69 #x00 #x00)))
+
+(addtest (mongo-bson-test)
+ encode-basic-test-12
+ (ensure-same (encode (son "$where" (make-instance 'javascript :code "test"))
+ :list)
+ (list #x1F #x00 #x00 #x00 #x0F #x24 #x77 #x68 #x65 #x72 #x65 #x00 #x12
+ #x00 #x00 #x00 #x05 #x00 #x00 #x00 #x74 #x65 #x73 #x74 #x00 #x05
+ #x00 #x00 #x00 #x00 #x00)))
+
+(addtest (mongo-bson-test)
+ encode-basic-test-13
(ensure-same (encode
(son "oid" (make-instance 'mongo.bson:object-id
:raw (list #x00 #x01 #x02 #x03 #x04 #x05 #x06 #x07 #x08 #x09 #x0A #x0B)))
@@ -66,13 +104,17 @@
#x04 #x05 #x06 #x07 #x08 #x09 #x0A #x0B #x00)))
(addtest (mongo-bson-test)
- encode-basic-test-10
+ encode-basic-test-14
(ensure-same (encode
(son "date" (local-time:encode-timestamp 0 11 30 0 8 1 2007 :timezone local-time:+utc-zone+))
:list)
(list #x13 #x00 #x00 #x00 #x09 #x64 #x61 #x74 #x65 #x00 #x38 #xBE #x1C
#xFF #x0F #x01 #x00 #x00 #x00)))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; encode-then-decode
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(addtest (mongo-bson-test)
encode-then-decode-1
(ensure-same (hash-table-alist (decode (encode (son "miki" -10120) :vector)))
@@ -134,4 +176,87 @@
:vector)))
(ensure-same "date" name)
(ensure (local-time:timestamp= date
- (local-time:encode-timestamp 0 0 0 2 4 4 1993 :timezone local-time:+utc-zone+)))))
+ (local-time:encode-timestamp 0 0 0 2 4 4 1993 :timezone local-time:+utc-zone+)))))
+
+(addtest (mongo-bson-test)
+ encode-the-decode-10
+ (destructuring-bind ((name . obj))
+ (hash-table-alist
+ (decode (encode (son "a binary"
+ (make-instance 'binary-data
+ :octets (coerce #(1 2 3 4 5 6 7 8 9 10) 'ub8-vector)
+ :subtype :function))
+ :vector)))
+ (ensure-same "a binary" name)
+ (ensure-same :function
+ (binary-data-subtype obj))
+ (ensure-same '(1 2 3 4 5 6 7 8 9 10)
+ (coerce (binary-data-octets obj) 'list))))
+
+(addtest (mongo-bson-test)
+ encode-the-decode-11
+ (destructuring-bind ((name . obj))
+ (hash-table-alist
+ (decode (encode (son "a binary"
+ (make-instance 'binary-data
+ :octets (coerce #(1 2 3 4 5 6 7 8 9 10) 'ub8-vector)
+ :subtype :uuid))
+ :vector)))
+ (ensure-same "a binary" name)
+ (ensure-same :uuid
+ (binary-data-subtype obj))
+ (ensure-same '(1 2 3 4 5 6 7 8 9 10)
+ (coerce (binary-data-octets obj) 'list))))
+
+(addtest (mongo-bson-test)
+ encode-the-decode-12
+ (destructuring-bind ((name . obj))
+ (hash-table-alist
+ (decode (encode (son "a binary"
+ (make-instance 'binary-data
+ :octets (coerce #(1 2 3 4 5 6 7 8 9 10) 'ub8-vector)
+ :subtype :md5))
+ :vector)))
+ (ensure-same "a binary" name)
+ (ensure-same :md5
+ (binary-data-subtype obj))
+ (ensure-same '(1 2 3 4 5 6 7 8 9 10)
+ (coerce (binary-data-octets obj) 'list))))
+
+(addtest (mongo-bson-test)
+ encode-the-decode-13
+ (ensure-same '(("foo" . +min-key+))
+ (hash-table-alist (decode (encode (son "foo" +min-key+) :vector)))))
+
+(addtest (mongo-bson-test)
+ encode-the-decode-14
+ (ensure-same '(("foo" . +max-key+))
+ (hash-table-alist (decode (encode (son "foo" +max-key+) :vector)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; errors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(addtest (mongo-bson-test)
+ type-error
+ (ensure-condition type-error
+ (encode 100 :list))
+ (ensure-condition type-error
+ (encode "hello" :vector))
+ (ensure-condition type-error
+ (encode nil :vector))
+ (ensure-condition type-error
+ (encode #() :vector))
+
+ (ensure (encode (son "x" 9223372036854775807) :vector))
+ (ensure-condition type-error
+ (encode (son "x" 9223372036854775808) :vector))
+
+ (ensure (encode (son "x" -9223372036854775808) :vector))
+ (ensure-condition type-error
+ (encode (son "x" -9223372036854775809) :vector))
+
+ (ensure-condition type-error
+ (encode (son 8.9 "test") :vector)))
+
+
View
135 t/wire.lisp
@@ -74,14 +74,14 @@
encode-op-update-3
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 1 target) ;; requestId
- (encode-int32 10 target) ;; responseTo
- (encode-int32 2001 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-cstring "db.system.index" target) ;; fullConnectionName
- (encode-int32 3 target) ;; flags
+ (encode-int32 1 target) ;; requestId
+ (encode-int32 10 target) ;; responseTo
+ (encode-int32 2001 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-cstring "db.system.index" target) ;; fullConnectionName
+ (encode-int32 3 target) ;; flags
(encode-document (son "x" (son "y" 2)) target) ;; selector
- (encode-document (son "x" #(3 4 5)) target) ;; update
+ (encode-document (son "x" #(3 4 5)) target) ;; update
(ensure-same (add-length-and-convert-to-list target)
(encode-protocol-message (make-instance 'op-update
@@ -102,11 +102,11 @@
encode-op-insert-1
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 0 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2002 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-cstring "db.test" target) ;; fullConnectionName
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2002 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-cstring "db.test" target) ;; fullConnectionName
;; documents
(encode-document (son "x" 2) target)
@@ -120,11 +120,11 @@
encode-op-insert-2
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 8 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2002 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-cstring "db.test" target) ;; fullConnectionName
+ (encode-int32 8 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2002 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-cstring "db.test" target) ;; fullConnectionName
;; documents
(encode-document (son "x" 2) target)
(encode-document (son "date" (local-time:encode-timestamp 0 0 10 23 27 4 2011)) target)
@@ -151,7 +151,7 @@
(encode-int32 0 target) ;; requestId
(encode-int32 0 target) ;; responseTo
(encode-int32 2004 target) ;; opcode
- (encode-int32 0 target) ;; flags
+ (encode-int32 162 target) ;; flags
(encode-cstring "db.test" target) ;; fullConnectionName
(encode-int32 0 target) ;; numberToSkip
(encode-int32 0 target) ;; numberToReturn
@@ -161,7 +161,10 @@
(ensure-same (add-length-and-convert-to-list target)
(encode-protocol-message (make-instance 'op-query
:full-collection-name "db.test"
- :query (son "x" 2))
+ :query (son "x" 2)
+ :tailable-cursor t
+ :await-data t
+ :partial t)
:list))))
(addtest (mongo-wire-test)
@@ -171,7 +174,7 @@
(encode-int32 0 target) ;; requestId
(encode-int32 0 target) ;; responseTo
(encode-int32 2004 target) ;; opcode
- (encode-int32 0 target) ;; flags
+ (encode-int32 84 target) ;; flags
(encode-cstring "db.test" target) ;; fullConnectionName
(encode-int32 0 target) ;; numberToSkip
(encode-int32 0 target) ;; numberToReturn
@@ -183,7 +186,10 @@
(encode-protocol-message (make-instance 'op-query
:full-collection-name "db.test"
:query (son "x" 2)
- :return-field-selector (son "title" 1))
+ :return-field-selector (son "title" 1)
+ :slave-ok t
+ :no-cursor-timeout t
+ :exhaust t)
:list))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -194,13 +200,13 @@
encode-op-getmore-1
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 0 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2005 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-cstring "db.test" target) ;; fullConnectionName
- (encode-int32 20 target) ;; numberToReturn
- (encode-int64 123 target) ;; cursorID
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2005 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-cstring "db.test" target) ;; fullConnectionName
+ (encode-int32 20 target) ;; numberToReturn
+ (encode-int64 123 target) ;; cursorID
(ensure-same (add-length-and-convert-to-list target)
(encode-protocol-message (make-instance 'op-getmore
@@ -217,13 +223,13 @@
encode-op-delete-1
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 0 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2006 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-cstring "db.test" target) ;; fullConnectionName
- (encode-int32 0 target) ;; flags
- (encode-document (son "foo" "bar") ;; selector
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2006 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-cstring "db.test" target) ;; fullConnectionName
+ (encode-int32 0 target) ;; flags
+ (encode-document (son "foo" "bar") ;; selector
target)
(ensure-same (add-length-and-convert-to-list target)
@@ -236,13 +242,13 @@
encode-op-delete-2
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 0 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2006 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-cstring "db.test" target) ;; fullConnectionName
- (encode-int32 1 target) ;; flags
- (encode-document (son "foo" "bar") ;; selector
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2006 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-cstring "db.test" target) ;; fullConnectionName
+ (encode-int32 1 target) ;; flags
+ (encode-document (son "foo" "bar") ;; selector
target)
(ensure-same (add-length-and-convert-to-list target)
@@ -260,11 +266,11 @@
encode-op-kill-cursor-1
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 0 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2007 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-int32 1 target) ;; numberOfCursorIDs
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2007 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-int32 1 target) ;; numberOfCursorIDs
;; sequence of cursorIDs to close
(encode-int64 123 target)
@@ -277,11 +283,11 @@
encode-op-kill-cursor-1
(let ((target (make-vector-target))
(*encoded-bytes-count* 0))
- (encode-int32 0 target) ;; requestId
- (encode-int32 0 target) ;; responseTo
- (encode-int32 2007 target) ;; opcode
- (encode-int32 0 target) ;; zero
- (encode-int32 3 target) ;; numberOfCursorIDs
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 2007 target) ;; opcode
+ (encode-int32 0 target) ;; zero
+ (encode-int32 3 target) ;; numberOfCursorIDs
;; sequence of cursorIDs to close
(encode-int64 123 target)
(encode-int64 256 target)
@@ -291,3 +297,28 @@
(encode-protocol-message (make-instance 'op-kill-cursors
:cursor-ids '(123 256 2561231))
:list))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;; decode op-reply
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(addtest (mongo-wire-test)
+ decode-op-reply-1
+ (let ((target (make-vector-target))
+ (*encoded-bytes-count* 0)
+ (*decoded-bytes-count* 0))
+ (encode-int32 0 target) ;; requestId
+ (encode-int32 0 target) ;; responseTo
+ (encode-int32 1 target) ;; opcode
+ (encode-int32 0 target) ;; responseFlags
+ (encode-int64 456 target) ;; cursorID
+ (encode-int32 7 target) ;; startingFrom
+ (encode-int32 1 target) ;; numberReturned
+ ;; documents
+ (encode-document (son "foo" "bar") target)
+
+ (let ((reply (decode-op-reply (coerce (add-length-and-convert-to-list target) 'vector))))
+ (ensure-same 456 (op-reply-cursor-id reply))
+ (ensure-same 7 (op-reply-starting-from reply))
+ (ensure-same 1 (op-reply-number-returned reply))
+ (ensure-same "bar" (gethash "foo" (car (op-reply-documents reply)))))))
+
Please sign in to comment.
Something went wrong with that request. Please try again.