guix: Add Docker image export.
[jackhill/guix/guix.git] / guix / docker.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
3 ;;;
4 ;;; This file is part of GNU Guix.
5 ;;;
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
10 ;;;
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
18
19 (define-module (guix docker)
20 #:use-module (guix hash)
21 #:use-module (guix store)
22 #:use-module (guix utils)
23 #:use-module ((guix build utils)
24 #:select (delete-file-recursively
25 with-directory-excursion))
26 #:use-module (json)
27 #:use-module (rnrs bytevectors)
28 #:use-module (ice-9 match)
29 #:export (build-docker-image))
30
31 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image
32 ;; containing the closure at PATH.
33 (define docker-id
34 (compose bytevector->base16-string sha256 string->utf8))
35
36 (define (layer-diff-id layer)
37 "Generate a layer DiffID for the given LAYER archive."
38 (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
39
40 ;; This is the semantic version of the JSON metadata schema according to
41 ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
42 ;; It is NOT the version of the image specification.
43 (define schema-version "1.0")
44
45 (define (image-description id time)
46 "Generate a simple image description."
47 `((id . ,id)
48 (created . ,time)
49 (container_config . #nil)))
50
51 (define (generate-tag path)
52 "Generate an image tag for the given PATH."
53 (match (string-split (basename path) #\-)
54 ((hash name . rest) (string-append name ":" hash))))
55
56 (define (manifest path id)
57 "Generate a simple image manifest."
58 `(((Config . "config.json")
59 (RepoTags . (,(generate-tag path)))
60 (Layers . (,(string-append id "/layer.tar"))))))
61
62 ;; According to the specifications this is required for backwards
63 ;; compatibility. It duplicates information provided by the manifest.
64 (define (repositories path id)
65 "Generate a repositories file referencing PATH and the image ID."
66 `((,(generate-tag path) . ((latest . ,id)))))
67
68 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
69 (define (config layer time arch)
70 "Generate a minimal image configuration for the given LAYER file."
71 ;; "architecture" must be values matching "platform.arch" in the
72 ;; runtime-spec at
73 ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
74 `((architecture . ,arch)
75 (comment . "Generated by GNU Guix")
76 (created . ,time)
77 (config . #nil)
78 (container_config . #nil)
79 (os . "linux")
80 (rootfs . ((type . "layers")
81 (diff_ids . (,(layer-diff-id layer)))))))
82
83 (define* (build-docker-image path #:key system)
84 "Generate a Docker image archive from the given store PATH. The image
85 contains the closure of the given store item."
86 (let ((id (docker-id path))
87 (time (strftime "%FT%TZ" (localtime (current-time))))
88 (name (string-append (getcwd)
89 "/docker-image-" (basename path) ".tar"))
90 (arch (match system
91 ("x86_64-linux" "amd64")
92 ("i686-linux" "386")
93 ("armhf-linux" "arm")
94 ("mips64el-linux" "mips64le"))))
95 (and (call-with-temporary-directory
96 (lambda (directory)
97 (with-directory-excursion directory
98 ;; Add symlink from /bin to /gnu/store/.../bin
99 (symlink (string-append path "/bin") "bin")
100
101 (mkdir id)
102 (with-directory-excursion id
103 (with-output-to-file "VERSION"
104 (lambda () (display schema-version)))
105 (with-output-to-file "json"
106 (lambda () (scm->json (image-description id time))))
107
108 ;; Wrap it up
109 (let ((items (with-store store
110 (requisites store (list path)))))
111 (and (zero? (apply system* "tar" "-cf" "layer.tar"
112 (cons "../bin" items)))
113 (delete-file "../bin"))))
114
115 (with-output-to-file "config.json"
116 (lambda ()
117 (scm->json (config (string-append id "/layer.tar")
118 time arch))))
119 (with-output-to-file "manifest.json"
120 (lambda ()
121 (scm->json (manifest path id))))
122 (with-output-to-file "repositories"
123 (lambda ()
124 (scm->json (repositories path id)))))
125 (and (zero? (system* "tar" "-C" directory "-cf" name "."))
126 (begin (delete-file-recursively directory) #t))))
127 name)))