tests: Add tests for "guix pack".

* guix/scripts/pack.scm (bootstrap-xz): New variable. (%options) <--bootstrap>: New option. (show-help): Document the new --bootstrap option. (guix-pack): When --bootstrap is specified, use the bootstrap Guile, tar, and xz to build the pack, and do not use any profile hooks or locales. * doc/guix.texi (Invoking guix pull): Document the new --bootstrap option. * tests/guix-pack.sh: New file. * Makefile.am (SH_TESTS): Add guix-pack.sh. * gnu/packages/package-management.scm (guix) <inputs>: Add util-linux.
2024-11-07 07:26:13 -05:00 · 2018-03-11 01:13:01 +01:00 · 2018-03-11 01:13:01 +01:00 · 272c070962
commit 272c070962
parent 24fa6bcac6
5 changed files with 138 additions and 18 deletions
--- a/Makefile.am
+++ b/Makefile.am
@ -374,6 +374,7 @@ SH_TESTS =					\
  tests/guix-download.sh			\
  tests/guix-gc.sh				\
  tests/guix-hash.sh				\
+  tests/guix-pack.sh				\
  tests/guix-package.sh				\
  tests/guix-package-net.sh			\
  tests/guix-system.sh				\
--- a/doc/guix.texi
+++ b/doc/guix.texi
@ -23,7 +23,7 @@ Copyright @copyright{} 2015 Taylan Ulrich Bayırlı/Kammer@*
 Copyright @copyright{} 2015, 2016, 2017 Leo Famulari@*
 Copyright @copyright{} 2015, 2016, 2017, 2018 Ricardo Wurmus@*
 Copyright @copyright{} 2016 Ben Woodcroft@*
-Copyright @copyright{} 2016, 2017 Chris Marusich@*
+Copyright @copyright{} 2016, 2017, 2018 Chris Marusich@*
 Copyright @copyright{} 2016, 2017, 2018 Efraim Flashner@*
 Copyright @copyright{} 2016 John Darrington@*
 Copyright @copyright{} 2016, 2017 Nils Gillmann@*
@ -2899,6 +2899,10 @@ added to it or removed from it after extraction of the pack.

 One use case for this is the Guix self-contained binary tarball
 (@pxref{Binary Installation}).
+
+@item --bootstrap
+Use the bootstrap binaries to build the pack.  This option is only
+useful to Guix developers.
@end table

 In addition, @command{guix pack} supports all the common build options
