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

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

Initial import of chicken3 code

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