1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (test-nar)
20 #:use-module (guix tests)
21 #:use-module (guix nar)
22 #:use-module (guix serialization)
23 #:use-module (guix store)
24 #:use-module ((gcrypt hash)
25 #:select (open-sha256-port open-sha256-input-port))
26 #:use-module ((guix packages)
28 #:use-module ((guix build utils)
29 #:select (find-files))
30 #:use-module (rnrs bytevectors)
31 #:use-module (rnrs io ports)
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-11)
34 #:use-module (srfi srfi-26)
35 #:use-module (srfi srfi-34)
36 #:use-module (srfi srfi-35)
37 #:use-module (srfi srfi-64)
38 #:use-module (ice-9 ftw)
39 #:use-module (ice-9 regex)
40 #:use-module ((ice-9 control) #:select (let/ec))
41 #:use-module (ice-9 match))
43 ;; Test the (guix nar) module.
47 ;;; File system testing tools, initially contributed to Guile, then libchop.
50 (define (random-file-size)
51 (define %average (* 1024 512)) ; 512 KiB
52 (define %stddev (* 1024 64)) ; 64 KiB
54 (max 0 (round (+ %average (* %stddev (random:normal)))))))
56 (define (make-file-tree dir tree)
57 "Make file system TREE at DIR."
61 (string-append dir "/" file))
64 (('directory name (body ...))
66 (for-each (cute loop (scope name) <>) body))
67 (('directory name (? integer? mode) (body ...))
69 (for-each (cute loop (scope name) <>) body)
70 (chmod (scope name) mode))
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))
77 (symlink to (scope from))))))
79 (define (delete-file-tree dir tree)
80 "Delete file TREE from DIR."
84 (string-append dir "/" file))
87 (('directory name (body ...))
88 (for-each (cute loop (scope name) <>) body)
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)
95 (delete-file (scope from)))
97 (delete-file (scope file))))))
99 (define-syntax-rule (with-file-tree dir tree body ...)
102 (make-file-tree dir 'tree))
106 (delete-file-tree dir 'tree))))
108 (define (file-tree-equal? input output)
109 "Return #t if the file trees at INPUT and OUTPUT are equal."
111 (cute string-drop <> (string-length input)))
113 (compose (cut string-append output <>) strip))
115 (file-system-fold (const #t)
116 (lambda (name stat result) ; leaf
118 (file=? name (sibling name))))
119 (lambda (name stat result) ; down
121 (lambda (name stat result) ; up
124 (lambda (name stat errno result)
125 (pk 'error name stat errno)
131 (define (populate-file file size)
132 (call-with-output-file file
134 (put-bytevector p (random-bytevector size)))))
137 (file-system-fold (const #t) ; enter?
138 (lambda (file stat result) ; leaf
141 (lambda (dir stat result) ; up
150 ;; An output directory under $top_builddir.
151 (string-append (dirname (search-path %load-path "pre-inst-env"))
152 "/test-nar-" (number->string (getpid))))
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")))
165 (define-values (port get-bytevector)
166 (open-bytevector-output-port))
167 (write-file-tree "root" port
171 (values 'directory 0))
173 (values 'regular (stat:size (stat file1))))
177 (values 'directory 0))
179 (values 'regular (stat:size (stat file2))))
181 (values 'executable (string-length file3))))
184 ("root/foo" (open-input-file file1))
185 ("root/dir/bar" (open-input-file file2))
186 ("root/dir/exe" (open-input-string file3)))
192 ("root" '("foo" "dir" "lnk"))
193 ("root/dir" '("bar" "exe"))))
198 (restore-file (open-bytevector-input-port (get-bytevector))
200 (and (file=? (string-append output "/foo") file1)
201 (string=? (readlink (string-append output "/lnk"))
203 (file=? (string-append output "/dir/bar") file2)
204 (string=? (call-with-input-file (string-append output "/dir/exe")
207 (> (logand (stat:mode (lstat (string-append output "/dir/exe")))
210 (equal? '("." ".." "bar" "exe")
211 (scandir (string-append output "/dir")))
212 (equal? '("." ".." "dir" "foo" "lnk")
215 (false-if-exception (rm-rf %test-dir))))))
217 (test-equal "write-file-tree + fold-archive"
219 ("R/dir" directory #f)
220 ("R/dir/exe" executable "1234")
221 ("R/foo" regular "abcdefg")
222 ("R/lnk" symlink "foo"))
225 (define-values (port get-bytevector)
226 (open-bytevector-output-port))
227 (write-file-tree "root" port
231 (values 'directory 0))
237 (values 'directory 0))
239 (values 'executable 4)))
242 ("root/foo" (open-input-string "abcdefg"))
243 ("root/dir/exe" (open-input-string "1234")))
249 ("root" '("foo" "dir" "lnk"))
250 ("root/dir" '("exe"))))
254 (fold-archive (lambda (file type contents result)
255 (let ((contents (if (memq type '(regular executable))
257 (get-bytevector-n (car contents)
260 (cons `(,file ,type ,contents)
263 (open-bytevector-input-port (get-bytevector))
266 (test-equal "write-file-tree + fold-archive, flat file"
267 '(("R" regular "abcdefg"))
270 (define-values (port get-bytevector)
271 (open-bytevector-output-port))
272 (write-file-tree "root" port
275 ("root" (values 'regular 7)))
278 ("root" (open-input-string "abcdefg"))))
282 (fold-archive (lambda (file type contents result)
283 (let ((contents (utf8->string
284 (get-bytevector-n (car contents)
286 (cons `(,file ,type ,contents) result)))
288 (open-bytevector-input-port (get-bytevector))
291 (test-assert "write-file supports non-file output ports"
292 (let ((input (string-append (dirname (search-path %load-path "guix.scm"))
294 (output (%make-void-port "w")))
295 (write-file input output)
298 (test-equal "write-file puts file in C locale collation order"
299 (base32 "0sfn5r63k88w9ls4hivnvscg82bqg8a0w7955l6xlk4g96jnb2z3")
300 (let ((input (string-append %test-dir ".input")))
304 (call-with-output-file (string-append input "/" file)
311 (symlink "B" (string-append input "/z")))
313 (let-values (((port get-hash) (open-sha256-port)))
314 (write-file input port)
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"))
329 (test-assert "write-file + restore-file"
330 (let* ((input (string-append (dirname (search-path %load-path "guix.scm"))
333 (nar (string-append output ".nar")))
337 (call-with-output-file nar
338 (cut write-file input <>))
339 (call-with-input-file nar
340 (cut restore-file <> output))
341 (file-tree-equal? input output))
343 (false-if-exception (delete-file nar))
344 (false-if-exception (rm-rf output))))))
346 (test-assert "write-file + restore-file with symlinks"
347 (let ((input (string-append %test-dir ".input")))
352 (with-file-tree input
354 (("reg") ("exe" #o777) ("sym" -> "reg")))
355 (let* ((output %test-dir)
356 (nar (string-append output ".nar")))
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))
366 (false-if-exception (delete-file nar))
367 (false-if-exception (rm-rf output)))))))
371 (test-assert "write-file #:select? + restore-file"
372 (let ((input (string-append %test-dir ".input")))
377 (with-file-tree input
379 ((directory "a" (("x") ("y") ("z")))
380 ("b") ("c") ("d" -> "b")))
381 (let* ((output %test-dir)
382 (nar (string-append output ".nar")))
386 (call-with-output-file nar
388 (write-file input port
391 (and (not (string=? (basename file)
393 (not (eq? (stat:type stat)
395 (call-with-input-file nar
396 (cut restore-file <> output))
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")))))
406 (false-if-exception (delete-file nar))
407 (false-if-exception (rm-rf output)))))))
411 (test-eq "restore-file with non-UTF8 locale" ;<https://bugs.gnu.org/33603>
413 (let* ((file (search-path %load-path "guix.scm"))
414 (output (string-append %test-dir "/output"))
415 (locale (setlocale LC_ALL "C")))
419 (define-values (port get-bytevector)
420 (open-bytevector-output-port))
422 (write-file-tree "root" port
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 '("λ")))
433 (catch 'encoding-error
435 ;; This show throw to 'encoding-error.
436 (restore-file (open-bytevector-input-port (get-bytevector))
442 (false-if-exception (rm-rf %test-dir))
443 (setlocale LC_ALL locale)))))
445 (test-assert "restore-file-set (signed, valid)"
447 (let* ((texts (unfold (cut >= <> 10)
448 (lambda _ (random-text))
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)))
465 (call-with-input-file file
468 (every canonical-file? files)))))))
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
476 (let* ((text1 (random-text))
477 (text2 (random-text))
478 (tree `("tree" directory
479 ("a" regular (data ,text1))
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))
492 (valid-path? store file)
494 (call-with-input-file (string-append file "/a")
497 (call-with-input-file
498 (string-append file "/b/c")
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))))))))
505 (test-assert "restore-file-set (missing signature)"
508 (let* ((file (add-text-to-store store "foo" (random-text)))
509 (dump (call-with-bytevector-output-port
510 (cute export-paths store (list file) <>
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)))
519 (and (string-match "lacks.*signature" message)
520 (string=? file (nar-error-file c))
521 (eq? source port))))))
522 (restore-file-set source))
525 (test-assert "restore-file-set (corrupt)"
528 (let* ((file (add-text-to-store store "foo"
530 (dump (call-with-bytevector-output-port
531 (cute export-paths store (list file) <>))))
532 (delete-paths store (list file))
534 ;; Flip a byte in the file contents.
536 (byte (bytevector-u8-ref dump index)))
537 (bytevector-u8-set! dump index (logxor #xff byte)))
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)))
545 (and (string-contains message "hash")
546 (string=? file (nar-error-file c))
547 (eq? source port))))))
548 (restore-file-set source))
554 ;;; eval: (put 'with-file-tree 'scheme-indent-function 2)