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 image)
22 #:use-module (gnu tests)
23 #:use-module (gnu system)
24 #:use-module (gnu system file-systems)
25 #:use-module (gnu system image)
26 #:use-module (gnu system vm)
27 #:use-module (gnu services)
28 #:use-module (gnu services dbus)
29 #:use-module (gnu services networking)
30 #:use-module (gnu services docker)
31 #:use-module (gnu services desktop)
32 #:use-module ((gnu packages base) #:select (glibc))
33 #:use-module (gnu packages guile)
34 #:use-module (gnu packages docker)
35 #:use-module (guix gexp)
36 #:use-module (guix grafts)
37 #:use-module (guix monads)
38 #:use-module (guix packages)
39 #:use-module (guix profiles)
40 #:use-module ((guix scripts pack) #:prefix pack:)
41 #:use-module (guix store)
42 #:use-module (guix tests)
43 #:use-module (guix build-system trivial)
44 #:use-module ((guix licenses) #:prefix license:)
45 #:export (%test-docker
49 (simple-operating-system
50 (service dhcp-client-service-type)
53 (service elogind-service-type)
54 (service docker-service-type)))
56 (define (run-docker-test docker-tarball)
57 "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
60 (marionette-operating-system
61 (operating-system-with-gc-roots
63 (list docker-tarball))
64 #:imported-modules '((gnu services herd)
72 (disk-image-size (* 3000 (expt 2 20)))
73 (port-forwardings '())))
76 (with-imported-modules '((gnu build marionette))
78 (use-modules (srfi srfi-11) (srfi srfi-64)
79 (gnu build marionette))
82 ;; Relax timeout to accommodate older systems.
83 (make-marionette (list #$vm) #:timeout 60))
85 (test-runner-current (system-test-runner #$output))
88 (test-assert "service running"
91 (use-modules (gnu services herd))
92 (match (start-service 'dockerd)
94 (('service response-parts ...)
95 (match (assq-ref response-parts 'running)
96 ((pid) (number? pid))))))
99 (test-eq "fetch version"
103 (system* ,(string-append #$docker-cli "/bin/docker")
107 (test-equal "Load docker image and run it"
108 '("hello world" "hi!" "JSON!" #o1777)
113 (let* ((port (apply open-pipe* OPEN_READ args))
114 (output (read-line port))
115 (status (close-pipe port)))
117 (let* ((raw-line (slurp ,(string-append #$docker-cli
121 (repository&tag (string-drop raw-line
125 ,(string-append #$docker-cli "/bin/docker")
126 "run" "--entrypoint" "bin/Guile"
129 (response2 (slurp ;default entry point
130 ,(string-append #$docker-cli "/bin/docker")
132 "-c" "(display \"hi!\")"))
134 ;; Check whether (json) is in $GUILE_LOAD_PATH.
135 (response3 (slurp ;default entry point + environment
136 ,(string-append #$docker-cli "/bin/docker")
138 "-c" "(use-modules (json))
139 (display (json-string->scm (scm->json-string \"JSON!\")))"))
141 ;; Check whether /tmp exists.
143 ,(string-append #$docker-cli "/bin/docker")
144 "run" repository&tag "-c"
145 "(display (stat:perms (lstat \"/tmp\")))")))
146 (list response1 response2 response3
147 (string->number response4))))
152 (gexp->derivation "docker-test" test))
154 (define (build-tarball&run-docker-test)
156 ((_ (set-grafting #f))
157 (guile (set-guile-for-build (default-guile)))
158 (guest-script-package ->
160 (name "guest-script")
163 (build-system trivial-build-system)
164 (arguments `(#:guile ,guile-3.0
166 (let ((out (assoc-ref %outputs "out")))
168 (call-with-output-file (string-append out "/a.scm")
170 (display "(display \"hello world\n\")" port)))
172 (synopsis "Display hello world using Guile")
173 (description "This package displays the text \"hello world\" on the
174 standard output device and then enters a new line.")
176 (license license:public-domain)))
177 (profile (profile-derivation (packages->manifest
178 (list guile-3.0 guile-json-3
179 guest-script-package))
182 (tarball (pack:docker-image
183 "docker-pack" profile
184 #:symlinks '(("/bin/Guile" -> "bin/guile")
185 ("aa.scm" -> "a.scm"))
186 #:entry-point "bin/guile"
187 #:localstatedir? #t)))
188 (run-docker-test tarball)))
193 (description "Test Docker container of Guix.")
194 (value (build-tarball&run-docker-test))))
197 (define (run-docker-system-test tarball)
198 "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
201 (marionette-operating-system
202 (operating-system-with-gc-roots
205 #:imported-modules '((gnu services herd)
206 (guix combinators))))
210 (operating-system os)
212 (disk-image-size (* 5000 (expt 2 20)))
214 (port-forwardings '())))
217 (with-imported-modules '((gnu build marionette)
220 (use-modules (srfi srfi-11) (srfi srfi-64)
221 (gnu build marionette)
225 ;; Relax timeout to accommodate older systems.
226 (make-marionette (list #$vm) #:timeout 60))
228 (test-runner-current (system-test-runner #$output))
229 (test-begin "docker")
231 (test-assert "service running"
234 (use-modules (gnu services herd))
235 (match (start-service 'dockerd)
237 (('service response-parts ...)
238 (match (assq-ref response-parts 'running)
239 ((pid) (number? pid))))))
242 (test-assert "load system image and run it"
245 (define (slurp command . args)
246 ;; Return the output from COMMAND.
247 (let* ((port (apply open-pipe* OPEN_READ command args))
248 (output (read-line port))
249 (status (close-pipe port)))
252 (define (docker-cli command . args)
253 ;; Run the given Docker COMMAND.
254 (apply invoke #$(file-append docker-cli "/bin/docker")
257 (define (wait-for-container-file container file)
258 ;; Wait for FILE to show up in CONTAINER.
259 (docker-cli "exec" container
260 #$(file-append guile-3.0 "/bin/guile")
265 (error "file didn't show up" ,file))
266 (unless (file-exists? ,file)
270 (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
271 "load" "-i" #$tarball))
272 (repository&tag (string-drop line
276 #$(file-append docker-cli "/bin/docker")
277 "create" repository&tag)))
278 (docker-cli "start" container)
280 ;; Wait for shepherd to be ready.
281 (wait-for-container-file container
282 "/var/run/shepherd/socket")
284 (docker-cli "exec" container
285 "/run/current-system/profile/bin/herd"
287 (slurp #$(file-append docker-cli "/bin/docker")
289 "/run/current-system/profile/bin/herd"
290 "status" "guix-daemon")))
295 (gexp->derivation "docker-system-test" test))
297 (define %test-docker-system
299 (name "docker-system")
300 (description "Run a system image as produced by @command{guix system
301 docker-image} inside Docker.")
302 (value (with-monad %store-monad
304 (system-image (os->image
306 (inherit (simple-operating-system))
307 ;; Use locales for a single libc to
308 ;; reduce space requirements.
309 (locale-libcs (list glibc)))
310 #:type docker-image-type)))
311 run-docker-system-test)))))