Commit | Line | Data |
---|---|---|
7d8a4eea | 1 | ;;; GNU Guix --- Functional package management for GNU |
babfd944 | 2 | ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> |
2b002681 | 3 | ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
7d8a4eea DM |
4 | ;;; |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (gnu tests docker) | |
21 | #:use-module (gnu tests) | |
22 | #:use-module (gnu system) | |
23 | #:use-module (gnu system file-systems) | |
24 | #:use-module (gnu system vm) | |
25 | #:use-module (gnu services) | |
26 | #:use-module (gnu services dbus) | |
27 | #:use-module (gnu services networking) | |
28 | #:use-module (gnu services docker) | |
dc4b4a38 | 29 | #:use-module (gnu services desktop) |
3c69e81d | 30 | #:use-module ((gnu packages base) #:select (glibc)) |
247649d4 | 31 | #:use-module (gnu packages guile) |
3c69e81d | 32 | #:use-module (gnu packages docker) |
7d8a4eea | 33 | #:use-module (guix gexp) |
49ec5d88 DM |
34 | #:use-module (guix grafts) |
35 | #:use-module (guix monads) | |
36 | #:use-module (guix packages) | |
37 | #:use-module (guix profiles) | |
38 | #:use-module (guix scripts pack) | |
7d8a4eea | 39 | #:use-module (guix store) |
49ec5d88 DM |
40 | #:use-module (guix tests) |
41 | #:use-module (guix build-system trivial) | |
69e47686 | 42 | #:use-module ((guix licenses) #:prefix license:) |
247649d4 LC |
43 | #:export (%test-docker |
44 | %test-docker-system)) | |
7d8a4eea DM |
45 | |
46 | (define %docker-os | |
47 | (simple-operating-system | |
48 | (service dhcp-client-service-type) | |
49 | (dbus-service) | |
50 | (polkit-service) | |
dc4b4a38 | 51 | (service elogind-service-type) |
7d8a4eea DM |
52 | (service docker-service-type))) |
53 | ||
49ec5d88 DM |
54 | (define (run-docker-test docker-tarball) |
55 | "Load DOCKER-TARBALL as Docker image and run it in a Docker container, | |
56 | inside %DOCKER-OS." | |
7d8a4eea DM |
57 | (define os |
58 | (marionette-operating-system | |
59 | %docker-os | |
60 | #:imported-modules '((gnu services herd) | |
61 | (guix combinators)))) | |
62 | ||
63 | (define vm | |
64 | (virtual-machine | |
65 | (operating-system os) | |
49ec5d88 DM |
66 | (memory-size 700) |
67 | (disk-image-size (* 1500 (expt 2 20))) | |
7d8a4eea DM |
68 | (port-forwardings '()))) |
69 | ||
70 | (define test | |
71 | (with-imported-modules '((gnu build marionette)) | |
72 | #~(begin | |
73 | (use-modules (srfi srfi-11) (srfi srfi-64) | |
74 | (gnu build marionette)) | |
75 | ||
76 | (define marionette | |
77 | (make-marionette (list #$vm))) | |
78 | ||
79 | (mkdir #$output) | |
80 | (chdir #$output) | |
81 | ||
82 | (test-begin "docker") | |
83 | ||
84 | (test-assert "service running" | |
85 | (marionette-eval | |
86 | '(begin | |
87 | (use-modules (gnu services herd)) | |
88 | (match (start-service 'dockerd) | |
89 | (#f #f) | |
90 | (('service response-parts ...) | |
91 | (match (assq-ref response-parts 'running) | |
92 | ((pid) (number? pid)))))) | |
93 | marionette)) | |
94 | ||
95 | (test-eq "fetch version" | |
96 | 0 | |
97 | (marionette-eval | |
98 | `(begin | |
99 | (system* ,(string-append #$docker-cli "/bin/docker") | |
100 | "version")) | |
101 | marionette)) | |
102 | ||
49ec5d88 | 103 | (test-equal "Load docker image and run it" |
7979a287 | 104 | '("hello world" "hi!" "JSON!" #o1777) |
49ec5d88 DM |
105 | (marionette-eval |
106 | `(begin | |
107 | (define slurp | |
108 | (lambda args | |
109 | (let* ((port (apply open-pipe* OPEN_READ args)) | |
110 | (output (read-line port)) | |
111 | (status (close-pipe port))) | |
112 | output))) | |
113 | (let* ((raw-line (slurp ,(string-append #$docker-cli | |
114 | "/bin/docker") | |
115 | "load" "-i" | |
116 | ,#$docker-tarball)) | |
117 | (repository&tag (string-drop raw-line | |
118 | (string-length | |
119 | "Loaded image: "))) | |
a0f352b3 LC |
120 | (response1 (slurp |
121 | ,(string-append #$docker-cli "/bin/docker") | |
122 | "run" "--entrypoint" "bin/Guile" | |
123 | repository&tag | |
124 | "/aa.scm")) | |
125 | (response2 (slurp ;default entry point | |
126 | ,(string-append #$docker-cli "/bin/docker") | |
127 | "run" repository&tag | |
b9fcf0c8 LC |
128 | "-c" "(display \"hi!\")")) |
129 | ||
130 | ;; Check whether (json) is in $GUILE_LOAD_PATH. | |
131 | (response3 (slurp ;default entry point + environment | |
132 | ,(string-append #$docker-cli "/bin/docker") | |
133 | "run" repository&tag | |
134 | "-c" "(use-modules (json)) | |
7979a287 LC |
135 | (display (json-string->scm (scm->json-string \"JSON!\")))")) |
136 | ||
137 | ;; Check whether /tmp exists. | |
138 | (response4 (slurp | |
139 | ,(string-append #$docker-cli "/bin/docker") | |
140 | "run" repository&tag "-c" | |
141 | "(display (stat:perms (lstat \"/tmp\")))"))) | |
142 | (list response1 response2 response3 | |
143 | (string->number response4)))) | |
49ec5d88 DM |
144 | marionette)) |
145 | ||
7d8a4eea DM |
146 | (test-end) |
147 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
148 | ||
149 | (gexp->derivation "docker-test" test)) | |
150 | ||
49ec5d88 DM |
151 | (define (build-tarball&run-docker-test) |
152 | (mlet* %store-monad | |
153 | ((_ (set-grafting #f)) | |
154 | (guile (set-guile-for-build (default-guile))) | |
155 | (guest-script-package -> | |
69e47686 DM |
156 | (package |
157 | (name "guest-script") | |
158 | (version "0") | |
159 | (source #f) | |
160 | (build-system trivial-build-system) | |
c9ea5dfd | 161 | (arguments `(#:guile ,guile-3.0 |
69e47686 DM |
162 | #:builder |
163 | (let ((out (assoc-ref %outputs "out"))) | |
164 | (mkdir out) | |
165 | (call-with-output-file (string-append out "/a.scm") | |
166 | (lambda (port) | |
167 | (display "(display \"hello world\n\")" port))) | |
168 | #t))) | |
169 | (synopsis "Display hello world using Guile") | |
170 | (description "This package displays the text \"hello world\" on the | |
171 | standard output device and then enters a new line.") | |
172 | (home-page #f) | |
173 | (license license:public-domain))) | |
49ec5d88 | 174 | (profile (profile-derivation (packages->manifest |
c9ea5dfd | 175 | (list guile-3.0 guile-json-3 |
49ec5d88 DM |
176 | guest-script-package)) |
177 | #:hooks '() | |
178 | #:locales? #f)) | |
179 | (tarball (docker-image "docker-pack" profile | |
180 | #:symlinks '(("/bin/Guile" -> "bin/guile") | |
181 | ("aa.scm" -> "a.scm")) | |
a0f352b3 | 182 | #:entry-point "bin/guile" |
49ec5d88 DM |
183 | #:localstatedir? #t))) |
184 | (run-docker-test tarball))) | |
185 | ||
7d8a4eea DM |
186 | (define %test-docker |
187 | (system-test | |
188 | (name "docker") | |
49ec5d88 DM |
189 | (description "Test Docker container of Guix.") |
190 | (value (build-tarball&run-docker-test)))) | |
247649d4 LC |
191 | |
192 | \f | |
193 | (define (run-docker-system-test tarball) | |
194 | "Load DOCKER-TARBALL as Docker image and run it in a Docker container, | |
195 | inside %DOCKER-OS." | |
196 | (define os | |
197 | (marionette-operating-system | |
198 | %docker-os | |
199 | #:imported-modules '((gnu services herd) | |
200 | (guix combinators)))) | |
201 | ||
202 | (define vm | |
203 | (virtual-machine | |
204 | (operating-system os) | |
205 | ;; FIXME: Because we're using the volatile-root setup where the root file | |
206 | ;; system is a tmpfs overlaid over a small root file system, 'docker | |
207 | ;; load' must be able to store the whole image into memory, hence the | |
208 | ;; huge memory requirements. We should avoid the volatile-root setup | |
209 | ;; instead. | |
2b002681 | 210 | (memory-size 4500) |
247649d4 LC |
211 | (port-forwardings '()))) |
212 | ||
213 | (define test | |
214 | (with-imported-modules '((gnu build marionette) | |
215 | (guix build utils)) | |
216 | #~(begin | |
217 | (use-modules (srfi srfi-11) (srfi srfi-64) | |
218 | (gnu build marionette) | |
219 | (guix build utils)) | |
220 | ||
221 | (define marionette | |
222 | (make-marionette (list #$vm))) | |
223 | ||
224 | (mkdir #$output) | |
225 | (chdir #$output) | |
226 | ||
227 | (test-begin "docker") | |
228 | ||
229 | (test-assert "service running" | |
230 | (marionette-eval | |
231 | '(begin | |
232 | (use-modules (gnu services herd)) | |
233 | (match (start-service 'dockerd) | |
234 | (#f #f) | |
235 | (('service response-parts ...) | |
236 | (match (assq-ref response-parts 'running) | |
237 | ((pid) (number? pid)))))) | |
238 | marionette)) | |
239 | ||
240 | (test-assert "load system image and run it" | |
241 | (marionette-eval | |
242 | `(begin | |
243 | (define (slurp command . args) | |
244 | ;; Return the output from COMMAND. | |
245 | (let* ((port (apply open-pipe* OPEN_READ command args)) | |
246 | (output (read-line port)) | |
247 | (status (close-pipe port))) | |
248 | output)) | |
249 | ||
250 | (define (docker-cli command . args) | |
251 | ;; Run the given Docker COMMAND. | |
252 | (apply invoke #$(file-append docker-cli "/bin/docker") | |
253 | command args)) | |
254 | ||
255 | (define (wait-for-container-file container file) | |
256 | ;; Wait for FILE to show up in CONTAINER. | |
257 | (docker-cli "exec" container | |
c9ea5dfd | 258 | #$(file-append guile-3.0 "/bin/guile") |
247649d4 LC |
259 | "-c" |
260 | (object->string | |
261 | `(let loop ((n 15)) | |
262 | (when (zero? n) | |
263 | (error "file didn't show up" ,file)) | |
264 | (unless (file-exists? ,file) | |
265 | (sleep 1) | |
266 | (loop (- n 1))))))) | |
267 | ||
268 | (let* ((line (slurp #$(file-append docker-cli "/bin/docker") | |
269 | "load" "-i" #$tarball)) | |
270 | (repository&tag (string-drop line | |
271 | (string-length | |
272 | "Loaded image: "))) | |
273 | (container (slurp | |
274 | #$(file-append docker-cli "/bin/docker") | |
275 | "create" repository&tag))) | |
276 | (docker-cli "start" container) | |
277 | ||
278 | ;; Wait for shepherd to be ready. | |
279 | (wait-for-container-file container | |
280 | "/var/run/shepherd/socket") | |
281 | ||
282 | (docker-cli "exec" container | |
283 | "/run/current-system/profile/bin/herd" | |
284 | "status") | |
285 | (slurp #$(file-append docker-cli "/bin/docker") | |
286 | "exec" container | |
287 | "/run/current-system/profile/bin/herd" | |
288 | "status" "guix-daemon"))) | |
289 | marionette)) | |
290 | ||
291 | (test-end) | |
292 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
293 | ||
294 | (gexp->derivation "docker-system-test" test)) | |
295 | ||
296 | (define %test-docker-system | |
297 | (system-test | |
298 | (name "docker-system") | |
299 | (description "Run a system image as produced by @command{guix system | |
300 | docker-image} inside Docker.") | |
301 | (value (with-monad %store-monad | |
3c69e81d LC |
302 | (>>= (system-docker-image (operating-system |
303 | (inherit (simple-operating-system)) | |
304 | ;; Use locales for a single libc to | |
305 | ;; reduce space requirements. | |
e1a46520 MO |
306 | (locale-libcs (list glibc))) |
307 | #:memory-size 1024) | |
247649d4 | 308 | run-docker-system-test))))) |