[jackhill/guix/guix.git] / tests / nar.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-nar)
  #:use-module (guix tests)
  #:use-module (guix nar)
  #:use-module (guix serialization)
  #:use-module (guix store)
  #:use-module ((gcrypt hash)
                #:select (open-sha256-port open-sha256-input-port))
  #:use-module ((guix packages)
                #:select (base32))
  #:use-module ((guix build utils)
                #:select (find-files))
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs io ports)
  #: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 (ice-9 ftw)
  #:use-module (ice-9 regex)
  #:use-module ((ice-9 control) #:select (let/ec))
  #:use-module (ice-9 match))

;; Test the (guix nar) module.

\f
;;;
;;; File system testing tools, initially contributed to Guile, then libchop.
;;;

(define (random-file-size)
  (define %average (* 1024 512))                  ; 512 KiB
  (define %stddev  (* 1024 64))                   ; 64 KiB
  (inexact->exact
   (max 0 (round (+ %average (* %stddev (random:normal)))))))

(define (make-file-tree dir tree)
  "Make file system TREE at DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body))
      (('directory name (? integer? mode) (body ...))
       (mkdir (scope name))
       (for-each (cute loop (scope name) <>) body)
       (chmod (scope name) mode))
      ((file)
       (populate-file (scope file) (random-file-size)))
      ((file (? integer? mode))
       (populate-file (scope file) (random-file-size))
       (chmod (scope file) mode))
      ((from '-> to)
       (symlink to (scope from))))))

