Coverage report: /development/source/library/org/datagraph/spocq-shard/src/store/rlmdb/rlmdb-mutation.lisp

KindCoveredAll%
expression0397 0.0
branch056 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.implementation; -*-
2
 
3
 (in-package :rlmdb.i)
4
 
5
 #|
6
 
7
 Methods:
8
 - spocq.i::repository-mutate : the interface operator accepts streams mediatype and global operation
9
   - process-intern-fields
10
     - spocq.i::rdfcache-intern-field (eventually rlmdb. direct)
11
   - call-with-decoded-field
12
     - rlmdb:repository-mutate-field
13
       - rlmdb::repository-insert-statement
14
         - rlmdb::compute-index-insertion-data
15
           - liblmdb:put
16
       - rlmdb::repository-delete-statement
17
         - rlmdb::compute-index-deletion-data
18
           - liblmdb:put
19
           - liblmdb:del
20
 
21
 The ANY method combination is central to the repository-insert/delete-statement operators.
22
 The control flow is as for PROGN, but the result as as for SOME.
23
 This provides the process whihc iterates over the input with an indication whether or not
24
 the statement mutated the index.
25
 
26
 |#
27
 
28
 (defun any (&rest values)
29
   (declare (dynamic-extent values))
30
   (some #'identity values))
31
 
32
 (define-method-combination any
33
   :documentation "Execute all methods. Return the first non-null result.")
34
   
35
 (defgeneric rlmdb.i::record-modified-resource (transaction subject)
36
   (:method ((transaction rlmdb:transaction) (subject t))
37
     nil))
38
 
39
 (defgeneric (setf rlmdb::transaction-graph-id-modified) (value transaction graph)
40
   (:method ((value t) (transaction rlmdb:transaction) (graph t))
41
     nil))
42
 
43
 (defgeneric rlmdb::repository-clear-graph (repository lmdb:transaction data)
44
   (:method ((repository rlmdb:repository) (lmdb:transaction rlmdb:transaction) (data symbol))
45
     (ecase data
46
       (|urn:dydra|:|all|
47
        (rlmdb:clear-repository repository :type 'rlmdb:index-database))))
48
   (:method ((repository rlmdb:repository) (lmdb:transaction rlmdb:transaction) (data t))
49
     0))
50
 
51
 (defgeneric rlmdb:repository-mutate-field (repository transaction method solution-field)
52
   
53
   (:method ((repository rlmdb:repository) (lmdb:transaction rlmdb:transaction) (method (eql :delete)) (graph (eql :all)))
54
     (rlmdb::repository-delete-statements repository 0 0 0 0))
55
 
56
   (:method ((repository rlmdb:repository) (lmdb:transaction rlmdb:transaction) (method t) (solution-field vector))
57
     (loop for sub-field across solution-field
58
       sum (rlmdb:repository-mutate-field repository lmdb:transaction sub-field method)))
59
   
60
   (:method ((repository rlmdb:repository) (lmdb:transaction rlmdb:transaction) (method t) (solution-field array))
61
     (assert (= (array-rank solution-field) 2) ()
62
             "solution field must be a quad field array")
63
       (labels ((mutate-statement (graph subject predicate object)
64
                  (ecase method
65
                    (:post
66
                     (rlmdb::repository-insert-statement repository lmdb:transaction graph subject predicate object))
67
                    (:delete
68
                     (rlmdb::repository-delete-statement repository lmdb:transaction graph subject predicate object)))))
69
         (let ((field-graph 0)
70
               (field-subject 0)
71
               (default-graph-id (rlmdb:transaction-default-context-term-id lmdb:transaction)))
72
           ;; modify the id list for any graph which appears
73
           (ecase (array-dimension solution-field 1)
74
             (3 
75
              (spocq.i::do-solution-field (subject predicate object) solution-field
76
                                          (when (and (/= subject 0)
77
                                                     (/= predicate 0)
78
                                                     (/= object 0))
79
                                            (when (mutate-statement default-graph-id subject predicate object)
80
                                              ;; always default graph
81
                                              (when (/= subject field-subject)
82
                                                (setf field-subject subject)
83
                                                (rlmdb.i::record-modified-resource lmdb:transaction subject)))
84
                                            #+(or)
85
                                            (format t "~&~a~%" (write-to-string (list subject predicate object graph))))))
86
             (4
87
              (spocq.i::do-solution-field (subject predicate object graph) solution-field
88
                                          (when (and (/= subject 0)
89
                                                     (/= predicate 0)
90
                                                     (/= object 0))
91
                                            (when (= graph 0)
92
                                              (setf graph default-graph-id))
93
                                            (when (mutate-statement graph subject predicate object)
94
                                              (when (and (/= graph field-graph)
95
                                                         (/= graph rdfcache:*default-context-number*))
96
                                                (setf field-graph graph)
97
                                                (setf (rlmdb::transaction-graph-id-modified lmdb:transaction graph) t))
98
                                              (when (/= subject field-subject)
99
                                                (setf field-subject subject)
100
                                                (rlmdb.i::record-modified-resource lmdb:transaction subject)))
101
                                            #+(or)
102
                                            (format t "~&~a~%" (write-to-string (list subject predicate object graph))))))))
103
         (array-dimension solution-field 0))))
104
 
105
 
106
 (defgeneric rlmdb::repository-insert-statement (repository transaction graph subject predicate object)
107
   (:documentation "Given an index arrangement, transform the statement terms
108
    into a key  respective the database type and use it to insert the given
109
    record into all databases of that type.
110
    Each arangement constructs its specific key and record.
111
    As there are at least three record forms - null, revision ordinal index,
112
    and replication id index, this simplified the logic.")
113
 
114
   (:method ((repository t) (transaction t) graph subject predicate object)
115
     "If the base method is reached, then no index accepted the statement"
116
     (error "rlmdb::repository-insert-statement: no applicable index: ~s: (~s ~s ~s ~s)"
117
            repository graph subject predicate object)))
118
 
119
 
120
 (defgeneric rlmdb::repository-delete-statement (repository transaction graph subject predicate object)
121
   (:documentation "Given an index arrangement, transform the statement terms
122
    into a key  respective the database type and use it to delete the given
123
    record from all databases of that type.
124
    Each arangement constructs its specific key and record.
125
    Some remove the key while others augment the entry.")
126
   (:method-combination any)
127
 
128
   (:method any ((repository t) (transaction t) graph subject predicate object)
129
     ; do nothing
130
     nil)
131
   )
132
 
133
 (defgeneric rlmdb::repository-delete-statements (repository graph subject predicate object)
134
   (:documentation "Given an index arrangement, transform the statement terms
135
    into a key respective the database type and use it as a pattern to select an index and match
136
    statemets from it. Iterate over them and use each to delete the respective entry form all
137
    indices.
138
    records from all databases of that type.
139
    Each arangement constructs its specific key and record.
140
    Some remove the key while others augment the entry.")
141
 
142
   (:method ((repository rlmdb:repository) graph subject predicate object)
143
     "A diachronic repository must mark statement deletion, not clear the indices"
144
     (lmdb:with-transaction ((transaction  (lmdb:make-transaction repository :flags 0))
145
                             :initial-disposition :begin :normal-disposition :commit
146
                             :error-disposition :abort)
147
       (flet ((delete-statement (%quad)
148
                (rlmdb::repository-delete-statement repository lmdb:*transaction*
149
                                                    (%quad-context %quad) (%quad-subject %quad)
150
                                                    (%quad-predicate %quad) (%quad-object %quad))))
151
         (declare (dynamic-extent #'delete-statement))
152
         (rlmdb:map-repository-statements #'delete-statement repository (vector graph subject predicate object)))))
153
 
154
   (:method ((repository rlmdb:synchronic-repository) graph subject predicate object)
155
     "A synchronic repository can delete its content by clearing the indices."
156
     (let ((wildcard-term (spocq.i::repository-wildcard-term repository)))
157
       (if (and (eql graph wildcard-term) (eql subject wildcard-term)
158
                  (eql predicate wildcard-term) (eql object wildcard-term))
159
           ;; establishes its transaction
160
           (rlmdb:clear-repository repository :type 'rlmdb::index-database)
161
           (call-next-method)))))
162
 
163
       
164
 (:documentation
165
  "Probe an index given a key to determine how to modify it.
166
   This distinguishes the insert/delete operation and how the index represents
167
   the statement state.
168
   A NULL-RECORD-DATABASE records keys, but no record content.
169
   An ORDINAL-RECORD-DATABASE stores linear indices for revision ordinals to
170
   represent insert/delete changes.
171
   nb. the current version records directly successive insert/delete and
172
   delete/insert operations despite that they do not change the visibility.")
173
 
174
 
175
 ;;;!!! this could just instruct to put without probing
176
 (defmethod rlmdb::compute-index-insertion-data ((database rlmdb::null-record-database) (transaction rlmdb:transaction) %key)
177
   (rlmdb.i::with-lmdb-values ((%value 0 (cffi:null-pointer)))
178
     (let ((return-code (liblmdb:get (lmdb::handle transaction) (lmdb::handle database) %key %value)))
179
       (cond ((zerop return-code) ;; it is already present
180
              nil)
181
             ((eql return-code liblmdb:+notfound+) ;; put the initial empty record
182
              (values #() :put))
183
             (t
184
              (lmdb::unknown-error return-code))))))
185
 
186
 (defmethod rlmdb::compute-index-insertion-data ((database rlmdb::ordinal-record-database) (transaction rlmdb:transaction) %key)
187
   (rlmdb.i::with-lmdb-values ((%value 0 (cffi:null-pointer)))
188
     (let ((return-code (liblmdb:get (lmdb::handle transaction) (lmdb::handle database) %key %value)))
189
       (cond ((zerop return-code)
190
              (let* ((element-size (load-time-value (cffi:foreign-type-size 'revision-ordinal)))
191
                     (count (floor (rlmdb.i::%mdb-val-size %value) element-size)))
192
                (cond ((evenp count) ;; it is present, but invisible
193
                       ;; (print (cons :ord-insert count))
194
                       (let* ((revision-ordinal (spocq.i::transaction-next-ordinal *transaction*))
195
                              (old-sequence (decode-ordinal-record (rlmdb.i::%mdb-val-data %value) count))
196
                              (new-sequence (concatenate 'vector old-sequence (list revision-ordinal))))
197
                         (values new-sequence :put)))
198
                      (t ;; it is already present and visible
199
                       ;; (print (cons :ord-insert-noop count))
200
                       nil))))
201
             ((eql return-code liblmdb:+notfound+) ;; put an initial record
202
              (let* ((revision-ordinal (spocq.i::transaction-next-ordinal *transaction*)))
203
                (values (vector revision-ordinal) :put)))
204
             (t
205
              (lmdb::unknown-error return-code))))))
206
 
207
 
208
 ;;; deletion
209
 
210
 (defmethod rlmdb::compute-index-deletion-data ((database rlmdb::null-record-database) (transaction rlmdb:transaction) %key)
211
   "returns
212
    - (nil t) if the key is present 
213
    - nil if the key is not present"
214
   (rlmdb.i::with-lmdb-values ((%value 0 (cffi:null-pointer)))
215
     (let ((return-code (liblmdb:get (lmdb::handle transaction) (lmdb::handle database) %key %value)))
216
       (cond ((zerop return-code) ;; it is present
217
              (values nil :del))
218
             ((eql return-code liblmdb:+notfound+) ;; nothing to delete
219
              nil)
220
             (t
221
              (lmdb::unknown-error return-code))))))
222
 
223
 (defmethod rlmdb::compute-index-deletion-data ((database rlmdb::ordinal-record-database) (transaction rlmdb:transaction) %key)
224
   "returns
225
    - (ordinal-index :put) if the key is present and visible
226
    - nil if the key is present, but invisible
227
    - nil if the key is not present"
228
   (rlmdb.i::with-lmdb-values ((%value 0 (cffi:null-pointer)))
229
     (let ((return-code (liblmdb:get (lmdb::handle transaction) (lmdb::handle database) %key %value)))
230
       (cond ((zerop return-code)
231
              (let* ((element-size (load-time-value (cffi:foreign-type-size :uint32)))
232
                     (count (floor (rlmdb.i::%mdb-val-size %value) element-size)))
233
                (cond ((oddp count) ;; it is present and visible
234
                       ;; (print (cons :ord-delete count))
235
                       (let* ((revision-ordinal (spocq.i::transaction-next-ordinal *transaction*))
236
                              (old-sequence (decode-ordinal-record (rlmdb.i::%mdb-val-data %value) count))
237
                              (new-sequence (concatenate 'vector old-sequence (list revision-ordinal))))
238
                         (values new-sequence :put)))
239
                      (t ;; it is already present, but invisible
240
                       ;; (print (cons :ord-delete-noop count))
241
                       nil))))
242
             ((eql return-code liblmdb:+notfound+) ;; nothing to delete
243
              nil)
244
             (t
245
              (lmdb::unknown-error return-code))))))
246
 
247
 
248
 
249
 (defgeneric rlmdb:clear-repository (repository &key type)
250
   (:documentation "Clear the content of all databases of the specified type.
251
     The default constraint, (not metadata-database), leaves the meta and the revision record databases.
252
     Update the metadata to reflect the new version,
253
     Return the maximum deletion count respective the given index composition.")
254
   (:method-combination max)
255
   (:method :around ((repository rlmdb:repository) &key
256
                     ;; unless the database type is specified, it has no effect
257
                     (type '(not metadata-database)))
258
     (let ((transaction (lmdb:make-transaction repository :flags 0)))
259
       (lmdb:with-transaction (transaction :initial-disposition :begin :normal-disposition :commit)
260
        (call-next-method repository :type type))))
261
 
262
   (:method max ((repository rlmdb:repository) &rest args)
263
     "The meta database remains"
264
     (declare (ignore args))
265
     0)
266
 
267
   (:method max ((repository rlmdb::revision-metadata-repository) &key (type 'nil))
268
     (let ((count nil))
269
       (flet ((clear-db (db)
270
                (when (typep db type)
271
                  (unless count (setf count (rlmdb::entry-count db)))
272
                  (lmdb:drop-database db :delete 0))))
273
         (clear-db (repository-revision-ordinal-database repository))
274
         (clear-db (repository-revision-record-database repository)))
275
       (or count 0)))
276
 
277
   (:method max ((repository rlmdb::quad-index-repository) &key (type 'nil))
278
     (let ((count nil))
279
       (flet ((clear-db (db)
280
                (when (typep db type)
281
                  (unless count (setf count (rlmdb::entry-count db)))
282
                  (lmdb:drop-database db :delete 0))))
283
         (map nil #'clear-db (repository-quad-databases repository)))
284
       (or count 0)))
285
 
286
   (:method max ((repository rlmdb::temporal-index-repository) &key (type 'nil))
287
     (let ((count nil))
288
       (flet ((clear-db (db)
289
                (when (typep db type)
290
                  (unless count (setf count (rlmdb::entry-count db)))
291
                  (lmdb:drop-database db :delete 0))))
292
         (map nil #'clear-db (repository-temporal-databases repository)))
293
       (or count 0)))
294
 
295
    (:method max ((repository rlmdb::time-series-index-repository) &key (type 'nil))
296
      (let ((count nil))
297
        (flet ((clear-db (db)
298
                 (when (typep db type)
299
                   (unless count (setf count (rlmdb::entry-count db)))
300
                   (lmdb:drop-database db :delete 0))))
301
          (map nil #'clear-db (repository-time-series-databases repository)))
302
        (or count 0))))
303
 
304
 #+(or)
305
 (progn
306
 ;; emerging direct lmdb method
307
 (defgeneric process-intern-fields (source destination &key skolemize)
308
   (:documentation "Establish a transaction context within which to read successive
309
    term object fields from one channel, intern them and write them to a destination.")
310
 
311
   (:method ((source sb-concurrency:mailbox) (destination sb-concurrency:mailbox) &key (skolemize (skolemize-insertions-p)))
312
     (with-open-repository ("system/null")
313
       (loop for term-value-field = (sb-concurrency:receive-message source)
314
         until (null term-value-field)
315
         do (sb-concurrency:send-message destination (term-number-field term-value-field :skolemize skolemize))))))
316
 
317
 (defun intern-field-task (solution-data &key (skolemize (skolemize-insertions-p))
318
                                             (field-width (length (first solution-data)))
319
                                             (field-length (length solution-data))
320
                                             (field (make-page field-length field-width)))
321
   (let* ((node-map ()))
322
     (destructuring-bind (field-length field-width) (array-dimensions field)
323
       (labels ((map-node (node)
324
                  (rest (or (assoc node node-map)
325
                            (first (push (cons node (cons-global-blank-node :transaction x-record))
326
                                         node-map)))))
327
                (map-term (term)
328
                  (cond ((member term '(nil :undef))
329
                         nil)
330
                        ((undistinguished-variable-p term)
331
                         (map-node term))
332
                        ((spocq:blank-node-p term)
333
                         (if skolemize (map-node term) term))
334
                        (t
335
                         term))))
336
       (loop for solution in solution-data
337
             for solution-index from 0
338
             do (progn (assert (= (length solution) field-width) ()
339
                               "Inconsistent solution (@~d not x ~d): ~s."
340
                               solution-index field-width solution)
341
                       (loop for term in solution
342
                             for term-index from 0 below field-width
343
                             do (setf (aref terms solution-index term-index) (map-term term)))))
344
       (rlmdb::with-term-database (sdb *global-dictionary* :normal-disposition :commit)
345
         (lmdb:with-transaction ((transaction  (lmdb:make-transaction sdb))
346
                                 :initial-disposition :begin :normal-disposition :commit
347
                                 :error-disposition :abort)
348
           (loop for solution-index from zero below field-length
349
             do (loop for term-index from 0 below field-width
350
                  do (setf (aref field solution-index term-index) (rlmdb:intern-term sdb term))))))))
351
   field))
352
 
353
 (defun rlmdb:intern-term (term-db term)
354
   (typecase term
355
     (string (constrain-string-length term)))
356
   (with-term-record (%ref-term)
357
     (unwind-protect
358
         (progn (set-optional-term %term term)
359
           (with-shard-term (%shard-term)
360
             (unwind-protect
361
                 (cffi:with-foreign-objects ((%term-key '(:struct rdfcache::shard-term-key)))
362
                   (rlmdb::%term-to-shard-term %term %shard-term)
363
                   (rlmdb::%canonicalize-ntriple-term %shard-term)
364
                   (rlmdb::%compute-sha1 %shard-term %term-key)
365
                   (cond ((rlmdb::get-term-id term-db %term-key))
366
                         (t
367
                          (let ((id (rlmdb::append-term term-db %shard-term)))
368
                            (rlmdb::set-term-id term-db %term-key id)
369
                            id))))
370
               (clear-shard-term %shard-term))))
371
       (clear-optional-term %term))))
372
 
373
 (defun rlmdb::%canonicalize-ntriple-term (%shard-term)
374
   %shard-term)
375
 (defun rlmdb::%term-to-shard-term (%term %shard-term)
376
   %term %shard-term)
377
 (defun rlmdb::%compute-sha1 (%shard-term %term-key)
378
   %shard-term %term-key)
379
 (defun rlmdb::get-term-id (term-db %term-key)
380
   term-db %term-key)
381
 (defun rlmdb::set-get-term-id (term-db %term-key id)
382
   term-db %term-key id)
383
 (defun  clear-shard-term (%shard-term)
384
   %shard-term)
385
 )
386
 
387
 ;;; generate a u32:term database
388
 ;;; ? what is the size
389
 ;;; ? how much slower is access
390
       
391
 ;;; /srv/dydra/storage/strings.mdb
392
 ;;; (decode-db-name "736861313a753332") : "sha1:u32"
393
 ;;; (decode-db-name "7533323a63737472") : "u32:cstr"
394
 ;;; (decode-db-name "7533323a73686131") : "u32:sha1" 
395
 ;;; /srv/dydra/storage/terms : vector of term records
396
 ;;; /srv/dydra/storage/terms.mdb : sha1:u32
397
 
398
 
399