--- a/gnu/packages/package-management.scm
+++ b/gnu/packages/package-management.scm
@ -257,6 +257,8 @@ (define (intern tarball)
         ;; Many tests rely on the 'guile-bootstrap' package, which is why we
         ;; have it here.
         ("boot-guile" ,(bootstrap-guile-origin (%current-system)))
+         ;; Some of the tests use "unshare" when it is available.
+         ("util-linux" ,util-linux)
         ,@(if (and (not (%current-target-system))
                    (string=? (%current-system) "x86_64-linux"))
               `(("boot-guile/i686" ,(bootstrap-guile-origin "i686-linux")))
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Konrad Hinsen <konrad.hinsen@fastmail.net>
+;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@ -33,7 +34,9 @@ (define-module (guix scripts pack)
  #:use-module (guix derivations)
  #:use-module (guix scripts build)
  #:use-module (gnu packages)
+  #:use-module (gnu packages bootstrap)
  #:use-module (gnu packages compression)
+  #:use-module (gnu packages guile)
  #:autoload   (gnu packages base) (tar)
  #:autoload   (gnu packages package-management) (guix)
  #:autoload   (gnu packages gnupg) (libgcrypt)
@ -67,6 +70,11 @@ (define %compressors
                    #~(#+(file-append bzip2 "/bin/bzip2") "-9"))
        (compressor "none" "" #f)))

+;; This one is only for use in this module, so don't put it in %compressors.
+(define bootstrap-xz
+  (compressor "bootstrap-xz" ".xz"
+              #~(#+(file-append %bootstrap-coreutils&co "/bin/xz") "-e -T0")))
+
 (define (lookup-compressor name)
  "Return the compressor object called NAME.  Error out if it could not be
 found."
@ -325,6 +333,9 @@ (define %options
         (option '("localstatedir") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'localstatedir? #t result)))
+         (option '("bootstrap") #f #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'bootstrap? #t result)))

         (append %transformation-options
                 %standard-build-options)))
@ -352,6 +363,8 @@ (define (show-help)
  -m, --manifest=FILE    create a pack with the manifest from FILE"))
  (display (G_ "
      --localstatedir    include /var/guix in the resulting pack"))
+  (display (G_ "
+      --bootstrap        use the bootstrap binaries to build the pack"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
@ -393,28 +406,43 @@ (define (manifest-from-args opts)
       (else (packages->manifest packages)))))

  (with-error-handling
-    (parameterize ((%graft? (assoc-ref opts 'graft?)))
-      (let* ((dry-run?    (assoc-ref opts 'dry-run?))
-             (manifest    (manifest-from-args opts))
-             (pack-format (assoc-ref opts 'format))
-             (name        (string-append (symbol->string pack-format)
-                                         "-pack"))
-             (target      (assoc-ref opts 'target))
-             (compressor  (assoc-ref opts 'compressor))
-             (symlinks    (assoc-ref opts 'symlinks))
-             (build-image (match (assq-ref %formats pack-format)
-                            ((? procedure? proc) proc)
-                            (#f
-                             (leave (G_ "~a: unknown pack format")
-                                    format))))
-             (localstatedir? (assoc-ref opts 'localstatedir?)))
-        (with-store store
+    (let* ((dry-run?    (assoc-ref opts 'dry-run?))
+           (manifest    (manifest-from-args opts))
+           (pack-format (assoc-ref opts 'format))
+           (name        (string-append (symbol->string pack-format)
+                                       "-pack"))
+           (target      (assoc-ref opts 'target))
+           (bootstrap?  (assoc-ref opts 'bootstrap?))
+           (compressor  (if bootstrap?
+                            bootstrap-xz
+                            (assoc-ref opts 'compressor)))
+           (tar         (if bootstrap?
+                            %bootstrap-coreutils&co
+                            tar))
+           (symlinks    (assoc-ref opts 'symlinks))
+           (build-image (match (assq-ref %formats pack-format)
+                          ((? procedure? proc) proc)
+                          (#f
+                           (leave (G_ "~a: unknown pack format")
+                                  format))))
+           (localstatedir? (assoc-ref opts 'localstatedir?)))
+      (with-store store
+        (parameterize ((%graft? (assoc-ref opts 'graft?))
+                       (%guile-for-build (package-derivation
+                                          store
+                                          (if (assoc-ref opts 'bootstrap?)
+                                              %bootstrap-guile
+                                              (canonical-package guile-2.2)))))
          ;; Set the build options before we do anything else.
          (set-build-options-from-command-line store opts)

          (run-with-store store
            (mlet* %store-monad ((profile (profile-derivation
                                           manifest
+                                           #:hooks (if bootstrap?
+                                                       '()
+                                                       %default-profile-hooks)
+                                           #:locales? (not bootstrap?)
                                           #:target target))
                                 (drv (build-image name profile
                                                   #:target
@ -424,7 +452,9 @@ (define (manifest-from-args opts)
                                                   #:symlinks
                                                   symlinks
                                                   #:localstatedir?
-                                                   localstatedir?)))
+                                                   localstatedir?
+                                                   #:tar
+                                                   tar)))
              (mbegin %store-monad
                (show-what-to-build* (list drv)
                                     #:use-substitutes?
--- a/tests/guix-pack.sh
+++ b/tests/guix-pack.sh
@ -0,0 +1,83 @@
+# GNU Guix --- Functional package management for GNU
+# Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
+#
+# 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/>.
+
+#
+# Test the `guix pack' command-line utility.
+#
+
+# A network connection is required to build %bootstrap-coreutils&co,
+# which is required to run these tests with the --bootstrap option.
+if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null; then
+    exit 77
+fi
+
+guix pack --version
+
+# 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 --bootstrap guile-bootstrap
+
+# Build a tarball (with compression).
+guix pack --bootstrap guile-bootstrap
+
+# Build a tarball with a symlink.
+the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`"
+
+# Try to extract it.
+test_directory="`mktemp -d`"
+trap 'rm -rf "$test_directory"' EXIT
+cd "$test_directory"
+tar -xf "$the_pack"
+test -x opt/gnu/bin/guile
+
+is_available () {
+    # Use the "type" shell builtin to see if the program is on PATH.
+    type "$1" > /dev/null
+}
+
+if is_available chroot && is_available unshare; then
+    # Verify we can use what we built.
+    unshare -r chroot . /opt/gnu/bin/guile --version
+    cd -
+else
+    echo "warning: skipped some verification because chroot or unshare is unavailable" >&2
+fi
+
+# For the tests that build Docker images below, we currently have to use
+# --dry-run because if we don't, there are only two possible cases:
+#
+#     Case 1: We do not use --bootstrap, and the build takes hours to finish
+#             because it needs to build tar etc.
+#
+#     Case 2: We use --bootstrap, and the build fails because the bootstrap
+#             Guile cannot dlopen shared libraries.  Not to mention the fact
+#             that we would still have to build many non-bootstrap inputs
+#             (e.g., guile-json) in order to create the Docker image.
+
+# Build a Docker image.
+guix pack --dry-run --bootstrap -f docker guile-bootstrap
+
+# Build a Docker image with a symlink.
+guix pack --dry-run --bootstrap -f docker -S /opt/gnu=/ guile-bootstrap
+
+# Build a tarball pack of cross-compiled software.  Use coreutils because
+# guile-bootstrap is not intended to be cross-compiled.
+guix pack --dry-run --bootstrap --target=arm-unknown-linux-gnueabihf coreutils