source: project/release/4/ugarit/trunk/backend-fs.scm @ 25521

Last change on this file since 25521 was 25521, checked in by Alaric Snell-Pym, 9 years ago

ugarit: Better use of sqlite, which will hopefully improve performance. 1.0.1 release.

File size: 15.6 KB
Line 
1(use ugarit-backend)
2(use sql-de-lite)
3(use srfi-69)
4(use matchable)
5(use regex)
6
7(define (backend-fs base)
8   (define (make-name key extension) ; Break into levels to reduce files-in-one-dir strain
9      (cond
10         ((< (string-length key) 4)
11            (string-append base "/" key extension))
12         ((< (string-length key) 7)
13            (string-append base "/" (string-take key 3) "/" (string-drop key 3) extension))
14         ((< (string-length key) 10)
15            (string-append base "/" (string-take key 3) "/" (string-take (string-drop key 3) 3)
16               "/" (string-drop key 6) extension))
17         (else
18            (string-append base "/" (string-take key 3) "/" (string-take (string-drop key 3) 3)
19               "/" (string-take (string-drop key 6) 3) "/"
20               (string-drop key 9) extension))))
21   (define (ensure-directory! key)
22      (let
23         ((ed (lambda (path)
24            (if (not (directory? path))
25               (create-directory path)))))
26         (if (>= (string-length key) 4)
27            (ed (string-append base "/" (string-take key 3))))
28         (if (>= (string-length key) 7)
29            (ed (string-append base "/" (string-take key 3) "/" (string-take (string-drop key 3) 3))))
30         (if (>= (string-length key) 10)
31            (ed (string-append base "/" (string-take key 3) "/" (string-take (string-drop key 3) 3) "/" (string-take (string-drop key 6) 3))))
32         (void)))
33   (define (delete-dir-if-empty! key)
34      (let
35         ((dd (lambda (path)
36            (if (and (directory? path) (null? (directory path)))
37               (delete-directory path)))))
38
39         (if (>= (string-length key) 10)
40            (dd (string-append base "/" (string-take key 3) "/" (string-take (string-drop key 3) 3) "/" (string-take (string-drop key 6) 3))))
41         (if (>= (string-length key) 7)
42            (dd (string-append base "/" (string-take key 3) "/" (string-take (string-drop key 3) 3))))
43         (if (>= (string-length key) 4)
44            (dd (string-append base "/" (string-take key 3))))
45         (void)))
46
47   (define (make-tag-name tag)
48      (string-append base "/" tag ".tag"))
49
50   (if (not (directory? base))
51      (signal (make-property-condition 'exn 'message "The archive does not exist" 'arguments base)))
52
53   (make-storage
54      (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap
55      #t ; We are writable
56      #t ; We support unlink!
57      (lambda (key data type) ; put!
58         (if (file-read-access? (make-name key ".type"))
59            (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type)))
60            (begin
61               (ensure-directory! key)
62               ; Note: We save to ...~ files then mv them into place, so as to avoid ending up with a partial block
63               ; in the archive if it dies in mid-write. We move the .type file in last, since the existance of that is what
64               ; makes the block "official".
65               ; The only thing we need worry about is a race between two snapshots writing the same block at once...
66               ; However, since we can't easily provide atomicity on link!, we just say "don't do that" for now.
67               (with-output-to-file (make-name key ".data~")
68                  (lambda () (write-u8vector data)))
69               (with-output-to-file (make-name key ".type~")
70                  (lambda () (write type)))
71               (with-output-to-file (make-name key ".refcount~")
72                  (lambda () (write 1)))
73               (rename-file (make-name key ".data~") (make-name key ".data"))
74               (rename-file (make-name key ".refcount~") (make-name key ".refcount"))
75               (rename-file (make-name key ".type~") (make-name key ".type"))
76               (void))))
77      (lambda (key) ; exists?
78         (if (file-read-access? (make-name key ".data"))
79            (with-input-from-file (make-name key ".type")
80               (lambda () (read)))
81            #f))
82      (lambda (key) ; get
83         (if (file-read-access? (make-name key ".data"))
84            (with-input-from-file (make-name key ".data")
85               (lambda () (read-u8vector)))
86            #f))
87      (lambda (key) ; link!
88         (if
89            (file-read-access? (make-name key ".data"))
90            (let
91               ((current-refcount
92                  (with-input-from-file (make-name key ".refcount")
93                     (lambda () (read)))))
94               (begin
95                  (with-output-to-file (make-name key ".refcount~")
96                     (lambda () (write (+ current-refcount 1))))
97                     (rename-file (make-name key ".refcount~") (make-name key ".refcount"))))))
98      (lambda (key) ; unlink!
99         (and-let*
100            (((file-read-access? (make-name key ".data")))
101            (current-refcount
102               (with-input-from-file (make-name key ".refcount")
103                  (lambda () (read))))
104            (new-refcount (- current-refcount 1)))
105            (if (zero? new-refcount)
106               (let
107                  ((data (with-input-from-file (make-name key ".data")
108                     (lambda () (read-u8vector)))))
109                  (begin
110                     (delete-file (make-name key ".data"))
111                     (delete-file (make-name key ".type"))
112                     (delete-file (make-name key ".refcount"))
113                     (delete-dir-if-empty! key)
114                     data)) ; returned in case of deletion
115               (begin
116                  (with-output-to-file (make-name key ".refcount~")
117                     (lambda () (write new-refcount)))
118                  (rename-file (make-name key ".refcount~") (make-name key ".refcount"))
119                  #f))))
120      (lambda (tag key) ; set-tag!
121         (with-output-to-file (make-tag-name tag)
122            (lambda () (write key))))
123      (lambda (tag) ; tag
124         (if (file-read-access? (make-tag-name tag))
125            (with-input-from-file (make-tag-name tag)
126               (lambda () (read)))
127            #f))
128      (lambda () ; all-tags
129         (let
130            ((tag-path-regexp (regexp (make-tag-name "(.*)"))))
131            (map
132               (lambda (path)
133                  (cadr (string-match tag-path-regexp path)))
134               (glob (make-tag-name "*")))))
135      (lambda (tag) ; remove-tag!
136         (if (file-write-access? (make-tag-name tag))
137            (delete-file (make-tag-name tag))
138            #f))
139      (lambda (tag) ; lock-tag!
140         ; (printf "FIXME: Implement lock-tag! in backend-fs.scm\n")
141         #f)
142      (lambda (tag) ; tag-locked?
143         ; (printf "FIXME: Implement tag-locked? in backend-fs.scm\n")
144         #f)
145      (lambda (tag) ; unlock-tag!
146         ; (printf "FIXME: Implement unlock-tag! in backend-fs.scm\n")
147         #f)
148      (lambda () ; close!
149         (void))))
150
151(define splitlog-sql-schema
152  (list
153   "CREATE TABLE metadata (key TEXT PRIMARY KEY, value TEXT);"
154   "INSERT INTO metadata VALUES ('version','1');"
155   "CREATE TABLE blocks (key TEXT PRIMARY KEY, type TEXT, fileno INTEGER, position INTEGER, length INTEGER);"
156   "CREATE TABLE tags (tag TEXT PRIMARY KEY, key TEXT, locked INTEGER DEFAULT 0);"))
157
158(define (backend-splitlog logdir metapath max-logpart-size)
159   (let*
160        ((*db*
161          (let ((db (open-database metapath)))
162            (change-file-mode metapath (bitwise-ior perm/irusr perm/iwusr)) ; Don't think we can do anything about the journal files, though.
163            (when (null? (schema db))
164                  (for-each (lambda (statement)
165                              (exec (sql db statement)))
166                            splitlog-sql-schema))
167            (exec (sql db "BEGIN;"))
168            db))
169
170         ; Prepared statements
171         (get-metadata-query (sql *db* "SELECT value FROM metadata WHERE key = ?"))
172         (set-metadata-query (sql *db* "INSERT OR REPLACE INTO metadata (key,value) VALUES (?,?)"))
173         (get-block-data-query (sql *db* "SELECT type, fileno, position, length FROM blocks WHERE key = ?"))
174         (set-block-data-query (sql *db* "INSERT INTO blocks (key,type,fileno,position,length) VALUES (?,?,?,?,?)"))
175         (get-tag-query (sql *db* "SELECT key FROM tags WHERE tag = ?"))
176         (set-tag-query (sql *db* "INSERT OR REPLACE INTO tags (tag,key) VALUES (?,?)"))
177         (remove-tag-query (sql *db* "DELETE FROM tags WHERE tag = ?"))
178         (set-tag-lock-query (sql *db* "UPDATE tags SET locked = ? WHERE tag = ?"))
179         (get-tag-lock-query (sql *db* "SELECT locked FROM tags WHERE tag = ?"))
180         (get-tags-query (sql *db* "SELECT tag FROM tags"))
181
182         ; Database access functions
183         (get-metadata (lambda (key default)
184                         (let ((result (query fetch get-metadata-query key)))
185                           (if (null? result)
186                               (begin
187                                 (exec set-metadata-query key default)
188                                 default)
189                               (car result)))))
190         (set-metadata (lambda (key value)
191                         (exec set-metadata-query key value)))
192
193         ; Log file management
194         (*logcount* (string->number (get-metadata "current-logfile" "0")))
195         (set-logcount! (lambda (newcount)
196                         (set! *logcount* newcount)))
197         (*log* (file-open (string-append logdir "/log" (number->string *logcount*))
198                  (bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))
199         (*logfiles* (make-hash-table)) ; hash of file number to FD
200         (get-log (lambda (index)
201            (if (hash-table-exists? *logfiles* index)
202               (hash-table-ref *logfiles* index)
203               (begin
204                  (let ((fd (file-open (string-append logdir "/log" (number->string index)) open/rdonly perm/irwxu)))
205                     (set! (hash-table-ref *logfiles* index) fd)
206                     fd)))))
207
208         ; Periodic commit management
209         (commit-interval (string->number (get-metadata "commit-interval" "1000")))
210         (*updates-since-last-commit* 0)
211         (flush! (lambda ()
212                   (set-metadata "current-logfile" (number->string *logcount*))
213                   (exec (sql *db* "COMMIT;"))
214                   (exec (sql *db* "BEGIN;"))
215                   (set! *updates-since-last-commit* 0)))
216         (maybe-flush! (lambda ()
217                         (set! *updates-since-last-commit*
218                               (+ *updates-since-last-commit* 1))
219                         (when (> *updates-since-last-commit* commit-interval)
220                             (flush!))))
221
222         ; Higher-level database utilities
223         (get-block-data (lambda (key) ; Returns #f for nonexistant blocks
224                           (let ((bd (query fetch get-block-data-query key)))
225                             (if (pair? bd)
226                                 (let ((type (string->symbol (first bd)))
227                                       (fileno (second bd))
228                                       (position (third bd))
229                                       (length (fourth bd)))
230                                   (list type fileno position length))
231                                 #f))))
232
233         (set-block-data! (lambda (key type fileno position length)
234                           (exec set-block-data-query key (symbol->string type) fileno position length)
235                           (maybe-flush!)))
236
237         (set-tag! (lambda (tag key)
238                    (exec set-tag-query tag key)
239                    (flush!)))
240
241         (remove-tag! (lambda (tag)
242                        (exec remove-tag-query tag)
243                        (flush!)))
244
245         (get-tag (lambda (tag)
246                         (let ((td (query fetch get-tag-query tag)))
247                           (if (pair? td)
248                               (car td)
249                               #f))))
250
251         (set-tag-lock! (lambda (tag lock)
252                      (exec set-tag-lock-query lock tag)
253                      (flush!)))
254
255         (get-tag-lock (lambda (tag lock)
256                         (let ((td (query fetch get-tag-lock-query tag)))
257                           (if (pair? td)
258                               (car td)
259                               #f))))
260
261         (get-tags (lambda ()
262                     (map car (query fetch-all get-tags-query)))))
263
264      (make-storage
265         (* 1024 1024) ; 1MiB blocks since local disk is fast and cheap, right?
266         #t ; We are writable
267         #f ; We DO NOT support unlink!
268
269         (lambda (key data type) ; put!
270           (when (pair? (get-block-data key))
271                 (signal (make-property-condition 'exn 'message "Duplicate block: put! should not be called on an existing hash" 'arguments (list key type))))
272
273           (set-file-position! *log* 0 seek/end)
274
275           (let ((header (sprintf "(block ~S ~S ~S)" key type (u8vector-length data)))
276                 (posn (file-position *log*)))
277             (if (> posn max-logpart-size)
278                 (begin
279                   (file-close *log*)
280                   (set! posn 0)
281                   (set-logcount! (+ *logcount* 1))
282                   (set! *log* (file-open (string-append logdir "/log" (number->string *logcount*))
283                                          (bitwise-ior open/creat open/rdwr open/append) (bitwise-ior perm/irusr perm/iwusr)))))
284             (file-write *log* header)
285             (file-write *log* (u8vector->blob/shared data))
286             (set-block-data! key type *logcount* (+ (string-length header) posn) (u8vector-length data))
287             (void)))
288
289         (lambda (key) ; exists?
290           (let ((bd (get-block-data key)))
291             (if (pair? bd)
292                 (car bd)
293                 #f)))
294
295         (lambda (key) ; get
296            (let* ((entry (get-block-data key)))
297              (if (pair? entry)
298               (let* ((type (first entry))
299                      (index (second entry))
300                      (position (third entry))
301                      (length (fourth entry))
302                      (buffer (make-blob length))
303                      (logpart (get-log index)))
304                 (set-file-position! logpart position seek/set)
305                 (file-read logpart length buffer)
306                 (blob->u8vector/shared buffer))
307               #f)))
308
309         (lambda (key) ; link!
310            (void))
311
312         (lambda (key) ; unlink!
313            (signal (make-property-condition 'exn 'message "Log archives do not support deletion")))
314
315         (lambda (tag key) ; set-tag!
316            (file-write *log* (sprintf "(tag ~S ~S)" tag key))
317            (set-tag! tag key)
318            (void))
319         (lambda (tag) ; tag
320           (get-tag tag))
321         (lambda () ; all-tags
322           (get-tags))
323         (lambda (tag) ; remove-tag!
324           (remove-tag! tag)
325           (void))
326         (lambda (tag) ; lock-tag!
327           (set-tag-lock! tag 1)
328           (void))
329         (lambda (tag) ; tag-locked?
330           (if (zero? (get-tag-lock tag))
331               #f
332               #t))
333         (lambda (tag) ; unlock-tag!
334           (set-tag-lock! tag 0))
335         (lambda () ; close!
336           (flush!)
337           (exec (sql *db* "COMMIT;"))
338           (close-database *db*)
339           (file-close *log*)
340           (hash-table-for-each *logfiles*
341                                (lambda (key value)
342                                  (file-close value)))))))
343
344(define backend
345  (match (command-line-arguments)
346         (("fs" base)
347          (backend-fs base))
348
349         (("splitlog" logdir metadir max-logpart-size)
350          (backend-splitlog logdir metadir (string->number max-logpart-size)))
351
352         (else
353          (printf "USAGE:\nbackend-fs fs <basedir-path>\nbackend-fs splitlog <logdir-path> <metadata-file-path> <max-file-size>\n")
354          #f)))
355
356(if backend
357    (export-storage! backend))
Note: See TracBrowser for help on using the repository browser.