diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/scripts/pack.scm | 13 | ||||
| -rw-r--r-- | tests/pack.scm | 79 |
3 files changed, 91 insertions, 2 deletions
diff --git a/Makefile.am b/Makefile.am index 23171ae837..dea70de00f 100644 --- a/Makefile.am +++ b/Makefile.am @@ -297,6 +297,7 @@ SCM_TESTS = \ tests/services.scm \ tests/scripts-build.scm \ tests/containers.scm \ + tests/pack.scm \ tests/import-utils.scm if HAVE_GUILE_JSON diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm index c3d85c568c..067b1227e0 100644 --- a/guix/scripts/pack.scm +++ b/guix/scripts/pack.scm @@ -70,7 +70,8 @@ found." #:key deduplicate? (compressor (first %compressors)) localstatedir? - (symlinks '())) + (symlinks '()) + (tar tar)) "Return a self-contained tarball containing a store initialized with the closure of PROFILE, a derivation. The tarball contains /gnu/store; if LOCALSTATEDIR? is true, it also contains /var/guix, including /var/guix/db @@ -104,6 +105,14 @@ added to the pack." ;; 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 #+tar "/bin/tar") + "cf" "/dev/null" "--files-from=/dev/null" + "--sort=name"))) + ;; We need Guix here for 'guix-register'. (setenv "PATH" (string-append #$(if localstatedir? @@ -137,7 +146,7 @@ added to the pack." ;; mtime = 1, not zero, because that is what the ;; daemon does for files in the store (see the ;; 'mtimeStore' constant in local-store.cc.) - "--sort=name" + (if tar-supports-sort? "--sort=name" "--mtime=@1") "--mtime=@1" ;for files in /var/guix "--owner=root:0" "--group=root:0" diff --git a/tests/pack.scm b/tests/pack.scm new file mode 100644 index 0000000000..de9ef8e6ab --- /dev/null +++ b/tests/pack.scm @@ -0,0 +1,79 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (test-pack) + #:use-module (guix scripts pack) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix profiles) + #:use-module (guix monads) + #:use-module (guix grafts) + #:use-module (guix tests) + #:use-module (guix gexp) + #: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) + +(define-syntax-rule (test-assertm name exp) + (test-assert name + (run-with-store %store exp + #:guile-for-build (%guile-for-build)))) + +(define %gzip-compressor + ;; Compressor that uses the bootstrap 'gzip'. + ((@ (guix scripts pack) compressor) "gzip" + %bootstrap-coreutils&co "gz" '("gzip" "-6n"))) + +(define %tar-bootstrap %bootstrap-coreutils&co) + + +(test-begin "pack") + +(test-assertm "self-contained-tarball" + (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 + #:tar %tar-bootstrap)) + (check (gexp->derivation + "check-tarball" + #~(let ((guile (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append guile "/guile")) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink guile)) + (string=? (string-append (string-drop guile 1) + "/guile") + (readlink "bin/Guile")))))))) + (built-derivations (list check)))) + +(test-end) |