(module ugarit-api (open-vault ;; Note: Mutates job configuration from the conf file vault-close! vault-fork-tag! ;; Re-exports from ugarit-core vault? vault-global-directory-rules vault-admin! make-job job? job-blocks-stored job-bytes-stored job-blocks-skipped job-bytes-skipped job-file-cache-hits job-file-cache-bytes job-store-atime? job-store-ctime? job-check-correctness? job-use-rules? current-job call-with-job-context job-log! epochtime->string ;; Re-exports from ugarit-streams.scm ;; Re-exports from ugarit-files.scm store-file! fold-leaf-object unlink-file! store-directory! unlink-directory! extract-object! dirent? dirent-subnode-key dirent-name dirent-type dirent-props ;; Re-exports from ugarit-snapshot.scm tag-snapshot! ;; Re-exports from ugarit-archive.scm make-archive-entry archive-entry? archive-entry-key archive-entry-key-reused? archive-entry-alist archive-entry-import archive-entry-guessed-extension archive-import? archive-import-tag archive-import-key archive-import-alist tag-archive-import! search-archive list-archive-properties list-archive-property-values archive-get-entry ;; Re-exports from ugarit-vfs.scm fold-vault-node traverse-vault-node traverse-vault-path archive-entry->dirent ;; Our own novel additions, which don't fit anywhere else vault-merge-tags! ) (import scheme) (import chicken) (use ugarit-backend) (use ugarit-core) (use ugarit-streams) (use ugarit-files) (use ugarit-snapshot) (use ugarit-archive) (use ugarit-vfs) (use pathname-expand) (use sql-de-lite) (use matchable) (use lolevel) (use extras) (use tiger-hash) (use message-digest) (use stty) (use crypto-tools) (use posix) (use srfi-1) (use srfi-4) (use srfi-13) ;; ;; 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)))) ;; IDEA: 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))) ;; ;; COMPRESSION ;; (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)))))))) ;; ;; HASHING ;; ;; 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))))))) ;; ;; ENCRYPTION ;; (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)))))) ;; ;; VAULT CONSTRUCTOR ;; (define (open-vault config) (let ((*storage* #f) (*compression* #f) (*crypto* #f) (*hash* #f) (*double-check?* #f) (*cache-path* #f) (*cache* #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)) (('cache path) (set! *cache-path* path)) (('file-cache path) (set! *cache-path* path) (set! *file-cache?* #t)) (('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) (unless *cache-path* ;; Fall back to default cache path (set! *cache-path* (pathname-expand "~/.ugarit-cache"))) (begin (set! *cache* (open-database *cache-path*)) (change-file-mode *cache-path* (bitwise-ior perm/irusr perm/iwusr)) (set-busy-handler! *cache* (busy-timeout 100000)) (exec (sql *cache* "begin;"))) (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*))) (let* ((vault (make-vault config *storage* hash compress decompress encrypt decrypt ;; Cache db *cache* 0 ; Uncommitted update counter ;; File subsystem (init-file-subsystem *cache* *file-cache?*) ;; Snapshot subssytem (init-snapshot-subsystem *cache*) ;; Archive subssytem (init-archive-subsystem *cache*) *global-rules* #f ; Unset version #f ; Unset configuration alist #f)) ; Not changed yet (conf-tag (vault-tag vault "#ugarit-vault-configuration"))) (unless conf-tag ;; Create default v1 tag (receive (conf-key conf-reused?) (store-sexpr! vault '(1) 'ugarit-vault-configuration '()) (vault-flush! vault) (set! conf-tag (make-tag "#ugarit-vault-configuration" 'ugarit-vault-configuration conf-key)) (vault-set-tag! vault conf-tag) (vault-flush! vault))) ;; Check tag type (unless (eq? (tag-type conf-tag) 'ugarit-vault-configuration) (signal (make-property-condition 'exn 'location 'open-vault 'message (sprintf "The vault contains a configuration tag of type ~S when ugarit-vault-configuration was expected" (tag-type conf-tag)) 'arguments (list (tag-type conf-tag))))) ;; Read configuration block ;; This bit will throw an error if the vault's encryption or ;; hashing is set up incorrectly. (let ((configuration (handle-exceptions exn (signal (make-property-condition 'exn 'location 'open-vault 'message "Reading the vault header failed. Most likely, your hash or encryption settings are incorrect, or there is a problem with the vault.")) (read-sexpr vault (tag-key conf-tag) 'ugarit-vault-configuration)))) (match configuration (((? integer? ver) . alist) (vault-format-version-set! vault ver) (set! (vault-conf-alist vault) alist)) (else (signal (make-property-condition 'exn 'location 'open-vault 'message (sprintf "The vault contains a configuration block of the wrong format: ~S" configuration) 'arguments (list (tag-type conf-tag))))))) ;; Return the resulting vault vault)))) (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 (exec (sql (vault-cache vault) "commit;")) (close-database (vault-cache vault)) (void)) (define (vault-fork-tag! vault old-tag-name new-tag-name) (let ((old-tag (vault-tag vault old-tag-name))) (vault-set-tag! vault (make-tag new-tag-name (tag-type old-tag) (tag-key old-tag))) ;; We have created a new reference to the block ;; the tag points to, so link! it (vault-link! vault (tag-key old-tag)))) (define (vault-merge-tags! vault out-tag in-tags) (check-vault-writable vault) (let* ((tags-to-lock in-tags) (*tags-locked* '()) (unlock-tags! (lambda () (for-each (lambda (tag) (vault-unlock-tag! vault tag)) *tags-locked*)))) ;; Include output tag, unless it's already in. (when (not (member out-tag in-tags)) (set! tags-to-lock (cons out-tag tags-to-lock))) ;; FIXME: Do all this with a dynamic-wind (for-each (lambda (tag) (vault-lock-tag! vault tag) (set! *tags-locked* (cons tag *tags-locked*))) tags-to-lock) (when (not (member out-tag in-tags)) ;; Only if out-tag is not a member of in-tags, ;; ensure that it does not already exist, or we'd ;; overwrite something willy-nilly. (when (vault-tag vault out-tag) (unlock-tags!) (error 'vault-merge-tags! (sprintf "The output tag ~a already exists" out-tag)))) (for-each (lambda (tag) (unless (vault-tag vault tag) (unlock-tags!) (error 'vault-merge-tags! (sprintf "The input tag ~a does not exist" tag)))) in-tags) (let* ((in-tag-values (map (cut vault-tag vault <>) in-tags)) (in-tag-types (fold ;; Unique list of tag types (lambda (t uniques) (if (member t uniques) uniques (cons t uniques))) '() (map tag-type in-tag-values))) (_ (match in-tag-types (('archive) 'ok) (('snapshot) 'ok) (_ (unlock-tags!) (error 'vault-merge-tags! "The input tags are not all of the same type" in-tag-types)))) (out-tag-type (car in-tag-types)) (merge-block (append (map (lambda (tag) (cons 'previous (tag-key tag))) in-tag-values) (list (cons 'mtime (current-seconds)) (cons 'merge in-tags))))) (receive (import-key import-reused?) (store-sexpr! vault merge-block out-tag-type (map (lambda (tag) (cons (tag-key tag) #t)) in-tag-values)) (vault-flush! vault) (vault-set-tag! vault (make-tag out-tag out-tag-type import-key)) (unlock-tags!)))) (void)) )