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