(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)
   (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")))
   (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 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")))

(define (key-stream-cat a ks-hash ks-type level)
   (define type (archive-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 (archive-get a ks-hash))))
      (printf "kleaf(~A): ~A (~A)\n" level ks-hash type)))

(define (sexpr-stream-cat a ss-hash leaf-type ss-type level)
   (define type (archive-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 (archive-get a ss-hash)))))
      ((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 (archive-get a ss-hash)))))))

(define (check-dir-is-empty store-path)
   (test-assert "Archive 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-archive a store-path)
   (if (archive-unlinkable? a)
      (check-dir-is-empty store-path)) ; Precondition

   (test-group "Basic archive operations"
	       (define test-list (list 1 2 3 4 5))
	       (define test-data (list->u8vector test-list))
	       (test-define "Archive hash" test-key ((archive-hash a) test-data 'test))
	       (test-assert "Archive is writable" (archive-writable? a))
	       (test-assert "Key does not already exist" (not (archive-exists? a test-key)))
	       (test "Data goes into archive" (void) (archive-put! a test-key test-data 'test))
	       (test-assert "Data now exists in archive" (archive-exists? a test-key))
	       (test "Data reads back" test-list (u8vector->list (archive-get a test-key)))

	       (if (archive-unlinkable? a)
		   (begin
		     (test "Unlink returns data" test-list (u8vector->list (archive-unlink! a test-key)))
		     (test-assert "Unlinked data is gone" (not (archive-exists? a test-key)))))
	       (test "Tag setting" (void) (archive-set-tag! a "TEST" test-key))
	       (test "Tag reading" test-key (archive-tag a "TEST"))
	       (test "Tag listing" (list "TEST") (archive-all-tags a))
	       (test "Tag removal" (void) (archive-remove-tag! a "TEST"))
	       (if (archive-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 "Archive hash" test-key ((archive-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"  "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3test-ks" ks-hash)
	       (test "Key stream reads back OK" '() (fold-key-stream a ks-hash 'test-ks cons '()))

	       (if (archive-unlinkable? a)
		   (begin
		     (test-assert (archive-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 "Archive hash" test-key ((archive-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 archive" (void) (archive-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 (archive-unlinkable? a)
		   (begin
		     (test-assert (archive-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 "Archive hash" test-key ((archive-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 archive" (void) (archive-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" (archive-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 (archive-unlinkable? a)
		   (begin
		     (test-assert (archive-unlink! a ks-hash))
		     (test-assert (not (archive-unlink! a test-key)))
		     (test-assert (archive-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 "Archive hash" test-key ((archive-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 archive" (void) (archive-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" (archive-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 (archive-unlinkable? a)
		   (begin
		     (test "Unlink key stream" (void)
			   (unlink-key-stream! a ks-hash 'test-ks
					       (lambda (archive key type)
						 (test-assert "Unlink non-final block" (not (archive-unlink! archive key))))))
		     (test-assert "Unlink final block" (archive-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"  "3293ac630c13f0245f92bbb1766e16167a4e58492dde73f3t" ss-hash)
	       (test "Sexpr stream reads back OK" '() (fold-sexpr-stream a ss-hash 't 'ti cons '()))

	       (if (archive-unlinkable? a)
		   (begin
		     (test-assert (archive-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 "Archive hash" test-key ((archive-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 (archive-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 (archive-unlink! a test-key)))))
		     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
		     (test-assert "Test block is gone" (not (archive-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 "Archive hash" test-key ((archive-hash a) test-data 'test))
	       (test "Archive write" (void) (archive-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 (archive-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) (archive-unlink! a test-key))
						   (set! unlinks (+ unlinks 1)))))
		     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
		     (test-assert "Test block is gone" (not (archive-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 "Archive hash" test-key ((archive-hash a) test-data 'test))
	       (test "Archive write" (void) (archive-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 (archive-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) (archive-unlink! a test-key))
						   (set! unlinks (+ unlinks 1)))))
		     (test-assert "Sexpr stream is gone" (not (archive-exists? a ss-hash)))
		     (test-assert "Test block is gone" (not (archive-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 (archive-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?)
				     (call-with-context-support
				      (archive-global-directory-rules a)
				      (lambda ()
				       (store-directory! a test-dir))))

		 (create-directory extract1-dir)

		 (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?)
				     (call-with-context-support
				      (archive-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?)
				     (call-with-context-support
				      (archive-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?)
				     (call-with-context-support
				      (archive-global-directory-rules a)
				      (lambda ()
				       (store-directory! a test-dir))))

		 (test-assert "Unchanged directory is reused" dir4-reused?)
                 (test "Mark reused directory" (void) (archive-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 (archive-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-dir (string-append store-path "-test-data")))
                 (test-define-values "Store a directory" (dir-key dir-reused?)
                                     (call-with-context-support
                                      (archive-global-directory-rules a)
                                      (lambda ()
                                        (store-directory! a test-dir))))

                 (if (archive-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-define-values "Store the directory again" (dir2-key dir2-reused?)
                                     (call-with-context-support
                                      (archive-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-define-values "Tag it as a snapshot" (sk2)
                                     (tag-snapshot! a "Test" dir2-key dir2-reused? (list)))

                 (test-define-values "Walk the history with fold-history" (result)
                                     (fold-history a (archive-tag a "Test")
                                                   (lambda (snapshot-key snapshot acc)
                                                     (cons snapshot acc))
                                                   '()))
                 (test-assert "History has expected form"
                              (match result
                                     (((('previous . sk1*)
                                        ('mtime . _)
                                        ('contents . dir2-key*))
                                       (('mtime . _)
                                        ('contents . dir-key*)))
                                      (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-archive-node" (root)
                                     (fold-archive-node a '() (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
                 (test-assert "Root history has expected form"
                              (match root
                                     (((('tag . "Test")
                                        "Test"
                                        'tag
                                        ('current . sk2*)))
                                      (string=? sk2 sk2*))
                                     (else #f)))
                 (test-define-values "Walk the history of tag 'Test' with fold-archive-node" (tag)
                                     (fold-archive-node a '(tag . "Test") (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
                 (test-assert "Tag history has expected form"
                              (match tag
                                     (((dir-key-c*
                                        "current"
                                        'snapshot
                                        ('previous . sk1*)
                                        ('mtime . _)
                                        ('contents . dir-key*))
                                       (dir-key-c**
                                        _
                                        'snapshot
                                        ('previous . sk1**)
                                        ('mtime . _)
                                        ('contents . dir-key**))
                                       (dir-key-c***
                                        _
                                        'snapshot
                                        ('mtime . _)
                                        ('contents . dir-key***)))
                                      (and
                                       (string=? sk1 sk1*)
                                       (string=? dir-key dir-key-c*)
                                       (string=? dir-key dir-key*)
                                       (string=? sk1 sk1**)
                                       (string=? dir-key dir-key-c**)
                                       (string=? dir-key dir-key**)
                                       (string=? dir-key dir-key-c***)
                                       (string=? dir-key dir-key***)))
                                     (else #f)))
                 (test-define-values "Walk the root directory with fold-archive-node" (dir)
                                     (fold-archive-node a dir-key (lambda (name dirent acc) (cons (cons name dirent) acc)) '()))
                 ; FIXME: Write a giant match to match this bad boy...
                 (if (zero? (current-user-id))
                     (test-assert "Directory history 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 history 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))))))

   "This archive seems to work!")

;; 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 "Close storage" (void) ((storage-close! be))))

(test-group "Splitlog backend"
 (create-directory "./tmp/be3")
 (test-define "Open storage" be (import-storage "backend-fs splitlog ./tmp/be3 ./tmp/be3/metadata 1024"))
 (test-backend be)
 (test "Close storage" (void) ((storage-close! 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 1024\""))
 (test-define "Wrap in block-limiter" lbe (backend-limit-block-size be 1024))
 (test-backend lbe)
 (test "Close storage" (void) ((storage-close! lbe))))

(test-group "Filesystem backend archive"
 (create-directory "./tmp/be5")
 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be5")) #f #t))
 (test-archive be "./tmp/be5")
 (test "Close archive" (void) (archive-close! be)))

(test-group "Filesystem backend archive plus file cache"
 (create-directory "./tmp/be6")
 (test-define "Open archive" be (open-archive '((storage "backend-fs fs ./tmp/be6") (file-cache "./tmp/be6-file-cache")) #f #t))
 (test-archive be "./tmp/be6")
 (test "Close archive" (void) (archive-close! be)))

(test-group "Splitlog backend archive"
 (create-directory "./tmp/be7")
 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be7 ./tmp/be7/metadata 1024")) #f #t))
 (test-archive be "./tmp/be7")
 (test "Close archive" (void) (archive-close! be)))

(test-group "Splitlog backend archive plus file cache"
 (create-directory "./tmp/be8")
 (test-define "Open archive" be (open-archive '((storage  "backend-fs splitlog ./tmp/be8 ./tmp/be8/metadata 1024") (file-cache "./tmp/be8-file-cache")) #f #t))
 (test-archive be "./tmp/be8")
 (test "Close archive" (void) (archive-close! be)))

(printf "Final count of failures: ~a\n" (test-failure-count))

(test-exit)