ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2025-01-23 11:09:41 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

store-copy: 'populate-store' resets timestamps.

Browse source 
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.
This commit is contained in:
Ludovic Courtès 2020-12-10 13:37:59 +01:00
parent 2718c29c3f
commit 7b8d239ec2
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
4 changed files with 95 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
gnu/build/image.scm
View file

@ -196,9 +196,8 @@ (define* (initialize-root-partition root
(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))

2
gnu/build/vm.scm
View file

@ -414,7 +414,7 @@ (define target-store
(for-each (lambda (closure)
(register-closure target
(string-append "/xchg/" closure)
#:reset-timestamps? copy-closures?
#:reset-timestamps? #f
#:deduplicate? deduplicate?))
closures)
(unless copy-closures?

103
guix/build/store-copy.scm
View file

@ -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 @@ (define items
(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 @@ (define (graph-from-file file)
(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)))))

19
tests/gexp.scm
View file

@ -723,10 +723,25 @@ (define guile ,guile)
(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