gnu/tests/docker.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
   3 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
   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)
  29   #:use-module (gnu services desktop)
  30   #:use-module (gnu packages bootstrap) ; %bootstrap-guile
  31   #:use-module (gnu packages docker)
  32   #:use-module (gnu packages guile)
  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
  44             %test-docker-system))
  45
  46 (define %docker-os
  47   (simple-operating-system
  48    (service dhcp-client-service-type)
  49    (dbus-service)
  50    (polkit-service)
  51    (service elogind-service-type)
  52    (service docker-service-type)))
  53
  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."
  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)
  66      (memory-size 700)
  67      (disk-image-size (* 1500 (expt 2 20)))
  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
 103           (test-equal "Load docker image and run it"
 104             '("hello world" "hi!")
 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: ")))
 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)))
 130              marionette))
 131
 132           (test-end)
 133           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 134
 135   (gexp->derivation "docker-test" test))
 136
 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 ->
 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)))
 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"))
 168                               #:entry-point "bin/guile"
 169                               #:localstatedir? #t)))
 170     (run-docker-test tarball)))
 171
 172 (define %test-docker
 173   (system-test
 174    (name "docker")
 175    (description "Test Docker container of Guix.")
 176    (value (build-tarball&run-docker-test))))
 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)))))