source: project/release/3/ugarit/trunk/ugarit-core.scm @ 13116

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

0.3 release - new backend, and fixed the .meta file typo

File size: 39.9 KB
Line 
1(use srfi-2)
2(use srfi-4)
3(use srfi-18)
4(use miscmacros)
5(use posix)
6(use tiger-hash)
7(use z3)
8(use lzma)
9(include "posixextras.scm")
10(include "backend-fs.scm")
11(include "backend-cache.scm")
12(include "backend-devtools.scm")
13
14(declare (export 
15   open-archive
16   archive?
17   archive-writable?
18   archive-unlinkable?
19   archive-get
20   archive-put!
21   archive-remove-tag!
22   archive-set-tag!
23   archive-tag
24   archive-lock-tag!
25   archive-unlock-tag!
26   archive-tag-locked?
27   archive-close!
28
29   archive-store-block!
30   
31   make-key-stream-writer*
32   key-stream-writer?
33   key-stream-writer-write!
34   key-stream-writer-finish!
35   unlink-key-stream!
36   fold-key-stream
37   
38   make-sexpr-stream-writer*
39   sexpr-stream-writer?
40   sexpr-stream-writer-write!
41   sexpr-stream-writer-finish!
42   unlink-sexpr-stream!
43   fold-sexpr-stream
44   
45   store-sexpr!
46   read-sexpr
47   
48   epochtime->string
49   
50   store-file!
51   store-directory!
52   unlink-directory!
53   extract-directory!
54   extract-object!
55   snapshot-directory-tree!
56   tag-snapshot!
57   fold-history
58   fold-archive-node))
59
60;;
61;; STORAGE ENGINES
62;;
63
64(define-record storage
65   max-block-size  ; Integer: largest size of block we can store
66   writable? ; Boolean: Can we call put!, link!, unlink!, set-tag!, lock-tag!, unlock-tag!?
67   unlinkable? ; Boolean: Can we call unlink?
68   put! ; Procedure: (put key data type) - stores the data (u8vector) under the key (string) with the given type tag (symbol) and a refcount of 1. Does nothing of the key is already in use.
69   exists? ; Procedure: (exists? key) - returns the type of the block with the given key if it exists, or #f otherwise
70   get ; Procedure: (get key) - returns the contents (u8vector) of the block with the given key (string) if it exists, or #f otherwise
71   link! ; Procedure: (link key) - increments the refcount of the block
72   unlink! ; Procedure: (unlink key) - decrements the refcount of the block. If it's now zero, deletes it but returns its value as a u8vector. If not, returns #f.
73   set-tag! ; Procedure: (set-tag! name key) - assigns the given key (string) to the given tag (named with a string). Creates a new tag if the name has not previously been used, otherwise updates an existing tag
74   tag ; Procedure: (tag name) - returns the key assigned to the given tag, or #f if it does not exist.
75   all-tags ; Procedure: (all-tags) - returns a list of all existing tag names
76   remove-tag! ; Procedure: (remove-tag! name) - removes the named tag
77   lock-tag! ; Procedure: (lock-tag! name) - locks the named tag, or blocks if already locked
78   tag-locked? ; Procedure: (tag-locked? name) - returns the locker identity string if the tag is locked, #f otherwise
79   unlock-tag! ; Procedure: (unlock-tag! name) - unlocks the named tag
80   close!)  ; Procedure: (close!) - closes the storage engine
81
82;;
83;; THE ARCHIVE
84;;
85
86(define-record archive
87   storage ; The storage instance we use
88   check-correctness? ; boolean flag
89   store-atime? ; boolean flag
90   store-ctime? ; boolean flag
91   hash ; the hash function, u8vector+type symbol->hex string
92   compress ; the compressor, u8vector->smaller u8vector
93   decompress ; the decompressor, inverse of the above
94   encrypt ; the encryptor, u8vector -> u8vector
95   decrypt) ; the decryptor, inverse of the above
96
97(define (prepend-type-byte b v)
98   (let* ((v-len (u8vector-length v))
99          (v2 (make-u8vector (+ 1 v-len))))
100   (set! (u8vector-ref v2 0) b)
101   
102   (move-memory! v v2 v-len 0 1)
103   v2))
104
105(define (choose-compression-function config) 
106   (match config
107      (#f (lambda (block) (prepend-type-byte 0 block))) ; No compression
108      (('deflate) (lambda (block) (prepend-type-byte 1 (blob->u8vector/shared (string->blob (z3:encode-buffer (blob->string (u8vector->blob/shared block)))))))) ; deflate compression
109      (('lzma) (lambda (block) (prepend-type-byte 2 (blob->u8vector/shared (lzma:compress (u8vector->blob/shared block))))))
110      (else (signal (make-property-condition 'exn 'message "Unknown compression type" 'arguments config)))))
111
112(define (decompress block) 
113   (case (u8vector-ref block 0)
114      ((0) (subu8vector block 1 (u8vector-length block))) ; No compression
115      ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate
116      ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma
117     
118(define (choose-crypto-functions config)
119   (case config
120      ((#f) (values
121         (lambda (block) block)
122         (lambda (block) block))) ; No encryption
123      (else (signal (make-property-condition 'exn 'message "Unknown encryption type" 'arguments config)))))
124
125; A config is an sexpr of the form:
126; ((<key> <value>)|<flag>...)
127; Valid keys:
128; storage (expression to create a storage backend)
129; compression algorithm name
130; encryption (algorithm-name "key")
131; Valid flags:
132; double-check - check correctness lots, even if it costs efficiency
133(define (open-archive config store-atime? store-ctime?)
134   (let ((*storage* #f)
135         (*compression* #f)
136         (*crypto* #f)
137         (*double-check?* #f))
138   
139      (for-each (lambda (confentry)
140         (match confentry
141            ('double-check (set! *double-check?* #t))
142            (('storage 'fs path) (set! *storage*
143               (backend-fs path)))
144            (('storage 'log logpath indexpath tagspath) (set! *storage*
145               (backend-log logpath indexpath tagspath)))
146            (('storage 'splitlog logdir metadir maxlen) (set! *storage*
147               (backend-splitlog logdir metadir maxlen)))
148            (('storage 'debug 'fs path) (set! *storage*
149               (backend-debug (backend-fs path) "DEBUG")))
150            (('compression . conf) (set! *compression* conf))
151            (('encryption . conf) (set! *compression* conf))
152            (_ (signal (make-property-condition 'exn 'message "Unknown configuration entry" 'arguments confentry)))))
153         config)
154   
155      (if (not *storage*)
156         (signal (make-property-condition 'exn 'message "No archive storage was specified in the configuration!")))
157   
158      (let-values 
159         (((compress) (choose-compression-function *compression*))
160          ((encrypt decrypt) (choose-crypto-functions *crypto*)))
161
162         (make-archive
163            *storage*
164            *double-check?*
165            store-atime?
166            store-ctime?
167            ; FIXME: Don't just use hash+type as the key, hash the type in so keys are all the same length
168            (lambda (block type) (string-append (tiger192:digest block) (symbol->string type)))
169            compress
170            decompress
171            encrypt
172            decrypt))))
173
174; Take a block, and return a compressed and encrypted block
175(define (wrap-block archive block)
176   ((archive-encrypt archive)
177      ((archive-compress archive) block)))
178
179;; Take a compressed and encrypted block, and recover the original data
180(define (unwrap-block archive block)
181   ((archive-decompress archive)
182      ((archive-decrypt archive) block)))
183
184(define (archive-max-block-size archive)
185   (storage-max-block-size (archive-storage archive)))
186
187(define (archive-writable? archive)
188   (storage-writable? (archive-storage archive)))
189
190(define (archive-unlinkable? archive)
191   (storage-unlinkable? (archive-storage archive)))
192
193(define (check-archive-writable archive)
194   (if (not (archive-writable? archive))
195      (signal (make-property-condition 'exn 'message "This isn't a writable archive"))))
196
197(define (check-archive-unlinkable archive)
198   (if (not (archive-writable? archive))
199      (signal (make-property-condition 'exn 'message "This isn't an unlinkable archive - it's append-only"))))
200
201(define (archive-put! archive key data type)
202   (if (not (archive-writable? archive))
203      (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
204   ((storage-put! (archive-storage archive)) key (wrap-block archive data) type))
205
206(define (archive-exists? archive key)
207   ((storage-exists? (archive-storage archive)) key))
208
209(define (archive-get archive key)
210   (let ((data (unwrap-block archive ((storage-get (archive-storage archive)) key))))
211      (if (archive-check-correctness? archive)
212         (if (string=? key ((archive-hash archive) data (archive-exists? archive key)))
213            data
214            (begin
215               (printf "CONSISTENCY CHECK FAILURE: Block ~A comes back as ~A which has hash ~A\n" key data ((archive-hash archive) data))
216               (assert #f))))
217      data))
218
219(define (archive-link! archive key)
220   (if (not (archive-writable? archive))
221      (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
222   ((storage-link! (archive-storage archive)) key))
223
224(define (archive-unlink! archive key)
225   (if (not (archive-writable? archive))
226      (signal (make-property-condition 'exn 'message "This isn't an unlinkable archive - it's append-only")))
227   (let ((result ((storage-unlink! (archive-storage archive)) key)))
228      (if result
229         (unwrap-block archive result)
230         #f)))
231
232(define (archive-set-tag! archive tag key)
233   (if (not (archive-writable? archive))
234      (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
235   ((storage-set-tag! (archive-storage archive)) tag key))
236
237(define (archive-tag archive tag)
238   ((storage-tag (archive-storage archive)) tag))
239
240(define (archive-all-tags archive)
241   ((storage-all-tags (archive-storage archive))))
242
243(define (archive-remove-tag! archive tag)
244   (if (not (archive-writable? archive))
245      (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
246   ((storage-remove-tag! (archive-storage archive)) tag))
247
248(define (archive-lock-tag! archive tag)
249   (if (not (archive-writable? archive))
250      (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
251   ((storage-lock-tag! (archive-storage archive)) tag))
252
253(define (archive-tag-locked? archive tag)
254   (if (not (archive-writable? archive))
255      #f)
256   ((storage-tag-locked? (archive-storage archive)) tag))
257
258(define (archive-unlock-tag! archive tag)
259   (if (not (archive-writable? archive))
260      (signal (make-property-condition 'exn 'message "This isn't a writable archive")))
261   ((storage-unlock-tag! (archive-storage archive)) tag))
262
263(define (archive-close! archive)
264   ((storage-close! (archive-storage archive))))
265
266;;
267;; CORE ALGORITHMS
268;;
269
270;; Philosophy: insertion routines
271;; Insertion routines insert an object into the archive, correctly managing reference counts.
272;; In order to do this, they all return two values: the key the object went in under,
273;; and a boolean flag that is true if the object was already in the archive.
274;; This is so that a parent object that calls that function can construct its data
275;; block from the supplied child keys, then do an exists? check to see if it
276;; already exists in the archive itself, if all of its children were already in the archive.
277;; If it was, then it in turn can just return the key and #t
278;; But if not, then it can link! every child that WAS already in the
279;; archive, and then put! its own value into the archive and return that with #f
280;; Thus, the reference counts are maintained correctly.
281
282(define (reusing hash)
283;   (printf "REUSING: ~A\n" hash)
284   hash)
285
286(define (virgin hash)
287;   (printf "CREATED: ~A\n" hash)
288   hash)
289
290;; BLOCKS OF RAW DATA THAT CANNOT CONTAIN CHILD KEYS
291;; We never have any child keys to link!, so the not-reused case is simple.
292(define (archive-store-block! archive data type)
293   (check-archive-writable archive)
294   
295   (let ((hash ((archive-hash archive) data type)))
296   
297      (if (archive-exists? archive hash)
298         (values (reusing hash) #t)
299         (begin
300            (archive-put! archive hash data type)
301            (values (virgin hash) #f)))))
302
303;; GENERIC STREAMS OF KEYS
304;; Both file and directory storage involve storing an arbitrary list of keys, in order
305;; to string together a load of data blocks into one.
306;; If they all fit into one block, then so be it. Otherwise, we have to split them
307;; into blocks then create a higher-level stream of keys to store the keys of those blocks...
308
309(define-record key-stream-writer
310   write! ;; Write a single string key to the stream. Accepts the key, and the already-existed boolean for proper reference counting.
311   finish!) ;; Terminate the stream. Returns two values: key of the stream, and an already-existed boolean.
312
313;
314(define (copy-string-into-place! u8v offset string string-offs string-len)
315   (move-memory! string u8v (- string-len string-offs) string-offs offset)
316   (void))
317   
318(define (serialise-strings! u8v offset strings)
319   (if (null? strings)
320      (void)
321      (begin
322         (let* ((string (blob->u8vector/shared (string->blob (string-append (car strings) "\n"))))
323                (string-len (u8vector-length string)))
324         (copy-string-into-place! u8v (- offset string-len) string 0 string-len)
325         (serialise-strings! u8v (- offset string-len) (cdr strings))))))
326
327(define (make-key-stream-writer* archive type)
328   (check-archive-writable archive)
329
330   (let* ((*key-buffer* '())
331         (*key-buffer-bytes* 0)
332         (*key-buffer-reused?* #t)
333         (*parent-stream* #f)
334         
335         (next-write-will-overflow? (lambda (key)
336            (assert (< (string-length key) (archive-max-block-size archive)))
337            (> (+ *key-buffer-bytes* (string-length key) 1) (archive-max-block-size archive))))
338           
339         (flush! (lambda ()
340            (let ((keys-serialised (make-u8vector *key-buffer-bytes*)))
341               (serialise-strings! keys-serialised *key-buffer-bytes* (map car *key-buffer*))
342     
343               (let ((hash ((archive-hash archive) keys-serialised type)))
344     
345                  (if (and *key-buffer-reused?* (archive-exists? archive hash))
346                     (begin
347                        (set! *key-buffer* '())
348                        (set! *key-buffer-bytes* 0)
349                        (set! *key-buffer-reused?* #t)
350                        (values (reusing hash) #t)) ; We, too, are reused
351                     (begin ; We are unique and new and precious!
352                        (for-each (lambda (x) ; link! all reused children
353                           (let ((key (car x))
354                                 (reused? (cdr x)))
355                              (if reused?
356                                 (archive-link! archive key))))
357                              *key-buffer*)
358           
359                        (archive-put! archive hash keys-serialised type)
360
361                        (set! *key-buffer* '())
362                        (set! *key-buffer-bytes* 0)
363                        (set! *key-buffer-reused?* #t)
364
365                        (values (virgin hash) #f)))))))
366                       
367         (write! (lambda (key reused?)
368            (if (next-write-will-overflow? key)
369               (let-values (((flush-key flush-reused?) (flush!)))
370                  (if (not *parent-stream*)
371                     (set! *parent-stream* (make-key-stream-writer* archive type)))
372                  ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
373
374                  ;; What happens if the same key comes up twice, eh?
375            (set! *key-buffer* (cons (cons key reused?) *key-buffer*))
376            (set! *key-buffer-reused?* (and *key-buffer-reused?* reused?))
377            (set! *key-buffer-bytes* (+ *key-buffer-bytes* (string-length key) 1))))
378         
379         (finish! (lambda ()
380            (cond
381               (*parent-stream*
382                  (begin
383                     (if (not (null? *key-buffer*))
384                        (let-values (((flush-key flush-reused?) (flush!)))
385                           ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
386                     ((key-stream-writer-finish! *parent-stream*))))
387               ((null? *key-buffer*) ; Empty stream
388                  (archive-store-block! archive (make-u8vector 0) type))
389               ((null? (cdr *key-buffer*)) ; Single-element stream
390                  (values (caar *key-buffer*) (cdar *key-buffer*))) ; Just return the one element!
391               (else ; More than one key, but not enough to have flushed before
392                  (flush!))))))
393   
394      (make-key-stream-writer
395         write!
396         finish!)))
397
398(define (deserialise-key-stream block) ; Convert a key stream block to a list of key strings
399   (string-split (blob->string (u8vector->blob/shared block)) "\n"))
400
401;; kons is called on (key type accumulator) for every key in the stream, in order
402(define (fold-key-stream archive key ks-type kons knil)
403   (let ((type (archive-exists? archive key)))
404      (if (eq? ks-type type)
405         ; Recurse
406         (begin
407            (let ((subkeys (deserialise-key-stream (archive-get archive key))))
408               (fold 
409                  (lambda (subkey acc) (fold-key-stream archive subkey ks-type kons acc))
410                  knil
411                  subkeys)))
412         ; Leaf node
413         (kons key type knil))))
414
415; (child-unlink! archive key type) is called on every child key of a deleted block
416(define (unlink-key-stream! archive key type child-unlink!)
417   (check-archive-unlinkable archive)
418
419   (let ((result (archive-unlink! archive key)))
420      (if result ; result is now list of keys, \n separated, to recursively unlink
421         (for-each (lambda (subkey)
422            (let ((child-type (archive-exists? archive subkey)))
423               (if child-type ; The child may not actually exist any more, in which case, job done!
424                  (if (eq? child-type type)
425                     (unlink-key-stream! archive subkey type child-unlink!)
426                     (child-unlink! archive subkey child-type)))))
427                  (deserialise-key-stream result)))))
428
429;; FILE STORAGE
430;; Files are stored as either:
431;; 1) A direct block of type "f" containing the file data
432;; 2) An indirect block of type "fi" that's a keystream of keys of direct or indirect blocks
433
434;; Uses standard input port for the file data
435;; Returns key and reused?
436(define (store-file! archive)
437   (check-archive-writable archive)
438   ;; FIXME: memory-map the file in 1MB chunks, and copy them into u8vectors?
439   (letrec ((blocksize (archive-max-block-size archive))
440            (*buffer* (make-u8vector blocksize))
441            (ksw (make-key-stream-writer* archive 'fi))
442            (upload-file (lambda ()
443               (let ((bytes-read (read-u8vector! blocksize *buffer*)))
444                  (if (not (zero? bytes-read))
445                     (let-values (((data-key data-reused?)
446                        (archive-store-block! archive (subu8vector *buffer* 0 bytes-read) 'f)))
447                           ((key-stream-writer-write! ksw) data-key data-reused?)
448                           (upload-file))
449                     ((key-stream-writer-finish! ksw)))))))
450         (upload-file)))
451
452;; Call kons on each u8vector block of the file in turn
453;; with an accumulator that starts as knil as a second argument
454(define (fold-file archive key kons knil)
455   (fold-key-stream archive key 'fi
456      (lambda (key type acc)
457         (kons (archive-get archive key) acc))
458      knil))
459     
460;; Write the contents of the file to the standard output port
461(define (write-file-contents archive key)
462   (fold-file archive key
463      (lambda (block acc)
464         (begin
465            (write-u8vector block)
466            #f))
467      #f))
468
469(define (unlink-file! archive key)
470   (check-archive-unlinkable archive)
471   
472   (unlink-key-stream! archive key 'fi (lambda (archive key type)
473   (archive-unlink! archive key))))
474
475;; GENERIC STREAMS OF S-EXPRESSIONS
476;; These are to be used to implement directories
477;; But might be useful for other complex structures in future
478
479(define-record sexpr-stream-writer
480   write! ;; Write an sexpr to the stream. Second argument is a list of pairs, one per key mentioned in the sexpr, car is the key and cdr is the reused? flag.
481   finish!) ;; Return the key and reused? flag for the whole thing
482
483;; FIXME: Examine this and make-key-stream-writer*
484;; and try and merge them to use a common string-stream-writer abstraction
485;; if it's worth it. They share a lot, yet also differ a lot.
486(define (make-sexpr-stream-writer* archive type ks-type)
487   (check-archive-writable archive)
488   (let* ((*sexpr-buffer* '()) ; List of strings
489          (*sexpr-buffer-bytes* 0) ; Bytes used so far
490          (*key-buffer* '()) ; List of key-reused? pairs
491          (*key-buffer-reused?* #t) ; All reused in the buffer so far?
492          (*parent-stream* #f) ; Key stream
493   
494          (flush! (lambda ()
495            (let ((serialised-buffer (make-u8vector *sexpr-buffer-bytes*)))
496               (begin
497                  (serialise-strings! serialised-buffer *sexpr-buffer-bytes* *sexpr-buffer*)
498                  (let ((hash ((archive-hash archive) serialised-buffer type)))
499                     (begin
500     
501                        (if (archive-check-correctness? archive)
502                           (if *key-buffer-reused?*
503                              (assert (every cdr *key-buffer*) "Key buffer thinks it's all reused, but it isn't:" *key-buffer*)
504                              ; else
505                              (assert (not (every cdr *key-buffer*)) "Key buffer thinks it's not all reused, but it is:" *key-buffer*)))
506     
507                        (if (and *key-buffer-reused?* (archive-exists? archive hash))
508                           (begin
509                              (set! *sexpr-buffer* '())
510                              (set! *sexpr-buffer-bytes* 0)
511                              (set! *key-buffer* '())
512                              (set! *key-buffer-reused?* #t)
513                              (values (reusing hash) #t)) ; We, too, are reused
514                           (begin ; We are unique and new and precious!
515                              (for-each (lambda (x) ; link! all reused children
516                                 (let ((key (car x))
517                                       (reused? (cdr x)))
518                                    (if reused?
519                                       (archive-link! archive key))))
520                                 *key-buffer*)
521           
522                              (archive-put! archive hash serialised-buffer type)
523
524                              (set! *sexpr-buffer* '())
525                              (set! *sexpr-buffer-bytes* 0)
526                              (set! *key-buffer* '())
527                              (set! *key-buffer-reused?* #t)
528
529                              (values (virgin hash) #f)))))))))
530                 
531          (write! (lambda (sexpr keys)
532            (let* ((sexpr-string
533                     (with-output-to-string (lambda ()
534                        (write sexpr))))
535                   (sexpr-len (string-length sexpr-string)))
536     
537               (assert (< sexpr-len (archive-max-block-size archive)))
538     
539               (if (> (+ *sexpr-buffer-bytes* sexpr-len 1) (archive-max-block-size archive))
540                  (let-values (((flush-key flush-reused?) (flush!)))
541                     (if (not *parent-stream*)
542                        (set! *parent-stream* (make-key-stream-writer* archive ks-type)))
543                     ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
544     
545               (set! *sexpr-buffer* (cons sexpr-string *sexpr-buffer*))
546               (set! *key-buffer* (append keys *key-buffer*))
547               (set! *key-buffer-reused?* (and *key-buffer-reused?* (every cdr keys)))
548               (set! *sexpr-buffer-bytes* (+ *sexpr-buffer-bytes* sexpr-len 1)))))
549   
550          (finish! (lambda ()
551            (cond
552               (*parent-stream*
553                  (begin
554                     (if (not (null? *sexpr-buffer*))
555                        (let-values (((flush-key flush-reused?) (flush!)))
556                           ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?)))
557                     ((key-stream-writer-finish! *parent-stream*))))
558               ((null? *sexpr-buffer*) ; Empty stream
559                  (archive-store-block! archive (make-u8vector 0) type))
560               (else ; Some sexprs, but not enough to have flushed before
561                  (flush!))))))
562
563      (make-sexpr-stream-writer write! finish!)))
564
565(define (deserialise-sexpr-stream block) ; Convert a sexpr stream block to a list of sexprs
566   (map
567      (lambda (string)
568         (with-input-from-string string read))
569      (string-split (blob->string (u8vector->blob/shared block)) "\n")))
570
571(define (fold-sexpr-stream archive key leaf-type ks-type kons knil)
572   (fold-key-stream archive key ks-type
573      (lambda (key found-leaf-type acc)
574         (assert (eq? found-leaf-type leaf-type))
575         (let ((sexprs (deserialise-sexpr-stream (archive-get archive key))))
576            (fold 
577               kons
578               acc
579               sexprs)))
580      knil))
581
582(define (unlink-sexpr-stream-block! key sexpr-unlink!)
583   (let ((result (archive-unlink! archive key)))
584      (if result
585         (for-each sexpr-unlink! (deserialise-sexpr-stream result)))))
586
587(define (unlink-sexpr-stream! archive key leaf-type ks-type sexpr-unlink!)
588   (check-archive-unlinkable archive)
589   (let ((type (archive-exists? archive key)))
590      (cond
591         ((eq? type ks-type)
592            (unlink-key-stream! archive key ks-type
593               (lambda (archive leaf-key found-leaf-type)
594                  (assert (eq? found-leaf-type leaf-type))
595                  (unlink-sexpr-stream-block! leaf-key sexpr-unlink!))))
596         ((eq? type leaf-type)
597            (unlink-sexpr-stream-block! key sexpr-unlink!))
598         (else
599            (assert (or (eq? type leaf-type) (eq? type ks-type)))))))
600
601;; DIRECTORY STORAGE
602;; Directories are stored as either;
603;; 1) A direct block of type "d" containing a list of file/directory entries, each of which is an s-expr
604;;    The car of the s-expr is the file name
605;;    The cadr is a type symbol - file, dir, symlink, chardev, blockdev, fifo, socket
606;;    The cddr is an alist of other properties
607;;    Regular files have a 'content entry containing a key, for example.
608;;    Also look out for 'mode 'uid 'gid 'atime 'mtime 'ctime
609;;    Symlinks have 'target
610;;    Directories have 'content, too
611;;    Files with streams or forks or whatnot can have more than one content key, of course...
612;; 2) An indirect block of type "di" that's a keystream of keys to direct or indirect blocks
613
614;; Store a directory
615;; Returns the usual key and reused? values
616(define (store-directory! archive path)
617   (check-archive-writable archive)
618
619   (let ((ssw (make-sexpr-stream-writer* archive 'd 'di)))
620   
621      (for-each (lambda (filename)
622         (let* ((file-path (make-pathname path filename))
623                (stats (file-stat file-path #t))
624                (mode (bitwise-and (vector-ref stats 1) (bitwise-not stat/ifmt)))
625                (uid (vector-ref stats 3))
626                (gid (vector-ref stats 4))
627                (atime (vector-ref stats 6))
628                (ctime (vector-ref stats 7))
629                (mtime (vector-ref stats 8))
630                (type (bitwise-and (vector-ref stats 1) stat/ifmt))
631                (standard-file-attributes
632                  (list (cons 'mode mode) (cons 'uid uid) (cons 'gid gid) (cons 'mtime mtime))))
633            (if (archive-store-ctime? archive)
634               (set! standard-file-attributes (cons (cons 'ctime ctime) standard-file-attributes)))
635            (if (archive-store-atime? archive)
636               (set! standard-file-attributes (cons (cons 'atime atime) standard-file-attributes)))
637            (cond
638               ((eq? type stat/ifsock)
639                  (printf "~A is a socket, ignoring...\n" file-path))
640               ((eq? type stat/ifreg)
641                  ;; FIXME: We can store a gdbm cache file
642                  ;; mapping file-path (or device+inode?) to an (mtime hash) pair
643                  ;; We can check the filename in the cache, and if the file's mtime has not changed,
644                  ;; consider it already uploaded and reuse the hash, thus avoiding hashing the entire file.
645                  ;; When we upload a file, we store its mtime and hash in the cache.
646                  (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! archive)))))
647                     ((sexpr-stream-writer-write! ssw)
648                        (append (list filename 'file (cons 'contents content-key) (cons 'size (vector-ref stats 5))) standard-file-attributes)
649                        (list (cons content-key content-reused?)))))
650               ((eq? type stat/ifdir)
651                  (let-values (((content-key content-reused?) (store-directory! archive file-path)))
652                     ((sexpr-stream-writer-write! ssw)
653                        (append (list filename 'dir (cons 'contents content-key)) standard-file-attributes)
654                        (list (cons content-key content-reused?)))))
655               ((eq? type stat/iflnk)
656                  ((sexpr-stream-writer-write! ssw)
657                     (append (list filename 'symlink (cons 'target (read-symbolic-link file-path))) standard-file-attributes)
658                     '()))
659               ((eq? type stat/ifblk)
660                  (let ((devnum (vector-ref stats 10)))
661                     ((sexpr-stream-writer-write! ssw)
662                        (append (list filename 'block-device (cons 'number devnum)) standard-file-attributes)
663                        '())))
664               ((eq? type stat/ifchr)
665                  (let ((devnum (vector-ref stats 10)))
666                     ((sexpr-stream-writer-write! ssw)
667                        (append (list filename 'character-device (cons 'number devnum)) standard-file-attributes)
668                        '())))
669               ((eq? type stat/ififo)
670                  ((sexpr-stream-writer-write! ssw)
671                     (append (list filename 'fifo) standard-file-attributes)
672                     '()))
673               (else
674                  ; WTF?
675                  (printf "ERROR: I can't ascertain the type of ~A. Skipping it...\n" file-path)))))
676      (directory path #t))
677   
678      ((sexpr-stream-writer-finish! ssw))))
679
680(define (unlink-directory! archive key)
681   (check-archive-unlinkable archive)
682
683   (unlink-sexpr-stream! archive key 'd 'di
684      (lambda (dirent)
685         (let ((type (cadr dirent))
686               (name (car dirent))
687               (props (cddr dirent)))
688            (cond
689               ((eq? type 'file)
690                  (unlink-file! archive (cdr (assq 'contents props))))
691               ((eq? type 'dir)
692                  (unlink-directory! archive (cdr (assq 'contents props)))))))))
693
694(define (set-standard-file-metadata! path props)
695   (let ((mode (assq 'mode props))
696         (uid (assq 'uid props))
697         (gid (assq 'gid props))
698         (mtime (assq 'mtime props))
699         (atime (assq 'atime props)))
700   
701   ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
702   ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,
703   ;        for unprived restores.
704   
705   (if mode
706      (change-file-mode path (cdr mode)))
707   
708   (if (or uid gid)
709      (change-file-owner path 
710         (if uid (cdr uid) (current-user-id))
711         (if gid (cdr gid) (current-group-id))))
712
713   (if (or mtime atime)
714      (change-file-times path
715         (if atime (cdr atime) (time->seconds (current-time)))
716         (if mtime (cdr mtime) (time->seconds (current-time)))))
717     
718   (void)))
719
720(define (extract-file! archive props path)
721   (let ((contents-key (cdr (assq 'contents props))))
722      (with-output-to-file path
723         (lambda ()
724            (write-file-contents archive contents-key)))
725      (set-standard-file-metadata! path props)))
726
727(define (extract-subdirectory! archive props path)
728   (if (not (directory? path))
729      (create-directory path))
730   
731   (let ((contents-key (cdr (assq 'contents props))))
732
733      (extract-directory! archive contents-key path)
734   
735      (set-standard-file-metadata! path props)))
736
737(define (extract-symlink! archive props path)
738   (let ((target (cdr (assq 'target props)))
739         (mode (assq 'mode props))
740         (uid (assq 'uid props))
741         (gid (assq 'gid props))
742         (mtime (assq 'mtime props))
743        (atime (assq 'atime props)))
744   
745      (create-symbolic-link target path)
746   
747      ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
748      ; FIXME: Sneak in a configuration variable from above to turn attempts to set metadata off,
749      ;        for unprived restores.
750   
751      ; Alas, there is no portable way to set the atime/mtime on a link.
752      ; I think, somehow, we will manage to live our lives without the atime and mtime on links...
753      (if mode
754         (change-link-mode path (cdr mode)))
755   
756      (if (or uid gid)
757         (change-link-owner path 
758            (or (cdr uid) (current-user-id))
759            (or (cdr gid) (current-group-id))))))
760
761(define (extract-fifo! archive props path)
762   
763   (create-fifo path)
764
765   (set-standard-file-metadata! path props))
766
767(define (extract-block-device! archive props path)
768   (let ((number (cdr (assq 'number props))))
769   
770      ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
771      (create-special-file path stat/ifblk number)
772   
773      (set-standard-file-metadata! path props)))
774
775(define (extract-character-device! archive props path)
776   (let ((number (cdr (assq 'number props))))
777   
778      ; FIXME: Wrap in exception handlers to continue anyway in the event of permissions errors.
779      (create-special-file path stat/ifchr number)
780   
781      (set-standard-file-metadata! path props)))
782
783(define (extract-object! archive dirent target-path)
784   (let ((type (cadr dirent))
785         (name (car dirent))
786         (props (cddr dirent)))
787      (cond
788         ((eq? type 'file)
789            (extract-file! archive props (make-pathname target-path name)))
790         ((eq? type 'dir)
791            (extract-subdirectory! archive props (make-pathname target-path name)))
792         ((eq? type 'symlink)
793            (extract-symlink! archive props (make-pathname target-path name)))
794         ((eq? type 'fifo)
795            (extract-fifo! archive props (make-pathname target-path name)))
796         ((eq? type 'block-device)
797            (extract-block-device! archive props (make-pathname target-path name)))
798         ((eq? type 'character-device)
799            (extract-character-device! archive props (make-pathname target-path name)))
800         (else
801            (printf "ERROR: Found an object (~A) of unknown type (~A), skipping...\n" name type)))))
802   
803(define (extract-directory! archive key target-path)
804   (fold-sexpr-stream archive key 'd 'di
805      (lambda (dirent acc)
806         (extract-object! archive dirent target-path)
807         (void))
808      '()))
809
810;; SINGLE SEXPRS
811;; A sexpr in a block. Simple, really.
812;; Given an sexpr, a type and a list of (key . reused?) pairs, returns a key and a reused? flag.
813(define (store-sexpr! archive sexpr type keys)
814   (let* ((data (blob->u8vector/shared (string->blob (with-output-to-string (lambda () (write sexpr))))))
815          (hash ((archive-hash archive) data type)))
816   
817      (if (archive-exists? archive hash)
818         (values (reusing hash) #t)
819         (begin
820            (for-each (lambda (key)
821               (if (cdr key) ; reused?
822                  (archive-link! archive (car key))))
823               keys)
824            (archive-put! archive hash data type)
825            (values (virgin hash) #f)))))
826
827(define (read-sexpr archive key)
828   (let ((data (archive-get archive key)))
829      (with-input-from-string
830         (blob->string (u8vector->blob/shared data))
831         (lambda ()
832            (read)))))
833
834;; SNAPSHOT STORAGE
835;; A snapshot is a single block containing an alist
836;; Keys are 'ctime (in seconds since the epoch),
837;; 'contents (hash of root directory),
838;; 'hostname (name of host snapshotted)
839;; 'prefix (prefix of filesystem on host)
840;; 'notes (user-supplied notes)
841;; 'previous (hash of previous snapshot)
842;; Returns the snapshot's key.
843(define (tag-snapshot! archive tag contents-key contents-reused? snapshot-properties)
844   (check-archive-writable archive)
845   (archive-lock-tag! archive tag)
846   (let ((previous (archive-tag archive tag))
847          (snapshot
848            (append
849               (list
850                  (cons 'mtime (time->seconds (current-time)))
851                  (cons 'contents contents-key))
852               snapshot-properties))
853          (keys
854            (list ; We do not list the previous snapshot - since we are about to overwrite the tag that points to it, which would be a decrement.
855               (cons contents-key contents-reused?))))
856      (if previous
857         (begin
858            (set! snapshot (cons
859               (cons 'previous previous)
860               snapshot))))
861      (let-values (((snapshot-key snapshot-reused?)
862                     (store-sexpr! archive snapshot 'snapshot keys)))
863         (archive-set-tag! archive tag snapshot-key)
864         (archive-unlock-tag! archive tag)
865         snapshot-key)))
866
867(define (fold-history archive snapshot-key kons knil)
868   (let ((snapshot (read-sexpr archive snapshot-key)))
869      (if (assq 'previous snapshot)
870         (kons snapshot-key snapshot 
871            (fold-history archive (cdr (assq 'previous snapshot)) kons knil))
872         (kons snapshot-key snapshot knil))))
873     
874;; BRING IT ALL TOGETHER
875
876(define (snapshot-directory-tree! archive tag path props)
877   (check-archive-writable archive)
878   (let-values (((root-key root-reused?)
879                  (store-directory! archive path)))
880      (tag-snapshot! archive tag root-key root-reused?
881         (append
882            (list
883               (cons 'hostname (get-host-name))
884               (cons 'prefix path))
885            props))))
886
887(define (epochtime->string e)
888   (let ((localtime (seconds->local-time e)))
889      (string-append
890         (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0)
891         "-"
892         (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0)
893         "-"
894         (string-pad (number->string (vector-ref localtime 3)) 2 #\0)
895         " "
896         (string-pad (number->string (vector-ref localtime 2)) 2 #\0)
897         ":"
898         (string-pad (number->string (vector-ref localtime 1)) 2 #\0)
899         ":"
900         (string-pad (number->string (vector-ref localtime 0)) 2 #\0))))
901
902; If given '() as the directory-key, makes a list of all tags
903; If given '(tag . "tag-name"), makes a list of snapshots of that tag
904; If given a key, if that key points to a directory, makes a list of the contents of that directory
905; Either way, the list of results are folded into the provided kons and knil functions
906; kons is called with three arguments: a directory-key for the object, a directory entry in the usual format, and the accumulator.
907(define (fold-archive-node archive directory-key kons knil)
908   (cond
909      ((null? directory-key)
910         ; List tags
911         (fold (lambda (tag acc)
912            (kons (cons 'tag tag) (list tag 'tag (cons 'current (archive-tag archive tag))) acc))
913            knil (archive-all-tags archive)))
914      ((and (pair? directory-key) (eq? (car directory-key) 'tag))
915         ; List a tag's snapshots
916         (let* ((tag (cdr directory-key))
917                (current (archive-tag archive tag))
918                (current-contents (read-sexpr archive current)))
919            (kons
920               (cdr (assq 'contents current-contents))
921               (cons "current" (cons 'snapshot current-contents)) 
922               (fold-history archive current
923                  (lambda (key snapshot acc)
924                     (kons
925                        (cdr (assq 'contents snapshot))
926                        (append
927                           (list (epochtime->string (cdr (assq 'mtime snapshot)))
928                           'snapshot)
929                           snapshot)
930                        acc))
931                  knil))))
932      ((string? directory-key)
933         ; List directory
934         (fold-sexpr-stream archive directory-key 'd 'di
935            (lambda (dirent acc)
936                  (let ((name (car dirent))
937                        (type (cadr dirent))
938                        (props (cddr dirent)))
939                     (cond
940                        ((eq? type 'file)
941                           (kons #f dirent acc))
942                        ((eq? type 'dir)
943                           (kons (cdr (assq 'contents props)) dirent acc))
944                        ((eq? type 'symlink)
945                           (kons #f dirent acc))
946                        (else
947                           (kons #f dirent acc)))))
948            knil))))
949
Note: See TracBrowser for help on using the repository browser.