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

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

ugarit: Many minor improvements to crash safety (see README.txt)

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