#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code

# This test assumes `TESTS_ENVIRONMENT' set up Guile's search path
# correctly.

# Export this before launching Guile so it can be used as the
# compilation cache.
XDG_CACHE_HOME="$builddir/backup-cache"
export XDG_CACHE_HOME

exec ${GUILE:-guile} -L "$top_builddir/utils" \
  -l "$0" -c "(apply $main (cdr (command-line)))" "$@"
!#
;;; Copyright (C) 2012  Ludovic Courtès <ludo@gnu.org>
;;;
;;; Libchop is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation, either version 3 of the License, or
;;; (at your option) any later version.
;;;
;;; Libchop is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with libchop.  If not, see <http://www.gnu.org/licenses/>.

(define-module (backup-test)
  #:use-module (chop-backup)
  #:use-module (chop tests)
  #:use-module (chop core)
  #:use-module (chop objects)
  #:use-module (chop streams)
  #:use-module (chop stores)
  #:use-module (chop indexers)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports))

;; Some tests check error messages.
(setlocale LC_ALL "C")


;;;
;;; Helpers.
;;;

(define %top-srcdir
  (or (getenv "top_srcdir")
      (error "please define $top_srcdir")))

(define %test-dir
  (temporary-file-name))

(mkdir %test-dir)

(define %include-dir
  (string-append %top-srcdir "/include"))

(define (directory-entry=stat? entry name stat)
  "Return #t when ENTRY is equivalent to NAME + STAT."
  (and (string=? (basename name)
                 (directory-entry-name entry))
       (= (stat:perms stat)
          (directory-entry-permissions entry))
       (= (stat:size stat)
          (directory-entry-size entry))
       (eq? (stat:type stat)
            (directory-entry-kind entry))))


(test-begin "run-storage-pipeline")

(test-assert "retrievable"
  (with-temporary-store
   (lambda (store)
     (let* ((bv     (make-random-bytevector (random-file-size)))
            (input  (mem-stream-open bv))
            (index  (run-storage-pipeline %default-storage-pipeline
                                          input store))
            (tuple  (pipeline-index-handle->tuple %default-storage-pipeline
                                                  index))
            (retr   (index-tuple->retriever tuple))
            (output (get-bytevector-all (retr store))))
       (bytevector=? bv output)))))

(test-assert "verify: ok"
  (with-temporary-store
   (lambda (store)
     (let* ((bv     (make-random-bytevector (random-file-size)))
            (input  (mem-stream-open bv))
            (index  (run-storage-pipeline %default-storage-pipeline
                                          input store))
            (tuple  (pipeline-index-handle->tuple %default-storage-pipeline
                                                  index))
            (verify (index-tuple->verifier tuple)))
       (eq? 'ok (verify store))))))

(test-assert "verify: missing"
  (with-temporary-store
   (lambda (store)
     (let* ((bv     (make-random-bytevector (random-file-size)))
            (input  (mem-stream-open bv))
            (index  (run-storage-pipeline %default-storage-pipeline
                                          input store))
            (tuple  (pipeline-index-handle->tuple %default-storage-pipeline
                                                  index))
            (verify (index-tuple->verifier tuple)))
       ;; XXX: Use `block-indexer-delete-block' when it exists.
       (store-delete-block store (index-handle->block-key index))
       (eq? 'missing (verify store))))))

(test-assert "repair root block"
  ;; Same as above, and repair the root block.
  (with-temporary-store
   (lambda (store)
     (let* ((bv     (make-random-bytevector (random-file-size)))
            (input  (mem-stream-open bv))
            (index  (run-storage-pipeline %default-storage-pipeline
                                          input store))
            (tuple  (pipeline-index-handle->tuple %default-storage-pipeline
                                                  index))
            (verify (index-tuple->verifier tuple)))
       ;; XXX: Use `block-indexer-delete-block' when it exists.
       (store-delete-block store (index-handle->block-key index))
       (and (eq? 'missing (verify store))
            (object=? (run-storage-pipeline %default-storage-pipeline
                                            (mem-stream-open bv) store)
                      index)
            (eq? 'ok (verify store)))))))

(test-end)


(test-begin "directory-changes")

(test-assert "added"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (new (make-directory-entry "a" 'regular 123 123 #o755 'some-tuple))
         (d1  (make-directory #f (list e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (match added
             (((? (cut eq? new <>))) #t)
             (_ #f))
           (null? deleted)
           (null? changed)))))

(test-assert "modified"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (old (make-directory-entry "a" 'regular 123 123 #o644 'some-tuple))
         (new (make-directory-entry "a" 'regular 123 123 #o644 'some-other-tuple))
         (d1  (make-directory #f (list old e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? deleted) (null? added)
           (match changed
             (((x y ('modified)))
              (and (eq? x new) (eq? y old))))))))

(test-assert "touched"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (old (make-directory-entry "a" 'regular 123 123 #o644 'some-tuple))
         (new (make-directory-entry "a" 'regular 124 123 #o644 'some-tuple))
         (d1  (make-directory #f (list old e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? deleted) (null? added)
           (match changed
             (((x y ('touched)))
              (and (eq? x new) (eq? y old))))))))

(test-assert "permissions"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (old (make-directory-entry "a" 'regular 123 123 #o644 'some-tuple))
         (new (make-directory-entry "a" 'regular 123 123 #o755 'some-tuple))
         (d1  (make-directory #f (list old e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? deleted) (null? added)
           (match changed
             (((x y ('permissions)))
              (and (eq? x new) (eq? y old))))))))

(test-assert "renamed"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (old (make-directory-entry "a" 'regular 123 123 #o644 'some-tuple))
         (new (make-directory-entry "z" 'regular 123 123 #o644 'some-tuple))
         (d1  (make-directory #f (list old e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? deleted) (null? added)
           (match changed
             (((x y ('renamed)))
              (and (eq? x new) (eq? y old))))))))

(test-assert "empty files not renamed"
  (let* ((old (make-directory-entry "a" 'regular 123 0 #o644 #f))
         (new (make-directory-entry "b" 'regular 123 0 #o644 #f))
         (d1  (make-directory #f (list old)))
         (d2  (make-directory 'prev (list new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? changed)
           (equal? (list old) deleted)
           (equal? (list new) added)))))

(test-assert "renamed + permissions"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (old (make-directory-entry "a" 'regular 123 123 #o644 'some-tuple))
         (new (make-directory-entry "c" 'regular 123 123 #o755 'some-tuple))
         (d1  (make-directory #f (list old e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? deleted) (null? added)
           (match changed
             (((x y ('permissions 'renamed)))
              (and (eq? x new) (eq? y old))))))))

(test-assert "modified + permissions"
  (let* ((e   (make-directory-entry "b" 'regular 234 234 234 'something))
         (old (make-directory-entry "a" 'regular 123 123 #o644 'some-tuple))
         (new (make-directory-entry "a" 'regular 123 123 #o755 'some-other-tuple))
         (d1  (make-directory #f (list old e)))
         (d2  (make-directory 'prev (list e new))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? deleted) (null? added)
           (match changed
             (((x y ('permissions 'modified)))
              (and (eq? x new) (eq? y old))))))))

(test-assert "deleted"
  (let* ((e1  (make-directory-entry "a" 'regular 234 234 #o400 'something))
         (e2  (make-directory-entry "b" 'regular 123 123 #o644 'some-tuple))
         (e3  (make-directory-entry "c" 'regular 123 123 #o755 'some-other-tuple))
         (d1  (make-directory #f (list e1 e2 e3)))
         (d2  (make-directory 'prev (list e1 e2))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (null? changed) (null? added)
           (equal? deleted (list e3))))))

(test-assert "modified + deleted"
  (let* ((e1  (make-directory-entry "a" 'regular 123 123 #o400 'something))
         (e2  (make-directory-entry "a" 'regular 234 234 #o400 'some-tuple))
         (e3  (make-directory-entry "b" 'regular 123 123 #o755 'some-other-tuple))
         (d1  (make-directory #f (list e1 e3)))
         (d2  (make-directory 'prev (list e2))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (equal? deleted (list e3))
           (null? added)
           (match changed
             (((x y ('modified)))
              (and (eq? x e2) (eq? y e1))))))))

(test-assert "modified + permissions + deleted + added"
  (let* ((e1  (make-directory-entry "a" 'regular 123 123 #o400 'something))
         (e2  (make-directory-entry "a" 'regular 234 234 #o420 'some-tuple))
         (e3  (make-directory-entry "b" 'regular 123 123 #o755
                                    'some-other-tuple))
         (e4  (make-directory-entry "c" 'regular 456 456 #o755
                                    'yet-another-tuple))
         (d1  (make-directory #f (list e1 e3)))
         (d2  (make-directory 'prev (list e2 e4))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (equal? deleted (list e3))
           (equal? added (list e4))
           (match changed
             (((x y ('permissions 'modified)))
              (and (eq? x e2) (eq? y e1))))))))

(test-assert "identical file deleted"
  ;; Make sure removing one of several identical files is seen as such.
  (let* ((e1  (make-directory-entry "a" 'regular 123 123 #o400 'something))
         (e2  (make-directory-entry "b" 'regular 234 123 #o420 'something))
         (d1  (make-directory #f (list e1 e2)))
         (d2  (make-directory 'prev (list e1))))
    (let-values (((added changed deleted) (directory-changes d2 d1)))
      (and (equal? deleted (list e2))
           (null? added) (null? changed)))))

(test-assert "recursive: changed"
  (let* ((e1  (make-directory-entry "a" 'regular 123 123 #o400 'something))
         (e2  (make-directory-entry "a" 'regular 234 123 #o420 'something))
         (e3  (make-directory-entry "c" 'regular 77 0 #o440 'something-else))
         (sd1 (make-directory #f (list e1)))
         (sd2 (make-directory #f (list e2)))      ; E1 touched -> E2
         (e4  (make-directory-entry "sub" 'directory 0 0 #o700 'subdir1-tuple))
         (e5  (make-directory-entry "sub" 'directory 0 0 #o700 'subdir2-tuple))
         (get (lambda (tuple)
                (case tuple
                  ((subdir1-tuple) sd1)
                  ((subdir2-tuple) sd2)
                  (else (error "unknown" tuple)))))
         (d1  (make-directory #f (list e4 e3)))
         (d2  (make-directory 'prev (list e5 e3))))
    (let-values (((added changed deleted)
                  (directory-changes/recursive d2 d1 get)))
      (and (equal? changed
                   `(((,e5 ,e2) (,e4 ,e1) (permissions touched))))
           (null? added) (null? deleted)))))

(test-assert "recursive: added"
  (let* ((e1  (make-directory-entry "a" 'regular 123 123 #o400 'a-tuple))
         (e2  (make-directory-entry "b" 'regular 234 123 #o420 'b-tuple))
         (e3  (make-directory-entry "c" 'regular 77 0 #o440 'c-tuple))
         (sd1 (make-directory #f (list e1)))
         (sd2 (make-directory #f (list e1 e2)))   ; add entry E2 in subdir
         (e4  (make-directory-entry "sub" 'directory 0 0 #o700 'subdir1-tuple))
         (e5  (make-directory-entry "sub" 'directory 0 0 #o700 'subdir2-tuple))
         (e6  (make-directory-entry "d" 'regular 77 0 #o440 'd-tuple))
         (get (lambda (tuple)
                (case tuple
                  ((subdir1-tuple) sd1)
                  ((subdir2-tuple) sd2)
                  (else (error "unknown" tuple)))))
         (d1  (make-directory #f (list e4 e3)))
         (d2  (make-directory 'prev (list e3 e5 e6)))) ; add entry E6
    (let-values (((added changed deleted)
                  (directory-changes/recursive d2 d1 get)))
      (and (equal? added `((,e5 ,e2) (,e6)))
           (null? deleted) (null? changed)))))

(test-assert "recursive: deleted"
  (let* ((e1  (make-directory-entry "a" 'regular 123 123 #o400 'a-tuple))
         (e2  (make-directory-entry "b" 'regular 234 123 #o420 'b-tuple))
         (e3  (make-directory-entry "c" 'regular 77 0 #o440 'c-tuple))
         (sd1 (make-directory #f (list e1 e2)))
         (sd2 (make-directory #f (list e1)))      ; remove entry E2 in subdir
         (e4  (make-directory-entry "sub" 'directory 0 0 #o700 'subdir1-tuple))
         (e5  (make-directory-entry "sub" 'directory 0 0 #o700 'subdir2-tuple))
         (e6  (make-directory-entry "d" 'regular 77 0 #o440 'd-tuple))
         (get (lambda (tuple)
                (case tuple
                  ((subdir1-tuple) sd1)
                  ((subdir2-tuple) sd2)
                  (else (error "unknown" tuple)))))
         (d1  (make-directory #f (list e4 e3 e6)))
         (d2  (make-directory 'prev (list e3 e5)))) ; remove entry E6
    (let-values (((added changed deleted)
                  (directory-changes/recursive d2 d1 get)))
      (and (equal? deleted `((,e4 ,e2) (,e6)))
           (null? added) (null? changed)))))

(test-end)


(test-begin "run-storage-pipeline-recursive")

(test-assert "unchanged dir ⇒ same tuple"
  (with-temporary-store
   (lambda (store)
     (let ((t1 (run-storage-pipeline/recursive (const %default-storage-pipeline)
                                               %include-dir
                                               store))
           (t2 (run-storage-pipeline/recursive (const %default-storage-pipeline)
                                               %include-dir
                                               store))
           (t3 (run-storage-pipeline/recursive (lambda (file stat)
                                                 %default-storage-pipeline)
                                               %include-dir
                                               store)))
       (and (pair? t1) (equal? t1 t2) (equal? t2 t3))))))

(test-assert "EACCES on file"
  (with-temporary-store
   (lambda (store)
     (with-file-tree %test-dir (directory "root"
                                          (("a") ("b") ("c" #o000)))
       (guard (c ((pipeline-storage-error? c)
                  (and (eq? (pipeline-error-pipeline c)
                            %default-storage-pipeline)
                       (string=? "c"
                                 (basename (pipeline-storage-error-input c)))
                       (= EACCES (pipeline-error-libchop-error c)))))
         (run-storage-pipeline/recursive (const %default-storage-pipeline)
                                         (string-append %test-dir "/root")
                                         store)

         ;; Never reached.
         #f)))))

(test-assert "EACCES on sub-directory"
  (with-temporary-store
   (lambda (store)
     (with-file-tree %test-dir (directory "root"
                                          (("a") ("b")
                                           (directory "subdir" #o000
                                                      (("c") ("d")))))
       (let ((port (open-output-string)))
         (with-error-to-port port
           (lambda ()
             (run-storage-pipeline/recursive (const %default-storage-pipeline)
                                             (string-append %test-dir "/root")
                                             store)))

         (string-match "subdir.*ignored" (get-output-string port)))))))

(test-assert "repair root blocks"
  (with-temporary-store
   (lambda (store)
     (with-file-tree %test-dir (directory "root" (("a") ("b")))
       (let* ((dir       (string-append %test-dir "/root"))
              (tuple     (run-storage-pipeline/recursive
                          (const %default-storage-pipeline)
                          dir store))
              (retr      (index-tuple->retriever tuple))
              (dir*      (read-directory (retr store)))
              (roots     (cons tuple (map directory-entry-tuple
                                          (directory-entries dir*))))
              (root-keys (map (match-lambda
                               ((_ (= deserialize-index-tuple/ascii
                                      index)
                                   _)
                                (index-handle->block-key index)))
                              roots))
              (verifiers (map index-tuple->verifier roots))
              (verify*   (lambda ()
                           (delete-duplicates
                            (map (lambda (verify) (verify store))
                                 verifiers)))))
         (and (equal? '(ok) (verify*))
              (begin
                ;; Remove all the root keys, and make sure the
                ;; verifiers fail.
                (for-each (cut store-delete-block store <>) root-keys)
                (equal? '(missing) (verify*)))

              ;; Store again.
              (equal? (run-storage-pipeline/recursive
                       (const %default-storage-pipeline) dir store
                       #:repair? #f)
                      tuple)

              ;; Make sure the verifiers are happy.
              (equal? '(ok) (verify*))))))))

(test-assert "repair non-root blocks"
  (with-temporary-file-tree
   (lambda (file)
     (define (store-block-keys)
       ;; Return the keys of all the blocks in STORE.
       ;; XXX: Replace this hack when the block iterator API has bindings.
       (file-system-fold (const #t)                 ; enter?
                         (lambda (path stat result) ; leaf
                           (let ((b32 (string-append (basename (dirname path))
                                                     (basename path))))
                             (cons (base32-string->bytevector b32)
                                   result)))
                         (lambda (path stat result) ; down
                           result)
                         (lambda (path stat result) ; up
                           result)
                         (lambda (path stat result) ; skip
                           result)
                         (lambda (path stat errno result) ; error
                           result)
                         '()
                         file))

     (with-file-tree %test-dir (directory "root" (("a") ("b")))
       (let* ((store     (file-based-block-store-open
                          (lookup-class "fs_block_store")
                          file (logior O_RDWR O_CREAT) #o644))
              (dir       (string-append %test-dir "/root"))
              (tuple     (run-storage-pipeline/recursive
                          (const %default-storage-pipeline)
                          dir store))
              (retr      (index-tuple->retriever tuple))
              (dir*      (read-directory (retr store)))
              (roots     (cons tuple (map directory-entry-tuple
                                          (directory-entries dir*))))
              (root-keys (map (match-lambda
                               ((_ (= deserialize-index-tuple/ascii
                                      index)
                                   _)
                                (index-handle->block-key index)))
                              roots))
              (non-roots (remove (lambda (key)
                                   (member key root-keys))
                                 (store-block-keys)))
              (verifiers (map index-tuple->verifier roots))
              (verify*   (lambda ()
                           (delete-duplicates
                            (map (lambda (verify) (verify store))
                                 verifiers)))))
         (and (equal? '(ok) (verify*))
              (not (null? non-roots))
              (begin
                ;; Remove all the keys but the root keys, and make
                ;; sure the verifiers fail.
                (for-each (cut store-delete-block store <>) non-roots)
                (equal? '(missing) (verify*)))

              ;; Store again.
              (equal? (run-storage-pipeline/recursive
                       (const %default-storage-pipeline) dir store)
                      tuple)

              ;; This didn't repair anything because the root keys were still
              ;; there.
              (equal? '(missing) (verify*))

              ;; So this time repair for good.
              (equal? (run-storage-pipeline/recursive
                       (const %default-storage-pipeline) dir store
                       #:repair? #t)
                      tuple)

              ;; Make sure the verifiers are happy.
              (equal? '(ok) (verify*))))))))

(test-assert "read-directory"
  (with-temporary-store
   (lambda (store)
     (with-file-tree %test-dir (directory "root"
                                          (("a" #o640) ("b" #o754)
                                           ("c" #o464)
                                           ("d" -> "a")))
       (let* ((dir   (string-append %test-dir "/root"))
              (tuple (run-storage-pipeline/recursive
                      (const %default-storage-pipeline) dir store))
              (retr  (index-tuple->retriever tuple)))
         (let ((d (read-directory (retr store))))
           (and (directory? d)
                ;;(not (directory-previous-version d))
                (let ((e (sort (directory-entries d)
                               (lambda (e1 e2)
                                 (string< (directory-entry-name e1)
                                          (directory-entry-name e2))))))
                  (fold (lambda (n+s e r)
                          (match n+s
                            ((name . stat)
                             (and r (directory-entry=stat? e name stat)))))
                        #t
                        (sort (file-system-fold (const #t) ; entries of DIR
                                                alist-cons
                                                (lambda (n s r) r)
                                                (lambda (n s r) r)
                                                (lambda (n s r) r)
                                                (lambda (n s e r) r)
                                                '()
                                                dir)
                              (lambda (e1 e2)
                                (string< (car e1) (car e2))))
                        e)))))))))

(test-end)


(gc) ;; stress the GC

(rmdir %test-dir)

;; rm -rf $XDG_CACHE_HOME
(file-system-fold (lambda (dir stat result) #t)   ; enter?
                  (lambda (file stat result)      ; leaf
                    (delete-file file))
                  (lambda (dir stat result)       ; down
                    result)
                  (lambda (dir stat result)       ; up
                    (rmdir dir))
                  (lambda (dir stat result)       ; skip
                    result)
                  (lambda (dir stat errno result) ; error
                    #f)
                  #t
                  (getenv "XDG_CACHE_HOME"))

(exit (= (test-runner-fail-count (test-runner-current)) 0))

;;; Local Variables:
;;; eval: (put 'test-assert 'scheme-indent-function 1)
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
;;; End:
