From patchwork Sun Nov 4 22:10:35 2018 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 116 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id C30D8167B2; Sun, 4 Nov 2018 22:25:28 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-6.9 required=5.0 tests=BAYES_00,RCVD_IN_DNSWL_HI, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [IPv6:2001:4830:134:3::11]) by mira.cbaines.net (Postfix) with ESMTPS id 6572B167B0 for ; Sun, 4 Nov 2018 22:25:28 +0000 (GMT) Received: from localhost ([::1]:60412 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gJQpj-0004yj-HX for patchwork@mira.cbaines.net; Sun, 04 Nov 2018 17:25:27 -0500 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 X-Loop: help-debbugs@gnu.org Subject: [bug#33259] [PATCH 7/8] store-copy: Canonicalize the mtime and permissions of the store copy. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sun, 04 Nov 2018 22:12:04 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 33259 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 33259@debbugs.gnu.org Received: via spool by 33259-submit@debbugs.gnu.org id=B33259.15413694746375 (code B ref 33259); Sun, 04 Nov 2018 22:12:04 +0000 Received: (at 33259) by debbugs.gnu.org; 4 Nov 2018 22:11:14 +0000 Received: from localhost ([127.0.0.1]:34357 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gJQby-0001ef-43 for submit@debbugs.gnu.org; Sun, 04 Nov 2018 17:11:14 -0500 Received: from eggs.gnu.org ([208.118.235.92]:53303) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1gJQbv-0001dP-8i for 33259@debbugs.gnu.org; Sun, 04 Nov 2018 17:11:12 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1gJQbp-0006bO-62 for 33259@debbugs.gnu.org; Sun, 04 Nov 2018 17:11:06 -0500 Received: from fencepost.gnu.org ([2001:4830:134:3::e]:40150) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1gJQbn-0006TS-08; Sun, 04 Nov 2018 17:11:03 -0500 Received: from [2a01:e0a:1d:7270:af76:b9b:ca24:c465] (port=33966 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:DHE_RSA_AES_256_CBC_SHA1:256) (Exim 4.82) (envelope-from ) id 1gJQbm-0004TQ-Nv; Sun, 04 Nov 2018 17:11:02 -0500 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> X-Mailer: git-send-email 2.19.1 In-Reply-To: <20181104221036.4776-1-ludo@gnu.org> References: <20181104221036.4776-1-ludo@gnu.org> MIME-Version: 1.0 X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 208.118.235.43 X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 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