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

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

ugarit: Backend unit tests now all pass!

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