├── README.md ├── bson.el ├── mongo-tests.el ├── mongo.el └── recipes └── mongo-el /README.md: -------------------------------------------------------------------------------- 1 | This is EmacsLisp for talking to mongo-db. 2 | 3 | A quick example using Marmalade's mongo-db: 4 | 5 | ``` 6 | (let* ((result 7 | (mongo-with-open-database 8 | (db :host 'local) 9 | (mongo-do-request 10 | (make-mongo-message-query 11 | :flags 0 12 | :number-to-skip 0 13 | :number-to-return 0 14 | :full-collection-name "marmalade.packages" 15 | :query '(("name" . "fakir"))) 16 | :database db))) 17 | (docres (mongo-message-reply-documents result))) 18 | (assoc-string 19 | "headers" 20 | (assoc-string "_latestVersion" (car docres)))) 21 | ``` 22 | 23 | This performs a query for a single result, the ```car docres``` is 24 | used just because the result is always a list. 25 | 26 | You can look up objects by their object id by using the bson serializer: 27 | 28 | ``` 29 | (make-mongo-message-query 30 | :flags 0 31 | :number-to-skip 0 32 | :number-to-return 0 33 | :full-collection-name "marmalade.packages" 34 | :query (list (cons "_id" (bson-oid-of-hex-string "4f65e980cd6108da68000252")))) 35 | ``` 36 | 37 | Dealing with mongo 38 | ================== 39 | 40 | Dealing with mongo seems to result in lots of little JSON documents 41 | represented as alists. 42 | 43 | [This module might help with that](https://github.com/nicferrier/emacs-dotaccess) 44 | 45 | 46 | Building with Elpakit 47 | ===================== 48 | 49 | An [elpakit](https://github.com/nicferrier/elpakit) recipe is included 50 | so you can easily build the mongo-el package. 51 | -------------------------------------------------------------------------------- /bson.el: -------------------------------------------------------------------------------- 1 | ;;; bson.el --- Binary JSON serializer/deserializer 2 | 3 | ;; Copyright (C) 2011-2015 Tomohiro Matsuyama 4 | 5 | ;; Author: Tomohiro Matsuyama 6 | ;; Version: 0.1 7 | ;; Keywords: convenience 8 | 9 | ;; This program is free software; you can redistribute it and/or modify 10 | ;; it under the terms of the GNU General Public License as published by 11 | ;; the Free Software Foundation, either version 3 of the License, or 12 | ;; (at your option) any later version. 13 | 14 | ;; This program is distributed in the hope that it will be useful, 15 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 16 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 17 | ;; GNU General Public License for more details. 18 | 19 | ;; You should have received a copy of the GNU General Public License 20 | ;; along with this program. If not, see . 21 | 22 | ;;; Commentary: 23 | 24 | ;;; Code: 25 | 26 | (require 'cl) 27 | 28 | (defmacro bson-aif (test then &rest else) 29 | (declare (indent 2)) 30 | `(let ((it ,test)) (if it ,then ,@else))) 31 | 32 | (defmacro bson-awhen (test &rest body) 33 | (declare (indent 1)) 34 | `(let ((it ,test)) (when it ,@body))) 35 | 36 | (defmacro bson-with-temp-unibyte-buffer (&rest body) 37 | (declare (indent 0)) 38 | `(with-temp-buffer (set-buffer-multibyte nil) ,@body)) 39 | 40 | 41 | 42 | (defsubst bson-alist-p (object) 43 | (and (listp object) 44 | (consp (first object)))) 45 | 46 | (defsubst bson-plist-p (object) 47 | (and (listp object) 48 | (symbolp (first object)))) 49 | 50 | (defmacro bson-evcase (object &rest clauses) 51 | (declare (indent 1)) 52 | (let ((obj (gensym))) 53 | `(let ((,obj ,object)) 54 | (cond 55 | ,@(loop for (value . body) in clauses 56 | collect `((eql ,obj ,value) ,@body)) 57 | (t (error "bson-evcase failed: %s, %s" 58 | ,obj ',(mapcar 'car clauses))))))) 59 | 60 | (defsubst bson-type-of (object) 61 | (or (and (eq object t) 'boolean) 62 | (and (eq object nil) 'boolean) 63 | (and (vectorp object) 64 | (> (length object) 0) 65 | (symbolp (elt object 0)) 66 | (let ((name (symbol-name (elt object 0)))) 67 | (when (string-match "^cl-struct-\\(.+\\)$" name) 68 | (intern (match-string 1 name))))) 69 | (type-of object))) 70 | 71 | (defmacro bson-etypecase (object &rest clauses) 72 | (declare (indent 1)) 73 | `(ecase (bson-type-of ,object) ,@clauses)) 74 | 75 | 76 | 77 | (defmacro bson-document-dispatch (document &rest clauses) 78 | (declare (indent 1)) 79 | `(cond 80 | ,@(loop for (type . body) in clauses 81 | collect 82 | (ecase type 83 | (hash-table `((hash-table-p ,document) ,@body)) 84 | (alist `((bson-alist-p ,document) ,@body)) 85 | (plist `((bson-plist-p ,document) ,@body)))))) 86 | 87 | (defun bson-document-size (document) 88 | (bson-document-dispatch document 89 | (hash-table (hash-table-count document)) 90 | (alist (length document)) 91 | (plist (/ (length document) 2)))) 92 | 93 | (defun bson-document-get (document key) 94 | (bson-document-dispatch document 95 | (hash-table (gethash key document)) 96 | (alist (cdr (assoc key document))) 97 | (plist (plist-get document (intern key))))) 98 | 99 | (defun bson-document-put (document key value) 100 | (bson-document-dispatch document 101 | (hash-table (puthash key value document)) 102 | (alist (bson-aif (assoc key document) 103 | (setcdr it value) 104 | (push (cons key value) document))) 105 | (plist (setq document (plist-put document (intern key) value)))) 106 | document) 107 | 108 | (defun bson-document-for (document function) 109 | (bson-document-dispatch document 110 | (hash-table (maphash function document)) 111 | (alist (loop for assoc in document 112 | do (funcall function (car assoc) (cdr assoc)))) 113 | (plist (loop for key = (pop document) 114 | for value = (pop document) 115 | while key 116 | do (funcall function (symbol-name key) value))))) 117 | 118 | (defmacro* bson-document-do ((key value document &optional result) &rest body) 119 | (declare (indent 1)) 120 | `(progn (bson-document-for ,document (lambda (,key ,value) ,@body)) 121 | ,result)) 122 | 123 | (defun bson-document-to-hash-table (document) 124 | (let ((table (make-hash-table :test 'equal))) 125 | (bson-document-do (key value document table) 126 | (puthash key value table)))) 127 | 128 | (defun* bson-document-to-alist (document &aux alist) 129 | (bson-document-do (key value document alist) 130 | (push (cons key value) alist))) 131 | 132 | (defun* bson-document-to-plist (document &aux plist) 133 | (bson-document-do (key value document plist) 134 | (setq plist `(,(intern key) ,value . ,plist)))) 135 | 136 | 137 | 138 | (defconst bson-marker-double #x01) 139 | (defconst bson-marker-string #x02) 140 | (defconst bson-marker-document #x03) 141 | (defconst bson-marker-array #x04) 142 | (defconst bson-marker-binary #x05) 143 | (defconst bson-marker-oid #x07) 144 | (defconst bson-marker-boolean #x08) 145 | (defconst bson-marker-datetime #x09) 146 | (defconst bson-marker-null #x0a) 147 | (defconst bson-marker-regexp #x0b) 148 | (defconst bson-marker-jscode #x0d) 149 | (defconst bson-marker-symbol #x0e) 150 | (defconst bson-marker-jscode/scope #x0f) 151 | (defconst bson-marker-int32 #x10) 152 | (defconst bson-marker-timestamp #x11) 153 | (defconst bson-marker-int64 #x12) 154 | (defconst bson-marker-min-key #xff) 155 | (defconst bson-marker-max-key #x7f) 156 | 157 | (defstruct bson-oid string) 158 | 159 | (defun bson-oid-to-hex-string (oid) 160 | (loop for byte across (bson-oid-string oid) 161 | collect (format "%02x" byte) into hex 162 | finally return (apply 'concat hex))) 163 | 164 | (defun bson-oid-of-hex-string (hex-string) 165 | (loop for i from 0 below (length hex-string) by 2 166 | for hex = (substring hex-string i (+ i 2)) 167 | collect (string-to-number hex 16) into bytes 168 | finally return (make-bson-oid :string (apply 'unibyte-string bytes)))) 169 | 170 | (defun bson-datetime-int64-to-time (byte-list) 171 | "Convert a 64 bit int as BYTE-LIST into an Elisp time." 172 | ;; Could do with some asserts to check byte-list 173 | (let ((calc-num 174 | (concat 175 | "16#" 176 | (mapconcat 177 | (lambda (x) (format "%02X" x)) 178 | byte-list "")))) 179 | (list 180 | (calc-eval 181 | "rsh(and(idiv($,1000),16#ffff0000),16)" 182 | 'rawnum 183 | calc-num) 184 | (calc-eval 185 | "and(idiv($,1000),16#ffff)" 186 | 'rawnum 187 | calc-num)))) 188 | 189 | (defsubst bson-serialize-byte (byte) 190 | (insert-char byte 1)) 191 | 192 | (defsubst bson-serialize-int32 (int32) 193 | ;; TODO bigint 194 | (bson-serialize-byte (logand (lsh int32 -0) #xff)) 195 | (bson-serialize-byte (logand (lsh int32 -8) #xff)) 196 | (bson-serialize-byte (logand (lsh int32 -16) #xff)) 197 | (bson-serialize-byte (logand (lsh int32 -24) #xff))) 198 | 199 | (defsubst bson-serialize-int64 (int64) 200 | ;; TODO bigint 201 | (bson-serialize-byte (logand (lsh int64 -0) #xff)) 202 | (bson-serialize-byte (logand (lsh int64 -8) #xff)) 203 | (bson-serialize-byte (logand (lsh int64 -16) #xff)) 204 | (bson-serialize-byte (logand (lsh int64 -24) #xff)) 205 | (bson-serialize-byte (logand (lsh int64 -32) #xff)) 206 | (bson-serialize-byte (logand (lsh int64 -40) #xff)) 207 | (bson-serialize-byte (logand (lsh int64 -48) #xff)) 208 | (bson-serialize-byte (logand (lsh int64 -56) #xff))) 209 | 210 | (defsubst bson-serialize-double (double) 211 | (let (bytes (byte 0) (nbit 0)) 212 | (flet ((serialize-bit (bit) 213 | (setq byte (logior (lsh byte 1) bit)) 214 | (when (eq (incf nbit) 8) 215 | (push byte bytes) 216 | (setq byte 0 217 | nbit 0))) 218 | (serialize-sign (sign) 219 | (serialize-bit (if (> sign 0) 0 1))) 220 | (serialize-exponent (exponent) 221 | (loop with bits 222 | repeat 11 do 223 | (push (mod exponent 2) bits) 224 | (setq exponent (/ exponent 2)) 225 | finally (mapc 'serialize-bit bits))) 226 | (serialize-significand (significand) 227 | (loop repeat 52 do 228 | (setq significand (* significand 2)) 229 | (if (< significand 1.0) 230 | (serialize-bit 0) 231 | (serialize-bit 1) 232 | (decf significand))))) 233 | (let ((significand double) 234 | (exponent 0)) 235 | (while (> significand 2.0) 236 | (setq significand (/ significand 2)) 237 | (incf exponent)) 238 | (serialize-sign (if (>= double 0.0) 1 -1)) 239 | (serialize-exponent (+ exponent 1023)) 240 | (serialize-significand (1- significand)))) 241 | (assert (and (eq byte 0) (eq nbit 0))) 242 | (mapc 'bson-serialize-byte bytes))) 243 | 244 | (defsubst bson-serialize-string (string) 245 | (bson-serialize-int32 (1+ (string-bytes string))) 246 | (insert string) 247 | (bson-serialize-byte #x00)) 248 | 249 | (defsubst bson-serialize-cstring (string) 250 | (insert string) 251 | (bson-serialize-byte #x00)) 252 | 253 | (defsubst bson-serialize-oid (oid) 254 | (insert (bson-oid-string oid))) 255 | 256 | (defsubst bson-serialize-array (array) 257 | (bson-serialize-document 258 | (loop for i from 0 259 | for element across array 260 | collect `(,i . ,element)))) 261 | 262 | (defsubst bson-serialize-symbol (symbol) 263 | (bson-serialize-string (symbol-name symbol))) 264 | 265 | (defsubst bson-serialize-boolean (boolean) 266 | (bson-serialize-byte (if boolean #x00 #x01))) 267 | 268 | (defsubst bson-serialize-name (name) 269 | (bson-serialize-cstring 270 | (cond ((stringp name) name) 271 | ((numberp name) (number-to-string name)) 272 | ((symbolp name) (symbol-name name)) 273 | (t (error "invalid element name: %s" name))))) 274 | 275 | (defsubst bson-serialize-marker (marker) 276 | (bson-serialize-byte marker)) 277 | 278 | (defun bson-serialize-element (name object) 279 | (macrolet ((serialize-element (marker function) 280 | `(progn 281 | (bson-serialize-marker ,marker) 282 | (bson-serialize-name name) 283 | (,function object)))) 284 | (bson-etypecase object 285 | (float (serialize-element 286 | bson-marker-double bson-serialize-double)) 287 | (string (serialize-element 288 | bson-marker-string bson-serialize-string)) 289 | (hash-table (serialize-element 290 | bson-marker-document bson-serialize-document)) 291 | (list (serialize-element 292 | bson-marker-document bson-serialize-document)) 293 | (bson-oid (serialize-element 294 | bson-marker-oid bson-serialize-oid)) 295 | (vector (serialize-element 296 | bson-marker-array bson-serialize-array)) 297 | (boolean (serialize-element 298 | bson-marker-boolean bson-serialize-boolean)) 299 | (symbol (serialize-element 300 | bson-marker-symbol bson-serialize-symbol)) 301 | (integer (serialize-element 302 | bson-marker-int32 bson-serialize-int32))))) 303 | 304 | (defun bson-serialize-document-1 (document) 305 | (bson-document-do (key value document) 306 | (bson-serialize-element key value))) 307 | 308 | (defun bson-serialize-document (document) 309 | (let ((start (point))) 310 | (bson-serialize-document-1 document) 311 | (bson-serialize-byte #x00) 312 | (let ((end (point))) 313 | (save-excursion 314 | (goto-char start) 315 | (bson-serialize-int32 (+ (- end start) 4)))))) 316 | 317 | (defun* bson-serialize-document-to-buffer (document 318 | &optional (buffer (current-buffer))) 319 | (with-current-buffer buffer 320 | (bson-serialize-document document))) 321 | 322 | (defun bson-serialize-document-to-string (document) 323 | (bson-with-temp-unibyte-buffer 324 | (bson-serialize-document document) 325 | (buffer-string))) 326 | 327 | (defun* bson-serialize-document-to-stream (document 328 | &optional (stream standard-output)) 329 | (let ((standard-output stream)) 330 | (princ (bson-serialize-document-to-string document)))) 331 | 332 | (defun bson-serialize-document-to-process (document process) 333 | (process-send-string process (bson-serialize-document-to-string document))) 334 | 335 | 336 | 337 | (defsubst bson-deserialize-byte () 338 | (prog1 (char-after) (forward-char))) 339 | 340 | (defsubst bson-deserialize-and-check-byte (expected) 341 | (let ((got (bson-deserialize-byte))) 342 | (assert (eq got expected)) 343 | got)) 344 | 345 | (defsubst bson-deserialize-int32 () 346 | (logior (lsh (bson-deserialize-byte) 0) 347 | (lsh (bson-deserialize-byte) 8) 348 | (lsh (bson-deserialize-byte) 16) 349 | (lsh (bson-deserialize-byte) 24))) 350 | 351 | (defsubst bson-deserialize-int64 () 352 | ;; FIXME: this probably needs to be done using calc or bigint 353 | (logior (lsh (bson-deserialize-byte) 0) 354 | (lsh (bson-deserialize-byte) 8) 355 | (lsh (bson-deserialize-byte) 16) 356 | (lsh (bson-deserialize-byte) 24) 357 | (lsh (bson-deserialize-byte) 32) 358 | (lsh (bson-deserialize-byte) 40) 359 | (lsh (bson-deserialize-byte) 48) 360 | (lsh (bson-deserialize-byte) 56))) 361 | 362 | (defsubst bson-deserialize-double () 363 | (let ((bytes (nreverse (loop repeat 8 collect (bson-deserialize-byte)))) 364 | (nbit 0)) 365 | (flet ((deserialize-bit () 366 | (prog1 (logand (lsh (car bytes) (- nbit 7)) 1) 367 | (when (eq (incf nbit) 8) 368 | (pop bytes) 369 | (setq nbit 0)))) 370 | (deserialize-sign () 371 | (if (zerop (deserialize-bit)) 1 -1)) 372 | (deserialize-exponent () 373 | (loop for i from 10 downto 0 374 | sum (lsh (deserialize-bit) i))) 375 | (deserialize-significand () 376 | (loop 377 | with bits = (nreverse 378 | (loop repeat 52 collect (deserialize-bit))) 379 | with significand = 0.0 380 | for bit in bits 381 | if (eq bit 1) 382 | do (incf significand) 383 | do (setq significand (/ significand 2)) 384 | finally return significand))) 385 | (let* ((sign (deserialize-sign)) 386 | (exponent (deserialize-exponent)) 387 | (significand (deserialize-significand))) 388 | (* sign 389 | (1+ significand) 390 | (expt 2 (- exponent 1023))))))) 391 | 392 | (defsubst bson-deserialize-string () 393 | (let* ((length (bson-deserialize-int32)) 394 | (start (point))) 395 | (forward-char (1- length)) 396 | (prog1 (buffer-substring-no-properties start (point)) 397 | (bson-deserialize-and-check-byte #x00)))) 398 | 399 | (defsubst bson-deserialize-cstring () 400 | (let ((start (point))) 401 | (search-forward (string #x00)) 402 | (forward-char -1) 403 | (prog1 (buffer-substring-no-properties start (point)) 404 | (bson-deserialize-and-check-byte #x00)))) 405 | 406 | (defsubst bson-deserialize-datetime () 407 | (let* ((bytes 408 | (loop repeat 8 409 | collect (bson-deserialize-byte)))) 410 | (bson-datetime-int64-to-time (reverse bytes)))) 411 | 412 | (defsubst bson-deserialize-oid () 413 | (let* ((bytes (loop repeat 12 414 | collect (bson-deserialize-byte))) 415 | (string (apply 'unibyte-string bytes))) 416 | (make-bson-oid :string string))) 417 | 418 | (defsubst bson-deserialize-array () 419 | (let* ((document (bson-deserialize-document)) 420 | (vector (make-vector (bson-document-size document) nil)) 421 | (index 0)) 422 | (bson-document-do (key value document vector) 423 | (declare (ignore key)) 424 | (aset vector index value) 425 | (incf index)))) 426 | 427 | (defsubst bson-deserialize-binary () 428 | (let* ((size (bson-deserialize-int32)) 429 | (subtype (bson-deserialize-byte)) 430 | (start (point))) 431 | (goto-char (+ start size)) 432 | (list 433 | subtype 434 | (buffer-substring-no-properties start (point))))) 435 | 436 | (defsubst bson-deserialize-symbol () 437 | (intern (bson-deserialize-string))) 438 | 439 | (defsubst bson-deserialize-boolean () 440 | (ecase (bson-deserialize-byte) 441 | (#x00 t) 442 | (#x01 nil))) 443 | 444 | (defsubst bson-deserialize-name () 445 | (bson-deserialize-cstring)) 446 | 447 | (defsubst bson-deserialize-marker () 448 | (bson-deserialize-byte)) 449 | 450 | (defsubst bson-deserialize-and-check-marker (expected) 451 | (let ((got (bson-deserialize-marker))) 452 | (assert (eq got expected)) 453 | got)) 454 | 455 | (defun bson-deserialize-element () 456 | (let* ((marker (bson-deserialize-marker)) 457 | (name (bson-deserialize-name))) 458 | (cons name 459 | (bson-evcase marker 460 | (bson-marker-null nil) 461 | (bson-marker-datetime (bson-deserialize-datetime)) 462 | (bson-marker-double (bson-deserialize-double)) 463 | (bson-marker-string (bson-deserialize-string)) 464 | (bson-marker-binary (bson-deserialize-binary)) 465 | (bson-marker-document (bson-deserialize-document)) 466 | (bson-marker-array (bson-deserialize-array)) 467 | (bson-marker-oid (bson-deserialize-oid)) 468 | (bson-marker-boolean (bson-deserialize-boolean)) 469 | (bson-marker-symbol (bson-deserialize-symbol)) 470 | (bson-marker-int32 (bson-deserialize-int32)))))) 471 | 472 | (defun bson-deserialize-document-1 (bound) 473 | (do ((document '())) 474 | ((or (>= (point) bound) 475 | (eq (char-after) #x00)) 476 | (nreverse document)) 477 | (destructuring-bind (key . value) 478 | (bson-deserialize-element) 479 | (push (cons key value) document)))) 480 | 481 | (defun bson-deserialize-document () 482 | (let ((length (bson-deserialize-int32))) 483 | (prog1 (bson-deserialize-document-1 (+ (point) length -4)) 484 | (bson-deserialize-and-check-byte #x00)))) 485 | 486 | (defun* bson-deserialize-document-from-buffer ((buffer (current-buffer))) 487 | (with-current-buffer buffer 488 | (bson-deserialize-document))) 489 | 490 | (defun bson-deserialize-document-from-string (string) 491 | (bson-with-temp-unibyte-buffer 492 | (insert string) 493 | (goto-char (point-min)) 494 | (bson-deserialize-document))) 495 | 496 | (provide 'bson) 497 | ;;; bson.el ends here 498 | -------------------------------------------------------------------------------- /mongo-tests.el: -------------------------------------------------------------------------------- 1 | ;;; tests.el --- tests for mongo and bson 2 | 3 | ;; Copyright (C) 2012 Nic Ferrier 4 | 5 | ;; Author: Nic Ferrier 6 | ;; Keywords: lisp, data 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; Test code for mongo-db and bson stuff. 24 | 25 | ;;; Code: 26 | 27 | (require 'bson) 28 | (require 'cl) 29 | 30 | (ert-deftest bson-datetime-int64-to-time () 31 | "Test the bson datetime conversion." 32 | (let ((december-10-2010 33 | ;; I know this is the the mongo rep for this time because 34 | ;; I've pulled it from a packet dump 35 | (list #x40 #xa0 #x9f #xc3 #x2c #x01 #x00 #x00))) 36 | (should 37 | (equal 38 | "12/08/10" 39 | (format-time-string 40 | "%D" 41 | (bson-datetime-int64-to-time 42 | (reverse december-10-2010))))))) 43 | 44 | (defmacro with-bson-test-buffer (datetime &rest body) 45 | "Execute BODY with the specified DATETIME in BSON format. 46 | 47 | Clearly this function needs to be more generic, it will be as we 48 | add tests to mongo.el." 49 | (declare (debug (sexp &rest form))) 50 | `(with-temp-buffer 51 | (insert 52 | (format "%c%s%c" ?\x09 "field_name" ?\x0)) 53 | (mapc (lambda (c) (insert (format "%c" c))) ,datetime) 54 | (goto-char (point-min)) 55 | (progn ,@body))) 56 | 57 | (ert-deftest bson-datetime-deserialize () 58 | "Test the de-serializing of BSON datetime." 59 | (let ((december-10-2010 60 | ;; I know this is the the mongo rep for this time because 61 | ;; I've pulled it from a packet dump 62 | (list #x40 #xa0 #x9f #xc3 #x2c #x01 #x00 #x00))) 63 | (with-bson-test-buffer december-10-2010 64 | (let ((bson-data (bson-deserialize-element))) 65 | ;; Check the value 66 | (should 67 | (equal 68 | "12/08/10" 69 | (format-time-string "%D" (cdr bson-data)))) 70 | ;; Check the field name 71 | (should 72 | (equal 73 | "field_name" (car bson-data))))))) 74 | 75 | (provide 'mongo-tests) 76 | 77 | ;;; tests.el ends here 78 | -------------------------------------------------------------------------------- /mongo.el: -------------------------------------------------------------------------------- 1 | ;;; mongo.el --- MongoDB driver for Emacs Lisp 2 | 3 | ;; Copyright (C) 2011-2015 Tomohiro Matsuyama 4 | 5 | ;; Author: Tomohiro Matsuyama 6 | ;; Keywords: convenience 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'cl) 28 | (require 'bson) 29 | 30 | (defmacro mongo-with-gensyms (names &rest body) 31 | (declare (indent 1)) 32 | `(let ,(loop for name in names 33 | collect `(,name (gensym ,(symbol-name name)))) 34 | ,@body)) 35 | 36 | (defsubst mongo-make-keyword (string) 37 | (intern (format ":%s" string))) 38 | 39 | (defsubst mongo-generate-new-unibyte-buffer (name) 40 | (let ((buffer (generate-new-buffer name))) 41 | (with-current-buffer buffer (set-buffer-multibyte nil)) 42 | buffer)) 43 | 44 | (defmacro* mongo-wait-for (form &key timeout (interval 0.1)) 45 | (mongo-with-gensyms (timeout! interval! elapsed last-value) 46 | `(let ((,timeout! ,timeout) 47 | (,interval! ,interval) 48 | (,elapsed 0.0) 49 | ,last-value) 50 | (while (null (setq ,last-value ,form)) 51 | (when (and ,timeout! (> ,elapsed ,timeout!)) 52 | (error "timeout: %s" ',form)) 53 | (sit-for ,interval!) 54 | (incf ,elapsed ,interval!)) 55 | ,last-value))) 56 | 57 | 58 | 59 | (defsubst mongo-document-oid (document) 60 | (bson-document-get document "_id")) 61 | 62 | 63 | 64 | (defsubst mongo-serialize-function (name) 65 | (get name 'mongo-serialize-function)) 66 | 67 | (defsubst mongo-deserialize-function (name) 68 | (get name 'mongo-deserialize-function)) 69 | 70 | (defmacro mongo-define-serialize-function (name lambda-list &rest body) 71 | (declare (indent 2)) 72 | `(put ',name 'mongo-serialize-function (lambda ,lambda-list ,@body))) 73 | 74 | (defmacro mongo-define-deserialize-function (name lambda-list &rest body) 75 | (declare (indent 2)) 76 | `(put ',name 'mongo-deserialize-function (lambda ,lambda-list ,@body))) 77 | 78 | (defsubst mongo-serialize-of-type (object type) 79 | (case type 80 | (cstring (bson-serialize-cstring object)) 81 | (document (bson-serialize-document object)) 82 | (int32 (bson-serialize-int32 object)) 83 | (int64 (bson-serialize-int64 object)) 84 | (otherwise (funcall (mongo-serialize-function type) object)))) 85 | 86 | (defsubst mongo-deserialize-of-type (type &optional bound) 87 | (case type 88 | (cstring (bson-deserialize-cstring)) 89 | (document (bson-deserialize-document)) 90 | (int32 (bson-deserialize-int32)) 91 | (int64 (bson-deserialize-int64)) 92 | (otherwise (funcall (mongo-deserialize-function type) bound)))) 93 | 94 | (defmacro mongo-define-message-fragment (name &rest slots) 95 | (declare (indent 1)) 96 | (flet 97 | ((make-slot-serializer (value slot-type) 98 | (if (consp slot-type) 99 | (ecase (first slot-type) 100 | (* 101 | `(loop for element in ,value 102 | collect 103 | (mongo-serialize-of-type 104 | element ',(second slot-type))))) 105 | `(mongo-serialize-of-type ,value ',slot-type))) 106 | (make-slot-deserializer (slot-type bound) 107 | (if (consp slot-type) 108 | (ecase (first slot-type) 109 | (* `(loop while (< (point) ,bound) 110 | collect 111 | (mongo-deserialize-of-type 112 | ',(second slot-type))))) 113 | `(mongo-deserialize-of-type ',slot-type)))) 114 | (let ((constructor-name (intern (format "make-%s" name)))) 115 | `(progn 116 | (defstruct (,name (:constructor ,constructor-name)) 117 | ,@(loop for slot in slots collect (first slot))) 118 | (mongo-define-serialize-function ,name (object) 119 | ,@(loop for (slot-name . slot-options) in slots 120 | for slot-type = (getf slot-options :type) 121 | for reader = (intern (format "%s-%s" name slot-name)) 122 | unless (getf slot-options :transient) 123 | collect (make-slot-serializer `(,reader object) slot-type))) 124 | (mongo-define-deserialize-function ,name (bound) 125 | (,constructor-name 126 | ,@(loop for (slot-name . slot-options) in slots 127 | for slot-type = (getf slot-options :type) 128 | unless (getf slot-options :transient) 129 | collect (mongo-make-keyword slot-name) 130 | and collect (make-slot-deserializer slot-type 'bound)))))))) 131 | 132 | 133 | 134 | (defconst mongo-op-code-table 135 | '(( 1 . mongo-message-reply) 136 | (1000 . mongo-message-message) 137 | (2001 . mongo-message-update) 138 | (2002 . mongo-message-insert) 139 | (2004 . mongo-message-query) 140 | (2005 . mongo-message-get-more) 141 | (2006 . mongo-message-delete) 142 | (2007 . mongo-message-kill-cursors))) 143 | 144 | (mongo-define-message-fragment mongo-message-header 145 | (message-length :type int32) 146 | (request-id :type int32) 147 | (response-to :type int32) 148 | (op-code :type int32)) 149 | 150 | (defmacro mongo-define-message (name &rest slots) 151 | (declare (indent 1)) 152 | `(mongo-define-message-fragment ,name 153 | (header :type mongo-message-header :transient t) 154 | ,@slots)) 155 | 156 | (mongo-define-message mongo-message-update 157 | (zero :type int32) 158 | (full-collection-name :type cstring) 159 | (flags :type int32) 160 | (selector :type document) 161 | (update :type document)) 162 | 163 | (mongo-define-message mongo-message-insert 164 | (flags :type int32) 165 | (full-collection-name :type cstring) 166 | (documents :type (* document))) 167 | 168 | (mongo-define-message mongo-message-query 169 | (flags :type int32) 170 | (full-collection-name :type cstring) 171 | (number-to-skip :type int32) 172 | (number-to-return :type int32) 173 | (query :type document) 174 | (return-field-selector :type document)) 175 | 176 | (mongo-define-message mongo-message-get-more 177 | (zero :type int32) 178 | (full-collection-name :type cstring) 179 | (number-to-return :type int32) 180 | (cursor-id :type int64)) 181 | 182 | (mongo-define-message mongo-message-delete 183 | (zero :type int32) 184 | (full-collection-name :type cstring) 185 | (flags :type int32) 186 | (selector :type document)) 187 | 188 | (mongo-define-message mongo-message-kill-cursors 189 | (zero :type int32) 190 | (number-to-cursor-ids :type int32) 191 | (cursor-ids :type (* int64))) 192 | 193 | (mongo-define-message mongo-message-message 194 | (message :type cstring)) 195 | 196 | (mongo-define-message mongo-message-reply 197 | (response-flags :type int32) 198 | (cursor-id :type int64) 199 | (starting-from :type int32) 200 | (number-returned :type int32) 201 | (documents :type (* document))) 202 | 203 | (defsubst mongo-message-header (message) 204 | (aref message 1)) 205 | 206 | (defsetf mongo-message-header (message) (header) 207 | `(aset ,message 1 ,header)) 208 | 209 | (defun mongo-serialize-message (message) 210 | (let* ((type (bson-type-of message)) 211 | (op-code (car (rassq type mongo-op-code-table))) 212 | (start (point))) 213 | (assert (integerp op-code)) 214 | (mongo-serialize-of-type message type) 215 | (let ((header (mongo-message-header message)) 216 | (message-length (+ (- (point) start) 16))) 217 | (setf (mongo-message-header-message-length header) message-length 218 | (mongo-message-header-op-code header) op-code) 219 | (save-excursion 220 | (goto-char start) 221 | (mongo-serialize-of-type header 'mongo-message-header))))) 222 | 223 | (defun* mongo-serialize-message-to-buffer (message 224 | &optional (buffer (current-buffer))) 225 | (with-current-buffer buffer 226 | (mongo-serialize-message message))) 227 | 228 | (defun mongo-serialize-message-to-string (message) 229 | (bson-with-temp-unibyte-buffer 230 | (mongo-serialize-message message) 231 | (buffer-string))) 232 | 233 | (defun mongo-serialize-message-to-process (message process) 234 | (process-send-string process (mongo-serialize-message-to-string message))) 235 | 236 | (defun mongo-deserialize-message () 237 | (let* ((header (mongo-deserialize-of-type 'mongo-message-header)) 238 | (op-code (mongo-message-header-op-code header)) 239 | (message-length (mongo-message-header-message-length header)) 240 | (type (cdr (assq op-code mongo-op-code-table))) 241 | (bound (+ (point) message-length -16)) 242 | (message (mongo-deserialize-of-type type bound))) 243 | (setf (mongo-message-header message) header) 244 | message)) 245 | 246 | (defun* mongo-deserialize-message-from-buffer ((buffer (current-buffer))) 247 | (with-current-buffer buffer (mongo-deserialize-message))) 248 | 249 | (defun mongo-deserialize-message-from-string (string) 250 | (bson-with-temp-unibyte-buffer 251 | (insert string) 252 | (goto-char (point-min)) 253 | (mongo-deserialize-message))) 254 | 255 | 256 | 257 | (defmacro mongo-define-process-struct (name &rest slots) 258 | (declare (indent 1)) 259 | (let* ((constructor-name (intern (format "make-%s" name))) 260 | (slot-names (loop for slot in slots 261 | for slot-name = (if (listp slot) (first slot) slot) 262 | collect slot-name))) 263 | `(progn 264 | (defun* ,constructor-name (underlying-process &key ,@slots) 265 | ,@(loop for slot-name in slot-names 266 | collect `(process-put 267 | underlying-process ',slot-name ,slot-name)) 268 | underlying-process) 269 | ,@(loop for slot-name in slot-names 270 | for accessor-name = (intern (format "%s-%s" name slot-name)) 271 | collect `(defsubst ,accessor-name (object) 272 | (process-get object ',slot-name)) 273 | collect `(defsetf ,accessor-name (object) (value) 274 | `(prog1 ,value (process-put 275 | ,object ',',slot-name ,value))))))) 276 | 277 | (mongo-define-process-struct mongo-database 278 | request response timeout (request-counter 0) callback) 279 | 280 | (defvar mongo-database nil) 281 | 282 | (defsubst mongo-peek-message-length () 283 | (save-excursion (bson-deserialize-int32))) 284 | 285 | (defun mongo-database-process-sentinel (database event)) 286 | 287 | (defun mongo-database-process-filter (database string) 288 | (with-current-buffer (process-buffer database) 289 | (goto-char (point-max)) 290 | (insert string) 291 | (let ((available (buffer-size))) 292 | (when (>= available 4) 293 | (goto-char (point-min)) 294 | (let ((message-length (mongo-peek-message-length))) 295 | (when (>= available message-length) 296 | (let ((message (mongo-deserialize-message))) 297 | (delete-region (point-min) (point)) 298 | (mongo-database-process-callback database message)))))))) 299 | 300 | (defun mongo-database-process-callback (database response) 301 | (setf (mongo-database-response database) response) 302 | (bson-awhen (mongo-database-callback database) 303 | (funcall it database response))) 304 | 305 | (defun* mongo-open-database (&key (host 'local) 306 | (port 27017) 307 | (make-default t) 308 | timeout 309 | callback) 310 | (let* ((process 311 | (make-network-process 312 | :name "mongo" 313 | :buffer (mongo-generate-new-unibyte-buffer " mongo") 314 | :host host 315 | :service (number-to-string port) 316 | :coding 'binary 317 | :filter 'mongo-database-process-filter 318 | :filter-multibyte nil 319 | :sentinel 'mongo-database-process-sentinel)) 320 | (database (make-mongo-database process :callback callback))) 321 | (when make-default (setq mongo-database database)) 322 | database)) 323 | 324 | (defun* mongo-close-database (&key (database mongo-database)) 325 | (process-send-eof database)) 326 | 327 | (defmacro mongo-with-current-database (database &rest body) 328 | (declare (indent 1)) 329 | `(let ((mongo-database ,database)) ,@body)) 330 | 331 | (defmacro* mongo-with-open-database ((var &rest args) &rest body) 332 | "Bind VAR to a db opened with ARGS and evaluate BODY. 333 | 334 | For ARGS see `mongo-open-database'." 335 | (declare 336 | (debug (sexp &rest form)) 337 | (indent 1)) 338 | `(let* ((mongo-database mongo-database) 339 | (,var (mongo-open-database ,@args))) 340 | (unwind-protect 341 | (progn ,@body) 342 | (mongo-close-database :database ,var)))) 343 | 344 | 345 | 346 | (defsubst mongo-new-request-id (database) 347 | (incf (mongo-database-request-counter database))) 348 | 349 | (defun mongo-finalize-request (request database) 350 | (let ((header (mongo-message-header request))) 351 | (unless header 352 | (setq header (make-mongo-message-header)) 353 | (setf (mongo-message-header request) header)) 354 | (unless (mongo-message-header-request-id header) 355 | (setf (mongo-message-header-request-id header) 356 | (mongo-new-request-id database))) 357 | (unless (mongo-message-header-response-to header) 358 | (setf (mongo-message-header-response-to header) 0)))) 359 | 360 | (defun* mongo-send-request (request &key (database mongo-database)) 361 | (setf (mongo-database-request database) request 362 | (mongo-database-response database) nil) 363 | (mongo-finalize-request request database) 364 | (mongo-serialize-message-to-process request database)) 365 | 366 | (defun* mongo-receive-response (&key (database mongo-database)) 367 | (mongo-wait-for (mongo-database-response database) 368 | :timeout (mongo-database-timeout database))) 369 | 370 | (defun* mongo-do-request (request &key (database mongo-database) async) 371 | (mongo-send-request request :database database) 372 | (unless async 373 | (mongo-receive-response :database database))) 374 | 375 | (provide 'mongo) 376 | ;;; mongo.el ends here 377 | -------------------------------------------------------------------------------- /recipes/mongo-el: -------------------------------------------------------------------------------- 1 | (mongo-el 2 | :version "0.5.1" 3 | :doc "Emacs Mongo-Db adapter." 4 | :files 5 | ("mongo.el" 6 | "bson.el" 7 | "README.md") 8 | :test 9 | (:files 10 | ("mongo-tests.el"))) 11 | --------------------------------------------------------------------------------