From 64a07ec030bcad4709eac538e8a445ea30b99c75 Mon Sep 17 00:00:00 2001 From: Matt Prelude Date: Wed, 9 Sep 2015 18:59:28 +0100 Subject: [PATCH 1/2] Going through changes. WIP. Do not use. --- cl-mongo.asd | 17 ++------ src/bson-binary.lisp | 13 +++++- src/db.lisp | 96 +++++++++++++++++++++++++++----------------- 3 files changed, 75 insertions(+), 51 deletions(-) diff --git a/cl-mongo.asd b/cl-mongo.asd index 06e70dc..40046f5 100644 --- a/cl-mongo.asd +++ b/cl-mongo.asd @@ -17,9 +17,10 @@ :lisp-unit :parenscript :split-sequence - :usocket) + :usocket + :cl-scram) :serial t - :components + :components ((:module "src" :serial t :components ((:file "packages") @@ -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"))))) - - - - - - - - - - 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/db.lisp b/src/db.lisp index f76fabd..dbc1811 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,10 +26,10 @@ 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 + (mongo-message mongo (mongo-query (full-collection-name mongo collection) kv - :limit limit - :skip skip + :limit limit + :skip skip :selector (bson-encode-container (expand-selector selector)) :options options)))) (multiple-value-bind (header docs) (mongo-reply (query)) @@ -37,7 +37,7 @@ mongo documentation. (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 +45,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) @@ -67,7 +67,7 @@ mongo documentation. :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 +80,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 +143,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 +187,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 +197,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 +229,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 +241,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 +274,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 +282,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 +299,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 +339,7 @@ For most commands you can just uses the key-value shown in the mongo documentati #| - + ;; special commands @@ -359,14 +359,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 +405,41 @@ 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))) - (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))) +(defmethod db.auth ((username string) (password string) &key (mongo (mongo)) (mechanism :SCRAM-SHA-1)) + (cond ((equal mechanism :SCRAM-SHA-1) + (let* ((nonce (cl-scram:gen-client-nonce)) + (pwd (concatenate 'string username ":mongo:" password)) + (md5-pwd (hex-md5 pwd)) + (md5-pwd-str (ironclad:byte-array-to-hex-string md5-pwd)) + (initial-message (cl-scram:gen-client-initial-message :username username + :nonce nonce)) + (request (kv (kv "saslStart" 1) + (kv "mechanism" "SCRAM-SHA-1") + (kv "payload" + (bson-binary :generic (ironclad:ascii-string-to-byte-array + (cl-scram:base64-encode initial-message)))))) + (response (car (docs (db.find "$cmd" request :limit 1 :mongo mongo)))) + (retval (pairlis '(errmsg ok code message binary-message) + (list (get-element "errmsg" response) + (get-element "ok" response) + (get-element "code" response) + initial-message + (ironclad:ascii-string-to-byte-array (cl-scram:base64-encode initial-message)))))) + (list request retval))) + ((equal mechanism :MONGODB-CR) + (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))) + (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) - From 84711388e9399e3cf18c865b456e4099a903651f Mon Sep 17 00:00:00 2001 From: muyinliu Date: Sat, 5 Feb 2022 11:28:18 +0800 Subject: [PATCH 2/2] Support auth with SCRAM-SHA-1(default authentication mechanism in MongoDB 3.0+) --- README.md | 6 +- cl-mongo.asd | 66 ++++++++++---------- src/bson-decode.lisp | 2 +- src/db.lisp | 144 +++++++++++++++++++++++++++++++------------ 4 files changed, 140 insertions(+), 78 deletions(-) diff --git a/README.md b/README.md index 8094404..1c08b33 100644 --- a/README.md +++ b/README.md @@ -783,10 +783,10 @@ Generate a time stamp the mongo/bson protocol understands. -


[Generic function]
db.auth username password &key mongo => result +


[Generic function]
db.auth username password &key mongo mechanism => result


-authenticate a user with a password +authenticate a user with a password, default mechanism is :SCRAM-SHA-1
@@ -1560,4 +1560,4 @@ This documentation was prepared with BACK TO MY HOMEPAGE - \ No newline at end of file + diff --git a/cl-mongo.asd b/cl-mongo.asd index 40046f5..161b43f 100644 --- a/cl-mongo.asd +++ b/cl-mongo.asd @@ -11,42 +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" + ((: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"))) @@ -62,5 +62,5 @@ ((:module "test" :serial t :components ((:file "package") - (:file "test-utils") - (:file "regression"))))) + (:file "test-utils") + (:file "regression"))))) 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 dbc1811..380690f 100644 --- a/src/db.lisp +++ b/src/db.lisp @@ -26,13 +26,15 @@ 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) @@ -62,9 +64,13 @@ 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 @@ -405,40 +411,96 @@ 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)) (mechanism :SCRAM-SHA-1)) +(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)))) + (= 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) - (let* ((nonce (cl-scram:gen-client-nonce)) - (pwd (concatenate 'string username ":mongo:" password)) - (md5-pwd (hex-md5 pwd)) - (md5-pwd-str (ironclad:byte-array-to-hex-string md5-pwd)) - (initial-message (cl-scram:gen-client-initial-message :username username - :nonce nonce)) - (request (kv (kv "saslStart" 1) - (kv "mechanism" "SCRAM-SHA-1") - (kv "payload" - (bson-binary :generic (ironclad:ascii-string-to-byte-array - (cl-scram:base64-encode initial-message)))))) - (response (car (docs (db.find "$cmd" request :limit 1 :mongo mongo)))) - (retval (pairlis '(errmsg ok code message binary-message) - (list (get-element "errmsg" response) - (get-element "ok" response) - (get-element "code" response) - initial-message - (ironclad:ascii-string-to-byte-array (cl-scram:base64-encode initial-message)))))) - (list request retval))) + (auth-scram-sha-1 username password :mongo mongo)) ((equal mechanism :MONGODB-CR) - (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))) + (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))))