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

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

ugarit: Initial support for out-of-process backends (not yet well tested...)

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