(define (delete-file-tree dir tree)
  "Delete file TREE from DIR."
  (let loop ((dir  dir)
             (tree tree))
    (define (scope file)
      (string-append dir "/" file))

    (match tree
      (('directory name (body ...))
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      (('directory name (? integer? mode) (body ...))
       (chmod (scope name) #o755)          ; make sure it can be entered
       (for-each (cute loop (scope name) <>) body)
       (rmdir (scope name)))
      ((from '-> _)
       (delete-file (scope from)))
      ((file _ ...)
       (delete-file (scope file))))))

(define-syntax-rule (with-file-tree dir tree body ...)
  (dynamic-wind
    (lambda ()
      (make-file-tree dir 'tree))
    (lambda ()
      body ...)
    (lambda ()
      (delete-file-tree dir 'tree))))

(define (file-tree-equal? input output)
  "Return #t if the file trees at INPUT and OUTPUT are equal."
  (define strip
    (cute string-drop <> (string-length input)))
  (define sibling
    (compose (cut string-append output <>) strip))

  (file-system-fold (const #t)
                    (lambda (name stat result)    ; leaf
                      (and result
                           (file=? name (sibling name))))
                    (lambda (name stat result)    ; down
                      result)
                    (lambda (name stat result)    ; up
                      result)
                    (const #f)                    ; skip
                    (lambda (name stat errno result)
                      (pk 'error name stat errno)
                      #f)
                    #t                            ; result
                    input
                    lstat))

(define (populate-file file size)
  (call-with-output-file file
    (lambda (p)
      (put-bytevector p (random-bytevector size)))))

(define (rm-rf dir)
  (file-system-fold (const #t)                    ; enter?
                    (lambda (file stat result)    ; leaf
                      (delete-file file))
                    (const #t)                    ; down
                    (lambda (dir stat result)     ; up
                      (rmdir dir))
                    (const #t)                    ; skip
                    (const #t)                    ; error
                    #t
                    dir
                    lstat))

(define %test-dir
  ;; An output directory under $top_builddir.
  (string-append (dirname (search-path %load-path "pre-inst-env"))
                 "/test-nar-" (number->string (getpid))))

\f
(test-begin "nar")

(test-assert "write-file-tree + restore-file"
  (let* ((file1  (search-path %load-path "guix.scm"))
         (file2  (search-path %load-path "guix/base32.scm"))
         (file3  "#!/bin/something")
         (output (string-append %test-dir "/output")))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (define-values (port get-bytevector)
          (open-bytevector-output-port))
        (write-file-tree "root" port
                         #:file-type+size
                         (match-lambda
                           ("root"
                            (values 'directory 0))
                           ("root/foo"
                            (values 'regular (stat:size (stat file1))))
                           ("root/lnk"
                            (values 'symlink 0))
                           ("root/dir"
                            (values 'directory 0))
                           ("root/dir/bar"
                            (values 'regular (stat:size (stat file2))))
                           ("root/dir/exe"
                            (values 'executable (string-length file3))))
                         #:file-port
                         (match-lambda
                           ("root/foo" (open-input-file file1))
                           ("root/dir/bar" (open-input-file file2))
                           ("root/dir/exe" (open-input-string file3)))
                         #:symlink-target
                         (match-lambda
                           ("root/lnk" "foo"))
                         #:directory-entries
                         (match-lambda
                           ("root" '("foo" "dir" "lnk"))
                           ("root/dir" '("bar" "exe"))))
        (close-port port)

        (rm-rf %test-dir)
        (mkdir %test-dir)
        (restore-file (open-bytevector-input-port (get-bytevector))
                      output)
        (and (file=? (string-append output "/foo") file1)
             (string=? (readlink (string-append output "/lnk"))
                       "foo")
             (file=? (string-append output "/dir/bar") file2)
             (string=? (call-with-input-file (string-append output "/dir/exe")
                         get-string-all)
                       file3)
             (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
                        #o100)
                0)
             (equal? '("." ".." "bar" "exe")
                     (scandir (string-append output "/dir")))
             (equal? '("." ".." "dir" "foo" "lnk")
                     (scandir output))))
      (lambda ()
        (false-if-exception (rm-rf %test-dir))))))

(test-equal "write-file-tree + fold-archive"
  '(("R" directory #f)
    ("R/dir" directory #f)
    ("R/dir/exe" executable "1234")
    ("R/foo" regular "abcdefg")
    ("R/lnk" symlink "foo"))

  (let ()
    (define-values (port get-bytevector)
      (open-bytevector-output-port))
    (write-file-tree "root" port
                     #:file-type+size
                     (match-lambda
                       ("root"
                        (values 'directory 0))
                       ("root/foo"
                        (values 'regular 7))
                       ("root/lnk"
                        (values 'symlink 0))
                       ("root/dir"
                        (values 'directory 0))
                       ("root/dir/exe"
                        (values 'executable 4)))
                     #:file-port
                     (match-lambda
                       ("root/foo" (open-input-string "abcdefg"))
                       ("root/dir/exe" (open-input-string "1234")))
                     #:symlink-target
                     (match-lambda
                       ("root/lnk" "foo"))
                     #:directory-entries
                     (match-lambda
                       ("root" '("foo" "dir" "lnk"))
                       ("root/dir" '("exe"))))
    (close-port port)

    (reverse
     (fold-archive (lambda (file type contents result)
                     (let ((contents (if (memq type '(regular executable))
                                         (utf8->string
                                          (get-bytevector-n (car contents)
                                                            (cdr contents)))
                                         contents)))
                       (cons `(,file ,type ,contents)
                             result)))
                   '()
                   (open-bytevector-input-port (get-bytevector))
                   "R"))))

(test-equal "write-file-tree + fold-archive, flat file"
  '(("R" regular "abcdefg"))

  (let ()
    (define-values (port get-bytevector)
      (open-bytevector-output-port))
    (write-file-tree "root" port
                     #:file-type+size
                     (match-lambda
                       ("root" (values 'regular 7)))
                     #:file-port
                     (match-lambda
                       ("root" (open-input-string "abcdefg"))))
    (close-port port)

    (reverse
     (fold-archive (lambda (file type contents result)
                     (let ((contents (utf8->string
                                      (get-bytevector-n (car contents)
                                                        (cdr contents)))))
                       (cons `(,file ,type ,contents) result)))
                   '()
                   (open-bytevector-input-port (get-bytevector))
                   "R"))))

(test-assert "write-file supports non-file output ports"
  (let ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                               "/guix"))
        (output (%make-void-port "w")))
    (write-file input output)
    #t))

(test-equal "write-file puts file in C locale collation order"
  (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
  (let ((input (string-append %test-dir ".input")))
    (dynamic-wind
      (lambda ()
        (define (touch file)
          (call-with-output-file (string-append input "/" file)
            (const #t)))

        (mkdir input)
        (touch "B")
        (touch "Z")
        (touch "a")
        (symlink "B" (string-append input "/z")))
      (lambda ()
        (let-values (((port get-hash) (open-sha256-port)))
          (write-file input port)
          (close-port port)
          (get-hash)))
      (lambda ()
        (rm-rf input)))))

(test-equal "restore-file with incomplete input"
  (string-append %test-dir "/foo")
  (let ((port (open-bytevector-input-port #vu8(1 2 3))))
    (guard (c ((nar-error? c)
               (and (eq? port (nar-error-port c))
                    (nar-error-file c))))
      (restore-file port (string-append %test-dir "/foo"))
      #f)))

(test-assert "write-file + restore-file"
  (let* ((input  (string-append (dirname (search-path %load-path "guix.scm"))
                                "/guix"))
         (output %test-dir)
         (nar    (string-append output ".nar")))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (call-with-output-file nar
          (cut write-file input <>))
        (call-with-input-file nar
          (cut restore-file <> output))
        (file-tree-equal? input output))
      (lambda ()
        (false-if-exception (delete-file nar))
        (false-if-exception (rm-rf output))))))

(test-assert "write-file + restore-file with symlinks"
  (let ((input (string-append %test-dir ".input")))
    (mkdir input)
    (dynamic-wind
      (const #t)
      (lambda ()
        (with-file-tree input
            (directory "root"
                       (("reg") ("exe" #o777) ("sym" -> "reg")))
          (let* ((output %test-dir)
                 (nar    (string-append output ".nar")))
            (dynamic-wind
              (lambda () #t)
              (lambda ()
                (call-with-output-file nar
                  (cut write-file input <>))
                (call-with-input-file nar
                  (cut restore-file <> output))
                (file-tree-equal? input output))
              (lambda ()
                (false-if-exception (delete-file nar))
                (false-if-exception (rm-rf output)))))))
      (lambda ()
        (rmdir input)))))

(test-assert "write-file #:select? + restore-file"
  (let ((input (string-append %test-dir ".input")))
    (mkdir input)
    (dynamic-wind
      (const #t)
      (lambda ()
        (with-file-tree input
            (directory "root"
                       ((directory "a" (("x") ("y") ("z")))
                        ("b") ("c") ("d" -> "b")))
          (let* ((output %test-dir)
                 (nar    (string-append output ".nar")))
            (dynamic-wind
              (lambda () #t)
              (lambda ()
                (call-with-output-file nar
                  (lambda (port)
                    (write-file input port
                                #:select?
                                (lambda (file stat)
                                  (and (not (string=? (basename file)
                                                      "a"))
                                       (not (eq? (stat:type stat)
                                                 'symlink)))))))
                (call-with-input-file nar
                  (cut restore-file <> output))

                ;; Make sure "a" and "d" have been filtered out.
                (and (not (file-exists? (string-append output "/root/a")))
                     (file=? (string-append output "/root/b")
                             (string-append input "/root/b"))
                     (file=? (string-append output "/root/c")
                             (string-append input "/root/c"))
                     (not (file-exists? (string-append output "/root/d")))))
              (lambda ()
                (false-if-exception (delete-file nar))
                (false-if-exception (rm-rf output)))))))
      (lambda ()
        (rmdir input)))))

(test-eq "restore-file with non-UTF8 locale"     ;<https://bugs.gnu.org/33603>
  'encoding-error
  (let* ((file   (search-path %load-path "guix.scm"))
         (output (string-append %test-dir "/output"))
         (locale (setlocale LC_ALL "C")))
    (dynamic-wind
      (lambda () #t)
      (lambda ()
        (define-values (port get-bytevector)
          (open-bytevector-output-port))

        (write-file-tree "root" port
                         #:file-type+size
                         (match-lambda
                           ("root"   (values 'directory 0))
                           ("root/λ" (values 'regular 0)))
                         #:file-port (const (%make-void-port "r"))
                         #:symlink-target (const #f)
                         #:directory-entries (const '("λ")))
        (close-port port)

        (mkdir %test-dir)
        (catch 'encoding-error
          (lambda ()
            ;; This show throw to 'encoding-error.
            (restore-file (open-bytevector-input-port (get-bytevector))
                          output)
            (scandir output))
          (lambda args
            'encoding-error)))
      (lambda ()
        (false-if-exception (rm-rf %test-dir))
        (setlocale LC_ALL locale)))))

(test-assert "restore-file-set (signed, valid)"
  (with-store store
    (let* ((texts (unfold (cut >= <> 10)
                          (lambda _ (random-text))
                          1+
                          0))
           (files (map (cut add-text-to-store store "text" <>) texts))
           (dump  (call-with-bytevector-output-port
                   (cut export-paths store files <>))))
      (delete-paths store files)
      (and (every (negate file-exists?) files)
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (restore-file-set source)))
             (and (equal? imported files)
                  (every (lambda (file)
                           (and (file-exists? file)
                                (valid-path? store file)))
                         files)
                  (equal? texts
                          (map (lambda (file)
                                 (call-with-input-file file
                                   get-string-all))
                               files))
                  (every canonical-file? files)))))))

(test-assert "restore-file-set with directories (signed, valid)"
  ;; <https://bugs.gnu.org/33361> describes a bug whereby directories
  ;; containing files subject to deduplication were not canonicalized--i.e.,
  ;; their mtime and permissions were not reset.  Ensure that this bug is
  ;; gone.
  (with-store store
    (let* ((text1 (random-text))
           (text2 (random-text))
           (tree  `("tree" directory
                    ("a" regular (data ,text1))
                    ("b" directory
                     ("c" regular (data ,text2))
                     ("d" regular (data ,text1))))) ;duplicate
           (file  (add-file-tree-to-store store tree))
           (dump  (call-with-bytevector-output-port
                   (cute export-paths store (list file) <>))))
      (delete-paths store (list file))
      (and (not (file-exists? file))
           (let* ((source   (open-bytevector-input-port dump))
                  (imported (restore-file-set source)))
             (and (equal? imported (list file))
                  (file-exists? file)
                  (valid-path? store file)
                  (string=? text1
                            (call-with-input-file (string-append file "/a")
                              get-string-all))
                  (string=? text2
                            (call-with-input-file
                                (string-append file "/b/c")
                              get-string-all))
                  (= (stat:ino (stat (string-append file "/a"))) ;deduplication
                     (stat:ino (stat (string-append file "/b/d"))))
                  (every canonical-file?
                         (find-files file #:directories? #t))))))))

(test-assert "restore-file-set (missing signature)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo" (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>
                           #:sign? #f))))
        (delete-paths store (list file))
        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-signature-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-match "lacks.*signature" message)
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-assert "restore-file-set (corrupt)"
  (let/ec return
    (with-store store
      (let* ((file  (add-text-to-store store "foo"
                                       (random-text)))
             (dump  (call-with-bytevector-output-port
                     (cute export-paths store (list file) <>))))
        (delete-paths store (list file))

        ;; Flip a byte in the file contents.
        (let* ((index 120)
               (byte  (bytevector-u8-ref dump index)))
          (bytevector-u8-set! dump index (logxor #xff byte)))

        (and (not (file-exists? file))
             (let ((source (open-bytevector-input-port dump)))
               (guard (c ((nar-invalid-hash-error? c)
                          (let ((message (condition-message c))
                                (port    (nar-error-port c)))
                            (return
                             (and (string-contains message "hash")
                                  (string=? file (nar-error-file c))
                                  (eq? source port))))))
                 (restore-file-set source))
               #f))))))

(test-end "nar")

;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
;;; End:
Commit	Line	Data
53c63ee9	1	;;; GNU Guix --- Functional package management for GNU
9fe3f113	2	;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
53c63ee9 LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (test-nar)
c1bc358f	20	#:use-module (guix tests)
53c63ee9	21	#:use-module (guix nar)
0363991a	22	#:use-module (guix serialization)
cd4027fa	23	#:use-module (guix store)
ca719424	24	#:use-module ((gcrypt hash)
96c7448f LC	25	#:select (open-sha256-port open-sha256-input-port))
	26	#:use-module ((guix packages)
	27	#:select (base32))
83908698 LC	28	#:use-module ((guix build utils)
83908698 LC	29	#:select (find-files))
53c63ee9 LC	30	#:use-module (rnrs bytevectors)
53c63ee9 LC	31	#:use-module (rnrs io ports)
cd4027fa	32	#:use-module (srfi srfi-1)
96c7448f	33	#:use-module (srfi srfi-11)
53c63ee9	34	#:use-module (srfi srfi-26)
cd4027fa LC	35	#:use-module (srfi srfi-34)
cd4027fa LC	36	#:use-module (srfi srfi-35)
53c63ee9	37	#:use-module (srfi srfi-64)
8f3114b7	38	#:use-module (ice-9 ftw)
cd4027fa	39	#:use-module (ice-9 regex)
36626c55	40	#:use-module ((ice-9 control) #:select (let/ec))
8f3114b7	41	#:use-module (ice-9 match))
53c63ee9 LC	42
	43	;; Test the (guix nar) module.
	44
8f3114b7 LC	45	\f
	46	;;;
	47	;;; File system testing tools, initially contributed to Guile, then libchop.
	48	;;;
	49
	50	(define (random-file-size)
	51	(define %average (* 1024 512)) ; 512 KiB
	52	(define %stddev (* 1024 64)) ; 64 KiB
	53	(inexact->exact
	54	(max 0 (round (+ %average (* %stddev (random:normal)))))))
	55
	56	(define (make-file-tree dir tree)
	57	"Make file system TREE at DIR."
	58	(let loop ((dir dir)
	59	(tree tree))
	60	(define (scope file)
	61	(string-append dir "/" file))
	62
	63	(match tree
	64	(('directory name (body ...))
	65	(mkdir (scope name))
	66	(for-each (cute loop (scope name) <>) body))
	67	(('directory name (? integer? mode) (body ...))
	68	(mkdir (scope name))
	69	(for-each (cute loop (scope name) <>) body)
	70	(chmod (scope name) mode))
	71	((file)
	72	(populate-file (scope file) (random-file-size)))
	73	((file (? integer? mode))
	74	(populate-file (scope file) (random-file-size))
	75	(chmod (scope file) mode))
	76	((from '-> to)
	77	(symlink to (scope from))))))
	78
	79	(define (delete-file-tree dir tree)
	80	"Delete file TREE from DIR."
	81	(let loop ((dir dir)
	82	(tree tree))
	83	(define (scope file)
	84	(string-append dir "/" file))
	85
	86	(match tree
	87	(('directory name (body ...))
	88	(for-each (cute loop (scope name) <>) body)
	89	(rmdir (scope name)))
	90	(('directory name (? integer? mode) (body ...))
	91	(chmod (scope name) #o755) ; make sure it can be entered
	92	(for-each (cute loop (scope name) <>) body)
	93	(rmdir (scope name)))
	94	((from '-> _)
	95	(delete-file (scope from)))
	96	((file _ ...)
	97	(delete-file (scope file))))))
	98
	99	(define-syntax-rule (with-file-tree dir tree body ...)
	100	(dynamic-wind
	101	(lambda ()
	102	(make-file-tree dir 'tree))
	103	(lambda ()
	104	body ...)
	105	(lambda ()
	106	(delete-file-tree dir 'tree))))
	107
	108	(define (file-tree-equal? input output)
109	"Return #t if the file trees at INPUT and OUTPUT are equal."
110	(define strip
111	(cute string-drop <> (string-length input)))
112	(define sibling
113	(compose (cut string-append output <>) strip))
8f3114b7 LC	114
	115	(file-system-fold (const #t)
	116	(lambda (name stat result) ; leaf
	117	(and result
	118	(file=? name (sibling name))))
	119	(lambda (name stat result) ; down
	120	result)
	121	(lambda (name stat result) ; up
	122	result)
	123	(const #f) ; skip
	124	(lambda (name stat errno result)
	125	(pk 'error name stat errno)
	126	#f)
fe32241a	127	#t ; result
8f3114b7 LC	128	input
	129	lstat))
	130
8f3114b7 LC	131	(define (populate-file file size)
	132	(call-with-output-file file
	133	(lambda (p)
c1bc358f	134	(put-bytevector p (random-bytevector size)))))
8f3114b7	135
53c63ee9 LC	136	(define (rm-rf dir)
	137	(file-system-fold (const #t) ; enter?
	138	(lambda (file stat result) ; leaf
	139	(delete-file file))
	140	(const #t) ; down
	141	(lambda (dir stat result) ; up
	142	(rmdir dir))
	143	(const #t) ; skip
	144	(const #t) ; error
	145	#t
	146	dir
	147	lstat))
	148
8f3114b7 LC	149	(define %test-dir
8f3114b7 LC	150	;; An output directory under $top_builddir.
410e38f8	151	(string-append (dirname (search-path %load-path "pre-inst-env"))
8f3114b7 LC	152	"/test-nar-" (number->string (getpid))))
8f3114b7 LC	153
53c63ee9 LC	154	\f
	155	(test-begin "nar")
	156
b94b698d LC	157	(test-assert "write-file-tree + restore-file"
	158	(let* ((file1 (search-path %load-path "guix.scm"))
	159	(file2 (search-path %load-path "guix/base32.scm"))
	160	(file3 "#!/bin/something")
	161	(output (string-append %test-dir "/output")))
	162	(dynamic-wind
	163	(lambda () #t)
	164	(lambda ()
	165	(define-values (port get-bytevector)
	166	(open-bytevector-output-port))
	167	(write-file-tree "root" port
	168	#:file-type+size
	169	(match-lambda
	170	("root"
	171	(values 'directory 0))
	172	("root/foo"
	173	(values 'regular (stat:size (stat file1))))
	174	("root/lnk"
	175	(values 'symlink 0))
	176	("root/dir"
	177	(values 'directory 0))
	178	("root/dir/bar"
	179	(values 'regular (stat:size (stat file2))))
	180	("root/dir/exe"
	181	(values 'executable (string-length file3))))
	182	#:file-port
	183	(match-lambda
	184	("root/foo" (open-input-file file1))
	185	("root/dir/bar" (open-input-file file2))
	186	("root/dir/exe" (open-input-string file3)))
	187	#:symlink-target
	188	(match-lambda
	189	("root/lnk" "foo"))
	190	#:directory-entries
	191	(match-lambda
	192	("root" '("foo" "dir" "lnk"))
	193	("root/dir" '("bar" "exe"))))
	194	(close-port port)
	195
	196	(rm-rf %test-dir)
	197	(mkdir %test-dir)
	198	(restore-file (open-bytevector-input-port (get-bytevector))
	199	output)
	200	(and (file=? (string-append output "/foo") file1)
	201	(string=? (readlink (string-append output "/lnk"))
	202	"foo")
	203	(file=? (string-append output "/dir/bar") file2)
	204	(string=? (call-with-input-file (string-append output "/dir/exe")
	205	get-string-all)
	206	file3)
	207	(> (logand (stat:mode (lstat (string-append output "/dir/exe")))
	208	#o100)
	209	0)
	210	(equal? '("." ".." "bar" "exe")
	211	(scandir (string-append output "/dir")))
	212	(equal? '("." ".." "dir" "foo" "lnk")
	213	(scandir output))))
	214	(lambda ()
	215	(false-if-exception (rm-rf %test-dir))))))
	216
12c1afcd LC	217	(test-equal "write-file-tree + fold-archive"
	218	'(("R" directory #f)
	219	("R/dir" directory #f)
	220	("R/dir/exe" executable "1234")
	221	("R/foo" regular "abcdefg")
	222	("R/lnk" symlink "foo"))
	223
	224	(let ()
	225	(define-values (port get-bytevector)
	226	(open-bytevector-output-port))
	227	(write-file-tree "root" port
	228	#:file-type+size
	229	(match-lambda
	230	("root"
	231	(values 'directory 0))
	232	("root/foo"
	233	(values 'regular 7))
	234	("root/lnk"
	235	(values 'symlink 0))
	236	("root/dir"
	237	(values 'directory 0))
	238	("root/dir/exe"
	239	(values 'executable 4)))
	240	#:file-port
	241	(match-lambda
	242	("root/foo" (open-input-string "abcdefg"))
	243	("root/dir/exe" (open-input-string "1234")))
	244	#:symlink-target
	245	(match-lambda
	246	("root/lnk" "foo"))
	247	#:directory-entries
	248	(match-lambda
	249	("root" '("foo" "dir" "lnk"))
	250	("root/dir" '("exe"))))
	251	(close-port port)
	252
	253	(reverse
	254	(fold-archive (lambda (file type contents result)
	255	(let ((contents (if (memq type '(regular executable))
	256	(utf8->string
	257	(get-bytevector-n (car contents)
	258	(cdr contents)))
	259	contents)))
	260	(cons `(,file ,type ,contents)
	261	result)))
	262	'()
	263	(open-bytevector-input-port (get-bytevector))
	264	"R"))))
	265
	266	(test-equal "write-file-tree + fold-archive, flat file"
	267	'(("R" regular "abcdefg"))
	268
	269	(let ()
	270	(define-values (port get-bytevector)
	271	(open-bytevector-output-port))
	272	(write-file-tree "root" port
	273	#:file-type+size
	274	(match-lambda
	275	("root" (values 'regular 7)))
	276	#:file-port
	277	(match-lambda
	278	("root" (open-input-string "abcdefg"))))
	279	(close-port port)
	280
281	(reverse
282	(fold-archive (lambda (file type contents result)
283	(let ((contents (utf8->string
284	(get-bytevector-n (car contents)
285	(cdr contents)))))
286	(cons `(,file ,type ,contents) result)))
287	'()
288	(open-bytevector-input-port (get-bytevector))
289	"R"))))
290
a93e91ff LC	291	(test-assert "write-file supports non-file output ports"
	292	(let ((input (string-append (dirname (search-path %load-path "guix.scm"))
	293	"/guix"))
	294	(output (%make-void-port "w")))
	295	(write-file input output)
	296	#t))
	297
96c7448f LC	298	(test-equal "write-file puts file in C locale collation order"
	299	(base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
	300	(let ((input (string-append %test-dir ".input")))
	301	(dynamic-wind
	302	(lambda ()
	303	(define (touch file)
	304	(call-with-output-file (string-append input "/" file)
	305	(const #t)))
	306
	307	(mkdir input)
	308	(touch "B")
	309	(touch "Z")
	310	(touch "a")
	311	(symlink "B" (string-append input "/z")))
	312	(lambda ()
	313	(let-values (((port get-hash) (open-sha256-port)))
	314	(write-file input port)
6f389600	315	(close-port port)
96c7448f LC	316	(get-hash)))
	317	(lambda ()
	318	(rm-rf input)))))
	319
46b8aadb LC	320	(test-equal "restore-file with incomplete input"
	321	(string-append %test-dir "/foo")
	322	(let ((port (open-bytevector-input-port #vu8(1 2 3))))
	323	(guard (c ((nar-error? c)
	324	(and (eq? port (nar-error-port c))
	325	(nar-error-file c))))
	326	(restore-file port (string-append %test-dir "/foo"))
	327	#f)))
	328
53c63ee9 LC	329	(test-assert "write-file + restore-file"
	330	(let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
	331	"/guix"))
8f3114b7	332	(output %test-dir)
53c63ee9 LC	333	(nar (string-append output ".nar")))
	334	(dynamic-wind
	335	(lambda () #t)
	336	(lambda ()
	337	(call-with-output-file nar
	338	(cut write-file input <>))
	339	(call-with-input-file nar
	340	(cut restore-file <> output))
8f3114b7	341	(file-tree-equal? input output))
53c63ee9 LC	342	(lambda ()
53c63ee9 LC	343	(false-if-exception (delete-file nar))
8f3114b7 LC	344	(false-if-exception (rm-rf output))))))
	345
	346	(test-assert "write-file + restore-file with symlinks"
	347	(let ((input (string-append %test-dir ".input")))
	348	(mkdir input)
	349	(dynamic-wind
	350	(const #t)
	351	(lambda ()
	352	(with-file-tree input
	353	(directory "root"
	354	(("reg") ("exe" #o777) ("sym" -> "reg")))
	355	(let* ((output %test-dir)
	356	(nar (string-append output ".nar")))
	357	(dynamic-wind
	358	(lambda () #t)
	359	(lambda ()
	360	(call-with-output-file nar
	361	(cut write-file input <>))
	362	(call-with-input-file nar
	363	(cut restore-file <> output))
	364	(file-tree-equal? input output))
	365	(lambda ()
77ffd691 LC	366	(false-if-exception (delete-file nar))
77ffd691 LC	367	(false-if-exception (rm-rf output)))))))
8f3114b7 LC	368	(lambda ()
8f3114b7 LC	369	(rmdir input)))))
53c63ee9	370
fe585be9 LC	371	(test-assert "write-file #:select? + restore-file"
	372	(let ((input (string-append %test-dir ".input")))
	373	(mkdir input)
	374	(dynamic-wind
	375	(const #t)
	376	(lambda ()
	377	(with-file-tree input
	378	(directory "root"
	379	((directory "a" (("x") ("y") ("z")))
	380	("b") ("c") ("d" -> "b")))
	381	(let* ((output %test-dir)
	382	(nar (string-append output ".nar")))
	383	(dynamic-wind
	384	(lambda () #t)
	385	(lambda ()
	386	(call-with-output-file nar
	387	(lambda (port)
	388	(write-file input port
	389	#:select?
	390	(lambda (file stat)
	391	(and (not (string=? (basename file)
	392	"a"))
	393	(not (eq? (stat:type stat)
	394	'symlink)))))))
	395	(call-with-input-file nar
	396	(cut restore-file <> output))
	397
	398	;; Make sure "a" and "d" have been filtered out.
	399	(and (not (file-exists? (string-append output "/root/a")))
	400	(file=? (string-append output "/root/b")
	401	(string-append input "/root/b"))
	402	(file=? (string-append output "/root/c")
	403	(string-append input "/root/c"))
	404	(not (file-exists? (string-append output "/root/d")))))
	405	(lambda ()
	406	(false-if-exception (delete-file nar))
	407	(false-if-exception (rm-rf output)))))))
	408	(lambda ()
	409	(rmdir input)))))
	410
9fe3f113 LC	411	(test-eq "restore-file with non-UTF8 locale" ;<https://bugs.gnu.org/33603>
	412	'encoding-error
	413	(let* ((file (search-path %load-path "guix.scm"))
	414	(output (string-append %test-dir "/output"))
	415	(locale (setlocale LC_ALL "C")))
	416	(dynamic-wind
	417	(lambda () #t)
	418	(lambda ()
	419	(define-values (port get-bytevector)
	420	(open-bytevector-output-port))
	421
	422	(write-file-tree "root" port
	423	#:file-type+size
	424	(match-lambda
	425	("root" (values 'directory 0))
	426	("root/λ" (values 'regular 0)))
	427	#:file-port (const (%make-void-port "r"))
	428	#:symlink-target (const #f)
	429	#:directory-entries (const '("λ")))
	430	(close-port port)
	431
	432	(mkdir %test-dir)
	433	(catch 'encoding-error
	434	(lambda ()
	435	;; This show throw to 'encoding-error.
	436	(restore-file (open-bytevector-input-port (get-bytevector))
	437	output)
	438	(scandir output))
	439	(lambda args
	440	'encoding-error)))
	441	(lambda ()
	442	(false-if-exception (rm-rf %test-dir))
	443	(setlocale LC_ALL locale)))))
	444
cd4027fa LC	445	(test-assert "restore-file-set (signed, valid)"
	446	(with-store store
	447	(let* ((texts (unfold (cut >= <> 10)
	448	(lambda _ (random-text))
	449	1+
	450	0))
	451	(files (map (cut add-text-to-store store "text" <>) texts))
	452	(dump (call-with-bytevector-output-port
	453	(cut export-paths store files <>))))
	454	(delete-paths store files)
	455	(and (every (negate file-exists?) files)
	456	(let* ((source (open-bytevector-input-port dump))
	457	(imported (restore-file-set source)))
	458	(and (equal? imported files)
	459	(every (lambda (file)
	460	(and (file-exists? file)
	461	(valid-path? store file)))
	462	files)
	463	(equal? texts
	464	(map (lambda (file)
	465	(call-with-input-file file
	466	get-string-all))
83908698 LC	467	files))
83908698 LC	468	(every canonical-file? files)))))))
cd4027fa	469
f5a2724a LC	470	(test-assert "restore-file-set with directories (signed, valid)"
	471	;; <https://bugs.gnu.org/33361> describes a bug whereby directories
	472	;; containing files subject to deduplication were not canonicalized--i.e.,
	473	;; their mtime and permissions were not reset. Ensure that this bug is
	474	;; gone.
	475	(with-store store
	476	(let* ((text1 (random-text))
	477	(text2 (random-text))
	478	(tree `("tree" directory
	479	("a" regular (data ,text1))
	480	("b" directory
	481	("c" regular (data ,text2))
	482	("d" regular (data ,text1))))) ;duplicate
	483	(file (add-file-tree-to-store store tree))
	484	(dump (call-with-bytevector-output-port
	485	(cute export-paths store (list file) <>))))
	486	(delete-paths store (list file))
	487	(and (not (file-exists? file))
	488	(let* ((source (open-bytevector-input-port dump))
	489	(imported (restore-file-set source)))
	490	(and (equal? imported (list file))
	491	(file-exists? file)
	492	(valid-path? store file)
	493	(string=? text1
	494	(call-with-input-file (string-append file "/a")
	495	get-string-all))
	496	(string=? text2
	497	(call-with-input-file
	498	(string-append file "/b/c")
	499	get-string-all))
	500	(= (stat:ino (stat (string-append file "/a"))) ;deduplication
	501	(stat:ino (stat (string-append file "/b/d"))))
	502	(every canonical-file?
	503	(find-files file #:directories? #t))))))))
	504
cd4027fa LC	505	(test-assert "restore-file-set (missing signature)"
	506	(let/ec return
	507	(with-store store
834ea02a	508	(let* ((file (add-text-to-store store "foo" (random-text)))
cd4027fa LC	509	(dump (call-with-bytevector-output-port
	510	(cute export-paths store (list file) <>
	511	#:sign? #f))))
	512	(delete-paths store (list file))
	513	(and (not (file-exists? file))
	514	(let ((source (open-bytevector-input-port dump)))
	515	(guard (c ((nar-signature-error? c)
	516	(let ((message (condition-message c))
	517	(port (nar-error-port c)))
	518	(return
	519	(and (string-match "lacks.*signature" message)
	520	(string=? file (nar-error-file c))
	521	(eq? source port))))))
	522	(restore-file-set source))
	523	#f))))))
	524
	525	(test-assert "restore-file-set (corrupt)"
	526	(let/ec return
	527	(with-store store
	528	(let* ((file (add-text-to-store store "foo"
	529	(random-text)))
	530	(dump (call-with-bytevector-output-port
	531	(cute export-paths store (list file) <>))))
	532	(delete-paths store (list file))
	533
	534	;; Flip a byte in the file contents.
	535	(let* ((index 120)
	536	(byte (bytevector-u8-ref dump index)))
	537	(bytevector-u8-set! dump index (logxor #xff byte)))
	538
	539	(and (not (file-exists? file))
	540	(let ((source (open-bytevector-input-port dump)))
	541	(guard (c ((nar-invalid-hash-error? c)
	542	(let ((message (condition-message c))
	543	(port (nar-error-port c)))
	544	(return
	545	(and (string-contains message "hash")
	546	(string=? file (nar-error-file c))
	547	(eq? source port))))))
	548	(restore-file-set source))
	549	#f))))))
	550
53c63ee9 LC	551	(test-end "nar")
53c63ee9 LC	552
8f3114b7 LC	553	;;; Local Variables:
	554	;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
	555	;;; End: