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 | ||
60 | (define (generate-tag path) | |
61 | "Generate an image tag for the given PATH." | |
62 | (match (string-split (basename path) #\-) | |
63 | ((hash name . rest) (string-append name ":" hash)))) | |
64 | ||
65 | (define (manifest path id) | |
66 | "Generate a simple image manifest." | |
81c3dc32 LC |
67 | `#(((Config . "config.json") |
68 | (RepoTags . #(,(generate-tag path))) | |
69 | (Layers . #(,(string-append id "/layer.tar")))))) | |
03476a23 RW |
70 | |
71 | ;; According to the specifications this is required for backwards | |
72 | ;; compatibility. It duplicates information provided by the manifest. | |
73 | (define (repositories path id) | |
74 | "Generate a repositories file referencing PATH and the image ID." | |
75 | `((,(generate-tag path) . ((latest . ,id))))) | |
76 | ||
77 | ;; See https://github.com/opencontainers/image-spec/blob/master/config.md | |
b9fcf0c8 | 78 | (define* (config layer time arch #:key entry-point (environment '())) |
03476a23 RW |
79 | "Generate a minimal image configuration for the given LAYER file." |
80 | ;; "architecture" must be values matching "platform.arch" in the | |
81 | ;; runtime-spec at | |
82 | ;; https://github.com/opencontainers/runtime-spec/blob/v1.0.0-rc2/config.md#platform | |
83 | `((architecture . ,arch) | |
84 | (comment . "Generated by GNU Guix") | |
85 | (created . ,time) | |
81c3dc32 LC |
86 | (config . ,`((env . ,(list->vector |
87 | (map (match-lambda | |
88 | ((name . value) | |
89 | (string-append name "=" value))) | |
90 | environment))) | |
b9fcf0c8 | 91 | ,@(if entry-point |
81c3dc32 | 92 | `((entrypoint . ,(list->vector entry-point))) |
b9fcf0c8 | 93 | '()))) |
03476a23 RW |
94 | (container_config . #nil) |
95 | (os . "linux") | |
96 | (rootfs . ((type . "layers") | |
81c3dc32 | 97 | (diff_ids . #(,(layer-diff-id layer))))))) |
03476a23 | 98 | |
54241dc8 LC |
99 | (define %tar-determinism-options |
100 | ;; GNU tar options to produce archives deterministically. | |
101 | '("--sort=name" "--mtime=@1" | |
102 | "--owner=root:0" "--group=root:0")) | |
103 | ||
2b7c89f4 LC |
104 | (define directive-file |
105 | ;; Return the file or directory created by a 'evaluate-populate-directive' | |
106 | ;; directive. | |
9e84ea36 LC |
107 | (match-lambda |
108 | ((source '-> target) | |
2b7c89f4 LC |
109 | (string-trim source #\/)) |
110 | (('directory name _ ...) | |
111 | (string-trim name #\/)))) | |
9e84ea36 | 112 | |
1c2ac6b4 CM |
113 | (define* (build-docker-image image paths prefix |
114 | #:key | |
2b7c89f4 | 115 | (extra-files '()) |
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 | ||
2b7c89f4 LC |
135 | EXTRA-FILES must be a list of directives for 'evaluate-populate-directive' |
136 | describing non-store files that must be created in the image. | |
137 | ||
1c2ac6b4 CM |
138 | TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to |
139 | transform the PATHS. Any path in PATHS that begins with OLD will be rewritten | |
140 | in the Docker image so that it begins with NEW instead. If a path is a | |
141 | non-empty directory, then its contents will be recursively added, as well. | |
142 | ||
143 | SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in | |
144 | PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a | |
145 | command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a | |
146 | SRFI-19 time-utc object, as the creation time in metadata." | |
147 | (define (sanitize path-fragment) | |
148 | (escape-special-chars | |
149 | ;; GNU tar strips the leading slash off of absolute paths before applying | |
150 | ;; the transformations, so we need to do the same, or else our | |
151 | ;; replacements won't match any paths. | |
152 | (string-trim path-fragment #\/) | |
153 | ;; Escape the basic regexp special characters (see: "(sed) BRE syntax"). | |
154 | ;; We also need to escape "/" because we use it as a delimiter. | |
155 | "/*.^$[]\\" | |
156 | #\\)) | |
157 | (define transformation->replacement | |
158 | (match-lambda | |
159 | ((old '-> new) | |
160 | ;; See "(tar) transform" for details on the expression syntax. | |
161 | (string-append "s/^" (sanitize old) "/" (sanitize new) "/")))) | |
162 | (define (transformations->expression transformations) | |
163 | (let ((replacements (map transformation->replacement transformations))) | |
164 | (string-append | |
165 | ;; Avoid transforming link targets, since that would break some links | |
166 | ;; (e.g., symlinks that point to an absolute store path). | |
167 | "flags=rSH;" | |
168 | (string-join replacements ";") | |
169 | ;; Some paths might still have a leading path delimiter even after tar | |
170 | ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so | |
171 | ;; strip any leading path delimiters that remain. | |
172 | ";s,^//*,,"))) | |
173 | (define transformation-options | |
174 | (if (eq? '() transformations) | |
175 | '() | |
176 | `("--transform" ,(transformations->expression transformations)))) | |
177 | (let* ((directory "/tmp/docker-image") ;temporary working directory | |
178 | (id (docker-id prefix)) | |
179 | (time (date->string (time-utc->date creation-time) "~4")) | |
180 | (arch (let-syntax ((cond* (syntax-rules () | |
181 | ((_ (pattern clause) ...) | |
182 | (cond ((string-prefix? pattern system) | |
183 | clause) | |
184 | ... | |
185 | (else | |
186 | (error "unsupported system" | |
187 | system))))))) | |
188 | (cond* ("x86_64" "amd64") | |
189 | ("i686" "386") | |
190 | ("arm" "arm") | |
191 | ("mips64" "mips64le"))))) | |
b1edfbc3 LC |
192 | ;; Make sure we start with a fresh, empty working directory. |
193 | (mkdir directory) | |
1c2ac6b4 CM |
194 | (with-directory-excursion directory |
195 | (mkdir id) | |
196 | (with-directory-excursion id | |
197 | (with-output-to-file "VERSION" | |
198 | (lambda () (display schema-version))) | |
199 | (with-output-to-file "json" | |
200 | (lambda () (scm->json (image-description id time)))) | |
201 | ||
2b7c89f4 LC |
202 | ;; Create a directory for the non-store files that need to go into the |
203 | ;; archive. | |
204 | (mkdir "extra") | |
205 | ||
206 | (with-directory-excursion "extra" | |
207 | ;; Create non-store files. | |
208 | (for-each (cut evaluate-populate-directive <> "./") | |
209 | extra-files) | |
1c2ac6b4 | 210 | |
2b7c89f4 LC |
211 | (when database |
212 | ;; Initialize /var/guix, assuming PREFIX points to a profile. | |
213 | (install-database-and-gc-roots "." database prefix)) | |
214 | ||
215 | (apply invoke "tar" "-cf" "../layer.tar" | |
216 | `(,@transformation-options | |
217 | ,@%tar-determinism-options | |
218 | ,@paths | |
219 | ,@(scandir "." | |
220 | (lambda (file) | |
221 | (not (member file '("." "..")))))))) | |
f5a2fb1b | 222 | |
1c2ac6b4 CM |
223 | ;; It is possible for "/" to show up in the archive, especially when |
224 | ;; applying transformations. For example, the transformation | |
225 | ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform | |
226 | ;; the path "/a" into "/". The presence of "/" in the archive is | |
227 | ;; probably benign, but it is definitely safe to remove it, so let's | |
228 | ;; do that. This fails when "/" is not in the archive, so use system* | |
d09ce3f9 LC |
229 | ;; instead of invoke to avoid an exception in that case, and redirect |
230 | ;; stderr to the bit bucket to avoid "Exiting with failure status" | |
231 | ;; error messages. | |
232 | (with-error-to-port (%make-void-port "w") | |
233 | (lambda () | |
234 | (system* "tar" "--delete" "/" "-f" "layer.tar"))) | |
235 | ||
2b7c89f4 | 236 | (delete-file-recursively "extra")) |
1c2ac6b4 CM |
237 | |
238 | (with-output-to-file "config.json" | |
239 | (lambda () | |
240 | (scm->json (config (string-append id "/layer.tar") | |
7ff4fde2 | 241 | time arch |
b9fcf0c8 | 242 | #:environment environment |
7ff4fde2 | 243 | #:entry-point entry-point)))) |
1c2ac6b4 CM |
244 | (with-output-to-file "manifest.json" |
245 | (lambda () | |
246 | (scm->json (manifest prefix id)))) | |
247 | (with-output-to-file "repositories" | |
248 | (lambda () | |
249 | (scm->json (repositories prefix id))))) | |
250 | ||
251 | (apply invoke "tar" "-cf" image "-C" directory | |
252 | `(,@%tar-determinism-options | |
253 | ,@(if compressor | |
254 | (list "-I" (string-join compressor)) | |
255 | '()) | |
256 | ".")) | |
257 | (delete-file-recursively directory))) |