1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
3 ;;; Copyright © 2019, 2020 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 docker)
31 #:use-module (gnu packages guile)
32 #:use-module (guix gexp)
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)
38 #:use-module (guix store)
39 #:use-module (guix tests)
40 #:use-module (guix build-system trivial)
41 #:use-module ((guix licenses) #:prefix license:)
42 #:export (%test-docker
46 (simple-operating-system
47 (service dhcp-client-service-type)
50 (service elogind-service-type)
51 (service docker-service-type)))
53 (define (run-docker-test docker-tarball)
54 "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
57 (marionette-operating-system
59 #:imported-modules '((gnu services herd)
66 (disk-image-size (* 1500 (expt 2 20)))
67 (port-forwardings '())))
70 (with-imported-modules '((gnu build marionette))
72 (use-modules (srfi srfi-11) (srfi srfi-64)
73 (gnu build marionette))
76 (make-marionette (list #$vm)))
83 (test-assert "service running"
86 (use-modules (gnu services herd))
87 (match (start-service 'dockerd)
89 (('service response-parts ...)
90 (match (assq-ref response-parts 'running)
91 ((pid) (number? pid))))))
94 (test-eq "fetch version"
98 (system* ,(string-append #$docker-cli "/bin/docker")
102 (test-equal "Load docker image and run it"
103 '("hello world" "hi!" "JSON!" #o1777)
108 (let* ((port (apply open-pipe* OPEN_READ args))
109 (output (read-line port))
110 (status (close-pipe port)))
112 (let* ((raw-line (slurp ,(string-append #$docker-cli
116 (repository&tag (string-drop raw-line
120 ,(string-append #$docker-cli "/bin/docker")
121 "run" "--entrypoint" "bin/Guile"
124 (response2 (slurp ;default entry point
125 ,(string-append #$docker-cli "/bin/docker")
127 "-c" "(display \"hi!\")"))
129 ;; Check whether (json) is in $GUILE_LOAD_PATH.
130 (response3 (slurp ;default entry point + environment
131 ,(string-append #$docker-cli "/bin/docker")
133 "-c" "(use-modules (json))
134 (display (json-string->scm (scm->json-string \"JSON!\")))"))
136 ;; Check whether /tmp exists.
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))))
146 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
148 (gexp->derivation "docker-test" test))
150 (define (build-tarball&run-docker-test)
152 ((_ (set-grafting #f))
153 (guile (set-guile-for-build (default-guile)))
154 (guest-script-package ->
156 (name "guest-script")
159 (build-system trivial-build-system)
160 (arguments `(#:guile ,guile-2.2
162 (let ((out (assoc-ref %outputs "out")))
164 (call-with-output-file (string-append out "/a.scm")
166 (display "(display \"hello world\n\")" port)))
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.")
172 (license license:public-domain)))
173 (profile (profile-derivation (packages->manifest
174 (list guile-2.2 guile-json-3
175 guest-script-package))
178 (tarball (docker-image "docker-pack" profile
179 #:symlinks '(("/bin/Guile" -> "bin/guile")
180 ("aa.scm" -> "a.scm"))
181 #:entry-point "bin/guile"
182 #:localstatedir? #t)))
183 (run-docker-test tarball)))
188 (description "Test Docker container of Guix.")
189 (value (build-tarball&run-docker-test))))
192 (define (run-docker-system-test tarball)
193 "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
196 (marionette-operating-system
198 #:imported-modules '((gnu services herd)
199 (guix combinators))))
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
210 (port-forwardings '())))
213 (with-imported-modules '((gnu build marionette)
216 (use-modules (srfi srfi-11) (srfi srfi-64)
217 (gnu build marionette)
221 (make-marionette (list #$vm)))
226 (test-begin "docker")
228 (test-assert "service running"
231 (use-modules (gnu services herd))
232 (match (start-service 'dockerd)
234 (('service response-parts ...)
235 (match (assq-ref response-parts 'running)
236 ((pid) (number? pid))))))
239 (test-assert "load system image and run it"
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)))
249 (define (docker-cli command . args)
250 ;; Run the given Docker COMMAND.
251 (apply invoke #$(file-append docker-cli "/bin/docker")
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")
262 (error "file didn't show up" ,file))
263 (unless (file-exists? ,file)
267 (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
268 "load" "-i" #$tarball))
269 (repository&tag (string-drop line
273 #$(file-append docker-cli "/bin/docker")
274 "create" repository&tag)))
275 (docker-cli "start" container)
277 ;; Wait for shepherd to be ready.
278 (wait-for-container-file container
279 "/var/run/shepherd/socket")
281 (docker-cli "exec" container
282 "/run/current-system/profile/bin/herd"
284 (slurp #$(file-append docker-cli "/bin/docker")
286 "/run/current-system/profile/bin/herd"
287 "status" "guix-daemon")))
291 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
293 (gexp->derivation "docker-system-test" test))
295 (define %test-docker-system
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)))))