summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/store-copy.scm103
1 files changed, 75 insertions, 28 deletions
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)))))