06/12: pack: Add '--format' option and Docker output support.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit b1edfbc37f2f008188d91f594b046c5986485e47
Author: Ludovic Courtès <address@hidden>
Date:   Thu Mar 16 18:02:59 2017 +0100

    pack: Add '--format' option and Docker output support.
    
    * guix/docker.scm: Remove dependency on (guix store) and (guix utils).
    Use (guix build store-copy).  Load (json) lazily.
    (build-docker-image): Remove #:system.  Add #:closure, #:compressor, and
    'image' parameters.  Use 'uname' to determine the architecture.  Remove
    use of 'call-with-temporary-directory'.  Use 'read-reference-graph' to
    compute ITEMS.  Honor #:compressor.
    * guix/scripts/pack.scm (docker-image): New procedure.
    (%default-options): Add 'format'.
    (%formats): New variable.
    (%options, show-help): Add '--format'.
    (guix-pack): Honor '--format'.
    * guix/scripts/archive.scm: Remove '--format' option.  This reverts
    commits 1545a012cb7cd78e25ed99ecee26df457be590e9,
    01445711db6771cea6122859c3f717f130359f55, and
    03476a23ff2d4175b7d3c808726178f764359bec.
    * doc/guix.texi (Invoking guix pack): Document '--format'.
    (Invoking guix archive): Remove documentation of '--format'.
---
 doc/guix.texi            |  34 ++++++++--------
 guix/docker.scm          | 103 ++++++++++++++++++++++++++---------------------
 guix/scripts/archive.scm |  31 ++------------
 guix/scripts/pack.scm    |  95 ++++++++++++++++++++++++++++++++++++++-----
 4 files changed, 161 insertions(+), 102 deletions(-)

diff --git a/doc/guix.texi b/doc/guix.texi
index 3382ac4..45d171c 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2435,6 +2435,22 @@ guix pack -S /opt/gnu/bin=bin guile emacs geiser
 @noindent
 That way, users can happily type @file{/opt/gnu/bin/guile} and enjoy.
 
+Alternatively, you can produce a pack in the Docker image format, as
+described in
address@hidden://github.com/docker/docker/blob/master/image/spec/v1.2.md,
+version 1.2 of the specification}.  This is what the following command
+does:
+
address@hidden
+guix pack -f docker guile emacs geiser
address@hidden example
+
address@hidden
+The result is a tarball that can be passed to the @command{docker load}
+command.  See the
address@hidden://docs.docker.com/engine/reference/commandline/load/, Docker
+documentation} for more information.
+
 Several command-line options allow you to customize your pack:
 
 @table @code
@@ -2537,7 +2553,7 @@ what you should use in this case (@pxref{Invoking guix 
copy}).
 
 @cindex nar, archive format
 @cindex normalized archive (nar)
