1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
3 ;;; Copyright © 2017, 2018, 2019, 2021 Ludovic Courtès <ludo@gnu.org>
4 ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com>
6 ;;; This file is part of GNU Guix.
8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
9 ;;; under the terms of the GNU General Public License as published by
10 ;;; the Free Software Foundation; either version 3 of the License, or (at
11 ;;; your option) any later version.
13 ;;; GNU Guix is distributed in the hope that it will be useful, but
14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 ;;; GNU General Public License for more details.
18 ;;; You should have received a copy of the GNU General Public License
19 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
21 (define-module (guix docker)
22 #:use-module (gcrypt hash)
23 #:use-module (guix base16)
24 #:use-module (guix build pack)
25 #:use-module ((guix build utils)
27 delete-file-recursively
28 with-directory-excursion
30 #:use-module (gnu build install)
31 #:use-module (json) ;guile-json
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-19)
34 #:use-module (srfi srfi-26)
35 #:use-module ((texinfo string-utils)
36 #:select (escape-special-chars))
37 #:use-module (rnrs bytevectors)
38 #:use-module (ice-9 ftw)
39 #:use-module (ice-9 match)
40 #:export (build-docker-image))
42 ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image.
44 (compose bytevector->base16-string sha256 string->utf8))
46 (define (layer-diff-id layer)
47 "Generate a layer DiffID for the given LAYER archive."
48 (string-append "sha256:" (bytevector->base16-string (file-sha256 layer))))
50 ;; This is the semantic version of the JSON metadata schema according to
51 ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md
52 ;; It is NOT the version of the image specification.
53 (define schema-version "1.0")
55 (define (image-description id time)
56 "Generate a simple image description."
59 (container_config . #nil)))
61 (define (canonicalize-repository-name name)
62 "\"Repository\" names are restricted to roughtl [a-z0-9_.-].
63 Return a version of TAG that follows these rules."
65 (string->char-set "abcdefghijklmnopqrstuvwxyz"))
68 (string->char-set "_-."))
71 (char-set-union char-set:digit ascii-letters separators))
73 (string-map (lambda (chr)
74 (if (char-set-contains? repo-char-set chr)
77 (string-trim (string-downcase name) separators)))
79 (define* (manifest path id #:optional (tag "guix"))
80 "Generate a simple image manifest."
81 (let ((tag (canonicalize-repository-name tag)))
82 `#(((Config . "config.json")
83 (RepoTags . #(,(string-append tag ":latest")))
84 (Layers . #(,(string-append id "/layer.tar")))))))
86 ;; According to the specifications this is required for backwards
87 ;; compatibility. It duplicates information provided by the manifest.
88 (define* (repositories path id #:optional (tag "guix"))
89 "Generate a repositories file referencing PATH and the image ID."
90 `((,(canonicalize-repository-name tag) . ((latest . ,id)))))
92 ;; See https://github.com/opencontainers/image-spec/blob/master/config.md
93 (define* (config layer time arch #:key entry-point (environment '()))
94 "Generate a minimal image configuration for the given LAYER file."
95 ;; "architecture" must be values matching "platform.arch" in the
97 ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform
98 `((architecture . ,arch)
99 (comment . "Generated by GNU Guix")
101 (config . ,`((env . ,(list->vector
104 (string-append name "=" value)))
107 `((entrypoint . ,(list->vector entry-point)))
109 (container_config . #nil)
111 (rootfs . ((type . "layers")
112 (diff_ids . #(,(layer-diff-id layer)))))))
114 (define directive-file
115 ;; Return the file or directory created by a 'evaluate-populate-directive'
119 (string-trim source #\/))
120 (('directory name _ ...)
121 (string-trim name #\/))))
123 (define* (build-docker-image image paths prefix
127 (transformations '())
128 (system (utsname:machine (uname)))
133 (creation-time (current-time time-utc)))
134 "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX
135 must be a store path that is a prefix of any store paths in PATHS. REPOSITORY
136 is a descriptive name that will show up in \"REPOSITORY\" column of the output
137 of \"docker images\".
139 When DATABASE is true, copy it to /var/guix/db in the image and create
140 /var/guix/gcroots and friends.
142 When ENTRY-POINT is true, it must be a list of strings; it is stored as the
143 entry point in the Docker image JSON structure.
145 ENVIRONMENT must be a list of name/value pairs. It specifies the environment
146 variables that must be defined in the resulting image.
148 EXTRA-FILES must be a list of directives for 'evaluate-populate-directive'
149 describing non-store files that must be created in the image.
151 TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to
152 transform the PATHS. Any path in PATHS that begins with OLD will be rewritten
153 in the Docker image so that it begins with NEW instead. If a path is a
154 non-empty directory, then its contents will be recursively added, as well.
156 SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in
157 PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a
158 command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a
159 SRFI-19 time-utc object, as the creation time in metadata."
160 (define (sanitize path-fragment)
161 (escape-special-chars
162 ;; GNU tar strips the leading slash off of absolute paths before applying
163 ;; the transformations, so we need to do the same, or else our
164 ;; replacements won't match any paths.
165 (string-trim path-fragment #\/)
166 ;; Escape the basic regexp special characters (see: "(sed) BRE syntax").
167 ;; We also need to escape "/" because we use it as a delimiter.
170 (define transformation->replacement
173 ;; See "(tar) transform" for details on the expression syntax.
174 (string-append "s/^" (sanitize old) "/" (sanitize new) "/"))))
175 (define (transformations->expression transformations)
176 (let ((replacements (map transformation->replacement transformations)))
178 ;; Avoid transforming link targets, since that would break some links
179 ;; (e.g., symlinks that point to an absolute store path).
181 (string-join replacements ";")
182 ;; Some paths might still have a leading path delimiter even after tar
183 ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so
184 ;; strip any leading path delimiters that remain.
186 (define transformation-options
187 (if (eq? '() transformations)
189 `("--transform" ,(transformations->expression transformations))))
190 (let* ((directory "/tmp/docker-image") ;temporary working directory
191 (id (docker-id prefix))
192 (time (date->string (time-utc->date creation-time) "~4"))
193 (arch (let-syntax ((cond* (syntax-rules ()
194 ((_ (pattern clause) ...)
195 (cond ((string-prefix? pattern system)
199 (error "unsupported system"
201 (cond* ("x86_64" "amd64")
204 ("mips64" "mips64le")))))
205 ;; Make sure we start with a fresh, empty working directory.
207 (with-directory-excursion directory
209 (with-directory-excursion id
210 (with-output-to-file "VERSION"
211 (lambda () (display schema-version)))
212 (with-output-to-file "json"
213 (lambda () (scm->json (image-description id time))))
215 ;; Create a directory for the non-store files that need to go into the
219 (with-directory-excursion "extra"
220 ;; Create non-store files.
221 (for-each (cut evaluate-populate-directive <> "./")
225 ;; Initialize /var/guix, assuming PREFIX points to a profile.
226 (install-database-and-gc-roots "." database prefix))
228 (apply invoke "tar" "-cf" "../layer.tar"
229 `(,@transformation-options
234 (not (member file '("." ".."))))))))
236 ;; It is possible for "/" to show up in the archive, especially when
237 ;; applying transformations. For example, the transformation
238 ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform
239 ;; the path "/a" into "/". The presence of "/" in the archive is
240 ;; probably benign, but it is definitely safe to remove it, so let's
241 ;; do that. This fails when "/" is not in the archive, so use system*
242 ;; instead of invoke to avoid an exception in that case, and redirect
243 ;; stderr to the bit bucket to avoid "Exiting with failure status"
245 (with-error-to-port (%make-void-port "w")
247 (system* "tar" "--delete" "/" "-f" "layer.tar")))
249 (delete-file-recursively "extra"))
251 (with-output-to-file "config.json"
253 (scm->json (config (string-append id "/layer.tar")
255 #:environment environment
256 #:entry-point entry-point))))
257 (with-output-to-file "manifest.json"
259 (scm->json (manifest prefix id repository))))
260 (with-output-to-file "repositories"
262 (scm->json (repositories prefix id repository)))))
264 (apply invoke "tar" "-cf" image "-C" directory
265 `(,@(tar-base-options #:compressor compressor)
267 (delete-file-recursively directory)))