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

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

V0.4

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