;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix nar)
#:use-module (guix serialization)
#:use-module (guix store)
- #:use-module ((guix hash)
+ #: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-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.
(lambda (name stat errno result)
(pk 'error name stat errno)
#f)
- (> (stat:nlink (stat output)) 2)
+ #t ; result
input
lstat))
(string-append (dirname (search-path %load-path "pre-inst-env"))
"/test-nar-" (number->string (getpid))))
-(define-syntax-rule (let/ec k exp...)
- ;; This one appeared in Guile 2.0.9, so provide a copy here.
- (let ((tag (make-prompt-tag)))
- (call-with-prompt tag
- (lambda ()
- (let ((k (lambda args
- (apply abort-to-prompt tag args))))
- exp...))
- (lambda (_ . args)
- (apply values args)))))
-
\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"))
(lambda ()
(let-values (((port get-hash) (open-sha256-port)))
(write-file input port)
+ (close-port port)
(get-hash)))
(lambda ()
(rm-rf input)))))
(lambda ()
(rmdir input)))))
-;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn
-;; relies on a Guile 2.0.10+ feature.
-(test-skip (if (false-if-exception
- (open-sha256-input-port (%make-void-port "r")))
- 0
- 3))
+(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
(map (lambda (file)
(call-with-input-file file
get-string-all))
- files))))))))
+ 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
(test-end "nar")
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
-
;;; Local Variables:
;;; eval: (put 'with-file-tree 'scheme-indent-function 2)
;;; End: