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 | |
7ff4fde2 | 76 | (define* (config layer time arch #:key entry-point) |
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) | |
7ff4fde2 LC |
84 | (config . ,(if entry-point |
85 | `((entrypoint . ,entry-point)) | |
86 | #nil)) | |
03476a23 RW |
87 | (container_config . #nil) |
88 | (os . "linux") | |
89 | (rootfs . ((type . "layers") | |
90 | (diff_ids . (,(layer-diff-id layer))))))) | |
91 | ||
54241dc8 LC |
92 | (define %tar-determinism-options |
93 | ;; GNU tar options to produce archives deterministically. | |
94 | '("--sort=name" "--mtime=@1" | |
95 | "--owner=root:0" "--group=root:0")) | |
96 | ||
9e84ea36 LC |
97 | (define symlink-source |
98 | (match-lambda | |
99 | ((source '-> target) | |
100 | (string-trim source #\/)))) | |
101 | ||
102 | (define (topmost-component file) | |
103 | "Return the topmost component of FILE. For instance, if FILE is \"/a/b/c\", | |
104 | return \"a\"." | |
105 | (match (string-tokenize file (char-set-complement (char-set #\/))) | |
106 | ((first rest ...) | |
107 | first))) | |
108 | ||
1c2ac6b4 CM |
109 | (define* (build-docker-image image paths prefix |
110 | #:key | |
9e84ea36 | 111 | (symlinks '()) |
1c2ac6b4 | 112 | (transformations '()) |
5461115e | 113 | (system (utsname:machine (uname))) |
f5a2fb1b | 114 | database |
7ff4fde2 | 115 | entry-point |
1c2ac6b4 | 116 | compressor |
84dda5a9 | 117 | (creation-time (current-time time-utc))) |
1c2ac6b4 CM |
118 | "Write to IMAGE a Docker image archive containing the given PATHS. PREFIX |
119 | must be a store path that is a prefix of any store paths in PATHS. | |
120 | ||
f5a2fb1b LC |
121 | When DATABASE is true, copy it to /var/guix/db in the image and create |
122 | /var/guix/gcroots and friends. | |
123 | ||
7ff4fde2 LC |
124 | When ENTRY-POINT is true, it must be a list of strings; it is stored as the |
125 | entry point in the Docker image JSON structure. | |
126 | ||
1c2ac6b4 CM |
127 | SYMLINKS must be a list of (SOURCE -> TARGET) tuples describing symlinks to be |
128 | created in the image, where each TARGET is relative to PREFIX. | |
129 | TRANSFORMATIONS must be a list of (OLD -> NEW) tuples describing how to | |
130 | transform the PATHS. Any path in PATHS that begins with OLD will be rewritten | |
131 | in the Docker image so that it begins with NEW instead. If a path is a | |
132 | non-empty directory, then its contents will be recursively added, as well. | |
133 | ||
134 | SYSTEM is a GNU triplet (or prefix thereof) of the system the binaries in | |
135 | PATHS are for; it is used to produce metadata in the image. Use COMPRESSOR, a | |
136 | command such as '(\"gzip\" \"-9n\"), to compress IMAGE. Use CREATION-TIME, a | |
137 | SRFI-19 time-utc object, as the creation time in metadata." | |
138 | (define (sanitize path-fragment) | |
139 | (escape-special-chars | |
140 | ;; GNU tar strips the leading slash off of absolute paths before applying | |
141 | ;; the transformations, so we need to do the same, or else our | |
142 | ;; replacements won't match any paths. | |
143 | (string-trim path-fragment #\/) | |
144 | ;; Escape the basic regexp special characters (see: "(sed) BRE syntax"). | |
145 | ;; We also need to escape "/" because we use it as a delimiter. | |
146 | "/*.^$[]\\" | |
147 | #\\)) | |
148 | (define transformation->replacement | |
149 | (match-lambda | |
150 | ((old '-> new) | |
151 | ;; See "(tar) transform" for details on the expression syntax. | |
152 | (string-append "s/^" (sanitize old) "/" (sanitize new) "/")))) | |
153 | (define (transformations->expression transformations) | |
154 | (let ((replacements (map transformation->replacement transformations))) | |
155 | (string-append | |
156 | ;; Avoid transforming link targets, since that would break some links | |
157 | ;; (e.g., symlinks that point to an absolute store path). | |
158 | "flags=rSH;" | |
159 | (string-join replacements ";") | |
160 | ;; Some paths might still have a leading path delimiter even after tar | |
161 | ;; transforms them (e.g., "/a/b" might be transformed into "/b"), so | |
162 | ;; strip any leading path delimiters that remain. | |
163 | ";s,^//*,,"))) | |
164 | (define transformation-options | |
165 | (if (eq? '() transformations) | |
166 | '() | |
167 | `("--transform" ,(transformations->expression transformations)))) | |
168 | (let* ((directory "/tmp/docker-image") ;temporary working directory | |
169 | (id (docker-id prefix)) | |
170 | (time (date->string (time-utc->date creation-time) "~4")) | |
171 | (arch (let-syntax ((cond* (syntax-rules () | |
172 | ((_ (pattern clause) ...) | |
173 | (cond ((string-prefix? pattern system) | |
174 | clause) | |
175 | ... | |
176 | (else | |
177 | (error "unsupported system" | |
178 | system))))))) | |
179 | (cond* ("x86_64" "amd64") | |
180 | ("i686" "386") | |
181 | ("arm" "arm") | |
182 | ("mips64" "mips64le"))))) | |
b1edfbc3 LC |
183 | ;; Make sure we start with a fresh, empty working directory. |
184 | (mkdir directory) | |
1c2ac6b4 CM |
185 | (with-directory-excursion directory |
186 | (mkdir id) | |
187 | (with-directory-excursion id | |
188 | (with-output-to-file "VERSION" | |
189 | (lambda () (display schema-version))) | |
190 | (with-output-to-file "json" | |
191 | (lambda () (scm->json (image-description id time)))) | |
192 | ||
193 | ;; Create SYMLINKS. | |
194 | (for-each (match-lambda | |
195 | ((source '-> target) | |
196 | (let ((source (string-trim source #\/))) | |
197 | (mkdir-p (dirname source)) | |
198 | (symlink (string-append prefix "/" target) | |
199 | source)))) | |
200 | symlinks) | |
201 | ||
f5a2fb1b LC |
202 | (when database |
203 | ;; Initialize /var/guix, assuming PREFIX points to a profile. | |
204 | (install-database-and-gc-roots "." database prefix)) | |
205 | ||
1c2ac6b4 CM |
206 | (apply invoke "tar" "-cf" "layer.tar" |
207 | `(,@transformation-options | |
208 | ,@%tar-determinism-options | |
209 | ,@paths | |
f5a2fb1b | 210 | ,@(if database '("var") '()) |
1c2ac6b4 CM |
211 | ,@(map symlink-source symlinks))) |
212 | ;; It is possible for "/" to show up in the archive, especially when | |
213 | ;; applying transformations. For example, the transformation | |
214 | ;; "s,^/a,," will (perhaps surprisingly) cause GNU tar to transform | |
215 | ;; the path "/a" into "/". The presence of "/" in the archive is | |
216 | ;; probably benign, but it is definitely safe to remove it, so let's | |
217 | ;; do that. This fails when "/" is not in the archive, so use system* | |
d09ce3f9 LC |
218 | ;; instead of invoke to avoid an exception in that case, and redirect |
219 | ;; stderr to the bit bucket to avoid "Exiting with failure status" | |
220 | ;; error messages. | |
221 | (with-error-to-port (%make-void-port "w") | |
222 | (lambda () | |
223 | (system* "tar" "--delete" "/" "-f" "layer.tar"))) | |
224 | ||
1c2ac6b4 CM |
225 | (for-each delete-file-recursively |
226 | (map (compose topmost-component symlink-source) | |
f5a2fb1b LC |
227 | symlinks)) |
228 | ||
229 | ;; Delete /var/guix. | |
230 | (when database | |
231 | (delete-file-recursively "var"))) | |
1c2ac6b4 CM |
232 | |
233 | (with-output-to-file "config.json" | |
234 | (lambda () | |
235 | (scm->json (config (string-append id "/layer.tar") | |
7ff4fde2 LC |
236 | time arch |
237 | #:entry-point entry-point)))) | |
1c2ac6b4 CM |
238 | (with-output-to-file "manifest.json" |
239 | (lambda () | |
240 | (scm->json (manifest prefix id)))) | |
241 | (with-output-to-file "repositories" | |
242 | (lambda () | |
243 | (scm->json (repositories prefix id))))) | |
244 | ||
245 | (apply invoke "tar" "-cf" image "-C" directory | |
246 | `(,@%tar-determinism-options | |
247 | ,@(if compressor | |
248 | (list "-I" (string-join compressor)) | |
249 | '()) | |
250 | ".")) | |
251 | (delete-file-recursively directory))) |