Commit | Line | Data |
---|---|---|
7d8a4eea | 1 | ;;; GNU Guix --- Functional package management for GNU |
babfd944 | 2 | ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org> |
247649d4 | 3 | ;;; Copyright © 2019 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) |
49ec5d88 | 30 | #:use-module (gnu packages bootstrap) ; %bootstrap-guile |
7d8a4eea | 31 | #:use-module (gnu packages docker) |
247649d4 | 32 | #:use-module (gnu packages guile) |
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" |
a0f352b3 | 104 | '("hello world" "hi!") |
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 | |
128 | "-c" "(display \"hi!\")"))) | |
129 | (list response1 response2))) | |
49ec5d88 DM |
130 | marionette)) |
131 | ||
7d8a4eea DM |
132 | (test-end) |
133 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
134 | ||
135 | (gexp->derivation "docker-test" test)) | |
136 | ||
49ec5d88 DM |
137 | (define (build-tarball&run-docker-test) |
138 | (mlet* %store-monad | |
139 | ((_ (set-grafting #f)) | |
140 | (guile (set-guile-for-build (default-guile))) | |
141 | (guest-script-package -> | |
69e47686 DM |
142 | (package |
143 | (name "guest-script") | |
144 | (version "0") | |
145 | (source #f) | |
146 | (build-system trivial-build-system) | |
147 | (arguments `(#:guile ,%bootstrap-guile | |
148 | #:builder | |
149 | (let ((out (assoc-ref %outputs "out"))) | |
150 | (mkdir out) | |
151 | (call-with-output-file (string-append out "/a.scm") | |
152 | (lambda (port) | |
153 | (display "(display \"hello world\n\")" port))) | |
154 | #t))) | |
155 | (synopsis "Display hello world using Guile") | |
156 | (description "This package displays the text \"hello world\" on the | |
157 | standard output device and then enters a new line.") | |
158 | (home-page #f) | |
159 | (license license:public-domain))) | |
49ec5d88 DM |
160 | (profile (profile-derivation (packages->manifest |
161 | (list %bootstrap-guile | |
162 | guest-script-package)) | |
163 | #:hooks '() | |
164 | #:locales? #f)) | |
165 | (tarball (docker-image "docker-pack" profile | |
166 | #:symlinks '(("/bin/Guile" -> "bin/guile") | |
167 | ("aa.scm" -> "a.scm")) | |
a0f352b3 | 168 | #:entry-point "bin/guile" |
49ec5d88 DM |
169 | #:localstatedir? #t))) |
170 | (run-docker-test tarball))) | |
171 | ||
7d8a4eea DM |
172 | (define %test-docker |
173 | (system-test | |
174 | (name "docker") | |
49ec5d88 DM |
175 | (description "Test Docker container of Guix.") |
176 | (value (build-tarball&run-docker-test)))) | |
247649d4 LC |
177 | |
178 | \f | |
179 | (define (run-docker-system-test tarball) | |
180 | "Load DOCKER-TARBALL as Docker image and run it in a Docker container, | |
181 | inside %DOCKER-OS." | |
182 | (define os | |
183 | (marionette-operating-system | |
184 | %docker-os | |
185 | #:imported-modules '((gnu services herd) | |
186 | (guix combinators)))) | |
187 | ||
188 | (define vm | |
189 | (virtual-machine | |
190 | (operating-system os) | |
191 | ;; FIXME: Because we're using the volatile-root setup where the root file | |
192 | ;; system is a tmpfs overlaid over a small root file system, 'docker | |
193 | ;; load' must be able to store the whole image into memory, hence the | |
194 | ;; huge memory requirements. We should avoid the volatile-root setup | |
195 | ;; instead. | |
196 | (memory-size 3000) | |
197 | (port-forwardings '()))) | |
198 | ||
199 | (define test | |
200 | (with-imported-modules '((gnu build marionette) | |
201 | (guix build utils)) | |
202 | #~(begin | |
203 | (use-modules (srfi srfi-11) (srfi srfi-64) | |
204 | (gnu build marionette) | |
205 | (guix build utils)) | |
206 | ||
207 | (define marionette | |
208 | (make-marionette (list #$vm))) | |
209 | ||
210 | (mkdir #$output) | |
211 | (chdir #$output) | |
212 | ||
213 | (test-begin "docker") | |
214 | ||
215 | (test-assert "service running" | |
216 | (marionette-eval | |
217 | '(begin | |
218 | (use-modules (gnu services herd)) | |
219 | (match (start-service 'dockerd) | |
220 | (#f #f) | |
221 | (('service response-parts ...) | |
222 | (match (assq-ref response-parts 'running) | |
223 | ((pid) (number? pid)))))) | |
224 | marionette)) | |
225 | ||
226 | (test-assert "load system image and run it" | |
227 | (marionette-eval | |
228 | `(begin | |
229 | (define (slurp command . args) | |
230 | ;; Return the output from COMMAND. | |
231 | (let* ((port (apply open-pipe* OPEN_READ command args)) | |
232 | (output (read-line port)) | |
233 | (status (close-pipe port))) | |
234 | output)) | |
235 | ||
236 | (define (docker-cli command . args) | |
237 | ;; Run the given Docker COMMAND. | |
238 | (apply invoke #$(file-append docker-cli "/bin/docker") | |
239 | command args)) | |
240 | ||
241 | (define (wait-for-container-file container file) | |
242 | ;; Wait for FILE to show up in CONTAINER. | |
243 | (docker-cli "exec" container | |
244 | #$(file-append guile-2.2 "/bin/guile") | |
245 | "-c" | |
246 | (object->string | |
247 | `(let loop ((n 15)) | |
248 | (when (zero? n) | |
249 | (error "file didn't show up" ,file)) | |
250 | (unless (file-exists? ,file) | |
251 | (sleep 1) | |
252 | (loop (- n 1))))))) | |
253 | ||
254 | (let* ((line (slurp #$(file-append docker-cli "/bin/docker") | |
255 | "load" "-i" #$tarball)) | |
256 | (repository&tag (string-drop line | |
257 | (string-length | |
258 | "Loaded image: "))) | |
259 | (container (slurp | |
260 | #$(file-append docker-cli "/bin/docker") | |
261 | "create" repository&tag))) | |
262 | (docker-cli "start" container) | |
263 | ||
264 | ;; Wait for shepherd to be ready. | |
265 | (wait-for-container-file container | |
266 | "/var/run/shepherd/socket") | |
267 | ||
268 | (docker-cli "exec" container | |
269 | "/run/current-system/profile/bin/herd" | |
270 | "status") | |
271 | (slurp #$(file-append docker-cli "/bin/docker") | |
272 | "exec" container | |
273 | "/run/current-system/profile/bin/herd" | |
274 | "status" "guix-daemon"))) | |
275 | marionette)) | |
276 | ||
277 | (test-end) | |
278 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
279 | ||
280 | (gexp->derivation "docker-system-test" test)) | |
281 | ||
282 | (define %test-docker-system | |
283 | (system-test | |
284 | (name "docker-system") | |
285 | (description "Run a system image as produced by @command{guix system | |
286 | docker-image} inside Docker.") | |
287 | (value (with-monad %store-monad | |
288 | (>>= (system-docker-image (simple-operating-system)) | |
289 | run-docker-system-test))))) |