(module ugarit-core (open-vault ;; Note: Mutates job configuration from the conf file vault? vault-hash vault-global-directory-rules vault-writable? vault-unlinkable? vault-exists? vault-get vault-put! vault-flush! vault-remove-tag! vault-set-tag! vault-tag vault-all-tags vault-lock-tag! vault-unlock-tag! vault-tag-locked? vault-link! vault-unlink! vault-admin! vault-close! vault-store-block! make-job current-job job-blocks-stored job-bytes-stored job-blocks-skipped job-bytes-skipped job-file-cache-hits job-file-cache-bytes job-event-log job-log! job-store-atime? job-store-ctime? job-check-correctness? make-key-stream-writer* key-stream-writer? key-stream-writer-write! key-stream-writer-finish! unlink-key-stream! fold-key-stream make-sexpr-stream-writer* sexpr-stream-writer? sexpr-stream-writer-write! sexpr-stream-writer-finish! unlink-sexpr-stream! fold-sexpr-stream store-sexpr! read-sexpr epochtime->string store-file! write-file-contents unlink-file! store-directory! unlink-directory! extract-directory! extract-object! ; FIXME: These two will be useful in future ;verify-directory! ;verify-object! tag-snapshot! fold-history fold-vault-node traverse-vault-node traverse-vault-path) (import scheme) (import chicken) (use srfi-1) (use srfi-4) (use srfi-13) (use srfi-18) (use extras) (use ports) (use files) (use lolevel) (use data-structures) (use directory-rules) (use miscmacros) (use posix) (use posix-extras) (use crypto-tools) (use stty) (use matchable) (use regex) (use ugarit-backend) (use sql-de-lite) (use data-structures) (use tiger-hash) (use message-digest) ;; ;; OPTIONAL FEATURES ;; (define (get-bindings-from-module egg module bindings) (let* ((vektor (gensym)) (rekuire-extension (gensym)) (expression `(module ,(gensym) () (import (rename (only scheme vector require-extension quote) ; quote shouldn't need to be here (vector ,vektor) (require-extension ,rekuire-extension))) (,rekuire-extension ,module) (,vektor ,@bindings)))) (handle-exceptions exn (if ((condition-predicate 'syntax) exn) (signal (make-composite-condition (make-property-condition 'exn 'message` (sprintf "This feature depends upon the optional module ~a being installed. Please install it with 'chicken-install -s ~a'." module egg)) (make-property-condition 'unsupported-feature 'egg egg 'module module 'bindings bindings))) (signal exn)) (eval expression)))) ;; FIXME: Write a macro to generate these for us. (define (autoload-lzma!) (let ((real-bindings (get-bindings-from-module 'lzma 'lzma '(compress decompress)))) (set! lzma:compress (vector-ref real-bindings 0)) (set! lzma:decompress (vector-ref real-bindings 1)))) (define lzma:compress (lambda args (autoload-lzma!) (apply lzma:compress args))) (define lzma:decompress (lambda args (autoload-lzma!) (apply lzma:decompress args))) (define (autoload-z3!) (let ((real-bindings (get-bindings-from-module 'z3 'z3 '(z3:encode-buffer z3:decode-buffer)))) (set! z3:encode-buffer (vector-ref real-bindings 0)) (set! z3:decode-buffer (vector-ref real-bindings 1)))) (define z3:encode-buffer (lambda args (autoload-z3!) (apply z3:encode-buffer args))) (define z3:decode-buffer (lambda args (autoload-z3!) (apply z3:decode-buffer args))) (define (autoload-sha2!) (let ((real-bindings (get-bindings-from-module 'sha2 'sha2 '(sha256-primitive sha384-primitive sha512-primitive)))) (set! sha256-primitive (vector-ref real-bindings 0)) (set! sha384-primitive (vector-ref real-bindings 1)) (set! sha512-primitive (vector-ref real-bindings 2)))) (define sha256-primitive (lambda args (autoload-sha2!) (apply sha256-primitive args))) (define sha384-primitive (lambda args (autoload-sha2!) (apply sha384-primitive args))) (define sha512-primitive (lambda args (autoload-sha2!) (apply sha512-primitive args))) (define (autoload-aes!) (let ((real-bindings (get-bindings-from-module 'aes 'aes '(make-aes128-encryptor make-aes128-decryptor make-aes192-encryptor make-aes192-decryptor make-aes256-encryptor make-aes256-decryptor)))) (set! make-aes128-encryptor (vector-ref real-bindings 0)) (set! make-aes128-decryptor (vector-ref real-bindings 1)) (set! make-aes192-encryptor (vector-ref real-bindings 2)) (set! make-aes192-decryptor (vector-ref real-bindings 3)) (set! make-aes256-encryptor (vector-ref real-bindings 4)) (set! make-aes256-decryptor (vector-ref real-bindings 5)))) (define make-aes128-encryptor (lambda args (autoload-aes!) (apply make-aes128-encryptor args))) (define make-aes128-decryptor (lambda args (autoload-aes!) (apply make-aes128-decryptor args))) (define make-aes192-encryptor (lambda args (autoload-aes!) (apply make-aes192-encryptor args))) (define make-aes192-decryptor (lambda args (autoload-aes!) (apply make-aes192-decryptor args))) (define make-aes256-encryptor (lambda args (autoload-aes!) (apply make-aes256-encryptor args))) (define make-aes256-decryptor (lambda args (autoload-aes!) (apply make-aes256-decryptor args))) ;; ;; LOG EVENTS ;; (define-record event type ; error/warning/note time ; timestamp (current-seconds) path ; where applicable, #f if not message ; string ) (define (make-event* type path message) (let ((now (current-seconds))) (make-event type now path message))) (define-record-printer (event e out) (fprintf out "~A: ~A [~A] ~A" (event-type e) (epochtime->string (event-time e)) (event-path e) (event-message e))) ;; ;; THE VAULT ;; This thing is becoming a bit of a God Object. Figure out how to ;; refactor it a bit, perhaps? ;; (define-record vault storage ; The storage instance we use hash ; the hash function, u8vector+type symbol->hex string compress ; the compressor, u8vector->smaller u8vector decompress ; the decompressor, inverse of the above encrypt ; the encryptor, u8vector -> u8vector decrypt ; the decryptor, inverse of the above ; File cache file-cache ; sqlite db storing filesystem cache (see store-file! procedure); #f if not enabled file-cache-get-query ; sqlite stored procedure file-cache-set-query ; sqlite stored procedure (setter file-cache-updates-uncommitted) ; count of updates since last commit global-directory-rules) ; top-level directory rules ;; The job record is the scope of a "job" performed on the vault, ;; possibly consisting of multiple different API operations. ;; It's placed in a parameter (current-job) and is a repository ;; for per-job configuration, event logging, and stats counters. (define-record job (setter check-correctness?) ; boolean flag (setter store-atime?) ; boolean flag (setter store-ctime?) ; boolean flag ; Snapshot counters (setter blocks-stored) ; Blocks written to storage (setter bytes-stored) ; Bytes written to storage (setter blocks-skipped) ; Blocks already in storage and reused (not including file cache wins) (setter bytes-skipped) ; Bytes already in storage and reused (not including file cache wins) (setter file-cache-hits) ; count of file cache hits (setter file-cache-bytes) ; count of file cache bytes saved progress-callback ; (lambda (type name size) ...) ; Event log log-event! ; (lambda (event) ...) event-log) ; a queue (see data-structures unit) of event records (define make-initialised-job make-job) (define (make-job log-event! queue-events? #!optional progress-callback) (make-initialised-job #f #f #f ; check correctness, store atime, store ctime 0 0 0 0 ; blocks stored, bytes stored, blocks skipped, bytes skipped 0 0 ; file cache hits, file cache bytes progress-callback log-event! (if queue-events? (make-queue) ; Initial empty log #f))) (define *anonymous-job* (make-job #f #f)) (define current-job (make-parameter *anonymous-job*)) (define (job-progress! type name files size) (let ((callback (job-progress-callback (current-job)))) (when callback (callback type name files size)))) (define (job-log! type path message) (let ((event (make-event* type path message))) (when (job-event-log (current-job)) (queue-add! (job-event-log (current-job)) event)) (when (job-log-event! (current-job)) ((job-log-event! (current-job)) event))) (void)) (define-syntax-rule (with-backend-logging body ...) (parameterize ((backend-log! (lambda (type message) (job-log! type #f message) (void)))) body ...)) (define file-cache-commit-interval 1000) (define (file-cache-put! vault file-path mtime size key) (when (> file-cache-commit-interval (vault-file-cache-updates-uncommitted vault)) ((with-backend-logging (storage-flush! (vault-storage vault)))) ; Flush the storage before we commit our cache, for crash safety (exec (sql (vault-file-cache vault) "commit;")) (exec (sql (vault-file-cache vault) "begin;")) (set! (vault-file-cache-updates-uncommitted vault) 0)) (exec (vault-file-cache-set-query vault) file-path mtime size key) (inc! (vault-file-cache-updates-uncommitted vault))) (define (file-cache-get vault file-path mtime size) (let ((data (query fetch (vault-file-cache-get-query vault) file-path mtime size))) (if (pair? data) (car data) #f))) (define (prepend-type-byte b v) (let* ((v-len (u8vector-length v)) (v2 (make-u8vector (+ 1 v-len)))) (set! (u8vector-ref v2 0) b) (move-memory! v v2 v-len 0 1) v2)) (define (choose-compression-function config) (match config (#f (lambda (block) (prepend-type-byte 0 block))) (('deflate) (lambda (block) (prepend-type-byte 1 (blob->u8vector/shared (string->blob (z3:encode-buffer (blob->string (u8vector->blob/shared block)))))))) (('lzma) (lambda (block) (prepend-type-byte 2 (blob->u8vector/shared (lzma:compress (u8vector->blob/shared block)))))) (else (signal (make-property-condition 'exn 'location 'open-vault 'message "Unknown compression type" 'arguments (list config)))))) (define (decompress block) (case (u8vector-ref block 0) ((0) (subu8vector block 1 (u8vector-length block))) ; No compression ((1) (blob->u8vector/shared (string->blob (z3:decode-buffer (blob->string (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; deflate ((2) (blob->u8vector/shared (lzma:decompress (u8vector->blob/shared (subu8vector block 1 (u8vector-length block)))))))) ; lzma #| function hmac (key, message) if (length(key) > blocksize) then key = hash(key) // keys longer than blocksize are shortened end if if (length(key) < blocksize) then key = key ∥ [0x00 * (blocksize - length(key))] // keys shorter than blocksize are zero-padded ('∥' is concatenation) end if o_key_pad = [0x5c * blocksize] ⊕ key // Where blocksize is that of the underlying hash function i_key_pad = [0x36 * blocksize] ⊕ key // Where ⊕ is exclusive or (XOR) return hash(o_key_pad ∥ hash(i_key_pad ∥ message)) // Where '∥' is concatenation end function |# ;; Hash function maps u8vector to a string (define (choose-hash-function config) (let ((make-basic-hash (lambda (prim) (lambda (block type) (message-digest-string (prim) (string-append (message-digest-u8vector (prim) block) (symbol->string type)))))) (make-keyed-hash (lambda (prim key) (lambda (block type) (message-digest-string (prim) (string-append key (message-digest-u8vector (prim) block) (symbol->string type))))))) (match config ((or #f ('tiger)) (make-basic-hash tiger192-primitive)) (('tiger key) (make-keyed-hash tiger192-primitive key)) (('sha256) (make-basic-hash sha256-primitive)) (('sha256 key) (make-keyed-hash sha256-primitive key)) (('sha384) (make-basic-hash sha384-primitive)) (('sha384 key) (make-keyed-hash sha384-primitive key)) (('sha512) (make-basic-hash sha512-primitive)) (('sha512 key) (make-keyed-hash sha512-primitive key)) (else (signal (make-property-condition 'exn 'location 'open-vault 'message "Unknown hash algorithm" 'arguments (list config))))))) (define (read-password prompt) (display prompt) (with-stty '(not echo) read-line)) ; Key specs are "hexhexhex" or (number-of-bytes "passphrase") (define (key->blob keyspec) (cond ((string? keyspec) (hexstring->blob keyspec)) ((pair? keyspec) (let* ((get-passphrase (lambda (maybe-passphrase) (if (eq? maybe-passphrase 'prompt) (read-password "Passphrase: ") maybe-passphrase))) (length (car keyspec)) (passphrase (get-passphrase (cadr keyspec))) (key (message-digest-string (sha512-primitive) passphrase 'string))) (if (> length 64) ; 512 bits = 64 bytes (signal (make-property-condition 'exn 'location 'open-vault 'message "Cannot generate a key that large due to a shortage of a big enough hash function (max 64)" 'arguments (list keyspec))) (string->blob (substring/shared key 0 length))))))) ;; Crypto functions are two functions, which map u8vectors to u8vectors; first encrypts, second decrypts. (define (choose-crypto-functions config) (match config (#f (values (lambda (block) block) (lambda (block) block))) ; No encryption (('aes keyspec) (let ((key (key->blob keyspec)) (iv (make-blob 16)) ; IV is pseudo-randomly generated based on the blocks we are fed as an entropy source (stir-iv! (lambda (iv block) (move-memory! (message-digest-string (tiger192-primitive) (string-append (message-digest-u8vector (tiger192-primitive) block 'string) (blob->string iv)) 'blob) iv 16)))) ; Generate initial IV from the key and current time (move-memory! (message-digest-string (tiger192-primitive) (string-append (blob->string key) (number->string (current-seconds))) 'blob) iv 16) (let-values (((encryptor decryptor) (case (blob-size key) ((16) (values (make-aes128-encryptor key) (make-aes128-decryptor key))) ((24) (values (make-aes192-encryptor key) (make-aes192-decryptor key))) ((32) (values (make-aes256-encryptor key) (make-aes256-decryptor key))) (else (signal (make-property-condition 'exn 'location 'open-vault 'message "AES keys must be 16, 24, or 32 bytes long" 'arguments (list keyspec))))))) (let ((cbc-encryptor (make-cbc*-encryptor encryptor 16)) (cbc-decryptor (make-cbc*-decryptor decryptor 16))) (values (lambda (block) (stir-iv! iv block) (blob->u8vector/shared (cbc-encryptor (u8vector->blob/shared block) iv))) (lambda (block) (blob->u8vector/shared (cbc-decryptor (u8vector->blob/shared block))))))))) (else (signal (make-property-condition 'exn 'location 'open-vault 'message "Unknown encryption type" 'arguments (list config)))))) ; A config is an sexpr of the form: ; (( )|...) ; Valid keys: ; storage (expression to create a storage backend) ; compression algorithm name ; encryption (algorithm-name "key") ; Valid flags: ; double-check - check correctness lots, even if it costs efficiency ; store-atime - store atimes ; store-ctime - store ctimes (define (open-vault config) (let ((*storage* #f) (*compression* #f) (*crypto* #f) (*hash* #f) (*double-check?* #f) (*file-cache* #f) (*global-rules* '())) (for-each (lambda (confentry) (match confentry ('double-check (set! (job-check-correctness? (current-job)) #t)) ('store-atime (set! (job-store-atime? (current-job)) #t)) ('store-ctime (set! (job-store-ctime? (current-job)) #t)) (('storage command-line) (set! *storage* (with-backend-logging (import-storage command-line)))) (('hash . conf) (set! *hash* conf)) (('compression . conf) (set! *compression* conf)) (('encryption . conf) (set! *crypto* conf)) (('file-cache path) (set! *file-cache* (open-database path)) (change-file-mode path (bitwise-ior perm/irusr perm/iwusr)) (set-busy-handler! *file-cache* (busy-timeout 100000)) (when (null? (schema *file-cache*)) (exec (sql *file-cache* "CREATE TABLE files (path TEXT PRIMARY KEY, mtime INTEGER, size INTEGER, key TEXT);"))) (exec (sql *file-cache* "begin;"))) (('rule . conf) (set! *global-rules* (cons conf *global-rules*))) (_ (signal (make-property-condition 'exn 'location 'open-vault 'message "Unknown configuration entry" 'arguments (list confentry)))))) config) (if (not *storage*) (signal (make-property-condition 'exn 'location 'open-vault 'message "No vault storage was specified in the configuration!" 'arguments (list config)))) (let-values (((compress) (choose-compression-function *compression*)) ((hash) (choose-hash-function *hash*)) ((encrypt decrypt) (choose-crypto-functions *crypto*))) (make-vault *storage* hash compress decompress encrypt decrypt ; File cache *file-cache* (if *file-cache* (sql *file-cache* "SELECT key FROM files WHERE path = ? AND mtime = ? AND size = ?") #f) (if *file-cache* (sql *file-cache* "INSERT OR REPLACE INTO files (path,mtime,size,key) VALUES (?,?,?,?)") #f) 0 ; Uncommitted update counter *global-rules*)))) ; Take a block, and return a compressed and encrypted block (define (wrap-block vault block) ((vault-encrypt vault) ((vault-compress vault) block))) ;; Take a compressed and encrypted block, and recover the original data (define (unwrap-block vault block) ((vault-decompress vault) ((vault-decrypt vault) block))) (define (vault-max-block-size vault) (storage-max-block-size (vault-storage vault))) (define (vault-writable? vault) (storage-writable? (vault-storage vault))) (define (vault-unlinkable? vault) (storage-unlinkable? (vault-storage vault))) (define (check-vault-writable vault) (if (not (vault-writable? vault)) (signal (make-property-condition 'exn 'location 'check-vault-writable 'message "This isn't a writable vault")))) (define (check-vault-unlinkable vault) (if (not (vault-writable? vault)) (signal (make-property-condition 'exn 'location 'check-vault-unlinkable 'message "This isn't an unlinkable vault - it's append-only")))) (define (vault-log-reuse! vault data) (inc! (job-blocks-skipped (current-job))) (inc! (job-bytes-skipped (current-job)) (u8vector-length data))) (define (epochtime->string e) (let ((localtime (seconds->local-time e))) (string-append (string-pad (number->string (+ 1900 (vector-ref localtime 5))) 4 #\0) "-" (string-pad (number->string (+ 1 (vector-ref localtime 4))) 2 #\0) "-" (string-pad (number->string (vector-ref localtime 3)) 2 #\0) " " (string-pad (number->string (vector-ref localtime 2)) 2 #\0) ":" (string-pad (number->string (vector-ref localtime 1)) 2 #\0) ":" (string-pad (number->string (vector-ref localtime 0)) 2 #\0)))) (define (vault-put! vault key data type) (unless (vault-writable? vault) (error 'vault-put! "This isn't a writable vault")) (with-backend-logging ((storage-put! (vault-storage vault)) key (wrap-block vault data) type)) (inc! (job-blocks-stored (current-job))) (inc! (job-bytes-stored (current-job)) (u8vector-length data)) (void)) (define (vault-flush! vault) (with-backend-logging ((storage-flush! (vault-storage vault)))) ; Flush the storage first, to ensure crash safety (when (vault-file-cache vault) (exec (sql (vault-file-cache vault) "commit;")) (exec (sql (vault-file-cache vault) "begin;")) (set! (vault-file-cache-updates-uncommitted vault) 0))) (define (vault-exists? vault key) (with-backend-logging ((storage-exists? (vault-storage vault)) key))) (define (vault-get vault key type) (let* ((raw-data (with-backend-logging ((storage-get (vault-storage vault)) key))) (data (if raw-data (unwrap-block vault raw-data) (error 'vault-get (sprintf "Nonexistant block ~A ~A" key type))))) (unless (string=? key ((vault-hash vault) data type)) (error 'vault-get (sprintf "Consistency check failure: asked for ~A, got ~A" key ((vault-hash vault) data type)))) data)) (define (vault-link! vault key) (unless (vault-writable? vault) (error 'vault-link! "This isn't a writable vault")) (with-backend-logging ((storage-link! (vault-storage vault)) key))) (define (vault-unlink! vault key) (unless (vault-writable? vault) (error 'vault-unlink! "This isn't a writable vault")) (let ((result (with-backend-logging ((storage-unlink! (vault-storage vault)) key)))) (if result (unwrap-block vault result) #f))) (define (vault-admin! vault command) (with-backend-logging ((storage-admin! (vault-storage vault)) command))) (define (vault-set-tag! vault tag key) (unless (vault-writable? vault) (error 'vault-set-tag! "This isn't a writable vault")) (with-backend-logging ((storage-set-tag! (vault-storage vault)) tag key))) (define (vault-tag vault tag) (with-backend-logging ((storage-tag (vault-storage vault)) tag))) (define (vault-all-tags vault) (with-backend-logging ((storage-all-tags (vault-storage vault))))) (define (vault-remove-tag! vault tag) (unless (vault-writable? vault) (error 'vault-remove-tag! "This isn't a writable vault")) (with-backend-logging ((storage-remove-tag! (vault-storage vault)) tag))) (define (vault-lock-tag! vault tag) (unless (vault-writable? vault) (error 'vault-lock-tag! "This isn't a writable vault")) (let loop ((tries-left 10)) (if (zero? tries-left) (signal (make-property-condition 'exn 'location 'vault-lock-tag! 'message (sprintf "We timed out attempting to lock the tag '~A'" tag))) (let ((result (with-backend-logging ((storage-lock-tag! (vault-storage vault)) tag)))) (if result result ; Lock got! (begin (thread-sleep! 1) (loop (- tries-left 1)))))))) (define (vault-tag-locked? vault tag) (unless (vault-writable? vault) (error 'vault-tag-locked? "This isn't a writable vault")) (with-backend-logging ((storage-tag-locked? (vault-storage vault)) tag))) (define (vault-unlock-tag! vault tag) (unless (vault-writable? vault) (error 'vault-unlock-tag! "This isn't a writable vault")) (with-backend-logging ((storage-unlock-tag! (vault-storage vault)) tag))) (define (vault-close! vault) (with-backend-logging ((storage-close! (vault-storage vault)))) ;; This flushes the backend before we flush the file cache, for crash safety (when (vault-file-cache vault) (exec (sql (vault-file-cache vault) "commit;")) (close-database (vault-file-cache vault))) (void)) ;; ;; CORE ALGORITHMS ;; ;; Philosophy: insertion routines ;; Insertion routines insert an object into the vault, correctly ;; managing reference counts. In order to do this, they all return ;; two values: the key the object went in under, and a boolean flag ;; that is true if the object was already in the vault. This is so ;; that a parent object that calls that function can construct its ;; data block from the supplied child keys, then do an exists? check ;; to see if it already exists in the vault itself, if all of its ;; children were already in the vault. If it was, then it in turn ;; can just return the key and #t But if not, then it can link! every ;; child that WAS already in the vault, and then put! its own value ;; into the vault and return that with #f Thus, the reference counts ;; are maintained correctly. (define (reusing hash) ; (printf "REUSING: ~A\n" hash) hash) (define (virgin hash) ; (printf "CREATED: ~A\n" hash) hash) ;; BLOCKS OF RAW DATA THAT CANNOT CONTAIN CHILD KEYS ;; We never have any child keys to link!, so the not-reused case is simple. (define (vault-store-block! vault data type) (check-vault-writable vault) (let ((hash ((vault-hash vault) data type))) (if (vault-exists? vault hash) (begin (vault-log-reuse! vault data) (values (reusing hash) #t)) (begin (vault-put! vault hash data type) (values (virgin hash) #f))))) ;; GENERIC STREAMS OF KEYS ;; Both file and directory storage involve storing an arbitrary list of keys, in order ;; to string together a load of data blocks into one. ;; If they all fit into one block, then so be it. Otherwise, we have to split them ;; into blocks then create a higher-level stream of keys to store the keys of those blocks... (define-record key-stream-writer write! ;; Write a single string key to the stream. Accepts the key, and the already-existed boolean for proper reference counting. finish!) ;; Terminate the stream. Returns two values: key of the stream, and an already-existed boolean. (define (copy-string-into-place! u8v offset string string-offs string-len) (move-memory! string u8v (- string-len string-offs) string-offs offset) (void)) (define (serialise-strings! u8v offset strings) (if (null? strings) (void) (begin (let* ((string (blob->u8vector/shared (string->blob (string-append (car strings) "\n")))) (string-len (u8vector-length string))) (copy-string-into-place! u8v (- offset string-len) string 0 string-len) (serialise-strings! u8v (- offset string-len) (cdr strings)))))) (define (make-key-stream-writer* vault type) (check-vault-writable vault) (let* ((*key-buffer* '()) (*key-buffer-bytes* 0) (*key-buffer-reused?* #t) (*parent-stream* #f) (next-write-will-overflow? (lambda (key) (assert (< (string-length key) (vault-max-block-size vault))) (> (+ *key-buffer-bytes* (string-length key) 1) (vault-max-block-size vault)))) (flush! (lambda () (let ((keys-serialised (make-u8vector *key-buffer-bytes*))) (serialise-strings! keys-serialised *key-buffer-bytes* (map car *key-buffer*)) (let ((hash ((vault-hash vault) keys-serialised type))) (if (and *key-buffer-reused?* (vault-exists? vault hash)) (begin (set! *key-buffer* '()) (set! *key-buffer-bytes* 0) (set! *key-buffer-reused?* #t) (vault-log-reuse! vault keys-serialised) (values (reusing hash) #t)) ; We, too, are reused (begin ; We are unique and new and precious! (for-each (lambda (x) ; link! all reused children (let ((key (car x)) (reused? (cdr x))) (if reused? (vault-link! vault key)))) *key-buffer*) (vault-put! vault hash keys-serialised type) (set! *key-buffer* '()) (set! *key-buffer-bytes* 0) (set! *key-buffer-reused?* #t) (values (virgin hash) #f))))))) (write! (lambda (key reused?) (if (next-write-will-overflow? key) (let-values (((flush-key flush-reused?) (flush!))) (if (not *parent-stream*) (set! *parent-stream* (make-key-stream-writer* vault type))) ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?))) ;; What happens if the same key comes up twice, eh? (set! *key-buffer* (cons (cons key reused?) *key-buffer*)) (set! *key-buffer-reused?* (and *key-buffer-reused?* reused?)) (set! *key-buffer-bytes* (+ *key-buffer-bytes* (string-length key) 1)) (void))) (finish! (lambda () (cond (*parent-stream* (begin (if (not (null? *key-buffer*)) (let-values (((flush-key flush-reused?) (flush!))) ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?))) ((key-stream-writer-finish! *parent-stream*)))) ((null? *key-buffer*) ; Empty stream (vault-store-block! vault (make-u8vector 0) type)) ((null? (cdr *key-buffer*)) ; Single-element stream (values (caar *key-buffer*) (cdar *key-buffer*))) ; Just return the one element! (else ; More than one key, but not enough to have flushed before (flush!)))))) (make-key-stream-writer write! finish!))) (define (deserialise-key-stream block) ; Convert a key stream block to a list of key strings (string-split (blob->string (u8vector->blob/shared block)) "\n")) ;; kons is called on (key type accumulator) for every key in the stream, in order (define (fold-key-stream vault key ks-type kons knil) (let ((type (vault-exists? vault key))) (if (eq? ks-type type) ; Recurse (begin (let ((subkeys (deserialise-key-stream (vault-get vault key type)))) (fold (lambda (subkey acc) (fold-key-stream vault subkey ks-type kons acc)) knil subkeys))) ; Leaf node (kons key type knil)))) ; (child-unlink! vault key type) is called on every child key of a deleted block (define (unlink-key-stream! vault key type child-unlink!) (check-vault-unlinkable vault) (let ((result (vault-unlink! vault key))) (if result ; result is now list of keys, \n separated, to recursively unlink (for-each (lambda (subkey) (let ((child-type (vault-exists? vault subkey))) (if child-type ; The child may not actually exist any more, in which case, job done! (if (eq? child-type type) (unlink-key-stream! vault subkey type child-unlink!) (child-unlink! vault subkey child-type))))) (deserialise-key-stream result))))) ;; FILE STORAGE ;; Files are stored as either: ;; 1) A direct block of type "f" containing the file data ;; 2) An indirect block of type "fi" that's a keystream of keys of direct or indirect blocks ;; Uses standard input port for the file data ;; Returns key and reused? (define (store-file! vault file-path file-stat) (let* ((store-file-without-caching! (lambda () ;; Actually upload the file ;; FIXME: memory-map the file in 1MB chunks, and ;; copy them into u8vectors? (letrec ((blocksize (vault-max-block-size vault)) (*buffer* (make-u8vector blocksize)) (ksw (make-key-stream-writer* vault 'fi)) (upload-file (lambda () (let ((bytes-read (read-u8vector! blocksize *buffer*))) (if (not (zero? bytes-read)) (begin (job-progress! 'file-block-start #f #f bytes-read) (let-values (((data-key data-reused?) (vault-store-block! vault (subu8vector *buffer* 0 bytes-read) 'f))) ((key-stream-writer-write! ksw) data-key data-reused?) (job-progress! 'file-block-end #f #f #f) (upload-file))) ((key-stream-writer-finish! ksw))))))) (upload-file)))) (store-file-and-cache! (lambda (mtime size) (let-values (((key reused?) (store-file-without-caching!))) (file-cache-put! vault file-path mtime size key) (values key reused?))))) (check-vault-writable vault) (job-progress! 'file-start file-path #f (vector-ref file-stat 5)) ;; Firstly, if we have an mtime cache, use it to see if the file is already in the vault ;; The cache is keyed on file paths, and the contents are ;; sexprs of the form (mtime hash) (receive (key reused?) (if (vault-file-cache vault) (let* ((mtime (vector-ref file-stat 8)) ; Should have used and-let* (size (vector-ref file-stat 5)) (cache-result (file-cache-get vault file-path mtime size))) (if (and cache-result (vault-exists? vault cache-result)) (begin (inc! (job-file-cache-hits (current-job))) (inc! (job-file-cache-bytes (current-job)) size) (values cache-result #t)) ; Found in cache! Woot! (store-file-and-cache! mtime size))) ; not in cache (store-file-without-caching!)) ; no mtime cache (begin (job-progress! 'file-end #f #f #f) (values key reused?))))) ;; Call kons on each u8vector block of the file in turn ;; with an accumulator that starts as knil as a second argument (define (fold-file vault key kons knil) (fold-key-stream vault key 'fi (lambda (key type acc) (kons (vault-get vault key type) acc)) knil)) ;; Write the contents of the file to the standard output port (define (write-file-contents vault key) (fold-file vault key (lambda (block acc) (begin (job-progress! 'file-block-start #f #f (u8vector-length block)) (write-u8vector block) (job-progress! 'file-block-end #f #f #f) #f)) #f)) (define (unlink-file! vault key) (check-vault-unlinkable vault) (unlink-key-stream! vault key 'fi (lambda (vault key type) (vault-unlink! vault key)))) ;; GENERIC STREAMS OF S-EXPRESSIONS ;; These are to be used to implement directories ;; But might be useful for other complex structures in future (define-record sexpr-stream-writer 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. finish!) ;; Return the key and reused? flag for the whole thing ;; FIXME: Examine this and make-key-stream-writer* ;; and try and merge them to use a common string-stream-writer abstraction ;; if it's worth it. They share a lot, yet also differ a lot. (define (make-sexpr-stream-writer* vault type ks-type) (check-vault-writable vault) (let* ((*sexpr-buffer* '()) ; List of strings (*sexpr-buffer-bytes* 0) ; Bytes used so far (*key-buffer* '()) ; List of key-reused? pairs (*key-buffer-reused?* #t) ; All reused in the buffer so far? (*parent-stream* #f) ; Key stream (flush! (lambda () (let ((serialised-buffer (make-u8vector *sexpr-buffer-bytes*))) (begin (serialise-strings! serialised-buffer *sexpr-buffer-bytes* *sexpr-buffer*) (let ((hash ((vault-hash vault) serialised-buffer type))) (begin (if (job-check-correctness? (current-job)) (if *key-buffer-reused?* (assert (every cdr *key-buffer*) "Key buffer thinks it's all reused, but it isn't:" *key-buffer*) ; else (assert (not (every cdr *key-buffer*)) "Key buffer thinks it's not all reused, but it is:" *key-buffer*))) (if (and *key-buffer-reused?* (vault-exists? vault hash)) (begin (set! *sexpr-buffer* '()) (set! *sexpr-buffer-bytes* 0) (set! *key-buffer* '()) (set! *key-buffer-reused?* #t) (vault-log-reuse! vault serialised-buffer) (values (reusing hash) #t)) ; We, too, are reused (begin ; We are unique and new and precious! (for-each (lambda (x) ; link! all reused children (let ((key (car x)) (reused? (cdr x))) (if reused? (vault-link! vault key)))) *key-buffer*) (vault-put! vault hash serialised-buffer type) (set! *sexpr-buffer* '()) (set! *sexpr-buffer-bytes* 0) (set! *key-buffer* '()) (set! *key-buffer-reused?* #t) (values (virgin hash) #f))))))))) (write! (lambda (sexpr keys) (let* ((sexpr-string (with-output-to-string (lambda () (write sexpr)))) (sexpr-len (string-length sexpr-string))) (assert (< sexpr-len (vault-max-block-size vault))) (if (> (+ *sexpr-buffer-bytes* sexpr-len 1) (vault-max-block-size vault)) (let-values (((flush-key flush-reused?) (flush!))) (if (not *parent-stream*) (set! *parent-stream* (make-key-stream-writer* vault ks-type))) ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?))) (set! *sexpr-buffer* (cons sexpr-string *sexpr-buffer*)) (set! *key-buffer* (append keys *key-buffer*)) (set! *key-buffer-reused?* (and *key-buffer-reused?* (every cdr keys))) (set! *sexpr-buffer-bytes* (+ *sexpr-buffer-bytes* sexpr-len 1)) (void)))) (finish! (lambda () (cond (*parent-stream* (begin (if (not (null? *sexpr-buffer*)) (let-values (((flush-key flush-reused?) (flush!))) ((key-stream-writer-write! *parent-stream*) flush-key flush-reused?))) ((key-stream-writer-finish! *parent-stream*)))) ((null? *sexpr-buffer*) ; Empty stream (vault-store-block! vault (make-u8vector 0) type)) (else ; Some sexprs, but not enough to have flushed before (flush!)))))) (make-sexpr-stream-writer write! finish!))) (define (deserialise-sexpr-stream block) ; Convert a sexpr stream block to a list of sexprs (map (lambda (string) (with-input-from-string string read)) (string-split (blob->string (u8vector->blob/shared block)) "\n"))) (define (fold-sexpr-stream vault key leaf-type ks-type kons knil) (fold-key-stream vault key ks-type (lambda (key found-leaf-type acc) (assert (eq? found-leaf-type leaf-type)) (let ((sexprs (deserialise-sexpr-stream (vault-get vault key found-leaf-type)))) (fold kons acc sexprs))) knil)) (define (unlink-sexpr-stream-block! vault key sexpr-unlink!) (let ((result (vault-unlink! vault key))) (if result (for-each sexpr-unlink! (deserialise-sexpr-stream result))))) (define (unlink-sexpr-stream! vault key leaf-type ks-type sexpr-unlink!) (check-vault-unlinkable vault) (let ((type (vault-exists? vault key))) (cond ((eq? type ks-type) (unlink-key-stream! vault key ks-type (lambda (vault leaf-key found-leaf-type) (assert (eq? found-leaf-type leaf-type)) (unlink-sexpr-stream-block! vault leaf-key sexpr-unlink!)))) ((eq? type leaf-type) (unlink-sexpr-stream-block! vault key sexpr-unlink!)) (else (assert (or (eq? type leaf-type) (eq? type ks-type)) "unlink-sexpr-stream!: Invalid block type" (list 'expected leaf-type ks-type) type))))) ;; DIRECTORY STORAGE ;; Directories are stored as either; ;; 1) A direct block of type "d" containing a list of file/directory entries, each of which is an s-expr ;; The car of the s-expr is the file name ;; The cadr is a type symbol - file, dir, symlink, chardev, blockdev, fifo, socket ;; The cddr is an alist of other properties ;; Regular files have a 'content entry containing a key, for example. ;; Also look out for 'mode 'uid 'gid 'atime 'mtime 'ctime ;; Symlinks have 'target ;; Directories have 'content, too ;; Files with streams or forks or whatnot can have more than one content key, of course... ;; 2) An indirect block of type "di" that's a keystream of keys to direct or indirect blocks ;; Look for a .ugarit file in the given directory ;; If one is found, return its contents (define (read-local-rules vault path) (let ((conf-file (make-pathname path ".ugarit"))) (if (file-exists? conf-file) (with-input-from-file conf-file read-file) '()))) ;; Do the rules list say to ignore the file? ;; Statements towards the head of the list take priority ;; And we want to accept the most recent 'ignore' or 'include', ;; defaulting to 'include' if neither is found (define (rules-say-ignore rules) (match rules ('() #f) ((('exclude) . _) #t) ((('include) . _) #f) ((_ . more) (rules-say-ignore more)))) ;; Store a directory entry for the given filename, which is in the ;; directory identified by path. The rules-checker is consulted to ;; decide what to do, and the resulting directory entry is written to ;; ssw (an sexpr stream writer) ;; Returns the number of files and bytes in the entry. (define (store-directory-entry! vault path filename ssw rules-checker) (let* ((file-path (make-pathname path filename)) (stats (file-stat file-path #t)) (mode (bitwise-and (vector-ref stats 1) (bitwise-not stat/ifmt))) (uid (vector-ref stats 3)) (gid (vector-ref stats 4)) (atime (vector-ref stats 6)) (ctime (vector-ref stats 7)) (mtime (vector-ref stats 8)) (type (bitwise-and (vector-ref stats 1) stat/ifmt)) (standard-file-attributes (list (cons 'mode mode) (cons 'uid uid) (cons 'gid gid) (cons 'mtime mtime))) (file-rules (object-matches filename rules-checker))) (when (job-store-ctime? (current-job)) (set! standard-file-attributes (cons (cons 'ctime ctime) standard-file-attributes))) (when (job-store-atime? (current-job)) (set! standard-file-attributes (cons (cons 'atime atime) standard-file-attributes))) (if (rules-say-ignore file-rules) (values 0 0) (cond ((eq? type stat/ifsock) (job-log! 'warning file-path "Ignoring a socket") (values 0 0)) ((eq? type stat/ifreg) (let-values (((content-key content-reused?) (with-input-from-file file-path (lambda () (store-file! vault file-path stats))))) ((sexpr-stream-writer-write! ssw) (append (list filename 'file (cons 'contents content-key) (cons 'size (vector-ref stats 5))) standard-file-attributes) '()) (values 1 (vector-ref stats 5)))) ((eq? type stat/ifdir) (let-values (((content-key content-reused? files bytes) (store-directory! vault file-path))) ((sexpr-stream-writer-write! ssw) (append (list filename 'dir (cons 'contents content-key) (cons 'files files) (cons 'size bytes)) standard-file-attributes) (list (cons content-key content-reused?))) (values files bytes))) ((eq? type stat/iflnk) (let ((target (read-symbolic-link file-path))) (job-progress! 'file-start file-path #f (string-length target)) (job-progress! 'file-block-start #f #f (string-length target)) ((sexpr-stream-writer-write! ssw) (append (list filename 'symlink (cons 'target target) (cons 'size (string-length target))) standard-file-attributes) '()) (job-progress! 'file-block-end #f #f #f) (job-progress! 'file-end #f #f #f) (values 1 (string-length target)))) ((eq? type stat/ifblk) (let ((devnum (vector-ref stats 10))) (job-progress! 'file-start path #f 0) (job-progress! 'file-block-start #f #f 0) ((sexpr-stream-writer-write! ssw) (append (list filename 'block-device (cons 'number devnum)) standard-file-attributes) '()) (job-progress! 'file-block-end #f #f #f) (job-progress! 'file-end #f #f #f) (values 1 0))) ((eq? type stat/ifchr) (let ((devnum (vector-ref stats 10))) (job-progress! 'file-start path #f 0) (job-progress! 'file-block-start #f #f 0) ((sexpr-stream-writer-write! ssw) (append (list filename 'character-device (cons 'number devnum)) standard-file-attributes) '()) (job-progress! 'file-block-end #f #f #f) (job-progress! 'file-end #f #f #f) (values 1 0))) ((eq? type stat/ififo) (job-progress! 'file-start path #f 0) (job-progress! 'file-block-start #f #f 0) ((sexpr-stream-writer-write! ssw) (append (list filename 'fifo) standard-file-attributes) '()) (job-progress! 'file-block-end #f #f #f) (job-progress! 'file-end #f #f #f) (values 1 0)) (else ; WTF? (job-log! 'error file-path "Unable to store object of unknown type") (values 0 0)))))) ;; Store a directory ;; Returns the usual key and reused? values, then the total files and ;; bytes in the directory (define (store-directory! vault path) (call-with-context (read-local-rules vault path) path (lambda () (check-vault-writable vault) (let ((ssw (make-sexpr-stream-writer* vault 'd 'di)) (rules-checker (make-filesystem-object-pattern-checker path)) (file-list (sort! (directory path #t) string>?))) (job-progress! 'dir-start path (length file-list) #f) (let ((sizes (fold (lambda (filename sizes) (condition-case (receive (files bytes) (store-directory-entry! vault path filename ssw rules-checker) (cons (+ files (car sizes)) (+ bytes (cdr sizes)))) (exn (exn i/o file) (job-log! 'error (make-pathname path filename) (sprintf "Unable to store into the vault (~a)" ((condition-property-accessor 'exn 'message "Unknown error") exn)))))) (cons 0 0) file-list))) (receive (key reused?) ((sexpr-stream-writer-finish! ssw)) (begin (job-progress! 'dir-end #f #f #f) (values key reused? (car sizes) (cdr sizes))))))))) (define (unlink-directory! vault key) (check-vault-unlinkable vault) (unlink-sexpr-stream! vault key 'd 'di (lambda (dirent) (let ((type (cadr dirent)) (name (car dirent)) (props (cddr dirent))) (cond ((eq? type 'file) (unlink-file! vault (cdr (assq 'contents props)))) ((eq? type 'dir) (unlink-directory! vault (cdr (assq 'contents props))))))))) (define (set-standard-file-metadata! vault path props) (let ((mode (assq 'mode props)) (uid (assq 'uid props)) (gid (assq 'gid props)) (mtime (assq 'mtime props)) (atime (assq 'atime props))) (if mode (change-file-mode path (cdr mode))) (if (or uid gid) (handle-exceptions exn (job-log! 'warning path "Unable to set the uid/gid") (change-file-owner path (if uid (cdr uid) (current-user-id)) (if gid (cdr gid) (current-group-id))))) (if (or mtime atime) (change-file-times path (if atime (cdr atime) (current-seconds)) (if mtime (cdr mtime) (current-seconds)))) (void))) (define (extract-file! vault props path) (job-progress! 'file-start path #f (cdr (assq 'size props))) (let ((contents-key (cdr (assq 'contents props)))) (with-output-to-file path (lambda () (write-file-contents vault contents-key)))) (set-standard-file-metadata! vault path props) (job-progress! 'file-end #f #f #f)) (define (extract-subdirectory! vault props path) (if (not (directory? path)) (create-directory path)) (let ((contents-key (cdr (assq 'contents props)))) (extract-directory! vault contents-key path) (set-standard-file-metadata! vault path props))) (define (extract-symlink! vault props path) (let ((target (cdr (assq 'target props))) (mode (assq 'mode props)) (uid (assq 'uid props)) (gid (assq 'gid props)) (mtime (assq 'mtime props)) (atime (assq 'atime props))) (job-progress! 'file-start path #f (string-length target)) (job-progress! 'file-block-start #f #f (string-length target)) (create-symbolic-link target path) (job-progress! 'file-block-end #f #f #f) ;; Alas, there is no portable way to set the atime/mtime on a link. ;; I think, somehow, we will manage to live our lives without the atime and mtime on links... (if mode (handle-exceptions exn (job-log! 'warning path "Unable to set the mode of a link") (change-link-mode path (cdr mode)))) (job-progress! 'file-end #f #f #f) (if (or uid gid) (handle-exceptions exn (job-log! 'warning path "Unable to set the uid/gid of a link") (change-link-owner path (if uid (cdr uid) (current-user-id)) (if gid (cdr gid) (current-group-id))))))) (define (extract-fifo! vault props path) (job-progress! 'file-start path #f 0) (create-fifo path) (set-standard-file-metadata! vault path props) (job-progress! 'file-end #f #f #f)) (define (extract-block-device! vault props path) (let ((number (cdr (assq 'number props)))) (handle-exceptions exn (job-log! 'warning path "Unable to recreate block device") (job-progress! 'file-start path #f 0) (create-special-file path stat/ifblk number) (set-standard-file-metadata! vault path props)) (job-progress! 'file-end #f #f #f))) (define (extract-character-device! vault props path) (let ((number (cdr (assq 'number props)))) (handle-exceptions exn (job-log! 'warning path "Unable to recreate character device") (job-progress! 'file-start path #f 0) (create-special-file path stat/ifchr number) (set-standard-file-metadata! vault path props)) (job-progress! 'file-end #f #f #f))) (define (extract-object! vault dirent target-path) (let ((type (cadr dirent)) (name (car dirent)) (props (cddr dirent))) (cond ((eq? type 'file) (extract-file! vault props (make-pathname target-path name))) ((eq? type 'tag) (signal (make-property-condition 'exn 'location 'extract-object! 'dirent dirent 'message "You can't extract an entire tag."))) ((eq? type 'root) (signal (make-property-condition 'exn 'location 'extract-object! 'dirent dirent 'message "You can't extract an entire vault."))) ((eq? type 'snapshot) (let ((output-path (make-pathname target-path name))) (if (not (directory? output-path)) (create-directory output-path)) (extract-directory! vault (cdr (assq 'contents (cddr dirent))) output-path))) ((eq? type 'dir) (extract-subdirectory! vault props (make-pathname target-path name))) ((eq? type 'symlink) (extract-symlink! vault props (make-pathname target-path name))) ((eq? type 'fifo) (extract-fifo! vault props (make-pathname target-path name))) ((eq? type 'block-device) (extract-block-device! vault props (make-pathname target-path name))) ((eq? type 'character-device) (extract-character-device! vault props (make-pathname target-path name))) (else (job-log! 'error (make-pathname target-path name) (sprintf "Unable to extract an object of unknown type ~A" type)))))) (define (extract-directory! vault key target-path) (job-progress! 'dir-start target-path #f #f) (fold-sexpr-stream vault key 'd 'di (lambda (dirent acc) (condition-case (begin (extract-object! vault dirent target-path)) (exn (exn i/o file) (job-log! 'error (make-pathname target-path (car dirent)) (sprintf "Unable to extract from the vault (~a)" ((condition-property-accessor 'exn 'message "Unknown error") exn))))) (void)) (void)) (job-progress! 'dir-end #f #f #f) (void)) ;; SINGLE SEXPRS ;; A sexpr in a block. Simple, really. ;; Given an sexpr, a type and a list of (key . reused?) pairs, returns a key and a reused? flag. (define (store-sexpr! vault sexpr type keys) (let* ((data (blob->u8vector/shared (string->blob (with-output-to-string (lambda () (write sexpr)))))) (hash ((vault-hash vault) data type))) (if (vault-exists? vault hash) (begin (vault-log-reuse! vault data) (values (reusing hash) #t)) (begin (for-each (lambda (key) (if (cdr key) ; reused? (vault-link! vault (car key)))) keys) (vault-put! vault hash data type) (values (virgin hash) #f))))) (define (read-sexpr vault key type) (let ((data (vault-get vault key type))) (with-input-from-string (blob->string (u8vector->blob/shared data)) (lambda () (read))))) ;; Accept an even number of arguments. Each pair of arguments ;; is a boolean and a value. The result is a list of all values ;; whose booleans were non-#f (define (conditional-list . args) (let loop ((args-left args) (result '())) (cond ((null? args-left) (reverse result)) ((null? (cdr args-left)) (error 'conditional-list "An even number of arguments is required" args)) ((car args-left) (loop (cddr args-left) (cons (cadr args-left) result))) (else (loop (cddr args-left) result))))) ;; SNAPSHOT STORAGE ;; A snapshot is a single block containing an alist ;; Keys are 'ctime (in seconds since the epoch), ;; 'contents (hash of root directory), ;; 'hostname (name of host snapshotted) ;; 'prefix (prefix of filesystem on host) ;; 'notes (user-supplied notes) ;; 'previous (hash of previous snapshot) ;; 'stats (alist of stats: ;; 'blocks-stored ;; 'bytes-stored ;; 'blocks-skipped ;; 'bytes-skipped ;; 'file-cache-hits ;; 'file-cache-bytes ;; 'log (list of log events, each being a (type timestamp path message) list ;; Returns the snapshot's key. (define (tag-snapshot! vault tag contents-key contents-reused? snapshot-properties job) (check-vault-writable vault) (vault-lock-tag! vault tag) ;; Lock BEFORE reading previous state of the tag, to avoid races. (let* ((previous (vault-tag vault tag)) (stats (if job (list (cons 'blocks-stored (job-blocks-stored job)) (cons 'bytes-stored (job-bytes-stored job)) (cons 'blocks-skipped (job-blocks-skipped job)) (cons 'bytes-skipped (job-bytes-skipped job)) (cons 'file-cache-hits (job-file-cache-hits job)) (cons 'file-cache-bytes (job-file-cache-bytes job))) #f)) (log (if job (map (lambda (event) (list (event-type event) (event-time event) (event-path event) (event-message event))) (queue->list (job-event-log job))) #f)) (snapshot (append (conditional-list #t (cons 'mtime (current-seconds)) #t (cons 'contents contents-key) (list? stats) (cons 'stats stats) (list? log) (cons 'log log)) snapshot-properties)) (keys (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. (cons contents-key contents-reused?)))) (when previous (set! snapshot (cons (cons 'previous previous) snapshot))) (let-values (((snapshot-key snapshot-reused?) (store-sexpr! vault snapshot 'snapshot keys))) (vault-flush! vault) ; After this point we can be sure that the snapshot and all blocks it refers to are stably stored (vault-set-tag! vault tag snapshot-key) ; Therefore, we can be confident in saving it in a tag. (vault-unlock-tag! vault tag) (when snapshot-reused? ; Rare, but possible; fork a tag then snapshot the same FS state to both at the same second. (vault-link! vault snapshot-key)) snapshot-key))) (define (fold-history vault snapshot-key kons knil) (let ((snapshot (read-sexpr vault snapshot-key 'snapshot))) (if (assq 'previous snapshot) (kons snapshot-key snapshot (fold-history vault (cdr (assq 'previous snapshot)) kons knil)) (kons snapshot-key snapshot knil)))) ;; BRING IT ALL TOGETHER ; If given '() as the directory-key, makes a list of all tags ; If given '(tag . "tag-name"), makes a list of snapshots of that tag ; If given a key, if that key points to a snapshot, return a directory listing the root. ; If given a key, if that key points to a directory, makes a list of the contents of that directory ; Either way, the list of results are folded into the provided kons and knil functions ; kons is called with three arguments: a directory-key for the object, a directory entry in the usual format, and the accumulator. (define (fold-vault-node vault directory-key kons knil) (cond ((null? directory-key) ; List tags (fold (lambda (tag acc) (kons (cons 'tag tag) (list tag 'tag (cons 'current (vault-tag vault tag)) (cons 'locked (vault-tag-locked? vault tag))) acc)) knil (vault-all-tags vault))) ((and (pair? directory-key) (eq? (car directory-key) 'tag)) ; List a tag's snapshots (let* ((tag (cdr directory-key)) (current (vault-tag vault tag)) (current-contents (read-sexpr vault current 'snapshot))) (kons current (cons "current" (cons 'snapshot current-contents)) (fold-history vault current (lambda (key snapshot acc) (kons key (append (list (epochtime->string (cdr (assq 'mtime snapshot))) 'snapshot) snapshot) acc)) knil)))) ((string? directory-key) (let ((type (vault-exists? vault directory-key))) (case type ((snapshot snapshoti) ; List snapshot contents (let* ((snapshot (read-sexpr vault directory-key 'snapshot)) (contents-key (cdr (assq 'contents snapshot))) (dirent (append (list "contents" 'dir) snapshot))) (kons contents-key dirent knil))) ((d di) ; List directory contents (fold-sexpr-stream vault directory-key 'd 'di (lambda (dirent acc) (let ((name (car dirent)) (type (cadr dirent)) (props (cddr dirent))) (cond ((eq? type 'file) (kons #f dirent acc)) ((eq? type 'dir) (kons (cdr (assq 'contents props)) dirent acc)) ((eq? type 'symlink) (kons #f dirent acc)) (else (kons #f dirent acc))))) knil)) ((#f) (signal (make-property-condition 'exn 'location 'fold-vault-node 'key directory-key 'message (sprintf "Could not examine the node with key ~A as it does not exist" directory-key)))) (else (signal (make-property-condition 'exn 'location 'fold-vault-node 'key directory-key 'message (sprintf "Could not examine the node with key ~A of type ~A" directory-key type))) )))))) ; Returns the fold-vault-node directory entry corresponding to the ; given name Eg, a list with elements key, name, type, properties. ; Returns #f if the name cannot be found. (define (traverse-vault-node vault directory-key name) (let/cc return (fold-vault-node vault directory-key (lambda (node-key dirent acc) (if (string=? (car dirent) name) (return (cons node-key dirent)) acc)) #f))) ; Traverses a path (given as a list of strings) in a vault. ; Returns a directory entry on success, but raises a signal on failure. (define (traverse-vault-path vault path #!optional (root-path '())) (match path (() (if (null? root-path) (list '() "/" 'root) (car root-path))) (("." . rest) (traverse-vault-path vault rest root-path)) ((".." . rest) (if (null? root-path) (signal (make-property-condition 'exn 'location 'traverse-vault-path 'message "You can't go up from the root!")) (traverse-vault-path vault rest (cdr root-path)))) ((name . rest) (let ((dirent (traverse-vault-node vault (if (null? root-path) '() (car (car root-path))) name))) (if dirent (traverse-vault-path vault rest (cons dirent root-path)) (signal (make-property-condition 'exn 'location 'traverse-vault-path 'message (sprintf "Object not found: ~A" name)))))))) )