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