bug#44760: [PATCH 04/15] store-copy: 'populate-store' resets timestamps.

["Ludovic Courtès" <ludo@gnu.org>]

Until now, 'populate-store' would reset permissions but not timestamps,
so callers would resort to going through an extra directory traversal to
reset timestamps.

* guix/build/store-copy.scm (reset-permissions): Remove.
(copy-recursively): New procedure.
(populate-store): Pass #:keep-permissions? to 'copy-recursively'.
Remove call to 'reset-permissions'.
* tests/gexp.scm ("gexp->derivation, store copy"): In BUILD-DRV, check
whether 'populate-store' canonicalizes permissions and timestamps.
* gnu/build/image.scm (initialize-root-partition): Pass #:reset-timestamps? #f
to 'register-closure'.
* gnu/build/vm.scm (root-partition-initializer): Likewise.
---
 gnu/build/image.scm       |   5 +-
 gnu/build/vm.scm          |   2 +-
 guix/build/store-copy.scm | 103 +++++++++++++++++++++++++++-----------
 tests/gexp.scm            |  19 ++++++-
 4 files changed, 95 insertions(+), 34 deletions(-)

diff --git a/gnu/build/image.scm b/gnu/build/image.scm
index 640a784204..2857362914 100644
--- a/gnu/build/image.scm
+++ b/gnu/build/image.scm
@@ -196,9 +196,8 @@ register-closure."
 
   (when register-closures?
     (for-each (lambda (closure)
-                (register-closure root
-                                  closure
-                                  #:reset-timestamps? #t
+                (register-closure root closure
+                                  #:reset-timestamps? #f
                                   #:deduplicate? deduplicate?
                                   #:wal-mode? wal-mode?))
               references-graphs))
diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm
index 287d099f79..30feaf800f 100644
--- a/gnu/build/vm.scm
+++ b/gnu/build/vm.scm
@@ -414,7 +414,7 @@ system that is passed to 'populate-root-file-system'."
       (for-each (lambda (closure)
                   (register-closure target
                                     (string-append "/xchg/" closure)
-                                    #:reset-timestamps? copy-closures?
+                                    #:reset-timestamps? #f
                                     #:deduplicate? deduplicate?))
                 closures)
       (unless copy-closures?
diff --git a/guix/build/store-copy.scm b/guix/build/store-copy.scm
index ad551bca98..95dcb8e114 100644
--- a/guix/build/store-copy.scm
+++ b/guix/build/store-copy.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2017, 2018, 2020 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,7 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build store-copy)
-  #:use-module (guix build utils)
+  #:use-module ((guix build utils) #:hide (copy-recursively))
   #:use-module (guix sets)
   #:use-module (guix progress)
   #:use-module (srfi srfi-1)
@@ -169,32 +169,83 @@ 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
+;; TODO: Remove when the one in (guix build utils) has #:keep-permissions?,
+;; the fix for <https://bugs.gnu.org/44741>, and when #:keep-mtime? works for
+;; symlinks.
+(define* (copy-recursively source destination
+                           #:key
+                           (log (current-output-port))
+                           (follow-symlinks? #f)
+                           (copy-file copy-file)
+                           keep-mtime? keep-permissions?)
+  "Copy SOURCE directory to DESTINATION.  Follow symlinks if FOLLOW-SYMLINKS?
+is true; otherwise, just preserve them.  Call COPY-FILE to copy regular files.
+When KEEP-MTIME? is true, keep the modification time of the files in SOURCE on
+those of DESTINATION.  When KEEP-PERMISSIONS? is true, preserve file
+permissions.  Write verbose output to the LOG port."
+  (define AT_SYMLINK_NOFOLLOW
+    ;; Guile 2.0 did not define this constant, hence this hack.
+    (let ((variable (module-variable the-root-module 'AT_SYMLINK_NOFOLLOW)))
+      (if variable
+          (variable-ref variable)
+          256)))                                    ;for GNU/Linux
+
+  (define (set-file-time file stat)
+    (utime file
+           (stat:atime stat)
+           (stat:mtime stat)
+           (stat:atimensec stat)
+           (stat:mtimensec stat)
+           AT_SYMLINK_NOFOLLOW))
+
+  (define strip-source
+    (let ((len (string-length source)))
+      (lambda (file)
+        (substring file len))))
+
+  (file-system-fold (const #t)                    ; enter?
+                    (lambda (file stat result)    ; leaf
+                      (let ((dest (string-append destination
+                                                 (strip-source file))))
+                        (format log "`~a' -> `~a'~%" file dest)
+                        (case (stat:type stat)
+                          ((symlink)
+                           (let ((target (readlink file)))
+                             (symlink target dest)))
+                          (else
+                           (copy-file file dest)
+                           (when keep-permissions?
+                             (chmod dest (stat:perms stat)))))
+                        (when keep-mtime?
+                          (set-file-time dest stat))))
+                    (lambda (dir stat result)     ; down
+                      (let ((target (string-append destination
+                                                   (strip-source dir))))
+                        (mkdir-p target)))
+                    (lambda (dir stat result)     ; up
+                      (let ((target (string-append destination
+                                                   (strip-source dir))))
+                        (when keep-mtime?
+                          (set-file-time target stat))
+                        (when keep-permissions?
+                          (chmod target (stat:perms stat)))))
+                    (const #t)                    ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port) "i/o error: ~a: ~a~%"
+                              file (strerror errno))
+                      #f)
                     #t
-                    file
-                    lstat))
+                    source
+
+                    (if follow-symlinks?
+                        stat
+                        lstat)))
 
 (define* (populate-store reference-graphs target
                          #:key (log-port (current-error-port)))
   "Populate the store under directory TARGET with the items specified in
-REFERENCE-GRAPHS, a list of reference-graph files."
+REFERENCE-GRAPHS, a list of reference-graph files.  Items copied to TARGET
+maintain timestamps and permissions."
   (define store
     (string-append target (%store-directory)))
 
@@ -221,12 +272,8 @@ REFERENCE-GRAPHS, a list of reference-graph files."
                     (copy-recursively thing
                                       (string-append target thing)
                                       #:keep-mtime? #t
+                                      #:keep-permissions? #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/gexp.scm b/tests/gexp.scm
index 686334af61..a0e55178fa 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -723,10 +723,25 @@
                            (lambda (port)
                              (display "This is the second one." port))))))
         (build-drv #~(begin
-                       (use-modules (guix build store-copy))
+                       (use-modules (guix build store-copy)
+                                    (guix build utils)
+                                    (srfi srfi-1))
+
+                       (define (canonical-file? file)
+                         ;; Copied from (guix tests).
+                         (let ((st (lstat file)))
+                           (or (not (string-prefix? (%store-directory) file))
+                               (eq? 'symlink (stat:type st))
+                               (and (= 1 (stat:mtime st))
+                                    (zero? (logand #o222 (stat:mode st)))))))
 
                        (mkdir #$output)
-                       (populate-store '("graph") #$output))))
+                       (populate-store '("graph") #$output)
+
+                       ;; Check whether 'populate-store' canonicalizes
+                       ;; permissions and timestamps.
+                       (unless (every canonical-file? (find-files #$output))
+                         (error "not canonical!" #$output)))))
     (mlet* %store-monad ((one (gexp->derivation "one" build-one))
                          (two (gexp->derivation "two" (build-two one)))
                          (drv (gexp->derivation "store-copy" build-drv
-- 
2.29.2