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

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

ugarit: Fixed all the silly errors, and got mtime caching working!

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