1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
3 ;;; Copyright © 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
5 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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)
29 #:use-module (gnu services desktop)
30 #:use-module ((gnu packages base) #:select (glibc))
31 #:use-module (gnu packages guile)
32 #:use-module (gnu packages docker)
33 #:use-module (guix gexp)
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)
39 #:use-module (guix store)
40 #:use-module (guix tests)
41 #:use-module (guix build-system trivial)
42 #:use-module ((guix licenses) #:prefix license:)
43 #:export (%test-docker
47 (simple-operating-system
48 (service dhcp-client-service-type)
51 (service elogind-service-type)
52 (service docker-service-type)))
54 (define (run-docker-test docker-tarball)
55 "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
58 (marionette-operating-system
60 #:imported-modules '((gnu services herd)
67 (disk-image-size (* 1500 (expt 2 20)))
68 (port-forwardings '())))
71 (with-imported-modules '((gnu build marionette))
73 (use-modules (srfi srfi-11) (srfi srfi-64)
74 (gnu build marionette))
77 (make-marionette (list #$vm)))
84 (test-assert "service running"
87 (use-modules (gnu services herd))
88 (match (start-service 'dockerd)
90 (('service response-parts ...)
91 (match (assq-ref response-parts 'running)
92 ((pid) (number? pid))))))
95 (test-eq "fetch version"
99 (system* ,(string-append #$docker-cli "/bin/docker")
103 (test-equal "Load docker image and run it"
104 '("hello world" "hi!" "JSON!" #o1777)
109 (let* ((port (apply open-pipe* OPEN_READ args))
110 (output (read-line port))
111 (status (close-pipe port)))
113 (let* ((raw-line (slurp ,(string-append #$docker-cli
117 (repository&tag (string-drop raw-line
121 ,(string-append #$docker-cli "/bin/docker")
122 "run" "--entrypoint" "bin/Guile"
125 (response2 (slurp ;default entry point
126 ,(string-append #$docker-cli "/bin/docker")
128 "-c" "(display \"hi!\")"))
130 ;; Check whether (json) is in $GUILE_LOAD_PATH.
131 (response3 (slurp ;default entry point + environment
132 ,(string-append #$docker-cli "/bin/docker")
134 "-c" "(use-modules (json))
135 (display (json-string->scm (scm->json-string \"JSON!\")))"))
137 ;; Check whether /tmp exists.
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))))
147 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
149 (gexp->derivation "docker-test" test))
151 (define (build-tarball&run-docker-test)
153 ((_ (set-grafting #f))
154 (guile (set-guile-for-build (default-guile)))
155 (guest-script-package ->
157 (name "guest-script")
160 (build-system trivial-build-system)
161 (arguments `(#:guile ,guile-3.0
163 (let ((out (assoc-ref %outputs "out")))
165 (call-with-output-file (string-append out "/a.scm")
167 (display "(display \"hello world\n\")" port)))
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.")
173 (license license:public-domain)))
174 (profile (profile-derivation (packages->manifest
175 (list guile-3.0 guile-json-3
176 guest-script-package))
179 (tarball (docker-image "docker-pack" profile
180 #:symlinks '(("/bin/Guile" -> "bin/guile")
181 ("aa.scm" -> "a.scm"))
182 #:entry-point "bin/guile"
183 #:localstatedir? #t)))
184 (run-docker-test tarball)))
189 (description "Test Docker container of Guix.")
190 (value (build-tarball&run-docker-test))))
193 (define (run-docker-system-test tarball)
194 "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
197 (marionette-operating-system
199 #:imported-modules '((gnu services herd)
200 (guix combinators))))
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
211 (port-forwardings '())))
214 (with-imported-modules '((gnu build marionette)
217 (use-modules (srfi srfi-11) (srfi srfi-64)
218 (gnu build marionette)
222 (make-marionette (list #$vm)))
227 (test-begin "docker")
229 (test-assert "service running"
232 (use-modules (gnu services herd))
233 (match (start-service 'dockerd)
235 (('service response-parts ...)
236 (match (assq-ref response-parts 'running)
237 ((pid) (number? pid))))))
240 (test-assert "load system image and run it"
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)))
250 (define (docker-cli command . args)
251 ;; Run the given Docker COMMAND.
252 (apply invoke #$(file-append docker-cli "/bin/docker")
255 (define (wait-for-container-file container file)
256 ;; Wait for FILE to show up in CONTAINER.
257 (docker-cli "exec" container
258 #$(file-append guile-3.0 "/bin/guile")
263 (error "file didn't show up" ,file))
264 (unless (file-exists? ,file)
268 (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
269 "load" "-i" #$tarball))
270 (repository&tag (string-drop line
274 #$(file-append docker-cli "/bin/docker")
275 "create" repository&tag)))
276 (docker-cli "start" container)
278 ;; Wait for shepherd to be ready.
279 (wait-for-container-file container
280 "/var/run/shepherd/socket")
282 (docker-cli "exec" container
283 "/run/current-system/profile/bin/herd"
285 (slurp #$(file-append docker-cli "/bin/docker")
287 "/run/current-system/profile/bin/herd"
288 "status" "guix-daemon")))
292 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
294 (gexp->derivation "docker-system-test" test))
296 (define %test-docker-system
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
302 (>>= (system-docker-image (operating-system
303 (inherit (simple-operating-system))
304 ;; Use locales for a single libc to
305 ;; reduce space requirements.
306 (locale-libcs (list glibc)))
308 run-docker-system-test)))))