\ No newline at end of file
+
diff --git a/cl-mongo.asd b/cl-mongo.asd
index 06e70dc..161b43f 100644
--- a/cl-mongo.asd
+++ b/cl-mongo.asd
@@ -11,41 +11,42 @@
:licence "MIT"
:description "lisp system to interact with mongodb, a non-sql db"
:depends-on (:uuid
- :babel
- :bordeaux-threads
- :documentation-template
- :lisp-unit
- :parenscript
- :split-sequence
- :usocket)
+ :babel
+ :bordeaux-threads
+ :documentation-template
+ :lisp-unit
+ :parenscript
+ :split-sequence
+ :usocket
+ :cl-scram)
:serial t
- :components
- ((:module "src"
+ :components
+ ((:module "src"
:serial t
:components ((:file "packages")
- (:file "octets")
- (:file "pair")
- (:file "encode-float")
- (:file "bson-oid")
- (:file "bson-binary")
- (:file "bson-time")
- (:file "bson-regex")
- (:file "bson-code")
- (:file "bson")
- (:file "bson-decode")
- (:file "bson-array")
- (:file "document")
- (:file "mongo-syntax")
- (:file "java-script")
- (:file "bson-encode-container")
- (:file "protocol")
- (:file "mongo")
- (:file "db")
- (:file "mem")
- (:file "do-query")
- (:file "doc")
- (:file "map-reduce")
- (:file "shell")))
+ (:file "octets")
+ (:file "pair")
+ (:file "encode-float")
+ (:file "bson-oid")
+ (:file "bson-binary")
+ (:file "bson-time")
+ (:file "bson-regex")
+ (:file "bson-code")
+ (:file "bson")
+ (:file "bson-decode")
+ (:file "bson-array")
+ (:file "document")
+ (:file "mongo-syntax")
+ (:file "java-script")
+ (:file "bson-encode-container")
+ (:file "protocol")
+ (:file "mongo")
+ (:file "db")
+ (:file "mem")
+ (:file "do-query")
+ (:file "doc")
+ (:file "map-reduce")
+ (:file "shell")))
(:static-file "README.md")
(:static-file "COPYING")))
@@ -57,19 +58,9 @@
:description "testing cl-mongo"
:depends-on (:cl-mongo)
:serial t
- :components
+ :components
((:module "test"
:serial t
:components ((:file "package")
- (:file "test-utils")
- (:file "regression")))))
-
-
-
-
-
-
-
-
-
-
+ (:file "test-utils")
+ (:file "regression")))))
diff --git a/src/bson-binary.lisp b/src/bson-binary.lisp
index 88a5e0c..38d703b 100644
--- a/src/bson-binary.lisp
+++ b/src/bson-binary.lisp
@@ -11,6 +11,10 @@
((data :reader data :initarg :data))
(:documentation "bson binary type; this is the base class."))
+(defclass bson-binary-generic (bson-binary-base)
+ ((type-id :reader type-id :initform +bson-binary-generic+))
+ (:documentation "bson generic binary type"))
+
(defclass bson-binary-function (bson-binary-base)
((type-id :reader type-id :initform +bson-binary-function+))
(:documentation "bson function binary type"))
@@ -33,7 +37,13 @@
(defgeneric bson-binary (type data)
(:documentation "Create a bson serializable binary object. type is a keyword; either one of
-:function :binary :uuid :md5 or :user. data is the data encapsulated by this type."))
+:generic :function :binary :uuid :md5 or :user. data is the data encapsulated by this type."))
+
+(defmethod bson-binary ((type (eql :generic)) data)
+ (make-instance 'bson-binary-generic :data data))
+
+(defmethod bson-binary ((type (eql +bson-binary-generic+)) data)
+ (make-instance 'bson-binary-generic :data data))
(defmethod bson-binary ((type (eql :function)) data)
(make-instance 'bson-binary-function :data data))
@@ -82,4 +92,3 @@
(if (slot-boundp bson-binary-base 'data)
(rep stream bson-binary-base)
"binary not set.."))
-
diff --git a/src/bson-decode.lisp b/src/bson-decode.lisp
index 55825b1..0e75c49 100644
--- a/src/bson-decode.lisp
+++ b/src/bson-decode.lisp
@@ -60,7 +60,7 @@
(size (if (eql type #x02)
(octet-to-int32.1 array (+ pos 5))
(octet-to-int32.1 array pos)))
- (offset (if (eql type #x02) 9 5))
+ (offset (+ pos (if (eql type #x02) 9 5)))
(binary (bson-binary type (subseq array offset (+ offset size)))))
(setf (gethash key ht) binary)
(incf pos totalsize)))
diff --git a/src/db.lisp b/src/db.lisp
index f76fabd..380690f 100644
--- a/src/db.lisp
+++ b/src/db.lisp
@@ -7,7 +7,7 @@
(concatenate 'string (db mongo) "." collection))
(defgeneric db.insert (collection document &key)
- (:documentation "Insert a document in a collection. A document is typically generated by `(make-document)`,
+ (:documentation "Insert a document in a collection. A document is typically generated by `(make-document)`,
but it can also be a hash table, a key-value pair or kv list (see the kv functions)."))
(defmethod db.insert ((collection string) (document t) &key (mongo (mongo)))
@@ -16,7 +16,7 @@ but it can also be a hash table, a key-value pair or kv list (see the kv functio
(defgeneric db.find (collection kv &key)
(:documentation "
-Find documents in the collection using the selector specified by kv.
+Find documents in the collection using the selector specified by kv.
Methods take two keywords. ':limit' sets the maximum number of documents returned. The default is 1.
':skip' sets the number of documents to skip in this query. It's default is 0.
Since the default value of the limit is one, db.find by default is the equivalant of *findOne* in the
@@ -26,18 +26,20 @@ mongo documentation.
(defmethod db.find ((collection string) (kv t)
&key (mongo (mongo)) (options 0) (skip 0) (limit 1) (selector nil))
(labels ((query ()
- (mongo-message mongo (mongo-query
- (full-collection-name mongo collection) kv
- :limit limit
- :skip skip
- :selector (bson-encode-container (expand-selector selector))
- :options options))))
- (multiple-value-bind (header docs) (mongo-reply (query))
+ (mongo-message mongo
+ (mongo-query
+ (full-collection-name mongo collection) kv
+ :limit limit
+ :skip skip
+ :selector (bson-encode-container (expand-selector selector))
+ :options options))))
+ (multiple-value-bind (header docs)
+ (mongo-reply (query))
(list (append header (list collection)) docs))))
(defmethod db.find ((collection symbol) (kv t)
&key (mongo (mongo)) (options 0) (skip 0) (limit 1) (selector nil))
- (db.find (string-downcase collection) kv
+ (db.find (string-downcase collection) kv
:mongo mongo :options options :skip skip :limit limit :selector selector))
@@ -45,7 +47,7 @@ mongo documentation.
&key (mongo (mongo)) (options 0) (skip 0) (limit 0) (selector nil))
(db.find collection (bson-encode "query" (kv nil nil))
:mongo mongo :options options :skip skip :limit limit :selector selector))
-
+
(defmethod db.find ((collection string) (kv integer)
&key (mongo (mongo)) (options 0) (skip 0) (selector nil))
(db.find collection (bson-encode nil nil)
@@ -62,12 +64,16 @@ mongo documentation.
:mongo mongo :options options :skip skip :limit limit :selector selector))
(defmethod db.find ((collection string) (kv kv-container)
- &key (mongo (mongo)) (options 0) (skip 0) (limit 1) (selector nil))
+ &key (mongo (mongo)) (options 0) (skip 0) (limit 1) (selector nil))
(db.find collection (bson-encode-container kv)
- :mongo mongo :options options :skip skip :limit limit :selector selector))
+ :mongo mongo
+ :options options
+ :skip skip
+ :limit limit
+ :selector selector))
(defmacro db.sort (collection query &rest args)
- "sort macro : Takes the same arguments and keywords as db.find but converts the query
+ "sort macro : Takes the same arguments and keywords as db.find but converts the query
so it works as a sort. use the :field keyword to select the field to sort on.
Set :asc to nil to reverse the sort order"
(let ((kv-query (gensym)))
@@ -80,28 +86,28 @@ mongo documentation.
(defgeneric db.update (collection selector new-document &key)
- (:documentation "In a collection update the document(s) identified by the selector statement.
-This method has two keywords. ':upsert' : If t insert the document if the document cannot be
+ (:documentation "In a collection update the document(s) identified by the selector statement.
+This method has two keywords. ':upsert' : If t insert the document if the document cannot be
found in the collection. ':multi' : Update all documents identified by the selector.
"))
(defmethod db.update ((collection string) (selector t) (new-document t)
&key (mongo (mongo)) (upsert nil) (multi nil))
;;(format t "[---> db.update selector ~A~% new doc ~A]~%" selector new-document)
- (mongo-message mongo (mongo-update
+ (mongo-message mongo (mongo-update
(full-collection-name mongo collection)
(bson-encode-container selector)
(bson-encode-container new-document)
:options (update-options :upsert upsert :multi-update multi))
:timeout 0))
-;(defgeneric db.find-and-modify (collection query
+;(defgeneric db.find-and-modify (collection query
(defgeneric db.save (collection document &key)
(:documentation "
Save a document to the collection. If the document has a unique `_id` value (i.e. if it's generated
by `(make-document)`) it will be 'upserted' (that is: it will be inserted if the document
-doesn't exist). If the document a hash table or a kv set, it will be inserted.
+doesn't exist). If the document a hash table or a kv set, it will be inserted.
In other words this a a helper-function build around *db.insert* and *db.update*.
"))
@@ -143,7 +149,7 @@ In other words this a a helper-function build around *db.insert* and *db.update*
(defmethod db.next ((collection string) (cursor-id integer) &key (mongo (mongo)) (limit 0))
(labels ((get-more ()
- (mongo-message mongo (mongo-get-more
+ (mongo-message mongo (mongo-get-more
(full-collection-name mongo collection)
(int64-to-octet cursor-id) :limit limit))))
(multiple-value-bind (header docs) (mongo-reply (get-more))
@@ -187,7 +193,7 @@ Stop iterating and clean up the iterator on the server by making a server call.
(defgeneric db.delete (collection object &key)
(:documentation "
Delete a document from a collection. The *document* field is used to identify the document to
-be deleted.
+be deleted.
You can enter a list of documents. In that the server will be contacted to delete each one of these.
It may be more efficient to run a delete script on the server side.
"))
@@ -197,7 +203,7 @@ It may be more efficient to run a delete script on the server side.
(defmethod db.delete ((collection string) (document document) &key (mongo (mongo)))
- (mongo-message mongo (mongo-delete
+ (mongo-message mongo (mongo-delete
(full-collection-name mongo collection)
document) :timeout 0))
@@ -229,7 +235,7 @@ Create an index specified by the keys in a collection
;; through the java script client. Apperently 1/-1 -> coneverted to float, rather
;; than an integer. This may or may not matter..
;;
-
+
(defun asc/desc->+1/-1 (ht)
(let ((new-ht (make-hash-table :test 'equal)))
(labels ((conv (value)
@@ -241,7 +247,7 @@ Create an index specified by the keys in a collection
(multiple-value-bind (exists-p key value) (iterator)
(when exists-p (setf (gethash key new-ht) (conv value)))))))
new-ht))
-
+
(defmethod db.ensure-index ((collection string) (index hash-table)
&key (mongo (mongo)) (unique nil) (drop-duplicates nil))
@@ -274,7 +280,7 @@ Create an index specified by the keys in a collection
;----------------------------------------------------------------------
(keys->name (k)
(format nil "~{~{~a~^_~}~^_~}" k)))
- (db.insert "system.indexes"
+ (db.insert "system.indexes"
(kv (kv "ns" (full-collection-name mongo collection))
(kv "key" (force-float index))
(spec-gen unique drop-duplicates)
@@ -282,9 +288,9 @@ Create an index specified by the keys in a collection
(defmethod db.ensure-index ((collection string) (index kv-container)
&key (mongo (mongo)) (unique nil) (drop-duplicates nil))
- (db.ensure-index collection (kv->ht index) :mongo mongo :unique unique
+ (db.ensure-index collection (kv->ht index) :mongo mongo :unique unique
:drop-duplicates drop-duplicates))
-
+
(defmethod db.ensure-index ((collection string) (key string)
&key (mongo (mongo)) (unique nil) (asc t) (drop-duplicates nil))
(let ((order-id (if asc 1 -1)))
@@ -299,7 +305,7 @@ Create an index specified by the keys in a collection
(defgeneric db.run-command (cmd &key)
(:documentation "
-Run a database command on the server. See the mongo documentation for a list of commands.
+Run a database command on the server. See the mongo documentation for a list of commands.
For most commands you can just uses the key-value shown in the mongo documentation.
"))
@@ -339,7 +345,7 @@ For most commands you can just uses the key-value shown in the mongo documentati
#|
-
+
;; special commands
@@ -359,14 +365,14 @@ For most commands you can just uses the key-value shown in the mongo documentati
(defmethod db.distinct ((collection string) (key string) &key (mongo (mongo)))
(db.find "$cmd" (kv (kv "distinct" collection) (kv "key" key)) :limit 1 :mongo mongo))
-
+
(defun count-it(collection key)
(db.find "$cmd" (kv (kv "distinct" collection) (kv "key" key))))
(defgeneric db.count (collection selector &key)
(:documentation "
-Count all the collections satifying the criterion set by the selector.
+Count all the collections satifying the criterion set by the selector.
:all can be used to return a count of
all the documents in the collection.
"))
@@ -405,17 +411,97 @@ all the documents in the collection.
(defgeneric db.auth (username password &key)
(:documentation "authenticate a user with a password"))
-(defmethod db.auth ((username string) (password string) &key (mongo (mongo)))
+(defun auth-scram-start (username)
+ (let* ((client-nonce (cl-scram:gen-client-nonce))
+ (first-bare (cl-scram:gen-client-initial-message :username username
+ :nonce client-nonce))
+ (request (kv (kv "saslStart" 1)
+ (kv "mechanism" "SCRAM-SHA-1")
+ (kv "payload"
+ (bson-binary :generic (ironclad:ascii-string-to-byte-array
+ first-bare)))
+ (kv "autoAuthorize" 1)
+ (kv "options" (kv "skipEmptyExchange" t)))))
+ (values client-nonce
+ first-bare
+ request)))
+
+(defun auth-scram-sha-1 (username password &key mongo)
+ "SCRAM-SHA-1 auth detail see:
+ - http://www.alienfactory.co.uk/articles/mongodb-scramsha1-over-sasl recommended
+ - https://github.com/mongodb/mongo-python-driver/blob/master/pymongo/auth.py#L181 _authenticate_scram"
+ (multiple-value-bind (client-nonce first-bare request)
+ (auth-scram-start username)
+ (let ((response (car (docs (db.find "$cmd" request :limit 1 :mongo mongo)))))
+ (when (= 1
+ (get-element "ok" response))
+ (let* ((payload (babel:octets-to-string (data (get-element "payload" response))))
+ (client-final-message (cl-scram:gen-client-final-message
+ :username username
+ :password password
+ :client-nonce client-nonce
+ :client-initial-message first-bare
+ :server-response payload))
+ (server-signature (rest (assoc 'cl-scram::server-signature client-final-message)))
+ (final-message (rest (assoc 'cl-scram::final-message client-final-message)))
+ (request (kv (kv "saslContinue" 1)
+ (kv "conversationId" (get-element "conversationId" response))
+ (kv "payload"
+ (bson-binary :generic (ironclad:ascii-string-to-byte-array
+ final-message))))))
+ (let ((response (car (docs (db.find "$cmd"
+ request
+ :limit 1
+ :mongo mongo)))))
+ (if (get-element "done" response)
+ (and (= 1
+ (get-element "ok" response))
+ (equal server-signature
+ (cl-scram:parse-server-signature
+ :response
+ (babel:octets-to-string
+ (data
+ (get-element "payload" response))))))
+ ;; A third empty challenge may be required if the server does not support
+ ;; skipEmptyExchange: SERVER-44857.
+ (let* ((request (kv (kv "saslContinue" 1)
+ (kv "conversationId" (get-element "conversationId" response))
+ (kv "payload"
+ (bson-binary :generic (ironclad:ascii-string-to-byte-array
+ "")))))
+ (response (car (docs (db.find "$cmd"
+ request
+ :limit 1
+ :mongo mongo)))))
+ (get-element "done" response)))))))))
+
+(defun auth-mongodb-cr (username password &key mongo)
(let* ((nonce (get-element "nonce" (car (docs (db.run-command 'getnonce :mongo mongo)))))
- (pwd (concatenate 'string username ":mongo:" password))
- (md5-pwd (hex-md5 pwd))
- (md5-pwd-str (ironclad:byte-array-to-hex-string md5-pwd))
- (md5-key (hex-md5 (concatenate 'string nonce username md5-pwd-str)))
- (md5-key-str (ironclad:byte-array-to-hex-string md5-key))
- (request (kv (kv "authenticate" 1) (kv "user" username) (kv "nonce" nonce) (kv "key" md5-key-str)))
- (retval (get-element "ok" (car (docs (db.find "$cmd" request :limit 1 :mongo mongo))))))
- (if retval t nil)))
+ (pwd (concatenate 'string username ":mongo:" password))
+ (md5-pwd (hex-md5 pwd))
+ (md5-pwd-str (ironclad:byte-array-to-hex-string md5-pwd))
+ (md5-key (hex-md5 (concatenate 'string nonce username md5-pwd-str)))
+ (md5-key-str (ironclad:byte-array-to-hex-string md5-key))
+ (request (kv (kv "authenticate" 1)
+ (kv "user" username)
+ (kv "nonce" nonce)
+ (kv "key" md5-key-str))))
+ (= 1
+ (get-element "ok"
+ (car (docs (db.find "$cmd"
+ request
+ :limit 1
+ :mongo mongo)))))))
+
+(defmethod db.auth ((username string) (password string)
+ &key
+ (mongo (mongo))
+ (mechanism :SCRAM-SHA-1))
+ (cond ((equal mechanism :SCRAM-SHA-1)
+ (auth-scram-sha-1 username password :mongo mongo))
+ ((equal mechanism :MONGODB-CR)
+ (auth-mongodb-cr username password :mongo mongo))
+ (t nil)))
;;(db.find "$cmd" (kv (kv "count" "foo") (kv "query" (kv nil nil)) (kv "fields" (kv nil nil))))
;;(db.find "foo" (kv (kv "query" (kv nil nil)) (kv "orderby" (kv "k" 1))) :limit 0)
-