-By default archives are stored in the ``normalized archive'' or ``nar'' 
format, which is
+Archives are stored in the ``normalized archive'' or ``nar'' format, which is
 comparable in spirit to `tar', but with differences
 that make it more appropriate for our purposes.  First, rather than
 recording all Unix metadata for each file, the nar format only mentions
@@ -2553,9 +2569,6 @@ verifies the signature and rejects the import in case of 
an invalid
 signature or if the signing key is not authorized.
 @c FIXME: Add xref to daemon doc about signatures.
 
-Optionally, archives can be exported as a Docker image in the tar
-archive format using @code{--format=docker}.
-
 The main options are:
 
 @table @code
@@ -2584,19 +2597,6 @@ Read a list of store file names from the standard input, 
one per line,
 and write on the standard output the subset of these files missing from
 the store.
 
address@hidden -f
address@hidden address@hidden
address@hidden docker, export
address@hidden export format
-Specify the export format.  Acceptable arguments are @code{nar} and
address@hidden  The default is the nar format.  When the format is
address@hidden, recursively export the specified store directory as a
-Docker image in tar archive format, as specified in
address@hidden://github.com/docker/docker/blob/master/image/spec/v1.2.md,
-version 1.2.0 of the Docker Image Specification}.  Using
address@hidden implies @code{--recursive}.  The generated
-archive can be loaded by Docker using @command{docker load}.
-
 @item address@hidden
 @cindex signing, archives
 Generate a new key pair for the daemon.  This is a prerequisite before
diff --git a/guix/docker.scm b/guix/docker.scm
index 6dabaf2..56a0f7e 100644
--- a/guix/docker.scm
+++ b/guix/docker.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
+;;; Copyright © 2017 Ludovic Courtès <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -18,17 +19,18 @@
 
 (define-module (guix docker)
   #:use-module (guix hash)
-  #:use-module (guix store)
   #:use-module (guix base16)
-  #:use-module (guix utils)
   #:use-module ((guix build utils)
                 #:select (delete-file-recursively
                           with-directory-excursion))
-  #:use-module (json)
+  #:use-module (guix build store-copy)
   #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:export (build-docker-image))
 
+;; Load Guile-JSON at run time to simplify the job of 'imported-modules' & co.
+(module-use! (current-module) (resolve-interface '(json)))
+
 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
 ;; containing the closure at PATH.
 (define docker-id
@@ -81,48 +83,55 @@
     (rootfs . ((type . "layers")
                (diff_ids . (,(layer-diff-id layer)))))))
 
-(define* (build-docker-image path #:key system)
-  "Generate a Docker image archive from the given store PATH.  The image
-contains the closure of the given store item."
-  (let ((id (docker-id path))
+(define* (build-docker-image image path #:key closure compressor)
+  "Write to IMAGE a Docker image archive from the given store PATH.  The image
+contains the closure of PATH, as specified in CLOSURE (a file produced by
+#:references-graphs).  Use COMPRESSOR, a command such as '(\"gzip\" \"-9n\"),
+to compress IMAGE."
+  (let ((directory "/tmp/docker-image")           ;temporary working directory
+        (closure (canonicalize-path closure))
+        (id (docker-id path))
         (time (strftime "%FT%TZ" (localtime (current-time))))
-        (name (string-append (getcwd)
-                             "/docker-image-" (basename path) ".tar"))
-        (arch (match system
-                ("x86_64-linux" "amd64")
-                ("i686-linux" "386")
-                ("armhf-linux" "arm")
-                ("mips64el-linux" "mips64le"))))
-    (and (call-with-temporary-directory
-          (lambda (directory)
-            (with-directory-excursion directory
-              ;; Add symlink from /bin to /gnu/store/.../bin
-              (symlink (string-append path "/bin") "bin")
-
-              (mkdir id)
-              (with-directory-excursion id
-                (with-output-to-file "VERSION"
-                  (lambda () (display schema-version)))
-                (with-output-to-file "json"
-                  (lambda () (scm->json (image-description id time))))
-
-                ;; Wrap it up
-                (let ((items (with-store store
-                               (requisites store (list path)))))
-                  (and (zero? (apply system* "tar" "-cf" "layer.tar"
-                                     (cons "../bin" items)))
-                       (delete-file "../bin"))))
-
-              (with-output-to-file "config.json"
-                (lambda ()
-                  (scm->json (config (string-append id "/layer.tar")
-                                     time arch))))
-              (with-output-to-file "manifest.json"
-                (lambda ()
-                  (scm->json (manifest path id))))
-              (with-output-to-file "repositories"
-                (lambda ()
-                  (scm->json (repositories path id)))))
-            (and (zero? (system* "tar" "-C" directory "-cf" name "."))
-                 (begin (delete-file-recursively directory) #t))))
-         name)))
+        (arch (match (utsname:machine (uname))
+                ("x86_64" "amd64")
+                ("i686"   "386")
+                ("armv7l" "arm")
+                ("mips64" "mips64le"))))
+    ;; Make sure we start with a fresh, empty working directory.
+    (mkdir directory)
+
+    (and (with-directory-excursion directory
+           ;; Add symlink from /bin to /gnu/store/.../bin
+           (symlink (string-append path "/bin") "bin")
+
+           (mkdir id)
+           (with-directory-excursion id
+             (with-output-to-file "VERSION"
+               (lambda () (display schema-version)))
+             (with-output-to-file "json"
+               (lambda () (scm->json (image-description id time))))
+
+             ;; Wrap it up
+             (let ((items (call-with-input-file closure
+                            read-reference-graph)))
+               (and (zero? (apply system* "tar" "-cf" "layer.tar"
+                                  (cons "../bin" items)))
+                    (delete-file "../bin"))))
+
+           (with-output-to-file "config.json"
+             (lambda ()
+               (scm->json (config (string-append id "/layer.tar")
+                                  time arch))))
+           (with-output-to-file "manifest.json"
+             (lambda ()
+               (scm->json (manifest path id))))
+           (with-output-to-file "repositories"
+             (lambda ()
+               (scm->json (repositories path id)))))
+
+         (and (zero? (apply system* "tar" "-C" directory "-cf" image
+                            `(,@(if compressor
+                                    (list "-I" (string-join compressor))
+                                    '())
+                              ".")))
+              (begin (delete-file-recursively directory) #t)))))
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index cad279f..8137455 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,6 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <address@hidden>
-;;; Copyright © 2017 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -45,11 +44,6 @@
   #:export (guix-archive
             options->derivations+files))
 
