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

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

ugarit: README updates, plus reporting on file cache performance.

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