Find file
Fetching contributors…
Cannot retrieve contributors at this time
377 lines (307 sloc) 13.3 KB
;;; mongo.el --- MongoDB driver for Emacs Lisp
;; Copyright (C) 2011-2015 Tomohiro Matsuyama
;; Author: Tomohiro Matsuyama <>
;; Keywords: convenience
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <>.
;;; Commentary:
;;; Code:
(require 'cl)
(require 'bson)
(defmacro mongo-with-gensyms (names &rest body)
(declare (indent 1))
`(let ,(loop for name in names
collect `(,name (gensym ,(symbol-name name))))
(defsubst mongo-make-keyword (string)
(intern (format ":%s" string)))
(defsubst mongo-generate-new-unibyte-buffer (name)
(let ((buffer (generate-new-buffer name)))
(with-current-buffer buffer (set-buffer-multibyte nil))
(defmacro* mongo-wait-for (form &key timeout (interval 0.1))
(mongo-with-gensyms (timeout! interval! elapsed last-value)
`(let ((,timeout! ,timeout)
(,interval! ,interval)
(,elapsed 0.0)
(while (null (setq ,last-value ,form))
(when (and ,timeout! (> ,elapsed ,timeout!))
(error "timeout: %s" ',form))
(sit-for ,interval!)
(incf ,elapsed ,interval!))
(defsubst mongo-document-oid (document)
(bson-document-get document "_id"))
(defsubst mongo-serialize-function (name)
(get name 'mongo-serialize-function))
(defsubst mongo-deserialize-function (name)
(get name 'mongo-deserialize-function))
(defmacro mongo-define-serialize-function (name lambda-list &rest body)
(declare (indent 2))
`(put ',name 'mongo-serialize-function (lambda ,lambda-list ,@body)))
(defmacro mongo-define-deserialize-function (name lambda-list &rest body)
(declare (indent 2))
`(put ',name 'mongo-deserialize-function (lambda ,lambda-list ,@body)))
(defsubst mongo-serialize-of-type (object type)
(case type
(cstring (bson-serialize-cstring object))
(document (bson-serialize-document object))
(int32 (bson-serialize-int32 object))
(int64 (bson-serialize-int64 object))
(otherwise (funcall (mongo-serialize-function type) object))))
(defsubst mongo-deserialize-of-type (type &optional bound)
(case type
(cstring (bson-deserialize-cstring))
(document (bson-deserialize-document))
(int32 (bson-deserialize-int32))
(int64 (bson-deserialize-int64))
(otherwise (funcall (mongo-deserialize-function type) bound))))
(defmacro mongo-define-message-fragment (name &rest slots)
(declare (indent 1))
((make-slot-serializer (value slot-type)
(if (consp slot-type)
(ecase (first slot-type)
`(loop for element in ,value
element ',(second slot-type)))))
`(mongo-serialize-of-type ,value ',slot-type)))
(make-slot-deserializer (slot-type bound)
(if (consp slot-type)
(ecase (first slot-type)
(* `(loop while (< (point) ,bound)
',(second slot-type)))))
`(mongo-deserialize-of-type ',slot-type))))
(let ((constructor-name (intern (format "make-%s" name))))
(defstruct (,name (:constructor ,constructor-name))
,@(loop for slot in slots collect (first slot)))
(mongo-define-serialize-function ,name (object)
,@(loop for (slot-name . slot-options) in slots
for slot-type = (getf slot-options :type)
for reader = (intern (format "%s-%s" name slot-name))
unless (getf slot-options :transient)
collect (make-slot-serializer `(,reader object) slot-type)))
(mongo-define-deserialize-function ,name (bound)
,@(loop for (slot-name . slot-options) in slots
for slot-type = (getf slot-options :type)
unless (getf slot-options :transient)
collect (mongo-make-keyword slot-name)
and collect (make-slot-deserializer slot-type 'bound))))))))
(defconst mongo-op-code-table
'(( 1 . mongo-message-reply)
(1000 . mongo-message-message)
(2001 . mongo-message-update)
(2002 . mongo-message-insert)
(2004 . mongo-message-query)
(2005 . mongo-message-get-more)
(2006 . mongo-message-delete)
(2007 . mongo-message-kill-cursors)))
(mongo-define-message-fragment mongo-message-header
(message-length :type int32)
(request-id :type int32)
(response-to :type int32)
(op-code :type int32))
(defmacro mongo-define-message (name &rest slots)
(declare (indent 1))
`(mongo-define-message-fragment ,name
(header :type mongo-message-header :transient t)
(mongo-define-message mongo-message-update
(zero :type int32)
(full-collection-name :type cstring)
(flags :type int32)
(selector :type document)
(update :type document))
(mongo-define-message mongo-message-insert
(flags :type int32)
(full-collection-name :type cstring)
(documents :type (* document)))
(mongo-define-message mongo-message-query
(flags :type int32)
(full-collection-name :type cstring)
(number-to-skip :type int32)
(number-to-return :type int32)
(query :type document)
(return-field-selector :type document))
(mongo-define-message mongo-message-get-more
(zero :type int32)
(full-collection-name :type cstring)
(number-to-return :type int32)
(cursor-id :type int64))
(mongo-define-message mongo-message-delete
(zero :type int32)
(full-collection-name :type cstring)
(flags :type int32)
(selector :type document))
(mongo-define-message mongo-message-kill-cursors
(zero :type int32)
(number-to-cursor-ids :type int32)
(cursor-ids :type (* int64)))
(mongo-define-message mongo-message-message
(message :type cstring))
(mongo-define-message mongo-message-reply
(response-flags :type int32)
(cursor-id :type int64)
(starting-from :type int32)
(number-returned :type int32)
(documents :type (* document)))
(defsubst mongo-message-header (message)
(aref message 1))
(defsetf mongo-message-header (message) (header)
`(aset ,message 1 ,header))
(defun mongo-serialize-message (message)
(let* ((type (bson-type-of message))
(op-code (car (rassq type mongo-op-code-table)))
(start (point)))
(assert (integerp op-code))
(mongo-serialize-of-type message type)
(let ((header (mongo-message-header message))
(message-length (+ (- (point) start) 16)))
(setf (mongo-message-header-message-length header) message-length
(mongo-message-header-op-code header) op-code)
(goto-char start)
(mongo-serialize-of-type header 'mongo-message-header)))))
(defun* mongo-serialize-message-to-buffer (message
&optional (buffer (current-buffer)))
(with-current-buffer buffer
(mongo-serialize-message message)))
(defun mongo-serialize-message-to-string (message)
(mongo-serialize-message message)
(defun mongo-serialize-message-to-process (message process)
(process-send-string process (mongo-serialize-message-to-string message)))
(defun mongo-deserialize-message ()
(let* ((header (mongo-deserialize-of-type 'mongo-message-header))
(op-code (mongo-message-header-op-code header))
(message-length (mongo-message-header-message-length header))
(type (cdr (assq op-code mongo-op-code-table)))
(bound (+ (point) message-length -16))
(message (mongo-deserialize-of-type type bound)))
(setf (mongo-message-header message) header)
(defun* mongo-deserialize-message-from-buffer ((buffer (current-buffer)))
(with-current-buffer buffer (mongo-deserialize-message)))
(defun mongo-deserialize-message-from-string (string)
(insert string)
(goto-char (point-min))
(defmacro mongo-define-process-struct (name &rest slots)
(declare (indent 1))
(let* ((constructor-name (intern (format "make-%s" name)))
(slot-names (loop for slot in slots
for slot-name = (if (listp slot) (first slot) slot)
collect slot-name)))
(defun* ,constructor-name (underlying-process &key ,@slots)
,@(loop for slot-name in slot-names
collect `(process-put
underlying-process ',slot-name ,slot-name))
,@(loop for slot-name in slot-names
for accessor-name = (intern (format "%s-%s" name slot-name))
collect `(defsubst ,accessor-name (object)
(process-get object ',slot-name))
collect `(defsetf ,accessor-name (object) (value)
`(prog1 ,value (process-put
,object ',',slot-name ,value)))))))
(mongo-define-process-struct mongo-database
request response timeout (request-counter 0) callback)
(defvar mongo-database nil)
(defsubst mongo-peek-message-length ()
(save-excursion (bson-deserialize-int32)))
(defun mongo-database-process-sentinel (database event))
(defun mongo-database-process-filter (database string)
(with-current-buffer (process-buffer database)
(goto-char (point-max))
(insert string)
(let ((available (buffer-size)))
(when (>= available 4)
(goto-char (point-min))
(let ((message-length (mongo-peek-message-length)))
(when (>= available message-length)
(let ((message (mongo-deserialize-message)))
(delete-region (point-min) (point))
(mongo-database-process-callback database message))))))))
(defun mongo-database-process-callback (database response)
(setf (mongo-database-response database) response)
(bson-awhen (mongo-database-callback database)
(funcall it database response)))
(defun* mongo-open-database (&key (host 'local)
(port 27017)
(make-default t)
(let* ((process
:name "mongo"
:buffer (mongo-generate-new-unibyte-buffer " mongo")
:host host
:service (number-to-string port)
:coding 'binary
:filter 'mongo-database-process-filter
:filter-multibyte nil
:sentinel 'mongo-database-process-sentinel))
(database (make-mongo-database process :callback callback)))
(when make-default (setq mongo-database database))
(defun* mongo-close-database (&key (database mongo-database))
(process-send-eof database))
(defmacro mongo-with-current-database (database &rest body)
(declare (indent 1))
`(let ((mongo-database ,database)) ,@body))
(defmacro* mongo-with-open-database ((var &rest args) &rest body)
"Bind VAR to a db opened with ARGS and evaluate BODY.
For ARGS see `mongo-open-database'."
(debug (sexp &rest form))
(indent 1))
`(let* ((mongo-database mongo-database)
(,var (mongo-open-database ,@args)))
(progn ,@body)
(mongo-close-database :database ,var))))
(defsubst mongo-new-request-id (database)
(incf (mongo-database-request-counter database)))
(defun mongo-finalize-request (request database)
(let ((header (mongo-message-header request)))
(unless header
(setq header (make-mongo-message-header))
(setf (mongo-message-header request) header))
(unless (mongo-message-header-request-id header)
(setf (mongo-message-header-request-id header)
(mongo-new-request-id database)))
(unless (mongo-message-header-response-to header)
(setf (mongo-message-header-response-to header) 0))))
(defun* mongo-send-request (request &key (database mongo-database))
(setf (mongo-database-request database) request
(mongo-database-response database) nil)
(mongo-finalize-request request database)
(mongo-serialize-message-to-process request database))
(defun* mongo-receive-response (&key (database mongo-database))
(mongo-wait-for (mongo-database-response database)
:timeout (mongo-database-timeout database)))
(defun* mongo-do-request (request &key (database mongo-database) async)
(mongo-send-request request :database database)
(unless async
(mongo-receive-response :database database)))
(provide 'mongo)
;;; mongo.el ends here