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

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

ugarit: Better use of sqlite, which will hopefully improve performance. 1.0.1 release.

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