forked from emacsorphanage/mongo
-
Notifications
You must be signed in to change notification settings - Fork 0
/
mongo.el
376 lines (307 loc) · 13.3 KB
/
mongo.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
;;; mongo.el --- MongoDB driver for Emacs Lisp
;; Copyright (C) 2011 Tomohiro Matsuyama
;; Author: Tomohiro Matsuyama <tomo@cx4a.org>
;; 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
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; 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 <http://www.gnu.org/licenses/>.
;;; 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))))
,@body))
(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))
buffer))
(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)
,last-value)
(while (null (setq ,last-value ,form))
(when (and ,timeout! (> ,elapsed ,timeout!))
(error "timeout: %s" ',form))
(sit-for ,interval!)
(incf ,elapsed ,interval!))
,last-value)))
(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))
(flet
((make-slot-serializer (value slot-type)
(if (consp slot-type)
(ecase (first slot-type)
(*
`(loop for element in ,value
collect
(mongo-serialize-of-type
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)
collect
(mongo-deserialize-of-type
',(second slot-type)))))
`(mongo-deserialize-of-type ',slot-type))))
(let ((constructor-name (intern (format "make-%s" name))))
`(progn
(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)
(,constructor-name
,@(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)
,@slots))
(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)
(save-excursion
(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)
(bson-with-temp-unibyte-buffer
(mongo-serialize-message message)
(buffer-string)))
(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)
message))
(defun* mongo-deserialize-message-from-buffer ((buffer (current-buffer)))
(with-current-buffer buffer (mongo-deserialize-message)))
(defun mongo-deserialize-message-from-string (string)
(bson-with-temp-unibyte-buffer
(insert string)
(goto-char (point-min))
(mongo-deserialize-message)))
(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)))
`(progn
(defun* ,constructor-name (underlying-process &key ,@slots)
,@(loop for slot-name in slot-names
collect `(process-put
underlying-process ',slot-name ,slot-name))
underlying-process)
,@(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)
timeout
callback)
(let* ((process
(make-network-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))
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'."
(declare
(debug (sexp &rest form))
(indent 1))
`(let* ((mongo-database mongo-database)
(,var (mongo-open-database ,@args)))
(unwind-protect
(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