X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/fe32241ad5394c12fc70a31de005ec1b563bbb4e..0747328e317de4bf936fab50e795d1e1523adfc1:/tests/nar.scm diff --git a/tests/nar.scm b/tests/nar.scm index e24a638db9..bfc71c69a8 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -21,10 +21,12 @@ #: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) @@ -35,6 +37,7 @@ #: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. @@ -148,20 +151,69 @@ (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))))) - (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")) @@ -186,6 +238,7 @@ (lambda () (let-values (((port get-hash) (open-sha256-port))) (write-file input port) + (close-port port) (get-hash))) (lambda () (rm-rf input))))) @@ -241,12 +294,79 @@ (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" ; + '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 @@ -270,7 +390,43 @@ (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)" + ;; 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 @@ -320,9 +476,6 @@ (test-end "nar") - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) - ;;; Local Variables: ;;; eval: (put 'with-file-tree 'scheme-indent-function 2) ;;; End: