41
|
1
|
(in-package :xdb) |
|
2
|
|
|
3
|
;;; XDB |
|
4
|
(defclass xdb () |
|
5
|
((location :initarg :location |
|
6
|
:accessor location |
|
7
|
:initform (required-argument "Location is required")) |
|
8
|
(collections :initarg :collections |
|
9
|
:accessor collections |
|
10
|
:initform (make-hash-table :test 'equal)))) |
|
11
|
|
|
12
|
(defclass dbs () |
|
13
|
((databases :initarg :databases |
|
14
|
:accessor databases |
|
15
|
:initform (make-hash-table :test 'equal)) |
|
16
|
(base-path :initarg :base-path |
|
17
|
:initform "/tmp/db/" |
|
18
|
:accessor base-path))) |
|
19
|
|
|
20
|
(defmethod get-db ((dbs dbs) name) |
|
21
|
(gethash name (databases dbs))) |
|
22
|
|
|
23
|
(defun parse-db-path (path) |
|
24
|
(make-pathname :directory |
|
25
|
(list* :relative |
|
26
|
(etypecase path |
|
27
|
(cons path |
|
28
|
path) |
|
29
|
(string path |
|
30
|
(list path)))))) |
|
31
|
|
|
32
|
(defmethod add-db ((dbs dbs) name &key base-path load-from-file-p) |
|
33
|
(unless (gethash name (databases dbs)) |
|
34
|
(let* ((base-path (or base-path (base-path dbs))) |
|
35
|
(db-path (merge-pathnames (parse-db-path name) base-path)) |
|
36
|
(db (make-instance 'xdb :location db-path))) |
|
37
|
(ensure-directories-exist db-path) |
|
38
|
(setf (gethash name (databases dbs)) db) |
|
39
|
(if load-from-file-p |
|
40
|
(load-db db :load-from-file-p load-from-file-p))))) |
|
41
|
|
|
42
|
(defparameter *dbs* nil) |
|
43
|
|
|
44
|
(defun dbs () |
|
45
|
*dbs*) |
|
46
|
|
|
47
|
(defmethod initialize-doc-container ((collection collection)) |
|
48
|
(setf (docs collection) (make-array 0 :adjustable t :fill-pointer 0))) |
|
49
|
|
|
50
|
(defmethod map-docs (result-type function (collection collection) |
|
51
|
&rest more-collections) |
|
52
|
(let ((result |
|
53
|
(map result-type function (docs collection)))) |
|
54
|
(loop for collection in more-collections |
|
55
|
for results = (map result-type function (docs collection)) |
|
56
|
if result-type |
|
57
|
do (setf result (concatenate result-type result results))) |
|
58
|
result)) |
|
59
|
|
|
60
|
(defmethod find-duplicate-doc ((collection collection) doc &key function) |
|
61
|
(let ((test (or function #'duplicate-doc-p))) |
|
62
|
(map-docs |
|
63
|
nil |
|
64
|
(lambda (docx) |
|
65
|
(when (funcall test doc docx) |
|
66
|
(return-from find-duplicate-doc docx))) |
|
67
|
collection))) |
|
68
|
|
|
69
|
(defmethod add-doc ((collection collection) doc &key duplicate-doc-p-func) |
|
70
|
(when doc |
|
71
|
(if duplicate-doc-p-func |
|
72
|
(let ((dup (find-duplicate-doc collection doc :function duplicate-doc-p-func))) |
|
73
|
(if (not dup) |
|
74
|
(vector-push-extend doc (docs collection)) |
|
75
|
(setf dup doc) ;;doing this because |
|
76
|
)) |
|
77
|
(vector-push-extend doc (docs collection))))) |
|
78
|
|
|
79
|
(defmethod store-doc ((collection collection) doc |
|
80
|
&key (duplicate-doc-p-func #'duplicate-doc-p)) |
|
81
|
(let ((dup (and duplicate-doc-p-func |
|
82
|
(find-duplicate-doc collection doc |
|
83
|
:function duplicate-doc-p-func)))) |
|
84
|
;; a document might be considered duplicate based on the data |
|
85
|
;;contained and not its eql status as lisp object so we have to replace |
|
86
|
;;it in the array with the new object effectively updating the data. |
|
87
|
(if dup |
|
88
|
(setf dup doc) |
|
89
|
(vector-push-extend doc (docs collection))) |
|
90
|
(serialize-doc collection doc)) |
|
91
|
collection) |
|
92
|
|
|
93
|
(defmethod serialize-doc ((collection collection) doc &key) |
|
94
|
(let ((path (make-pathname :type "log" :defaults (db::path collection)))) |
|
95
|
(ensure-directories-exist path) |
|
96
|
(db::save-doc collection doc path)) |
|
97
|
doc) |
|
98
|
|
|
99
|
(defmethod serialize-docs (collection &key duplicate-doc-p-func) |
|
100
|
(map-docs |
|
101
|
nil |
|
102
|
(lambda (doc) |
|
103
|
(store-doc collection doc |
|
104
|
:duplicate-doc-p-func duplicate-doc-p-func)) |
|
105
|
collection)) |
|
106
|
|
|
107
|
(defmethod load-from-file ((collection collection) file) |
|
108
|
(when (probe-file file) |
|
109
|
(db::load-data collection file |
|
110
|
(lambda (object) |
|
111
|
(add-doc collection object))))) |
|
112
|
|
|
113
|
(defmethod get-collection ((db xdb) name) |
|
114
|
(gethash name (collections db))) |
|
115
|
|
|
116
|
(defun make-new-collection (name db &key collection-class) |
|
117
|
(let ((collection |
|
118
|
(make-instance collection-class |
|
119
|
:name name |
|
120
|
:path (merge-pathnames name (location db))))) |
|
121
|
(initialize-doc-container collection) |
|
122
|
collection)) |
|
123
|
|
|
124
|
(defmethod add-collection ((db xdb) name |
|
125
|
&key (collection-class 'collection) load-from-file-p) |
|
126
|
(let ((collection (or (gethash name (collections db)) |
|
127
|
(setf (gethash name (collections db)) |
|
128
|
(make-new-collection name db |
|
129
|
:collection-class collection-class))))) |
|
130
|
(ensure-directories-exist (db::path collection)) |
|
131
|
(when load-from-file-p |
|
132
|
(load-from-file collection |
|
133
|
(make-pathname :defaults (db::path collection) |
|
134
|
:type "snap")) |
|
135
|
(load-from-file collection |
|
136
|
(make-pathname :defaults (db::path collection) |
|
137
|
:type "log"))) |
|
138
|
collection)) |
|
139
|
|
|
140
|
(defun append-date (name) |
|
141
|
(format nil "~a-~a" name (file-date))) |
|
142
|
|
|
143
|
(defmethod snapshot ((collection collection)) |
|
144
|
(let* ((backup (merge-pathnames "backup/" (db::path collection))) |
|
145
|
(log (make-pathname :type "log" :defaults (db::path collection))) |
|
146
|
(snap (make-pathname :type "snap" :defaults (db::path collection))) |
|
147
|
(backup-name (append-date (db::name collection))) |
|
148
|
(log-backup (make-pathname :name backup-name |
|
149
|
:type "log" |
|
150
|
:defaults backup)) |
|
151
|
(snap-backup (make-pathname :name backup-name |
|
152
|
:type "snap" |
|
153
|
:defaults backup))) |
|
154
|
(ensure-directories-exist backup) |
|
155
|
(when (probe-file snap) |
|
156
|
(rename-file snap snap-backup)) |
|
157
|
(when (probe-file log) |
|
158
|
(rename-file log log-backup)) |
|
159
|
(db::save-data collection snap))) |
|
160
|
|
|
161
|
(defmethod snapshot ((db xdb)) |
|
162
|
(maphash (lambda (key value) |
|
163
|
(declare (ignore key)) |
|
164
|
(snapshot value)) |
|
165
|
(collections db))) |
|
166
|
|
|
167
|
(defmethod load-db ((db xdb) &key load-from-file-p) |
|
168
|
(let ((unique-collections (make-hash-table :test 'equal))) |
|
169
|
(dolist (path (directory (format nil "~A/*.*" (location db)))) |
|
170
|
(when (pathname-name path) |
|
171
|
(setf (gethash (pathname-name path) unique-collections) |
|
172
|
(pathname-name path)))) |
|
173
|
(maphash #'(lambda (key value) |
|
174
|
(declare (ignore key)) |
|
175
|
(add-collection db value :load-from-file-p load-from-file-p)) |
|
176
|
unique-collections))) |
|
177
|
|
|
178
|
(defmethod get-docs ((db xdb) collection-name &key return-type) |
|
179
|
(let ((col (gethash collection-name (collections db)))) |
|
180
|
(if return-type |
|
181
|
(coerce return-type |
|
182
|
(docs col)) |
|
183
|
(docs col)))) |
|
184
|
|
|
185
|
(defmethod get-doc (collection value &key (element 'key) (test #'equal)) |
|
186
|
(map-docs |
|
187
|
nil |
|
188
|
(lambda (doc) |
|
189
|
(when (funcall test (get-val doc element) value) |
|
190
|
(return-from get-doc doc))) |
|
191
|
collection)) |
|
192
|
|
|
193
|
(defmethod get-doc-complex (test element value collection &rest more-collections) |
|
194
|
(apply #'map-docs |
|
195
|
nil |
|
196
|
(lambda (doc) |
|
197
|
(when (apply test (list (get-val doc element) value)) |
|
198
|
(return-from get-doc-complex doc))) |
|
199
|
collection |
|
200
|
more-collections)) |
|
201
|
|
|
202
|
(defmethod find-doc (collection &key test) |
|
203
|
(if test |
|
204
|
(map-docs |
|
205
|
nil |
|
206
|
(lambda (doc) |
|
207
|
(when (funcall test doc) |
|
208
|
(return-from find-doc doc))) |
|
209
|
collection))) |
|
210
|
|
|
211
|
(defmethod find-doc-complex (test collection &rest more-collections) |
|
212
|
(apply #'map-docs |
|
213
|
(lambda (doc) |
|
214
|
(when (funcall test doc) |
|
215
|
(return-from find-doc-complex doc))) |
|
216
|
collection |
|
217
|
(cdr more-collections))) |
|
218
|
|
|
219
|
(defmethod find-docs (return-type test collection) |
|
220
|
(coerce (loop for doc across (docs collection) |
|
221
|
when (funcall test doc) |
|
222
|
collect doc) |
|
223
|
return-type)) |
|
224
|
|
|
225
|
(defclass union-docs () |
|
226
|
((docs :initarg :docs |
|
227
|
:accessor :docs))) |
|
228
|
|
|
229
|
(defmethod union-collection (return-type (collection collection) &rest more-collections) |
|
230
|
(make-instance |
|
231
|
'union-docs |
|
232
|
:docs (apply #'map-docs (list return-type collection more-collections)))) |
|
233
|
|
|
234
|
(defclass join-docs () |
|
235
|
((docs :initarg :docs |
|
236
|
:accessor :docs))) |
|
237
|
|
|
238
|
(defclass join-result () |
|
239
|
((docs :initarg :docs |
|
240
|
:accessor :docs))) |
|
241
|
|
|
242
|
(defun sort-key (doc) |
|
243
|
(get-val doc 'key)) |
|
244
|
|
|
245
|
;; TODO: How to update log if collection is sorted? Make a snapshot? |
|
246
|
(defmethod sort-collection ((collection collection) |
|
247
|
&key return-sort |
|
248
|
(sort-value-func #'sort-key) (sort-test-func #'>)) |
|
249
|
(setf (docs collection) |
|
250
|
(sort (docs collection) |
|
251
|
sort-test-func |
|
252
|
:key sort-value-func)) |
|
253
|
(if return-sort |
|
254
|
(docs collection) |
|
255
|
t)) |
|
256
|
|
|
257
|
(defmethod db::sort-collection-temporary ((collection collection) |
|
258
|
&key (sort-value-func #'sort-key) (sort-test-func #'>)) |
|
259
|
(let ((sorted-array (copy-array (docs collection)))) |
|
260
|
(setf sorted-array |
|
261
|
(sort sorted-array |
|
262
|
sort-test-func |
|
263
|
:key sort-value-func)) |
|
264
|
sorted-array)) |
|
265
|
|
|
266
|
(defun sort-docs (docs &key (sort-value-func #'sort-key) (sort-test-func #'>)) |
|
267
|
:documentation "Sorts array/list of docs and returns the sorted array." |
|
268
|
(sort docs |
|
269
|
sort-test-func |
|
270
|
:key sort-value-func)) |
|
271
|
|
|
272
|
;;Add method for validation when updating a collection. |
|
273
|
|
|
274
|
(defclass xdb-sequence () |
|
275
|
((key :initarg :key |
|
276
|
:accessor key) |
|
277
|
(value :initarg :value |
|
278
|
:accessor value))) |
|
279
|
|
|
280
|
(defmethod enable-sequences ((xdb xdb)) |
|
281
|
(add-collection xdb "sequences" |
|
282
|
:collection-class 'collection |
|
283
|
:load-from-file-p t)) |
|
284
|
|
|
285
|
(defmethod next-sequence ((xdb xdb) key) |
|
286
|
(let ((doc (get-doc (get-collection xdb "sequences") key))) |
|
287
|
(unless doc |
|
288
|
(setf doc (make-instance 'xdb-sequence :key key :value 0))) |
|
289
|
(incf (get-val doc 'value)) |
|
290
|
(store-doc (get-collection xdb "sequences") |
|
291
|
doc) |
|
292
|
(get-val doc 'value))) |