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

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

ugarit: tag locking, and strict enforcement of maximum file size in splitlog archives

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