From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:36144) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gJQl1-0008BO-Oc for guix-patches@gnu.org; Sun, 04 Nov 2018 17:20:36 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gJQcp-0000zs-HI for guix-patches@gnu.org; Sun, 04 Nov 2018 17:12:08 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:58341) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1gJQcm-0000xY-SP for guix-patches@gnu.org; Sun, 04 Nov 2018 17:12:05 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1gJQcm-0001gq-N7 for guix-patches@gnu.org; Sun, 04 Nov 2018 17:12:04 -0500 Subject: [bug#33259] [PATCH 7/8] store-copy: Canonicalize the mtime and permissions of the store copy. Resent-Message-ID: From: Ludovic =?UTF-8?Q?Court=C3=A8s?= Date: Sun, 4 Nov 2018 23:10:35 +0100 Message-Id: <20181104221036.4776-7-ludo@gnu.org> In-Reply-To: <20181104221036.4776-1-ludo@gnu.org> References: <20181104221036.4776-1-ludo@gnu.org> MIME-Version: 1.0 Content-Transfer-Encoding: 8bit List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 33259@debbugs.gnu.org Fixes a bug whereby directories in the output of 'guix pack -f tarball' would not be read-only. * guix/build/store-copy.scm (reset-permissions): New procedure. (populate-store): Pass #:keep-mtime? #t to 'copy-recursively'. Call 'reset-permissions'. * tests/pack.scm ("self-contained-tarball"): In CHECK, define 'canonical?' and use it to check that every file has an mtime of 1 and is read-only. * tests/guix-pack.sh: Invoke "chmod -Rf +w" before "rm -rf" in trap. --- guix/build/store-copy.scm | 28 +++++++++++++++++++++++ tests/guix-pack.sh | 2 +- tests/pack.scm | 48 +++++++++++++++++++++++++++++---------- 3 files changed, 65 insertions(+), 13 deletions(-) diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm index 64ade7885c..549aa4f28b 100644 --- a/guix/build/store-copy.scm +++ b/guix/build/store-copy.scm @@ -168,6 +168,28 @@ REFERENCE-GRAPHS, a list of reference-graph files." (reduce + 0 (map file-size items))) +(define (reset-permissions file) + "Reset the permissions on FILE and its sub-directories so that they are all +read-only." + ;; XXX: This procedure exists just to work around the inability of + ;; 'copy-recursively' to preserve permissions. + (file-system-fold (const #t) ;enter? + (lambda (file stat _) ;leaf + (unless (eq? 'symlink (stat:type stat)) + (chmod file + (if (zero? (logand (stat:mode stat) + #o100)) + #o444 + #o555)))) + (const #t) ;down + (lambda (directory stat _) ;up + (chmod directory #o555)) + (const #f) ;skip + (const #f) ;error + #t + file + lstat)) + (define* (populate-store reference-graphs target #:key (log-port (current-error-port))) "Populate the store under directory TARGET with the items specified in @@ -197,7 +219,13 @@ REFERENCE-GRAPHS, a list of reference-graph files." (for-each (lambda (thing) (copy-recursively thing (string-append target thing) + #:keep-mtime? #t #:log (%make-void-port "w")) + + ;; XXX: Since 'copy-recursively' doesn't allow us to + ;; preserve permissions, we have to traverse TARGET to + ;; make sure everything is read-only. + (reset-permissions (string-append target thing)) (report)) things))))) diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 8c1f556426..a43f4d128f 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -49,7 +49,7 @@ the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`" # exists because /opt/gnu/bin may be an absolute symlink to a store item that # has been GC'd. test_directory="`mktemp -d`" -trap 'rm -rf "$test_directory"' EXIT +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT cd "$test_directory" tar -xf "$the_pack" test -L opt/gnu/bin diff --git a/tests/pack.scm b/tests/pack.scm index 22321a3e46..70e3e812be 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -68,18 +68,42 @@ #:archiver %tar-bootstrap)) (check (gexp->derivation "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile")))))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define store + ;; The unpacked store. + (string-append "." (%store-directory) "/")) + + (define (canonical? file) + ;; Return #t if FILE is read-only and its mtime is 1. + (let ((st (lstat file))) + (or (not (string-prefix? store file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 + (stat:mode st))))))) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (file-exists? store) + (every canonical? + (find-files "." (const #t) + #:directories? #t)) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile"))))))))) (built-derivations (list check)))) ;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of -- 2.19.1