[PATCH] Creating a docker image with Guix

[Ricardo Wurmus <ricardo.wurmus@mdc-berlin.de>]

[-- Attachment #1: Type: text/plain, Size: 1111 bytes --]


Ludovic Courtès <ludo@gnu.org> writes:

> I’m not familiar enough with Docker but I’m under the impression that we
> should be able to generate an image without even using Docker.  :-)

The attached patch adds a Docker export feature, so you can do this:

    docker load < \
      $(guix archive --export-docker-image=$(readlink -f ~/.guix-profile))

Then you can use “docker images” to show the available images.  For some
reason Docker won’t show the name and tag “guix archive” generates, so
just take the most recently added image.  Then run it, e.g. like this:

    docker run --rm -ti d11111472905 /bin/emacs

This starts the container and runs “/bin/emacs” interactively.  During
export “guix archive” also links the item’s “./bin” directory to “/bin”,
so users can run commands without having to know the long store path.

I used it successfully to build an Emacs Docker image like this:

    guix environment --ad-hoc coreutils bash emacs-no-x-toolkit
    docker load < $(guix archive --export-docker-image=$GUIX_ENVIRONMENT)

~~ Ricardo


[-- Attachment #2: 0001-guix-Add-Docker-image-export.patch --]
[-- Type: text/x-patch, Size: 8522 bytes --]

From d600db91078f28d82324671e3d43acaddc9b9608 Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <ricardo.wurmus@mdc-berlin.de>
Date: Tue, 3 Jan 2017 16:20:15 +0100
Subject: [PATCH] guix: Add Docker image export.

* guix/docker.scm: New file.
* Makefile.am (MODULES): Register it.
* guix/scripts/archive.scm (show-help, %options, guix-archive): Add
support for "--export-docker-image".
* doc/guix.texi (Invoking guix archive): Document it.
---
 Makefile.am              |   1 +
 doc/guix.texi            |   6 +++
 guix/docker.scm          | 120 +++++++++++++++++++++++++++++++++++++++++++++++
 guix/scripts/archive.scm |  11 +++++
 4 files changed, 138 insertions(+)
 create mode 100644 guix/docker.scm

diff --git a/Makefile.am b/Makefile.am
index fb08a004b..4317b83a2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -158,6 +158,7 @@ MODULES =					\
 if HAVE_GUILE_JSON
 
 MODULES +=					\
+  guix/docker.scm	   			\
   guix/import/github.scm   			\
   guix/import/json.scm				\
   guix/import/crate.scm				\
diff --git a/doc/guix.texi b/doc/guix.texi
index 8c65f44da..1dd501261 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -2438,6 +2438,12 @@ 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.
 
+@item --export-docker-image=@var{directory}
+@cindex docker, export
+Recursively export the specified store directory as a Docker image in
+tar archive format.  The generated archive can be loaded by Docker using
+@command{docker load}.
+
 @item --generate-key[=@var{parameters}]
 @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
new file mode 100644
index 000000000..0f6c3bf90
--- /dev/null
+++ b/guix/docker.scm
@@ -0,0 +1,120 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
+;;;
+;;; 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 (guix docker)
+  #:use-module (guix hash)
+  #:use-module (guix store)
+  #:use-module ((guix build utils)
+                #:select (delete-file-recursively
+                          with-directory-excursion))
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
+  #:export (build-docker-image))
+
+(define (hexencode bv)
+  "Return the hexadecimal representation of the bytevector BV."
+  (format #f "~{~2,'0x~}" (bytevector->u8-list bv)))
+
+(define (docker-id path)
+  "Generate a 256-bit identifier in hexadecimal encoding for the Docker image
+containing the closure at PATH."
+  (hexencode (sha256 (string->utf8 path))))
+
+(define (layer-diff-id layer)
+  "Generate a layer DiffID for the given LAYER archive."
+  (string-append "sha256:" (hexencode (file-sha256 layer))))
+
+(define spec-version "1.0")
+
+(define (image-description id time)
+  "Generate a simple image description."
+  `((id . ,id)
+    (created . ,time)
+    (container_config . #nil)))
+
+(define (manifest id)
+  "Generate a simple image manifest."
+  `(((Config . "config.json")
+     (RepoTags . #nil)
+     (Layers . (,(string-append id "/layer.tar"))))))
+
+(define (repositories path id)
+  "Generate a repositories file referencing PATH and the image ID."
+  `((,(basename path) . ((latest . ,id)))))
+
+;; See https://github.com/opencontainers/image-spec/blob/master/config.md
+(define (config layer time)
+  "Generate a minimal image configuratio for the given LAYER file."
+  `((architecture . "amd64")
+    (comment . "Generated by GNU Guix")
+    (created . ,time)
+    (config . #nil)
+    (container_config . #nil)
+    (os . "linux")
+    (rootfs . ((type . "layers")
+               (diff_ids . (,(layer-diff-id layer)))))))
+
+;; TODO: heroically copied from guix/script/pull.scm
+(define (temporary-directory)
+  "Make a temporary directory and return its name."
+  (let ((name (tmpnam)))
+    (mkdir name)
+    (chmod name #o700)
+    name))
+
+(define (build-docker-image path)
+  "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))
+        (directory (temporary-directory))
+        (time (strftime "%FT%TZ" (localtime (current-time)))))
+    (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 spec-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))))
+
+      (with-output-to-file "manifest.json"
+        (lambda ()
+          (scm->json (manifest id))))
+      (with-output-to-file "repositories"
+        (lambda ()
+          (scm->json (repositories path id)))))
+
+    (let ((name (string-append (getcwd)
+                               "/docker-image-" (basename path) ".tar")))
+      (and (zero? (system* "tar" "-C" directory "-cf" name "."))
+           (delete-file-recursively directory)
+           name))))
diff --git a/guix/scripts/archive.scm b/guix/scripts/archive.scm
index 7e432351e..ffa6e9f44 100644
--- a/guix/scripts/archive.scm
+++ b/guix/scripts/archive.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,6 +31,7 @@
   #:use-module (guix ui)
   #:use-module (guix pki)
   #:use-module (guix pk-crypto)
+  #:use-module (guix docker)
   #:use-module (guix scripts)
   #:use-module (guix scripts build)
   #:use-module (gnu packages)
@@ -63,6 +65,9 @@ Export/import one or more packages from/to the store.\n"))
   (display (_ "
       --export           export the specified files/packages to stdout"))
   (display (_ "
+      --export-docker-image=DIR
+                         export the specified store item DIR as a Docker image"))
+  (display (_ "
   -r, --recursive        combined with '--export', include dependencies"))
   (display (_ "
       --import           import from the archive passed on stdin"))
@@ -117,6 +122,9 @@ 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 '("export-docker-image") #t #f
+                 (lambda (opt name arg result . rest)
+                   (alist-cons 'export-docker-image arg result)))
          (option '(#\r "recursive") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'export-recursive? #t result)))
@@ -328,6 +336,9 @@ the input port."
                  generate-key-pair)
                 ((assoc-ref opts 'authorize)
                  (authorize-key))
+                ((assoc-ref opts 'export-docker-image)
+                 => (lambda (item)
+                      (format #t "~a\n" (build-docker-image item))))
                 (else
                  (with-store store
                    (cond ((assoc-ref opts 'export)
-- 
2.11.0