Commit | Line | Data |
---|---|---|
03476a23 RW |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net> | |
7ff4fde2 | 3 | ;;; Copyright © 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
1c2ac6b4 | 4 | ;;; Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> |
03476a23 RW |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
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. | |
12 | ;;; | |
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. | |
17 | ;;; | |
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/>. | |
20 | ||
21 | (define-module (guix docker) | |
ca719424 | 22 | #:use-module (gcrypt hash) |
4c0c4db0 | 23 | #:use-module (guix base16) |
03476a23 | 24 | #:use-module ((guix build utils) |
9e84ea36 LC |
25 | #:select (mkdir-p |
26 | delete-file-recursively | |
1c2ac6b4 CM |
27 | with-directory-excursion |
28 | invoke)) | |
f5a2fb1b | 29 | #:use-module (gnu build install) |
13993c77 | 30 | #:use-module (json) ;guile-json |
84dda5a9 | 31 | #:use-module (srfi srfi-19) |
1c2ac6b4 CM |
32 | #:use-module (srfi srfi-26) |
33 | #:use-module ((texinfo string-utils) | |
34 | #:select (escape-special-chars)) | |
03476a23 RW |
35 | #:use-module (rnrs bytevectors) |
36 | #:use-module (ice-9 match) | |
37 | #:export (build-docker-image)) | |
38 | ||
1c2ac6b4 | 39 | ;; Generate a 256-bit identifier in hexadecimal encoding for the Docker image. |
03476a23 RW |
40 | (define docker-id |
41 | (compose bytevector->base16-string sha256 string->utf8)) | |
42 | ||
43 | (define (layer-diff-id layer) | |
44 | "Generate a layer DiffID for the given LAYER archive." | |
45 | (string-append "sha256:" (bytevector->base16-string (file-sha256 layer)))) | |
46 | ||
47 | ;; This is the semantic version of the JSON metadata schema according to | |
48 | ;; https://github.com/docker/docker/blob/master/image/spec/v1.2.md | |
49 | ;; It is NOT the version of the image specification. | |
50 | (define schema-version "1.0") | |
51 | ||
52 | (define (image-description id time) | |
53 | "Generate a simple image description." | |
54 | `((id . ,id) | |
55 | (created . ,time) | |
56 | (container_config . #nil))) | |
57 | ||
58 | (define (generate-tag path) | |
59 | "Generate an image tag for the given PATH." | |
60 | (match (string-split (basename path) #\-) | |
61 | ((hash name . rest) (string-append name ":" hash)))) | |
62 | ||
63 | (define (manifest path id) | |
64 | "Generate a simple image manifest." | |
65 | `(((Config . "config.json") | |
66 | (RepoTags . (,(generate-tag path))) | |
67 | (Layers . (,(string-append id "/layer.tar")))))) | |
68 | ||
69 | ;; According to the specifications this is required for backwards | |
70 | ;; compatibility. It duplicates information provided by the manifest. | |
71 | (define (repositories path id) | |
72 | "Generate a repositories file referencing PATH and the image ID." | |
73 | `((,(generate-tag path) . ((latest . ,id))))) | |
74 | ||
75 | ;; See https://github.com/opencontainers/image-spec/blob/master/config.md | |
b9fcf0c8 | 76 | (define* (config layer time arch #:key entry-point (environment '())) |
03476a23 RW |
77 | "Generate a minimal image configuration for the given LAYER file." |
78 | ;; "architecture" must be values matching "platform.arch" in the | |
79 | ;; runtime-spec at | |
80 | ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform | |
81 | `((architecture . ,arch) | |
82 | (comment . "Generated by GNU Guix") | |
83 | (created . ,time) | |
b9fcf0c8 LC |
84 | (config . ,`((env . ,(map (match-lambda |
85 | ((name . value) | |
86 | (string-append name "=" value))) | |
87 | environment)) | |
88 | ,@(if entry-point | |
89 | `((entrypoint . ,entry-point)) | |
90 | '()))) | |
03476a23 RW |
91 | (container_config . #nil) |
92 | (os . "linux") | |
93 | (rootfs . ((type . "layers") | |
94 | (diff_ids . (,(layer-diff-id layer))))))) | |
95 | ||
54241dc8 LC |
96 | (define %tar-determinism-options |
97 | ;; GNU tar options to produce archives deterministically. | |
98 | '("--sort=name" "--mtime=@1" | |
99 | "--owner=root:0" "--group=root:0")) | |
100 | ||
9e84ea36 LC |
101 | (define symlink-source |
102 | (match-lambda | |
103 | ((source '-> target) | |
104 | (string-trim source #\/)))) | |
105 | ||
106 | (define (topmost-component file) | |
107 | "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", | |
108 | return \"a\"." | |
109 | (match (string-tokenize file (char-set-complement (char-set #\/))) | |
110 | ((first rest ...) | |
111 | first))) | |
112 | ||
1c2ac6b4 CM |
113 | (define* (build-docker-image image paths prefix |
114 | #:key | |
9e84ea36 | 115 | (symlinks '()) |
1c2ac6b4 | 116 | (transformations '()) |
5461115e | 117 | (system (utsname:machine (uname))) |
f5a2fb1b | 118 | database |
7ff4fde2 | 119 | entry-point |
b9fcf0c8 | 120 | (environment '()) |
1c2ac6b4 | 121 | compressor |
84dda5a9 | 122 | (creation-time (current-time time-utc))) |
1c2ac6b4 CM |
123 | "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX |
124 | must be a store path that is a prefix of any store paths in PATHS. | |
125 | ||
f5a2fb1b LC |
126 | When DATABASE is true, copy it to /var/guix/db in the image and create |
127 | /var/guix/gcroots and friends. | |
128 | ||
7ff4fde2 LC |
129 | When ENTRY-POINT is true, it must be a list of strings; it is stored as the |
130 | entry point in the Docker image JSON structure. | |
131 | ||
b9fcf0c8 LC |
132 | ENVIRONMENT must be a list of name/value pairs. It specifies the environment |
133 | variables that must be defined in the resulting image. | |
134 | ||
1c2ac6b4 CM |
135 | SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be |
136 | created in the image, where each TARGET is relative to PREFIX. | |
137 | TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to | |
138 | transform the PATHS. Any path in PATHS that begins with OLD will be rewritten | |
139 | in the Docker image so that it begins with NEW instead. If a path is a | |
140 | non-empty directory, then its contents will be recursively added, as well. | |
141 | ||
142 | SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in | |
143 | PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a | |
144 | command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a | |
145 | SRFI-19 time-utc object, as the creation time in metadata." | |
146 | (define (sanitize path-fragment) | |
147 | (escape-special-chars | |
148 | ;; GNU tar strips the leading slash off of absolute paths before applying | |
149 | ;; the transformations, so we need to do the same, or else our | |
150 | ;; replacements won't match any paths. | |
151 | (string-trim path-fragment #\/) | |
152 | ;; Escape the basic regexp special characters (see: "(sed) BRE syntax"). | |
153 | ;; We also need to escape "/" because we use it as a delimiter. | |
154 | "/*.^$[]\\" | |
155 | #\\)) | |
156 | (define transformation->replacement | |
157 | (match-lambda | |
158 | ((old '-> new) | |
159 | ;; See "(tar) transform" for details on the expression syntax. | |
160 | (string-append "s/^" (sanitize old) "/" (sanitize new) "/")))) | |
161 | (define (transformations->expression transformations) | |
162 | (let ((replacements (map transformation->replacement transformations))) | |
163 | (string-append | |
164 | ;; Avoid transforming link targets, since that would break some links | |
165 | ;; (e.g., symlinks that point to an absolute store path). | |
166 | "flags=rSH;" | |
167 | (string-join replacements ";") | |
168 | ;; Some paths might still have a leading path delimiter even after tar | |
169 | ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so | |
170 | ;; strip any leading path delimiters that remain. | |
171 | ";s,^//*,,"))) | |
172 | (define transformation-options | |
173 | (if (eq? '() transformations) | |
174 | '() | |
175 | `("--transform" ,(transformations->expression transformations)))) | |
176 | (let* ((directory "/tmp/docker-image") ;temporary working directory | |
177 | (id (docker-id prefix)) | |
178 | (time (date->string (time-utc->date creation-time) "~4")) | |
179 | (arch (let-syntax ((cond* (syntax-rules () | |
180 | ((_ (pattern clause) ...) | |
181 | (cond ((string-prefix? pattern system) | |
182 | clause) | |
183 | ... | |
184 | (else | |
185 | (error "unsupported system" | |
186 | system))))))) | |
187 | (cond* ("x86_64" "amd64") | |
188 | ("i686" "386") | |
189 | ("arm" "arm") | |
190 | ("mips64" "mips64le"))))) | |
b1edfbc3 LC |
191 | ;; Make sure we start with a fresh, empty working directory. |
192 | (mkdir directory) | |
1c2ac6b4 CM |
193 | (with-directory-excursion directory |
194 | (mkdir id) | |
195 | (with-directory-excursion id | |
196 | (with-output-to-file "VERSION" | |
197 | (lambda () (display schema-version))) | |
198 | (with-output-to-file "json" | |
199 | (lambda () (scm->json (image-description id time)))) | |
200 | ||
201 | ;; Create SYMLINKS. | |
202 | (for-each (match-lambda | |
203 | ((source '-> target) | |
204 | (let ((source (string-trim source #\/))) | |
205 | (mkdir-p (dirname source)) | |
206 | (symlink (string-append prefix "/" target) | |
207 | source)))) | |
208 | symlinks) | |
209 | ||
f5a2fb1b LC |
210 | (when database |
211 | ;; Initialize /var/guix, assuming PREFIX points to a profile. | |
212 | (install-database-and-gc-roots "." database prefix)) | |
213 | ||
1c2ac6b4 CM |
214 | (apply invoke "tar" "-cf" "layer.tar" |
215 | `(,@transformation-options | |
216 | ,@%tar-determinism-options | |
217 | ,@paths | |
f5a2fb1b | 218 | ,@(if database '("var") '()) |
1c2ac6b4 CM |
219 | ,@(map symlink-source symlinks))) |
220 | ;; It is possible for "/" to show up in the archive, especially when | |
221 | ;; applying transformations. For example, the transformation | |
222 | ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform | |
223 | ;; the path "/a" into "/". The presence of "/" in the archive is | |
224 | ;; probably benign, but it is definitely safe to remove it, so let's | |
225 | ;; do that. This fails when "/" is not in the archive, so use system* | |
d09ce3f9 LC |
226 | ;; instead of invoke to avoid an exception in that case, and redirect |
227 | ;; stderr to the bit bucket to avoid "Exiting with failure status" | |
228 | ;; error messages. | |
229 | (with-error-to-port (%make-void-port "w") | |
230 | (lambda () | |
231 | (system* "tar" "--delete" "/" "-f" "layer.tar"))) | |
232 | ||
1c2ac6b4 CM |
233 | (for-each delete-file-recursively |
234 | (map (compose topmost-component symlink-source) | |
f5a2fb1b LC |
235 | symlinks)) |
236 | ||
237 | ;; Delete /var/guix. | |
238 | (when database | |
239 | (delete-file-recursively "var"))) | |
1c2ac6b4 CM |
240 | |
241 | (with-output-to-file "config.json" | |
242 | (lambda () | |
243 | (scm->json (config (string-append id "/layer.tar") | |
7ff4fde2 | 244 | time arch |
b9fcf0c8 | 245 | #:environment environment |
7ff4fde2 | 246 | #:entry-point entry-point)))) |
1c2ac6b4 CM |
247 | (with-output-to-file "manifest.json" |
248 | (lambda () | |
249 | (scm->json (manifest prefix id)))) | |
250 | (with-output-to-file "repositories" | |
251 | (lambda () | |
252 | (scm->json (repositories prefix id))))) | |
253 | ||
254 | (apply invoke "tar" "-cf" image "-C" directory | |
255 | `(,@%tar-determinism-options | |
256 | ,@(if compressor | |
257 | (list "-I" (string-join compressor)) | |
258 | '()) | |
259 | ".")) | |
260 | (delete-file-recursively directory))) |