-;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
-;; See <http://bugs.gnu.org/12202>.
-(module-autoload! (current-module)
-                  '(guix docker) '(build-docker-image))
-
 
 ;;;
 ;;; Command-line options.
@@ -57,8 +51,7 @@
 
 (define %default-options
   ;; Alist of default option values.
-  `((format . "nar")
-    (system . ,(%current-system))
+  `((system . ,(%current-system))
     (substitutes? . #t)
     (graft? . #t)
     (max-silent-time . 3600)
@@ -70,8 +63,6 @@ Export/import one or more packages from/to the store.\n"))
   (display (_ "
       --export           export the specified files/packages to stdout"))
   (display (_ "
-      --format=FMT       export files/packages in the specified format FMT"))
-  (display (_ "
   -r, --recursive        combined with '--export', include dependencies"))
   (display (_ "
       --import           import from the archive passed on stdin"))
@@ -126,9 +117,6 @@ Export/import one or more packages from/to the store.\n"))
          (option '("export") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'export #t result)))
-         (option '(#\f "format") #t #f
-                 (lambda (opt name arg result . rest)
-                   (alist-cons 'format arg result)))
          (option '(#\r "recursive") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'export-recursive? #t result)))
@@ -258,21 +246,8 @@ resulting archive to the standard output port."
 
     (if (or (assoc-ref opts 'dry-run?)
             (build-derivations store drv))
-        (match (assoc-ref opts 'format)
-          ("nar"
-           (export-paths store files (current-output-port)
-                         #:recursive? (assoc-ref opts 'export-recursive?)))
-          ("docker"
-           (match files
-             ((file)
-              (let ((system (assoc-ref opts 'system)))
-                (format #t "~a\n"
-                        (build-docker-image file #:system system))))
-             (x
-              ;; TODO: Remove this restriction.
-              (leave (_ "only a single item can be exported to Docker~%")))))
-          (format
-           (leave (_ "~a: unknown archive format~%") format)))
+        (export-paths store files (current-output-port)
+                      #:recursive? (assoc-ref opts 'export-recursive?))
         (leave (_ "unable to export the given packages~%")))))
 
 (define (generate-key-pair parameters)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index e422b3c..c6f2145 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -24,6 +24,7 @@
   #:use-module (guix store)
   #:use-module (guix grafts)
   #:use-module (guix monads)
+  #:use-module (guix modules)
   #:use-module (guix packages)
   #:use-module (guix profiles)
   #:use-module (guix derivations)
@@ -32,6 +33,8 @@
   #:use-module (gnu packages compression)
   #:autoload   (gnu packages base) (tar)
   #:autoload   (gnu packages package-management) (guix)
+  #:autoload   (gnu packages gnupg) (libgcrypt)
+  #:autoload   (gnu packages guile) (guile-json)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-37)
@@ -177,6 +180,59 @@ added to the pack."
                     build
                     #:references-graphs `(("profile" ,profile))))
 
+(define* (docker-image name profile
+                       #:key deduplicate?
+                       (compressor (first %compressors))
+                       localstatedir?
+                       (symlinks '())
+                       (tar tar))
+  "Return a derivation to construct a Docker image of PROFILE.  The
+image is a tarball conforming to the Docker Image Specification, compressed
+with COMPRESSOR.  It can be passed to 'docker load'."
+  ;; FIXME: Honor SYMLINKS and LOCALSTATEDIR?.
+  (define not-config?
+    (match-lambda
+      (('guix 'config) #f)
+      (('guix rest ...) #t)
+      (('gnu rest ...) #t)
+      (rest #f)))
+
+  (define config
+    ;; (guix config) module for consumption by (guix gcrypt).
+    (scheme-file "gcrypt-config.scm"
+                 #~(begin
+                     (define-module (guix config)
+                       #:export (%libgcrypt))
+
+                     ;; XXX: Work around <http://bugs.gnu.org/15602>.
+                     (eval-when (expand load eval)
+                       (define %libgcrypt
+                         #+(file-append libgcrypt "/lib/libgcrypt"))))))
+
+  (define build
+    (with-imported-modules `(,@(source-module-closure '((guix docker))
+                                                      #:select? not-config?)
+                             ((guix config) => ,config))
+      #~(begin
+          ;; Guile-JSON is required by (guix docker).
+          (add-to-load-path
+           (string-append #$guile-json "/share/guile/site/"
+                          (effective-version)))
+
+          (use-modules (guix docker))
+
+          (setenv "PATH"
+                  (string-append #$tar "/bin:"
+                                 #$(compressor-package compressor) "/bin"))
+
+          (build-docker-image #$output #$profile
+                              #:closure "profile"
+                              #:compressor '#$(compressor-command 
compressor)))))
+
+  (gexp->derivation (string-append name ".tar."
+                                   (compressor-extension compressor))
+                    build
+                    #:references-graphs `(("profile" ,profile))))
 
 
 ;;;
@@ -185,7 +241,8 @@ added to the pack."
 
 (define %default-options
   ;; Alist of default option values.
-  `((system . ,(%current-system))
+  `((format . tarball)
+    (system . ,(%current-system))
     (substitutes? . #t)
     (graft? . #t)
     (max-silent-time . 3600)
@@ -193,6 +250,11 @@ added to the pack."
     (symlinks . ())
     (compressor . ,(first %compressors))))
 
+(define %formats
+  ;; Supported pack formats.
+  `((tarball . ,self-contained-tarball)
+    (docker  . ,docker-image)))
+
 (define %options
   ;; Specifications of the command-line options.
   (cons* (option '(#\h "help") #f #f
@@ -206,6 +268,9 @@ added to the pack."
          (option '(#\n "dry-run") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'dry-run? #t (alist-cons 'graft? #f result))))
+         (option '(#\f "format") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'format (string->symbol arg) result)))
          (option '(#\s "system") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'system arg
@@ -242,6 +307,8 @@ Create a bundle of PACKAGE.\n"))
   (show-transformation-options-help)
   (newline)
   (display (_ "
+  -f, --format=FORMAT    build a pack in the given FORMAT"))
+  (display (_ "
   -s, --system=SYSTEM    attempt to build for SYSTEM--e.g., \"i686-linux\""))
   (display (_ "
   -C, --compression=TOOL compress using TOOL--e.g., \"lzip\""))
@@ -280,8 +347,16 @@ Create a bundle of PACKAGE.\n"))
                                     (specification->package+output spec))
                                 list))
                             specs))
-             (compressor (assoc-ref opts 'compressor))
-             (symlinks   (assoc-ref opts 'symlinks))
+             (pack-format (assoc-ref opts 'format))
+             (name        (string-append (symbol->string pack-format)
+                                         "-pack"))
+             (compressor  (assoc-ref opts 'compressor))
+             (symlinks    (assoc-ref opts 'symlinks))
+             (build-image (match (assq-ref %formats pack-format)
+                            ((? procedure? proc) proc)
+                            (#f
+                             (leave (_ "~a: unknown pack format")
+                                    format))))
              (localstatedir? (assoc-ref opts 'localstatedir?)))
         (with-store store
           ;; Set the build options before we do anything else.
@@ -290,13 +365,13 @@ Create a bundle of PACKAGE.\n"))
           (run-with-store store
             (mlet* %store-monad ((profile (profile-derivation
                                            (packages->manifest packages)))
-                                 (drv (self-contained-tarball "pack" profile
-                                                              #:compressor
-                                                              compressor
-                                                              #:symlinks
-                                                              symlinks
-                                                              #:localstatedir?
-                                                              localstatedir?)))
+                                 (drv (build-image name profile
+                                                   #:compressor
+                                                   compressor
+                                                   #:symlinks
+                                                   symlinks
+                                                   #:localstatedir?
+                                                   localstatedir?)))
               (mbegin %store-monad
                 (show-what-to-build* (list drv)
                                      #:use-substitutes?