source: project/release/4/ugarit/trunk/ugarit-core.scm @ 20243

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

ugarit: Removed explicit dependency on hash, compression, and encryption eggs, instead replacing them with dynamic autoloading.

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