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

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

ugarit: Ongoing work to fix all the errors caused by merging in a load of untested code

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