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