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

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

ugarit: Only commit the file-cache sqlite database periodically, to improve performance on lots of small files.

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