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

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

C-Keen's patches

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