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

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

ugarit: Tracking archive space usage stats. Also migrated to using the miscmacros inc! macro to increment all those pesky counters nicely.

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