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

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

ugarit: Unit test suite now covers everything except fold-archive-node over directories (but that's really hard to test, and really simple to implement, so not worth testing, right?)

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