(use ugarit-core) (use miscmacros) (use ugarit-backend) (use test) (use posix) (use posix-extras) (use directory-rules) (use matchable) (include "../backend-devtools.scm") ;; Test egg extensions (define-syntax test-no-errors (syntax-rules () ((_ expr) (test-no-errors (->string expr) expr)) ((_ name expr) (test name (void) (begin expr (void)))))) (define-syntax test-define (syntax-rules () ((_ var expr) (test-define (->string '(define var expr)) var expr)) ((_ name var expr) (begin (define var (void)) (test-no-errors name (set! var expr)))))) (define-syntax test-define-values (syntax-rules () ((_ (var ...) expr) (test-define-values (->string '(define-values (var ...) expr)) (var ...) expr)) ((_ name (var ...) expr) (begin (define var (void)) ... (test-no-errors name (set!-values (var ...) expr)))))) ;; Test utilities (define (test-backend w) (parameterize ((backend-log! (lambda (type message) (void)))) (test-assert "Storage writable" (storage-writable? w)) (test-assert "Storage is empty" (not ((storage-exists? w) "TEST"))) (test "Load a block" (void) ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5)) 'test)) (test-assert "Block successfully loaded" ((storage-exists? w) "TEST")) (test "Block contents reads back" (list 1 2 3 4 5) (u8vector->list ((storage-get w) "TEST"))) (let ((long-name "caeef4a6ffe0cc5e25f9966c922366ec36b2bcf0dcd40754991ffe107b49fb33")) (test "Nonexistant block with a long name reacts correctly" #f ((storage-get w) long-name)) (test "Load a block with a long name" (void) ((storage-put! w) long-name (list->u8vector (list 6 7 8 9 10)) 'test)) (test-assert "Block with a long name successfully loaded" ((storage-exists? w) long-name)) (test "Block contents with a long name reads back" (list 6 7 8 9 10) (u8vector->list ((storage-get w) long-name)))) (test "Nonexistant block reacts correctly" #f ((storage-get w) "NONEXISTANT")) (test-error "Cannot update existing blocks" ((storage-put! w) "TEST" (list->u8vector (list 1 2 3 4 5 6)) 'test)) (if (storage-unlinkable? w) (begin (test "Unlink returns data" (list 1 2 3 4 5) (u8vector->list ((storage-unlink! w) "TEST"))) (test-assert "Unlinked block is gone" (not ((storage-exists? w) "TEST"))))) (test "Set a tag" (void) ((storage-set-tag! w) "TEST" "TEST123")) (test "Tag is not locked" #f ((storage-tag-locked? w) "TEST")) (test "Lock a tag" #t ((storage-lock-tag! w) "TEST")) (test "Tag is now locked" #t ((storage-tag-locked? w) "TEST")) (test "Lock a tag again" #f ((storage-lock-tag! w) "TEST")) (test "Tag is still locked" #t ((storage-tag-locked? w) "TEST")) (test "Unlock a tag" (void) ((storage-unlock-tag! w) "TEST")) (test "Tag is no longer locked" #f ((storage-tag-locked? w) "TEST")) (test "Tag reads back" "TEST123" ((storage-tag w) "TEST")) (test "Tag list works" (list "TEST") ((storage-all-tags w))) (test "Remove tag" (void) ((storage-remove-tag! w) "TEST")) (test "Nonexistant tag is not locked" #f ((storage-tag-locked? w) "NONEXISTANT")) (test "Lock a nonexistant tag" #t ((storage-lock-tag! w) "NONEXISTANT")) (test "Nonexistant tag is now locked" #t ((storage-tag-locked? w) "NONEXISTANT")) (test "Lock a nonexistant tag again" #f ((storage-lock-tag! w) "NONEXISTANT")) (test "Nonexistant tag is still locked" #t ((storage-tag-locked? w) "NONEXISTANT")) (test "Unlock a locked nonexistant tag" (void) ((storage-unlock-tag! w) "NONEXISTANT")) (test "Nonexistant tag is no longer locked" #f ((storage-tag-locked? w) "NONEXISTANT")) (test "Close storage" (void) ((storage-close! be))))) (define (key-stream-cat a ks-hash ks-type level) (define type (vault-exists? a ks-hash)) (if (eq? type ks-type) (begin (printf "ks(~A): ~A (~A)\n" level ks-hash type) (for-each (lambda (subkey) (key-stream-cat a subkey ks-type (+ level 1))) (deserialise-key-stream (vault-get a ks-hash type)))) (printf "kleaf(~A): ~A (~A)\n" level ks-hash type))) (define (sexpr-stream-cat a ss-hash leaf-type ss-type level) (define type (vault-exists? a ss-hash)) (test-assert "sexpr stream internal consistency" (or (eq? type ss-type) (eq? type leaf-type))) (cond ((eq? type ss-type) (begin ; key stream node (printf "ss(~A): ~A (~A)\n" level ss-hash type) (for-each (lambda (subkey) (sexpr-stream-cat a subkey leaf-type ss-type (+ level 1))) (deserialise-key-stream (vault-get a ss-hash type))))) ((eq? type leaf-type) (begin ; leaf node (printf "sleaf(~A): ~A (~A)\n" level ss-hash type) (for-each (lambda (sexpr) (printf " ~A\n" sexpr)) (deserialise-sexpr-stream (vault-get a ss-hash type))))))) (define (check-dir-is-empty store-path) (test-assert "Vault is in initial state" (null? (directory store-path)))) (define (check-extract-results path plain-file1-contents plain-file2-contents) (let* ((tp (lambda (relative) (string-append path "/" relative))) (check-file (lambda (relative contents) (when contents (test (sprintf "Contents of ~s are as expected" relative) contents (with-input-from-file (tp relative) read)))))) ;; Plain file(s) (check-file "plain-file1" plain-file1-contents) (check-file "plain-file2" plain-file2-contents) ;; FIFO (test-assert "FIFO exists" (fifo? (tp "fifo"))) ;; Specials (if (zero? (current-user-id)) (begin (let* ((stats (file-stat (tp "block-special"))) (type (bitwise-and (vector-ref stats 1) stat/ifmt)) (devnum (vector-ref stats 10))) (test-assert "Block special file exists" (eq? type stat/ifblk)) (test "Block special file has correct devnum" 123 devnum)) (let* ((stats (file-stat (tp "character-special"))) (type (bitwise-and (vector-ref stats 1) stat/ifmt)) (devnum (vector-ref stats 10))) (test-assert "Character special file exists" (eq? type stat/ifchr)) (test "Character special file has correct devnum" 456 devnum)))) ;; Directory (test-assert "Directory exists" (directory? (tp "directory"))))) (define (test-vault a store-path hash-values) (let ((hash-value-0 (vector-ref hash-values 0)) (hash-value-1 (vector-ref hash-values 1))) (if (vault-unlinkable? a) (check-dir-is-empty store-path)) ; Precondition (test-group "Basic vault operations" (define test-list (list 1 2 3 4 5)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test-assert "Vault is writable" (vault-writable? a)) (test-assert "Key does not already exist" (not (vault-exists? a test-key))) (test "Data goes into vault" (void) (vault-put! a test-key test-data 'test)) (test-assert "Data now exists in vault" (vault-exists? a test-key)) (test "Data reads back" test-list (u8vector->list (vault-get a test-key 'test))) (if (vault-unlinkable? a) (begin (test "Unlink returns data" test-list (u8vector->list (vault-unlink! a test-key))) (test-assert "Unlinked data is gone" (not (vault-exists? a test-key))))) (test "Tag setting" (void) (vault-set-tag! a "TEST" test-key)) (test "Tag is not locked" #f (vault-tag-locked? a "TEST")) (test "Lock a tag" #t (vault-lock-tag! a "TEST")) (test "Tag is now locked" #t (vault-tag-locked? a "TEST")) (test-error "Lock a tag again" (vault-lock-tag! a "TEST")) (test "Tag is still locked" #t (vault-tag-locked? a "TEST")) (test "Unlock a tag" (void) (vault-unlock-tag! a "TEST")) (test "Tag is no longer locked" #f (vault-tag-locked? a "TEST")) (test "Tag reading" test-key (vault-tag a "TEST")) (test "Tag listing" (list "TEST") (vault-all-tags a)) (test "Tag removal" (void) (vault-remove-tag! a "TEST")) (if (vault-unlinkable? a) (check-dir-is-empty store-path))) (test-group "0-element key stream" (define test-list (list 1 2 3 4 5 6)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks)) (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw))) (test-assert "Key stream did not already exist" (not ks-reused?)) (test "Correct hash" hash-value-0 ks-hash) (test "Key stream reads back OK" '() (fold-key-stream a ks-hash 'test-ks cons '())) (if (vault-unlinkable? a) (begin (test-assert (vault-unlink! a ks-hash)) (check-dir-is-empty store-path)))) (test-group "1-element key stream...\n" (define test-list (list 1 2 3 4 5 6 7)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks)) (test "Store a block into the vault" (void) (vault-put! a test-key test-data 'test)) (test "Insert hash into key stream" (void) ((key-stream-writer-write! ksw) test-key #f)) (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw))) (test-assert "Key stream did not already exist" (not ks-reused?)) (test "Correct hash" test-key ks-hash) (test "Correct result from reading back key stream" (list (cons test-key 'test)) (fold-key-stream a ks-hash 'test-ks (lambda (key type acc) (cons (cons key type) acc)) '())) (if (vault-unlinkable? a) (begin (test-assert (vault-unlink! a test-key)) (check-dir-is-empty store-path)))) (test-group "2-element key stream...\n" (define test-list (list 1 2 3 4 5 6 7 8)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks)) (test "Store a block into the vault" (void) (vault-put! a test-key test-data 'test)) (test "Insert hash 1 into key stream" (void) ((key-stream-writer-write! ksw) test-key #f)) (test "Insert hash 2 into key stream" (void) ((key-stream-writer-write! ksw) test-key #t)) (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw))) (test-assert "Key stream did not already exist" (not ks-reused?)) (test-assert "Key stream now exists" (vault-exists? a ks-hash)) (test "Correct result from reading back key stream" (list (cons test-key 'test) (cons test-key 'test)) (fold-key-stream a ks-hash 'test-ks (lambda (key type acc) (cons (cons key type) acc)) '())) (if (vault-unlinkable? a) (begin (test-assert (vault-unlink! a ks-hash)) (test-assert (not (vault-unlink! a test-key))) (test-assert (vault-unlink! a test-key)) (check-dir-is-empty store-path)))) (define iterations 1024) (test-group (sprintf "~a-element key stream..." iterations) (define test-list (list 1 2 3 4 5 6 7 8 9)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test-define "Create key-stream writer" ksw (make-key-stream-writer* a 'test-ks)) (test "Store a block into the vault" (void) (vault-put! a test-key test-data 'test)) (test "Insert hash 1 into key stream" (void) ((key-stream-writer-write! ksw) test-key #t)) ; Ensure one reference is left at the end (test "Insert more hashes into key stream" (void) (dotimes (iter iterations) ((key-stream-writer-write! ksw) test-key #t))) (test-define-values "Close key-stream writer" (ks-hash ks-reused?) ((key-stream-writer-finish! ksw))) (test-assert "Key stream did not already exist" (not ks-reused?)) (test-assert "Key stream now exists" (vault-exists? a ks-hash)) (test-define "Key stream reads back OK" keys (fold-key-stream a ks-hash 'test-ks (lambda (key type acc) (cons (cons key type) acc)) '())) (test "Correct number of keys come back" (+ 1 iterations) (length keys)) (test-assert "Correct keys come back" (every (lambda (key) (string=? (car key) test-key)) keys)) (if (vault-unlinkable? a) (begin (test "Unlink key stream" (void) (unlink-key-stream! a ks-hash 'test-ks (lambda (vault key type) (test-assert "Unlink non-final block" (not (vault-unlink! vault key)))))) (test-assert "Unlink final block" (vault-unlink! a test-key)) (check-dir-is-empty store-path)))) (test-group "0-element sexpr stream" (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti)) (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw))) (test-assert "Sexpr stream did not already exist" (not ss-reused?)) (test "Correct hash" hash-value-1 ss-hash) (test "Sexpr stream reads back OK" '() (fold-sexpr-stream a ss-hash 't 'ti cons '())) (if (vault-unlinkable? a) (begin (test-assert (vault-unlink! a ss-hash)) (check-dir-is-empty store-path)))) (test-group "1-element sexpr stream" (define test-list (list 1 2 3 4 5 6 7 8 9 10 11)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti)) (test "Write to sexpr stream" (void) ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))) (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw))) (test-assert "Sexpr stream did not already exist" (not ss-reused?)) (test "Sexpr stream reads back OK" `((foo ,test-key)) (fold-sexpr-stream a ss-hash 't 'ti cons '())) (if (vault-unlinkable? a) (begin (test "Unlink sexpr stream" (void) (unlink-sexpr-stream! a ss-hash 't 'ti (lambda (sexpr) (test "Correct entry read back" `(foo ,test-key) (identity sexpr)) (test "Unlink entry" #f (vault-unlink! a test-key))))) (test-assert "Sexpr stream is gone" (not (vault-exists? a ss-hash))) (test-assert "Test block is gone" (not (vault-exists? a test-key))) (check-dir-is-empty store-path)))) (test-group "2-element sexpr stream" (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test "Vault write" (void) (vault-put! a test-key test-data 'test)) (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti)) (test "Write to sexpr stream" (void) ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f)))) (test "Write to sexpr stream" (void) ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #t)))) (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw))) (test-assert "Sexpr stream did not already exist" (not ss-reused?)) (test "Sexpr stream reads back OK" `((foo ,test-key) (foo ,test-key)) (fold-sexpr-stream a ss-hash 't 'ti cons '())) (if (vault-unlinkable? a) (begin (define unlinks 0) (test "Unlink sexpr stream" (void) (unlink-sexpr-stream! a ss-hash 't 'ti (lambda (sexpr) (test "Correct entry read back" `(foo ,test-key) (identity sexpr)) (test (sprintf "Unlink entry ~a" unlinks) (if (zero? unlinks) #f test-data) (vault-unlink! a test-key)) (set! unlinks (+ unlinks 1))))) (test-assert "Sexpr stream is gone" (not (vault-exists? a ss-hash))) (test-assert "Test block is gone" (not (vault-exists? a test-key))) (check-dir-is-empty store-path)))) (test-group (sprintf "~A-element sexpr stream" iterations) (define test-list (list 1 2 3 4 5 6 7 8 9 10 11 12 13)) (define test-data (list->u8vector test-list)) (test-define "Vault hash" test-key ((vault-hash a) test-data 'test)) (test "Vault write" (void) (vault-put! a test-key test-data 'test)) (test-define "Create sexpr-stream writer" ssw (make-sexpr-stream-writer* a 't 'ti)) ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #f))) (dotimes (iter iterations) (test "Write to sexpr stream" (void) ((sexpr-stream-writer-write! ssw) `(foo ,test-key) (list (cons test-key #t))))) (test-define-values "Close sexpr-stream writer" (ss-hash ss-reused?) ((sexpr-stream-writer-finish! ssw))) (test-assert "Sexpr stream did not already exist" (not ss-reused?)) (test-define "Sexpr stream reads back OK" sexprs (fold-sexpr-stream a ss-hash 't 'ti cons '())) (test "Correct number of sexprs read back" (+ 1 iterations) (length sexprs)) (test-assert "Correct sexprs read back" (every (lambda (sexpr) (equal? sexpr `(foo ,test-key))) sexprs)) (if (vault-unlinkable? a) (begin (define unlinks 0) (test "Unlink sexpr stream" (void) (unlink-sexpr-stream! a ss-hash 't 'ti (lambda (sexpr) (test "Correct entry read back" `(foo ,test-key) (identity sexpr)) (test (sprintf "Unlink entry ~a" unlinks) (if (< unlinks iterations) #f test-data) (vault-unlink! a test-key)) (set! unlinks (+ unlinks 1))))) (test-assert "Sexpr stream is gone" (not (vault-exists? a ss-hash))) (test-assert "Test block is gone" (not (vault-exists? a test-key))) (check-dir-is-empty store-path)))) (test-group "Files" (define test-string "Lorem ipsum dolor sit amet, consectetur adipisicing elit, sed do eiusmod tempor incididunt ut labore et dolore magna aliqua. Ut enim ad minim veniam, quis nostrud exercitation ullamco laboris nisi ut aliquip ex ea commodo consequat. Duis aute irure dolor in reprehenderit in voluptate velit esse cillum dolore eu fugiat nulla pariatur. Excepteur sint occaecat cupidatat non proident, sunt in culpa qui officia deserunt mollit anim id est laborum.") (test-define-values "Store a file" (file-key file-reused?) (with-input-from-string test-string (lambda () (store-file! a "/test-file" (vector 0 0 0 0 0 0 0 0 0 0 0 0 0))))) (test "Read it back" test-string (with-output-to-string (lambda () (write-file-contents a file-key)))) (if (vault-unlinkable? a) (begin (test "Delete the file" (void) (unlink-file! a file-key)) (check-dir-is-empty store-path)))) (test-group "Directories" (let* ((test-dir (string-append store-path "-test-data")) (extract1-dir (string-append store-path "-test-extract1")) (extract2-dir (string-append store-path "-test-extract2")) (extract3-dir (string-append store-path "-test-extract3")) (extract4-dir (string-append store-path "-test-extract4")) (tp (lambda (relative) (string-append test-dir "/" relative)))) (create-directory test-dir) (with-output-to-file (tp "plain-file1") (lambda () (write "Hello world"))) (create-fifo (tp "fifo")) ;; These two need root! (if (zero? (current-user-id)) (begin (create-special-file (tp "block-special") stat/ifblk 123) (create-special-file (tp "character-special") stat/ifchr 456))) (create-directory (tp "directory")) ;; Dump it (test-define-values "Store a directory" (dir1-key dir1-reused? files bytes) (call-with-context-support (vault-global-directory-rules a) (lambda () (store-directory! a test-dir)))) (create-directory extract1-dir) ; FIXME: Set up a progress callback that counts the ; bytes and files and checks they match the ; directory metadata in the vault on every extract (test "Extract a directory" (void) (extract-directory! a dir1-key extract1-dir)) (check-extract-results extract1-dir "Hello world" #f) ;; Now add an extra file and dump again (with-output-to-file (tp "plain-file2") (lambda () (write "Hello world 2"))) (test-define-values "Store a directory again" (dir2-key dir2-reused? dir2-files dir2-bytes) (call-with-context-support (vault-global-directory-rules a) (lambda () (store-directory! a test-dir)))) (test-assert "Changed directory is not reused" (not dir2-reused?)) (create-directory extract2-dir) (test "Extract a directory" (void) (extract-directory! a dir2-key extract2-dir)) (check-extract-results extract2-dir "Hello world" "Hello world 2") ;; Now change an existing file and dump again (with-output-to-file (tp "plain-file1") (lambda () (write "Hello world again!"))) (test-define-values "Store a directory again" (dir3-key dir3-reused? dir3-files dir3-bytes) (call-with-context-support (vault-global-directory-rules a) (lambda () (store-directory! a test-dir)))) (test-assert "Changed directory is not reused" (not dir3-reused?)) (create-directory extract3-dir) (test "Extract a directory" (void) (extract-directory! a dir3-key extract3-dir)) (check-extract-results extract3-dir "Hello world again!" "Hello world 2") ;; Now make no changes and dump again (test-define-values "Store a directory again" (dir4-key dir4-reused? dir4-files dir4-bytes) (call-with-context-support (vault-global-directory-rules a) (lambda () (store-directory! a test-dir)))) (test-assert "Unchanged directory is reused" dir4-reused?) (test "Mark reused directory" (void) (vault-link! a dir4-key)) (create-directory extract4-dir) (test "Extract a directory" (void) (extract-directory! a dir4-key extract4-dir)) (check-extract-results extract4-dir "Hello world again!" "Hello world 2") ;; Tidy up (if (vault-unlinkable? a) (begin (test "Delete the first directory" (void) (unlink-directory! a dir1-key)) (check-extract-results extract2-dir "Hello world" "Hello world 2") (test "Delete the second directory" (void) (unlink-directory! a dir2-key)) (check-extract-results extract3-dir "Hello world again!" "Hello world 2") (test "Delete the third directory" (void) (unlink-directory! a dir3-key)) (check-extract-results extract4-dir "Hello world again!" "Hello world 2") (test "Delete the fourth directory" (void) (unlink-directory! a dir4-key)) (check-dir-is-empty store-path))))) (test-group "Snapshots" (let ((test-job (make-job #f #t))) (parameterize ((current-job test-job)) (let* ((test-dir (string-append store-path "-test-data"))) (test-define-values "Store a directory" (dir-key dir-reused? dir-files dir-bytes) (call-with-context-support (vault-global-directory-rules a) (lambda () (store-directory! a test-dir)))) (if (vault-unlinkable? a) (test-assert "Directory was not reused" (not dir-reused?))) (test-define-values "Tag it as a snapshot" (sk1) (tag-snapshot! a "Test" dir-key dir-reused? (list) test-job)) (test-define-values "Store the directory again" (dir2-key dir2-reused? dir2-files dir2-bytes) (call-with-context-support (vault-global-directory-rules a) (lambda () (store-directory! a test-dir)))) (test-assert "Directory was reused" dir2-reused?) (test-assert "Directory has the same key" (string=? dir-key dir2-key)) (test "Log a message" (void) (job-log! 'info #f "This is a test")) (test-define-values "Tag it as a snapshot" (sk2) (tag-snapshot! a "Test" dir2-key dir2-reused? (list) test-job)) (test-define-values "Read the tag back" (tag2) (vault-tag a "Test")) (test-define-values "Walk the history with fold-history" (result) (fold-history a tag2 (lambda (snapshot-key snapshot acc) (cons snapshot acc)) '())) (test-assert "History has expected form" (match result (((('previous . sk1*) ('mtime . _) ('contents . dir2-key*) ('stats . _) ('log . (('info _ #f "This is a test")))) (('mtime . _) ('contents . dir-key*) ('stats . _) ('log))) (and (string=? sk1 sk1*) (string=? dir2-key dir2-key*) (string=? dir-key dir-key*))) (else #f))) (test-define-values "Walk the tag list with fold-vault-node" (root) (fold-vault-node a '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '())) (test-assert "Root listing has expected form" (match root (((('tag . "Test") "Test" 'tag ('current . sk2*) ('locked . #f))) (string=? sk2 sk2*)) (else #f))) (test-define-values "Walk the history of tag 'Test' with fold-vault-node" (tag) (fold-vault-node a '(tag . "Test") (lambda (name dirent acc) (cons (cons name dirent) acc)) '())) (test-assert "Tag history has expected form" (match tag (((sk-c* "current" 'snapshot ('previous . sk1*) ('mtime . _) ('contents . dir-key*) ('stats . _) ('log . (('info _ #f "This is a test")))) (sk-c** _ 'snapshot ('previous . sk1**) ('mtime . _) ('contents . dir-key**) ('stats . _) ('log . (('info _ #f "This is a test")))) (sk-c*** _ 'snapshot ('mtime . _) ('contents . dir-key***) ('stats . _) ('log))) (and (string=? sk1 sk1*) (string=? sk2 sk-c*) (string=? dir-key dir-key*) (string=? sk1 sk1**) (string=? sk2 sk-c**) (string=? dir-key dir-key**) (string=? sk1 sk-c***) (string=? dir-key dir-key***))) (else #f))) (test-define-values "Walk the snapshot metadata directory with fold-vault-node" (snapshot-meta) (fold-vault-node a sk1 (lambda (name dirent acc) (cons (cons name dirent) acc)) '())) (test-assert "Snapshot metadata has the expected form" (match snapshot-meta (((dir-key* "contents" 'dir ('mtime . _) ('contents . dir-key**) ('stats . _) ('log))) (and (string=? dir-key dir-key*) (string=? dir-key dir-key**))) (else #f))) (test-define-values "Walk the root directory with fold-vault-node" (dir) (fold-vault-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '())) (if (zero? (current-user-id)) (test-assert "Directory listing has the expected form (as root)" (match dir (((#f "block-special" 'block-device (number . 123) . _) (#f "character-special" 'character-device (number . 456) . _) (_ "directory" 'dir . _) (#f "fifo" 'fifo . _) (#f "plain-file1" 'file . _) (#f "plain-file2" 'file . _)) #t) (else #f))) (test-assert "Directory listing has the expected form (not as root)" (match dir (((_ "directory" 'dir . _) (#f "fifo" 'fifo . _) (#f "plain-file1" 'file . _) (#f "plain-file2" 'file . _)) #t) (else #f)))) (test-group "Path traversals" (test "()" '(() "/" root) (traverse-vault-path a '())) (test "(.)" '(() "/" root) (traverse-vault-path a '("."))) (test-assert "(\"Test\")" (match (traverse-vault-path a '("Test")) ((('tag . "Test") "Test" 'tag ('current . sk2*) ('locked . #f)) (and (string=? sk2 sk2*))) (else #f))) (test-assert "(\"Test\" .)" (match (traverse-vault-path a '("Test" ".")) ((('tag . "Test") "Test" 'tag ('current . sk2*) ('locked . #f)) (and (string=? sk2 sk2*))) (else #f))) (test "(\"Test\" ..)" '(() "/" root) (traverse-vault-path a '("Test" ".."))) (test-assert "(\"Test\" \"current\")" (match (traverse-vault-path a '("Test" "current")) ((sk2* "current" 'snapshot ('previous . sk1*) ('mtime . _) ('contents . dk2*) ('stats . _) ('log . _)) (and (string=? sk1 sk1*) (string=? sk2 sk2*) (string=? dir-key dk2*))) (else #f))) (test-assert "(\"Test\" \"current\" \"contents\")" (match (traverse-vault-path a '("Test" "current" "contents")) ((dk2* "contents" 'dir ('previous . sk1*) ('mtime . _) ('contents . dk2**) ('stats . _) ('log . _)) (and (string=? sk1 sk1*) (string=? dir-key dk2*) (string=? dir-key dk2**))) (else #f))) (test-assert "(\"Test\" \"current\" \"contents\" \"directory\")" (match (traverse-vault-path a '("Test" "current" "contents" "directory")) ((sdk2* "directory" 'dir ('contents . sdk2**) ('files . 0) ('size . 0) ('mode . 493) ('uid . _) ('gid . _) ('mtime . _)) #t) (else #f))) (test-assert "(\"Test\" \"current\" \"contents\" \"plain-file1\")" (match (traverse-vault-path a '("Test" "current" "contents" "plain-file1")) ((#f "plain-file1" 'file ('contents . pfk1*) ('size . 20) ('mode . 420) ('uid . _) ('gid . _) ('mtime . _)) #t) (else #f)))))))) "This vault seems to work!")) ;; A more detailled tests of the snapshot/unlink/extract algorithms (define (test-vault-algorithms a store-path) ;; FIXME: Write a procedure that reads a directory tree from disk ;; and creates an s-expression description of it, omitting ;; irrelevant things like atimes, but including symlink ;; targets, file contents as a string, fifos/devices/etc, ;; uid/gid, permissions. ;; Set up a test directory with some sample objects in, ;; including at least one huge file that will be multiple ;; blocks (based on the storage block size, which should be ;; dialled down for this test). ;; Test group: snapshotting ;; Snapshot it, modify it, snapshot it again, and so on to ;; create a snapshot chain. ;; Fork the snapshot chain and diverge the forks somewhat. ;; Test group: extraction ;; Then extract every single snapshot and generate a ;; s-expression representation of each and test-equal them to ;; their expected state. ;; Test group: Unlinked snapshots ;; Unlink a few of the snapshots. Test that ;; fold-snapshot-history still works. Test that attempting ;; to extract missing snapshots errors as expected. Test ;; that all the other snapshots extract OK. ;; Test group: Missing blocks ;; Unlink a single block from the large multi-block file, and ;; attempt to extract affected snapshots. Check we get the ;; error message, and a file with gaps in. ;; Unlink an entire file and attempt to extract affected ;; snapshots. Check for error message and missing file. ;; Unlink a directory block and, again, extract and check for ;; errors and missing subdirectory. (void) ) ;; Actual Tests (if (directory? "./tmp") (delete-directory "./tmp" #t)) (create-directory "./tmp") (test-group "Filesystem backend" (create-directory "./tmp/be1") (test-define "Open storage" be (import-storage "backend-fs fs ./tmp/be1")) (test-backend be)) (test-group "Splitlog backend" (create-directory "./tmp/be3") (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata")) (test "Set max file size to 1024" '((result . "Done")) ((storage-admin! be) '(set-max-logfile-size! 1024))) (test-backend be)) (test-group "Limited cached splitlog backend" (create-directory "./tmp/be4") (test-define "Open storage" be (import-storage "backend-cache ./tmp/be4-cache \"backend-fs splitlog ./tmp/be4 ./tmp/be4/metadata\"")) (test-define "Wrap in block-limiter" lbe (backend-limit-block-size be 1024)) (test-backend lbe)) (define tiger-hash-values (vector "947020be151022522aec2a98293963156059a7553655fe5a" "ffe0058890b682d7b3da062284635df245d7e209d8a23dee")) (test-group "Filesystem backend vault" (create-directory "./tmp/be5") (test-define "Open vault" be (open-vault '((storage "backend-fs fs ./tmp/be5")))) (test-vault be "./tmp/be5" tiger-hash-values) (test "Close vault" (void) (vault-close! be))) (test-group "Filesystem backend vault plus file cache" (create-directory "./tmp/be6") (test-define "Open vault" be (open-vault '((storage "backend-fs fs ./tmp/be6") (file-cache "./tmp/be6-file-cache")))) (test-vault be "./tmp/be6" tiger-hash-values) (test "Close vault" (void) (vault-close! be))) (test-group "Splitlog backend vault" (create-directory "./tmp/be7") (test-define "Open vault" be (open-vault '((storage "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata")))) (test "Set max file size to 1024" '((result . "Done")) (vault-admin! be '(set-max-logfile-size! 1024))) (test-vault be "./tmp/be7" tiger-hash-values) (test "Close vault" (void) (vault-close! be))) (test-group "Splitlog backend vault plus file cache" (create-directory "./tmp/be8") (test-define "Open vault" be (open-vault '((storage "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata") (file-cache "./tmp/be8-file-cache")))) (test "Set max file size to 1024" '((result . "Done")) (vault-admin! be '(set-max-logfile-size! 1024))) (test-vault be "./tmp/be8" tiger-hash-values) (test "Close vault" (void) (vault-close! be))) ; FIXME: Tests disabled as part of [92f88fa27a] #;(test-group "TEST TEST" (create-directory "./tmp/be2") (test-define "Open vault" be (open-vault '((storage "backend-fs splitlog ./tmp/be2 ./tmp/be2/metadata") (file-cache "./tmp/be9-file-cache")))) (test-vault be "./tmp/be2" tiger-hash-values) (test "Close vault" (void) (vault-close! be))) #;(test-group "sha256" (create-directory "./tmp/be9") (test-define "Open vault" be (open-vault '((storage "backend-log -v ./tmp/be9.log \"backend-fs splitlog ./tmp/be9 ./tmp/be9/metadata\"") (file-cache "./tmp/be9-file-cache") (hash sha256)))) (test-vault be "./tmp/be9" (vector "caeef4a6ffe0cc5e25f9966c922366ec36b2bcf0dcd40754991ffe107b49fb33" "96fac35dac30143182f1f73579c4f5a1826e7e5562823a944ca9eda54bc523e6")) (test "Close vault" (void) (vault-close! be))) #;(test-group "sha256 key" (create-directory "./tmp/be10") (test-define "Open vault" be (open-vault '((storage "backend-fs splitlog ./tmp/be10 ./tmp/be10/metadata") (file-cache "./tmp/be10-file-cache") (hash sha256 "Hello World")))) (test-vault be "./tmp/be10" (vector "4d4b44fbb607ce4c7234de11689879c90824feb8def822cfc2efc20f9c7dda33" "f9f910ebc758d4c33d4f558c6e088b4851b0320b548001a43521ecb2d9a55d46")) (test "Close vault" (void) (vault-close! be))) ;; FIXME: Progress callback tests (test-group "Command line interface tests" (let* ((vault-dir "./tmp/cli-vault") (data-dir "./tmp/cli-data") (extract1-dir "./tmp/cli-extract1") (extract2-dir "./tmp/cli-extract2") (ugarit-conf-file (string-append vault-dir "/ugarit.conf")) (tp (lambda (file) (string-append data-dir "/" file)))) (create-directory vault-dir) (create-directory data-dir) (create-directory extract1-dir) (create-directory extract2-dir) ;; FIXME: Put in some .ugarit files, too! (with-output-to-file (tp "plain-file") (lambda () (printf "Hello, world!\n"))) (with-output-to-file ugarit-conf-file (lambda () (write `(storage ,(string-append "backend-fs splitlog " vault-dir " " vault-dir "/metadata.sqlite"))) (newline))) (test "Snapshot" 0 (system (string-append "ugarit snapshot " ugarit-conf-file " test " data-dir))) ;; FIXME ;; Restore it ;; Fork it and restore the fork to check it worked ;; Test explore mode somehow? )) (printf "Final count of failures: ~a\n" (test-failure-count)) (test-exit)