[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-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
a93e91ff LC	217	(test-assert "write-file supports non-file output ports"
	218	(let ((input (string-append (dirname (search-path %load-path "guix.scm"))
	219	"/guix"))
	220	(output (%make-void-port "w")))
	221	(write-file input output)
	222	#t))
	223
96c7448f LC	224	(test-equal "write-file puts file in C locale collation order"
	225	(base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
	226	(let ((input (string-append %test-dir ".input")))
	227	(dynamic-wind
	228	(lambda ()
	229	(define (touch file)
	230	(call-with-output-file (string-append input "/" file)
	231	(const #t)))
	232
	233	(mkdir input)
	234	(touch "B")
	235	(touch "Z")
	236	(touch "a")
	237	(symlink "B" (string-append input "/z")))
	238	(lambda ()
	239	(let-values (((port get-hash) (open-sha256-port)))
	240	(write-file input port)
6f389600	241	(close-port port)
96c7448f LC	242	(get-hash)))
	243	(lambda ()
	244	(rm-rf input)))))
	245
46b8aadb LC	246	(test-equal "restore-file with incomplete input"
	247	(string-append %test-dir "/foo")
	248	(let ((port (open-bytevector-input-port #vu8(1 2 3))))
	249	(guard (c ((nar-error? c)
	250	(and (eq? port (nar-error-port c))
	251	(nar-error-file c))))
	252	(restore-file port (string-append %test-dir "/foo"))
	253	#f)))
	254
53c63ee9 LC	255	(test-assert "write-file + restore-file"
	256	(let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
	257	"/guix"))
8f3114b7	258	(output %test-dir)
53c63ee9 LC	259	(nar (string-append output ".nar")))
	260	(dynamic-wind
	261	(lambda () #t)
	262	(lambda ()
	263	(call-with-output-file nar
	264	(cut write-file input <>))
	265	(call-with-input-file nar
	266	(cut restore-file <> output))
8f3114b7	267	(file-tree-equal? input output))
53c63ee9 LC	268	(lambda ()
53c63ee9 LC	269	(false-if-exception (delete-file nar))
8f3114b7 LC	270	(false-if-exception (rm-rf output))))))
	271
	272	(test-assert "write-file + restore-file with symlinks"
	273	(let ((input (string-append %test-dir ".input")))
	274	(mkdir input)
	275	(dynamic-wind
	276	(const #t)
	277	(lambda ()
	278	(with-file-tree input
	279	(directory "root"
	280	(("reg") ("exe" #o777) ("sym" -> "reg")))
	281	(let* ((output %test-dir)
	282	(nar (string-append output ".nar")))
	283	(dynamic-wind
	284	(lambda () #t)
	285	(lambda ()
	286	(call-with-output-file nar
	287	(cut write-file input <>))
	288	(call-with-input-file nar
	289	(cut restore-file <> output))
	290	(file-tree-equal? input output))
	291	(lambda ()
77ffd691 LC	292	(false-if-exception (delete-file nar))
77ffd691 LC	293	(false-if-exception (rm-rf output)))))))
8f3114b7 LC	294	(lambda ()
8f3114b7 LC	295	(rmdir input)))))
53c63ee9	296
fe585be9 LC	297	(test-assert "write-file #:select? + restore-file"
	298	(let ((input (string-append %test-dir ".input")))
	299	(mkdir input)
	300	(dynamic-wind
	301	(const #t)
	302	(lambda ()
	303	(with-file-tree input
	304	(directory "root"
	305	((directory "a" (("x") ("y") ("z")))
	306	("b") ("c") ("d" -> "b")))
	307	(let* ((output %test-dir)
	308	(nar (string-append output ".nar")))
	309	(dynamic-wind
	310	(lambda () #t)
	311	(lambda ()
	312	(call-with-output-file nar
	313	(lambda (port)
	314	(write-file input port
	315	#:select?
	316	(lambda (file stat)
	317	(and (not (string=? (basename file)
	318	"a"))
	319	(not (eq? (stat:type stat)
	320	'symlink)))))))
	321	(call-with-input-file nar
	322	(cut restore-file <> output))
	323
	324	;; Make sure "a" and "d" have been filtered out.
	325	(and (not (file-exists? (string-append output "/root/a")))
	326	(file=? (string-append output "/root/b")
	327	(string-append input "/root/b"))
	328	(file=? (string-append output "/root/c")
	329	(string-append input "/root/c"))
	330	(not (file-exists? (string-append output "/root/d")))))
	331	(lambda ()
	332	(false-if-exception (delete-file nar))
	333	(false-if-exception (rm-rf output)))))))
	334	(lambda ()
	335	(rmdir input)))))
	336
9fe3f113 LC	337	(test-eq "restore-file with non-UTF8 locale" ;<https://bugs.gnu.org/33603>
	338	'encoding-error
	339	(let* ((file (search-path %load-path "guix.scm"))
	340	(output (string-append %test-dir "/output"))
	341	(locale (setlocale LC_ALL "C")))
	342	(dynamic-wind
	343	(lambda () #t)
	344	(lambda ()
	345	(define-values (port get-bytevector)
	346	(open-bytevector-output-port))
	347
	348	(write-file-tree "root" port
	349	#:file-type+size
	350	(match-lambda
	351	("root" (values 'directory 0))
	352	("root/λ" (values 'regular 0)))
	353	#:file-port (const (%make-void-port "r"))
	354	#:symlink-target (const #f)
	355	#:directory-entries (const '("λ")))
	356	(close-port port)
	357
	358	(mkdir %test-dir)
	359	(catch 'encoding-error
	360	(lambda ()
	361	;; This show throw to 'encoding-error.
	362	(restore-file (open-bytevector-input-port (get-bytevector))
	363	output)
	364	(scandir output))
	365	(lambda args
	366	'encoding-error)))
	367	(lambda ()
	368	(false-if-exception (rm-rf %test-dir))
	369	(setlocale LC_ALL locale)))))
	370
cd4027fa LC	371	(test-assert "restore-file-set (signed, valid)"
	372	(with-store store
	373	(let* ((texts (unfold (cut >= <> 10)
	374	(lambda _ (random-text))
	375	1+
	376	0))
	377	(files (map (cut add-text-to-store store "text" <>) texts))
	378	(dump (call-with-bytevector-output-port
	379	(cut export-paths store files <>))))
	380	(delete-paths store files)
	381	(and (every (negate file-exists?) files)
	382	(let* ((source (open-bytevector-input-port dump))
	383	(imported (restore-file-set source)))
	384	(and (equal? imported files)
	385	(every (lambda (file)
	386	(and (file-exists? file)
	387	(valid-path? store file)))
	388	files)
	389	(equal? texts
	390	(map (lambda (file)
	391	(call-with-input-file file
	392	get-string-all))
83908698 LC	393	files))
83908698 LC	394	(every canonical-file? files)))))))
cd4027fa	395
f5a2724a LC	396	(test-assert "restore-file-set with directories (signed, valid)"
	397	;; <https://bugs.gnu.org/33361> describes a bug whereby directories
	398	;; containing files subject to deduplication were not canonicalized--i.e.,
	399	;; their mtime and permissions were not reset. Ensure that this bug is
	400	;; gone.
	401	(with-store store
	402	(let* ((text1 (random-text))
	403	(text2 (random-text))
	404	(tree `("tree" directory
	405	("a" regular (data ,text1))
	406	("b" directory
	407	("c" regular (data ,text2))
	408	("d" regular (data ,text1))))) ;duplicate
	409	(file (add-file-tree-to-store store tree))
	410	(dump (call-with-bytevector-output-port
	411	(cute export-paths store (list file) <>))))
	412	(delete-paths store (list file))
	413	(and (not (file-exists? file))
	414	(let* ((source (open-bytevector-input-port dump))
	415	(imported (restore-file-set source)))
	416	(and (equal? imported (list file))
	417	(file-exists? file)
	418	(valid-path? store file)
	419	(string=? text1
	420	(call-with-input-file (string-append file "/a")
	421	get-string-all))
	422	(string=? text2
	423	(call-with-input-file
	424	(string-append file "/b/c")
	425	get-string-all))
	426	(= (stat:ino (stat (string-append file "/a"))) ;deduplication
	427	(stat:ino (stat (string-append file "/b/d"))))
	428	(every canonical-file?
	429	(find-files file #:directories? #t))))))))
	430
cd4027fa LC	431	(test-assert "restore-file-set (missing signature)"
	432	(let/ec return
	433	(with-store store
834ea02a	434	(let* ((file (add-text-to-store store "foo" (random-text)))
cd4027fa LC	435	(dump (call-with-bytevector-output-port
	436	(cute export-paths store (list file) <>
	437	#:sign? #f))))
	438	(delete-paths store (list file))
	439	(and (not (file-exists? file))
	440	(let ((source (open-bytevector-input-port dump)))
	441	(guard (c ((nar-signature-error? c)
	442	(let ((message (condition-message c))
	443	(port (nar-error-port c)))
	444	(return
	445	(and (string-match "lacks.*signature" message)
	446	(string=? file (nar-error-file c))
	447	(eq? source port))))))
	448	(restore-file-set source))
	449	#f))))))
	450
	451	(test-assert "restore-file-set (corrupt)"
	452	(let/ec return
	453	(with-store store
	454	(let* ((file (add-text-to-store store "foo"
	455	(random-text)))
	456	(dump (call-with-bytevector-output-port
	457	(cute export-paths store (list file) <>))))
	458	(delete-paths store (list file))
	459
	460	;; Flip a byte in the file contents.
	461	(let* ((index 120)
	462	(byte (bytevector-u8-ref dump index)))
	463	(bytevector-u8-set! dump index (logxor #xff byte)))
	464
	465	(and (not (file-exists? file))
	466	(let ((source (open-bytevector-input-port dump)))
	467	(guard (c ((nar-invalid-hash-error? c)
	468	(let ((message (condition-message c))
	469	(port (nar-error-port c)))
	470	(return
	471	(and (string-contains message "hash")
	472	(string=? file (nar-error-file c))
	473	(eq? source port))))))
	474	(restore-file-set source))
	475	#f))))))
	476
53c63ee9 LC	477	(test-end "nar")
53c63ee9 LC	478
8f3114b7 LC	479	;;; Local Variables:
	480	;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
	481	;;; End: