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

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

ugarit: Used the parley egg for command-line editing.

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