mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 05:18:07 -05:00
store-copy: Canonicalize the mtime and permissions of the store copy.
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.
This commit is contained in:
parent
1ff53787db
commit
72dc64f8f7
3 changed files with 65 additions and 13 deletions
|
@ -168,6 +168,28 @@ (define items
|
||||||
|
|
||||||
(reduce + 0 (map file-size 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
|
||||||
|
#t
|
||||||
|
file
|
||||||
|
lstat))
|
||||||
|
|
||||||
(define* (populate-store reference-graphs target
|
(define* (populate-store reference-graphs target
|
||||||
#:key (log-port (current-error-port)))
|
#:key (log-port (current-error-port)))
|
||||||
"Populate the store under directory TARGET with the items specified in
|
"Populate the store under directory TARGET with the items specified in
|
||||||
|
@ -197,7 +219,13 @@ (define (graph-from-file file)
|
||||||
(for-each (lambda (thing)
|
(for-each (lambda (thing)
|
||||||
(copy-recursively thing
|
(copy-recursively thing
|
||||||
(string-append target thing)
|
(string-append target thing)
|
||||||
|
#:keep-mtime? #t
|
||||||
#:log (%make-void-port "w"))
|
#: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))
|
(report))
|
||||||
things)))))
|
things)))))
|
||||||
|
|
||||||
|
|
|
@ -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
|
# exists because /opt/gnu/bin may be an absolute symlink to a store item that
|
||||||
# has been GC'd.
|
# has been GC'd.
|
||||||
test_directory="`mktemp -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"
|
cd "$test_directory"
|
||||||
tar -xf "$the_pack"
|
tar -xf "$the_pack"
|
||||||
test -L opt/gnu/bin
|
test -L opt/gnu/bin
|
||||||
|
|
|
@ -68,18 +68,42 @@ (define %tar-bootstrap %bootstrap-coreutils&co)
|
||||||
#:archiver %tar-bootstrap))
|
#:archiver %tar-bootstrap))
|
||||||
(check (gexp->derivation
|
(check (gexp->derivation
|
||||||
"check-tarball"
|
"check-tarball"
|
||||||
#~(let ((bin (string-append "." #$profile "/bin")))
|
(with-imported-modules '((guix build utils))
|
||||||
(setenv "PATH"
|
#~(begin
|
||||||
(string-append #$%tar-bootstrap "/bin"))
|
(use-modules (guix build utils)
|
||||||
(system* "tar" "xvf" #$tarball)
|
(srfi srfi-1))
|
||||||
(mkdir #$output)
|
|
||||||
(exit
|
(define store
|
||||||
(and (file-exists? (string-append bin "/guile"))
|
;; The unpacked store.
|
||||||
(string=? (string-append #$%bootstrap-guile "/bin")
|
(string-append "." (%store-directory) "/"))
|
||||||
(readlink bin))
|
|
||||||
(string=? (string-append ".." #$profile
|
(define (canonical? file)
|
||||||
"/bin/guile")
|
;; Return #t if FILE is read-only and its mtime is 1.
|
||||||
(readlink "bin/Guile"))))))))
|
(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))))
|
(built-derivations (list check))))
|
||||||
|
|
||||||
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
|
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of
|
||||||
|
|
Loading…
Reference in a new issue