ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

pack: Import (guix store database) only when '--localstatedir' is passed.

Browse source 
This is another way to address <https://bugs.gnu.org/32184>, which was
previously addressed in commit 19c924af4f.

* gnu/build/install.scm (register-closure): Move to...
* gnu/build/vm.scm (register-closure): ... here.  New procedure.
* guix/scripts/pack.scm (self-contained-tarball)[build]: Remove
now unneeded 'with-extensions' form and custom (guix config) module.
* tests/guix-pack.sh: Revert the strategy from
commit 19c924af4f.
* tests/pack.scm ("self-contained-tarball"): Likewise.
This commit is contained in:
Ludovic Courtès 2018-10-28 00:17:08 +02:00
parent ec4c81fe32
commit b27ef1d46c
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
5 changed files with 147 additions and 167 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
gnu/build/install.scm
View file

@ -18,7 +18,6 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (gnu build install) (define-module (gnu build install)
#:use-module (guix store database)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
@ -141,23 +140,6 @@ (define (populate-root-file-system system target)
(try)) (try))
(apply throw args))))))) (apply throw args)))))))
(define* (register-closure prefix closure
#:key
(deduplicate? #t) (reset-timestamps? #t)
(schema (sql-schema)))
"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph)))
(register-items items
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:registration-time %epoch
#:schema schema)))
(define* (populate-single-profile-directory directory (define* (populate-single-profile-directory directory
#:key profile closure #:key profile closure
(profile-name "guix-profile") (profile-name "guix-profile")

19
gnu/build/vm.scm
View file

@ -25,7 +25,7 @@ (define-module (gnu build vm)
#:use-module (guix build utils) #:use-module (guix build utils)
#:use-module (guix build store-copy) #:use-module (guix build store-copy)
#:use-module (guix build syscalls) #:use-module (guix build syscalls)
#:use-module ((guix store database) #:select (reset-timestamps)) #:use-module (guix store database)
#:use-module (gnu build linux-boot) #:use-module (gnu build linux-boot)
#:use-module (gnu build install) #:use-module (gnu build install)
#:use-module (gnu system uuid) #:use-module (gnu system uuid)
@ -191,6 +191,23 @@ (define arch-specific-flags
(mkdir output) (mkdir output)
(copy-recursively "xchg" output))))) (copy-recursively "xchg" output)))))
(define* (register-closure prefix closure
#:key
(deduplicate? #t) (reset-timestamps? #t)
(schema (sql-schema)))
"Register CLOSURE in PREFIX, where PREFIX is the directory name of the
target store and CLOSURE is the name of a file containing a reference graph as
produced by #:references-graphs.. As a side effect, if RESET-TIMESTAMPS? is
true, reset timestamps on store files and, if DEDUPLICATE? is true,
deduplicates files common to CLOSURE and the rest of PREFIX."
(let ((items (call-with-input-file closure read-reference-graph)))
(register-items items
#:prefix prefix
#:deduplicate? deduplicate?
#:reset-timestamps? reset-timestamps?
#:registration-time %epoch
#:schema schema)))
;;; ;;;
;;; Partitions. ;;; Partitions.

187
guix/scripts/pack.scm
View file

@ -164,113 +164,110 @@ (define database
"/db/db.sqlite"))) "/db/db.sqlite")))
(define build (define build
(with-imported-modules `(((guix config) => ,(make-config.scm)) (with-imported-modules (source-module-closure
,@(source-module-closure `((guix build utils)
`((guix build utils) (guix build union)
(guix build union) (gnu build install))
(guix build store-copy) #:select? not-config?)
(gnu build install)) #~(begin
#:select? not-config?)) (use-modules (guix build utils)
(with-extensions gcrypt-sqlite3&co ((guix build union) #:select (relative-file-name))
#~(begin (gnu build install)
(use-modules (guix build utils) (srfi srfi-1)
((guix build union) #:select (relative-file-name)) (srfi srfi-26)
(gnu build install) (ice-9 match))
(srfi srfi-1)
(srfi srfi-26)
(ice-9 match))
(define %root "root") (define %root "root")
(define symlink->directives (define symlink->directives
;; Return "populate directives" to make the given symlink and its ;; Return "populate directives" to make the given symlink and its
;; parent directories. ;; parent directories.
(match-lambda (match-lambda
((source '-> target) ((source '-> target)
(let ((target (string-append #$profile "/" target)) (let ((target (string-append #$profile "/" target))
(parent (dirname source))) (parent (dirname source)))
;; Never add a 'directory' directive for "/" so as to ;; Never add a 'directory' directive for "/" so as to
;; preserve its ownnership when extracting the archive (see ;; preserve its ownnership when extracting the archive (see
;; below), and also because this would lead to adding the ;; below), and also because this would lead to adding the
;; same entries twice in the tarball. ;; same entries twice in the tarball.
`(,@(if (string=? parent "/") `(,@(if (string=? parent "/")
'() '()
`((directory ,parent))) `((directory ,parent)))
(,source (,source
-> ,(relative-file-name parent target))))))) -> ,(relative-file-name parent target)))))))
(define directives (define directives
;; Fully-qualified symlinks. ;; Fully-qualified symlinks.
(append-map symlink->directives '#$symlinks)) (append-map symlink->directives '#$symlinks))
;; The --sort option was added to GNU tar in version 1.28, released ;; The --sort option was added to GNU tar in version 1.28, released
;; 2014-07-28. For testing, we use the bootstrap tar, which is ;; 2014-07-28. For testing, we use the bootstrap tar, which is
;; older and doesn't support it. ;; older and doesn't support it.
(define tar-supports-sort? (define tar-supports-sort?
(zero? (system* (string-append #+archiver "/bin/tar") (zero? (system* (string-append #+archiver "/bin/tar")
"cf" "/dev/null" "--files-from=/dev/null" "cf" "/dev/null" "--files-from=/dev/null"
"--sort=name"))) "--sort=name")))
;; Add 'tar' to the search path. ;; Add 'tar' to the search path.
(setenv "PATH" #+(file-append archiver "/bin")) (setenv "PATH" #+(file-append archiver "/bin"))
;; Note: there is not much to gain here with deduplication and there ;; Note: there is not much to gain here with deduplication and there
;; is the overhead of the '.links' directory, so turn it off. ;; is the overhead of the '.links' directory, so turn it off.
;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs
;; with hard links: ;; with hard links:
;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>.
(populate-single-profile-directory %root (populate-single-profile-directory %root
#:profile #$profile #:profile #$profile
#:closure "profile" #:closure "profile"
#:database #+database) #:database #+database)
;; Create SYMLINKS. ;; Create SYMLINKS.
(for-each (cut evaluate-populate-directive <> %root) (for-each (cut evaluate-populate-directive <> %root)
directives) directives)
;; Create the tarball. Use GNU format so there's no file name ;; Create the tarball. Use GNU format so there's no file name
;; length limitation. ;; length limitation.
(with-directory-excursion %root (with-directory-excursion %root
(exit (exit
(zero? (apply system* "tar" (zero? (apply system* "tar"
#+@(if (compressor-command compressor) #+@(if (compressor-command compressor)
#~("-I" #~("-I"
(string-join (string-join
'#+(compressor-command compressor))) '#+(compressor-command compressor)))
#~()) #~())
"--format=gnu" "--format=gnu"
;; Avoid non-determinism in the archive. Use ;; Avoid non-determinism in the archive. Use
;; mtime = 1, not zero, because that is what the ;; mtime = 1, not zero, because that is what the
;; daemon does for files in the store (see the ;; daemon does for files in the store (see the
;; 'mtimeStore' constant in local-store.cc.) ;; 'mtimeStore' constant in local-store.cc.)
(if tar-supports-sort? "--sort=name" "--mtime=@1") (if tar-supports-sort? "--sort=name" "--mtime=@1")
"--mtime=@1" ;for files in /var/guix "--mtime=@1" ;for files in /var/guix
"--owner=root:0" "--owner=root:0"
"--group=root:0" "--group=root:0"
"--check-links" "--check-links"
"-cvf" #$output "-cvf" #$output
;; Avoid adding / and /var to the tarball, so ;; Avoid adding / and /var to the tarball, so
;; that the ownership and permissions of those ;; that the ownership and permissions of those
;; directories will not be overwritten when ;; directories will not be overwritten when
;; extracting the archive. Do not include /root ;; extracting the archive. Do not include /root
;; because the root account might have a ;; because the root account might have a
;; different home directory. ;; different home directory.
#$@(if localstatedir? #$@(if localstatedir?
'("./var/guix") '("./var/guix")
'()) '())
(string-append "." (%store-directory)) (string-append "." (%store-directory))
(delete-duplicates (delete-duplicates
(filter-map (match-lambda (filter-map (match-lambda
(('directory directory) (('directory directory)
(string-append "." directory)) (string-append "." directory))
((source '-> _) ((source '-> _)
(string-append "." source)) (string-append "." source))
(_ #f)) (_ #f))
directives)))))))))) directives)))))))))
(gexp->derivation (string-append name ".tar" (gexp->derivation (string-append name ".tar"
(compressor-extension compressor)) (compressor-extension compressor))

26
tests/guix-pack.sh
View file

@ -29,33 +29,21 @@ fi
guix pack --version guix pack --version
# Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, 'guix pack' # Use --no-substitutes because we need to verify we can do this ourselves.
# produces derivations that refer to guile-sqlite3 and libgcrypt. To make GUIX_BUILD_OPTIONS="--no-substitutes"
# that relatively inexpensive, run the test in the user's global store if export GUIX_BUILD_OPTIONS
# possible, on the grounds that binaries may already be there or can be built
# or downloaded inexpensively.
NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`"
localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`"
GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket"
export NIX_STORE_DIR GUIX_DAEMON_SOCKET
if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))'
then
exit 77
fi
# Build a tarball with no compression. # Build a tarball with no compression.
guix pack --compression=none guile-bootstrap guix pack --compression=none --bootstrap guile-bootstrap
# Build a tarball (with compression). Check that '-e' works as well. # Build a tarball (with compression). Check that '-e' works as well.
out1="`guix pack guile-bootstrap`" out1="`guix pack --bootstrap guile-bootstrap`"
out2="`guix pack -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" out2="`guix pack --bootstrap -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`"
test -n "$out1" test -n "$out1"
test "$out1" = "$out2" test "$out1" = "$out2"
# Build a tarball with a symlink. # Build a tarball with a symlink.
the_pack="`guix pack -S /opt/gnu/bin=bin guile-bootstrap`" the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`"
# Try to extract it. Note: we cannot test whether /opt/gnu/bin/guile itself # Try to extract it. Note: we cannot test whether /opt/gnu/bin/guile itself
# 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

64
tests/pack.scm
View file

@ -29,6 +29,9 @@ (define-module (test-pack)
#:use-module (gnu packages bootstrap) #:use-module (gnu packages bootstrap)
#:use-module (srfi srfi-64)) #:use-module (srfi srfi-64))
(define %store
(open-connection-for-tests))
;; Globally disable grafts because they can trigger early builds. ;; Globally disable grafts because they can trigger early builds.
(%graft? #f) (%graft? #f)
@ -48,40 +51,33 @@ (define %tar-bootstrap %bootstrap-coreutils&co)
(test-begin "pack") (test-begin "pack")
;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of (unless (network-reachable?) (test-skip 1))
;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, (test-assertm "self-contained-tarball" %store
;; run it on the user's store, if it's available, on the grounds that these (mlet* %store-monad
;; dependencies may be already there, or we can get substitutes or build them ((profile (profile-derivation (packages->manifest
;; quite inexpensively; see <https://bugs.gnu.org/32184>. (list %bootstrap-guile))
#:hooks '()
(with-external-store store #:locales? #f))
(unless store (test-skip 1)) (tarball (self-contained-tarball "pack" profile
(test-assertm "self-contained-tarball" store #:symlinks '(("/bin/Guile"
(mlet* %store-monad -> "bin/guile"))
((profile (profile-derivation (packages->manifest #:compressor %gzip-compressor
(list %bootstrap-guile)) #:archiver %tar-bootstrap))
#:hooks '() (check (gexp->derivation
#:locales? #f)) "check-tarball"
(tarball (self-contained-tarball "pack" profile #~(let ((bin (string-append "." #$profile "/bin")))
#:symlinks '(("/bin/Guile" (setenv "PATH"
-> "bin/guile")) (string-append #$%tar-bootstrap "/bin"))
#:compressor %gzip-compressor (system* "tar" "xvf" #$tarball)
#:archiver %tar-bootstrap)) (mkdir #$output)
(check (gexp->derivation (exit
"check-tarball" (and (file-exists? (string-append bin "/guile"))
#~(let ((bin (string-append "." #$profile "/bin"))) (string=? (string-append #$%bootstrap-guile "/bin")
(setenv "PATH" (readlink bin))
(string-append #$%tar-bootstrap "/bin")) (string=? (string-append ".." #$profile
(system* "tar" "xvf" #$tarball) "/bin/guile")
(mkdir #$output) (readlink "bin/Guile"))))))))
(exit (built-derivations (list check))))
(and (file-exists? (string-append bin "/guile"))
(string=? (string-append #$%bootstrap-guile "/bin")
(readlink bin))
(string=? (string-append ".." #$profile
"/bin/guile")
(readlink "bin/Guile"))))))))
(built-derivations (list check)))))
(test-end) (test-end)