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

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

ugarit: Version 2 of the backend protocol, supporting better reporting back to the user, and administrative interfaces. Backends outfitted with admin interfaces, and a ugarit-archive-admin tool added to drive them.

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