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