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

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

ugarit: Ongoing test development, and removed the version number

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