diff options
| -rw-r--r-- | gnu/build/install.scm | 18 | ||||
| -rw-r--r-- | gnu/build/vm.scm | 19 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 211 | ||||
| -rw-r--r-- | tests/guix-pack.sh | 26 | ||||
| -rw-r--r-- | tests/pack.scm | 64 |
5 files changed, 159 insertions, 179 deletions
diff --git a/gnu/build/install.scm b/gnu/build/install.scm index 9f9a6aba0f..a31e1945d6 100644 --- a/gnu/build/install.scm +++ b/gnu/build/install.scm @@ -18,7 +18,6 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (gnu build install) - #:use-module (guix store database) #:use-module (guix build utils) #:use-module (guix build store-copy) #:use-module (srfi srfi-26) @@ -141,23 +140,6 @@ includes /etc, /var, /run, /bin/sh, etc., and all the symlinks to SYSTEM." (try)) (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 #:key profile closure (profile-name "guix-profile") diff --git a/gnu/build/vm.scm b/gnu/build/vm.scm index 5579886264..746808515f 100644 --- a/gnu/build/vm.scm +++ b/gnu/build/vm.scm @@ -25,7 +25,7 @@ #:use-module (guix build utils) #:use-module (guix build store-copy) #: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 install) #:use-module (gnu system uuid) @@ -191,6 +191,23 @@ the #:references-graphs parameter of 'derivation'." (mkdir 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. diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index faeea68426..3e6430bcce 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -164,113 +164,110 @@ added to the pack." "/db/db.sqlite"))) (define build - (with-imported-modules `(((guix config) => ,(make-config.scm)) - ,@(source-module-closure - `((guix build utils) - (guix build union) - (guix build store-copy) - (gnu build install)) - #:select? not-config?)) - (with-extensions gcrypt-sqlite3&co - #~(begin - (use-modules (guix build utils) - ((guix build union) #:select (relative-file-name)) - (gnu build install) - (srfi srfi-1) - (srfi srfi-26) - (ice-9 match)) - - (define %root "root") - - (define symlink->directives - ;; Return "populate directives" to make the given symlink and its - ;; parent directories. - (match-lambda - ((source '-> target) - (let ((target (string-append #$profile "/" target)) - (parent (dirname source))) - ;; Never add a 'directory' directive for "/" so as to - ;; preserve its ownnership when extracting the archive (see - ;; below), and also because this would lead to adding the - ;; same entries twice in the tarball. - `(,@(if (string=? parent "/") - '() - `((directory ,parent))) - (,source - -> ,(relative-file-name parent target))))))) - - (define directives - ;; Fully-qualified symlinks. - (append-map symlink->directives '#$symlinks)) - - ;; 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 - ;; older and doesn't support it. - (define tar-supports-sort? - (zero? (system* (string-append #+archiver "/bin/tar") - "cf" "/dev/null" "--files-from=/dev/null" - "--sort=name"))) - - ;; Add 'tar' to the search path. - (setenv "PATH" #+(file-append archiver "/bin")) - - ;; Note: there is not much to gain here with deduplication and there - ;; is the overhead of the '.links' directory, so turn it off. - ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs - ;; with hard links: - ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. - (populate-single-profile-directory %root - #:profile #$profile - #:closure "profile" - #:database #+database) - - ;; Create SYMLINKS. - (for-each (cut evaluate-populate-directive <> %root) - directives) - - ;; Create the tarball. Use GNU format so there's no file name - ;; length limitation. - (with-directory-excursion %root - (exit - (zero? (apply system* "tar" - #+@(if (compressor-command compressor) - #~("-I" - (string-join - '#+(compressor-command compressor))) - #~()) - "--format=gnu" - - ;; Avoid non-determinism in the archive. Use - ;; mtime = 1, not zero, because that is what the - ;; daemon does for files in the store (see the - ;; 'mtimeStore' constant in local-store.cc.) - (if tar-supports-sort? "--sort=name" "--mtime=@1") - "--mtime=@1" ;for files in /var/guix - "--owner=root:0" - "--group=root:0" - - "--check-links" - "-cvf" #$output - ;; Avoid adding / and /var to the tarball, so - ;; that the ownership and permissions of those - ;; directories will not be overwritten when - ;; extracting the archive. Do not include /root - ;; because the root account might have a - ;; different home directory. - #$@(if localstatedir? - '("./var/guix") - '()) - - (string-append "." (%store-directory)) - - (delete-duplicates - (filter-map (match-lambda - (('directory directory) - (string-append "." directory)) - ((source '-> _) - (string-append "." source)) - (_ #f)) - directives)))))))))) + (with-imported-modules (source-module-closure + `((guix build utils) + (guix build union) + (gnu build install)) + #:select? not-config?) + #~(begin + (use-modules (guix build utils) + ((guix build union) #:select (relative-file-name)) + (gnu build install) + (srfi srfi-1) + (srfi srfi-26) + (ice-9 match)) + + (define %root "root") + + (define symlink->directives + ;; Return "populate directives" to make the given symlink and its + ;; parent directories. + (match-lambda + ((source '-> target) + (let ((target (string-append #$profile "/" target)) + (parent (dirname source))) + ;; Never add a 'directory' directive for "/" so as to + ;; preserve its ownnership when extracting the archive (see + ;; below), and also because this would lead to adding the + ;; same entries twice in the tarball. + `(,@(if (string=? parent "/") + '() + `((directory ,parent))) + (,source + -> ,(relative-file-name parent target))))))) + + (define directives + ;; Fully-qualified symlinks. + (append-map symlink->directives '#$symlinks)) + + ;; 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 + ;; older and doesn't support it. + (define tar-supports-sort? + (zero? (system* (string-append #+archiver "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + + ;; Add 'tar' to the search path. + (setenv "PATH" #+(file-append archiver "/bin")) + + ;; Note: there is not much to gain here with deduplication and there + ;; is the overhead of the '.links' directory, so turn it off. + ;; Furthermore GNU tar < 1.30 sometimes fails to extract tarballs + ;; with hard links: + ;; <http://lists.gnu.org/archive/html/bug-tar/2017-11/msg00009.html>. + (populate-single-profile-directory %root + #:profile #$profile + #:closure "profile" + #:database #+database) + + ;; Create SYMLINKS. + (for-each (cut evaluate-populate-directive <> %root) + directives) + + ;; Create the tarball. Use GNU format so there's no file name + ;; length limitation. + (with-directory-excursion %root + (exit + (zero? (apply system* "tar" + #+@(if (compressor-command compressor) + #~("-I" + (string-join + '#+(compressor-command compressor))) + #~()) + "--format=gnu" + + ;; Avoid non-determinism in the archive. Use + ;; mtime = 1, not zero, because that is what the + ;; daemon does for files in the store (see the + ;; 'mtimeStore' constant in local-store.cc.) + (if tar-supports-sort? "--sort=name" "--mtime=@1") + "--mtime=@1" ;for files in /var/guix + "--owner=root:0" + "--group=root:0" + + "--check-links" + "-cvf" #$output + ;; Avoid adding / and /var to the tarball, so + ;; that the ownership and permissions of those + ;; directories will not be overwritten when + ;; extracting the archive. Do not include /root + ;; because the root account might have a + ;; different home directory. + #$@(if localstatedir? + '("./var/guix") + '()) + + (string-append "." (%store-directory)) + + (delete-duplicates + (filter-map (match-lambda + (('directory directory) + (string-append "." directory)) + ((source '-> _) + (string-append "." source)) + (_ #f)) + directives))))))))) (gexp->derivation (string-append name ".tar" (compressor-extension compressor)) diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index cd721a60e9..8c1f556426 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -29,33 +29,21 @@ fi guix pack --version -# Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, 'guix pack' -# produces derivations that refer to guile-sqlite3 and libgcrypt. To make -# that relatively inexpensive, run the test in the user's global store if -# 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 +# Use --no-substitutes because we need to verify we can do this ourselves. +GUIX_BUILD_OPTIONS="--no-substitutes" +export GUIX_BUILD_OPTIONS # 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. -out1="`guix pack guile-bootstrap`" -out2="`guix pack -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" +out1="`guix pack --bootstrap guile-bootstrap`" +out2="`guix pack --bootstrap -e '(@ (gnu packages bootstrap) %bootstrap-guile)'`" test -n "$out1" test "$out1" = "$out2" # 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 # exists because /opt/gnu/bin may be an absolute symlink to a store item that diff --git a/tests/pack.scm b/tests/pack.scm index 4eb5be92ff..6bd18bdee2 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -29,6 +29,9 @@ #:use-module (gnu packages bootstrap) #:use-module (srfi srfi-64)) +(define %store + (open-connection-for-tests)) + ;; Globally disable grafts because they can trigger early builds. (%graft? #f) @@ -48,40 +51,33 @@ (test-begin "pack") -;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of -;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, -;; run it on the user's store, if it's available, on the grounds that these -;; dependencies may be already there, or we can get substitutes or build them -;; quite inexpensively; see <https://bugs.gnu.org/32184>. - -(with-external-store store - (unless store (test-skip 1)) - (test-assertm "self-contained-tarball" store - (mlet* %store-monad - ((profile (profile-derivation (packages->manifest - (list %bootstrap-guile)) - #:hooks '() - #:locales? #f)) - (tarball (self-contained-tarball "pack" profile - #:symlinks '(("/bin/Guile" - -> "bin/guile")) - #:compressor %gzip-compressor - #:archiver %tar-bootstrap)) - (check (gexp->derivation - "check-tarball" - #~(let ((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")) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile")))))))) - (built-derivations (list check))))) +(unless (network-reachable?) (test-skip 1)) +(test-assertm "self-contained-tarball" %store + (mlet* %store-monad + ((profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (self-contained-tarball "pack" profile + #:symlinks '(("/bin/Guile" + -> "bin/guile")) + #:compressor %gzip-compressor + #:archiver %tar-bootstrap)) + (check (gexp->derivation + "check-tarball" + #~(let ((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")) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile")))))))) + (built-derivations (list check)))) (test-end) |