gnu/tests/docker.scm

   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>
   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 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
  43             %test-docker-system))
  44
  45 (define %docker-os
  46   (simple-operating-system
  47    (service dhcp-client-service-type)
  48    (dbus-service)
  49    (polkit-service)
  50    (service elogind-service-type)
  51    (service docker-service-type)))
  52
  53 (define (run-docker-test docker-tarball)
  54   "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
  55 inside %DOCKER-OS."
  56   (define os
  57     (marionette-operating-system
  58      %docker-os
  59      #:imported-modules '((gnu services herd)
  60                           (guix combinators))))
  61
  62   (define vm
  63     (virtual-machine
  64      (operating-system os)
  65      (memory-size 700)
  66      (disk-image-size (* 1500 (expt 2 20)))
  67      (port-forwardings '())))
  68
  69   (define test
  70     (with-imported-modules '((gnu build marionette))
  71       #~(begin
  72           (use-modules (srfi srfi-11) (srfi srfi-64)
  73                        (gnu build marionette))
  74
  75           (define marionette
  76             (make-marionette (list #$vm)))
  77
  78           (mkdir #$output)
  79           (chdir #$output)
  80
  81           (test-begin "docker")
  82
  83           (test-assert "service running"
  84             (marionette-eval
  85              '(begin
  86                 (use-modules (gnu services herd))
  87                 (match (start-service 'dockerd)
  88                   (#f #f)
  89                   (('service response-parts ...)
  90                    (match (assq-ref response-parts 'running)
  91                      ((pid) (number? pid))))))
  92              marionette))
  93
  94           (test-eq "fetch version"
  95             0
  96             (marionette-eval
  97              `(begin
  98                 (system* ,(string-append #$docker-cli "/bin/docker")
  99                          "version"))
 100              marionette))
 101
 102           (test-equal "Load docker image and run it"
 103             '("hello world" "hi!" "JSON!" #o1777)
 104             (marionette-eval
 105              `(begin
 106                 (define slurp
 107                   (lambda args
 108                     (let* ((port (apply open-pipe* OPEN_READ args))
 109                            (output (read-line port))
 110                            (status (close-pipe port)))
 111                       output)))
 112                 (let* ((raw-line (slurp ,(string-append #$docker-cli
 113                                                         "/bin/docker")
 114                                                         "load" "-i"
 115                                                         ,#$docker-tarball))
 116                        (repository&tag (string-drop raw-line
 117                                                     (string-length
 118                                                      "Loaded image: ")))
 119                        (response1 (slurp
 120                                    ,(string-append #$docker-cli "/bin/docker")
 121                                    "run" "--entrypoint" "bin/Guile"
 122                                    repository&tag
 123                                    "/aa.scm"))
 124                        (response2 (slurp          ;default entry point
 125                                    ,(string-append #$docker-cli "/bin/docker")
 126                                    "run" repository&tag
 127                                    "-c" "(display \"hi!\")"))
 128
 129                        ;; Check whether (json) is in $GUILE_LOAD_PATH.
 130                        (response3 (slurp    ;default entry point + environment
 131                                    ,(string-append #$docker-cli "/bin/docker")
 132                                    "run" repository&tag
 133                                    "-c" "(use-modules (json))
 134   (display (json-string->scm (scm->json-string \"JSON!\")))"))
 135
 136                        ;; Check whether /tmp exists.
 137                        (response4 (slurp
 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))))
 143              marionette))
 144
 145           (test-end)
 146           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 147
 148   (gexp->derivation "docker-test" test))
 149
 150 (define (build-tarball&run-docker-test)
 151   (mlet* %store-monad
 152       ((_ (set-grafting #f))
 153        (guile (set-guile-for-build (default-guile)))
 154        (guest-script-package ->
 155         (package
 156           (name "guest-script")
 157           (version "0")
 158           (source #f)
 159           (build-system trivial-build-system)
 160           (arguments `(#:guile ,guile-3.0
 161                        #:builder
 162                        (let ((out (assoc-ref %outputs "out")))
 163                          (mkdir out)
 164                          (call-with-output-file (string-append out "/a.scm")
 165                            (lambda (port)
 166                              (display "(display \"hello world\n\")" port)))
 167                          #t)))
 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.")
 171           (home-page #f)
 172           (license license:public-domain)))
 173        (profile (profile-derivation (packages->manifest
 174                                      (list guile-3.0 guile-json-3
 175                                            guest-script-package))
 176                                     #:hooks '()
 177                                     #:locales? #f))
 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)))
 184
 185 (define %test-docker
 186   (system-test
 187    (name "docker")
 188    (description "Test Docker container of Guix.")
 189    (value (build-tarball&run-docker-test))))
 190
 191 \f
 192 (define (run-docker-system-test tarball)
 193   "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
 194 inside %DOCKER-OS."
 195   (define os
 196     (marionette-operating-system
 197      %docker-os
 198      #:imported-modules '((gnu services herd)
 199                           (guix combinators))))
 200
 201   (define vm
 202     (virtual-machine
 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
 208      ;; instead.
 209      (memory-size 3500)
 210      (port-forwardings '())))
 211
 212   (define test
 213     (with-imported-modules '((gnu build marionette)
 214                              (guix build utils))
 215       #~(begin
 216           (use-modules (srfi srfi-11) (srfi srfi-64)
 217                        (gnu build marionette)
 218                        (guix build utils))
 219
 220           (define marionette
 221             (make-marionette (list #$vm)))
 222
 223           (mkdir #$output)
 224           (chdir #$output)
 225
 226           (test-begin "docker")
 227
 228           (test-assert "service running"
 229             (marionette-eval
 230              '(begin
 231                 (use-modules (gnu services herd))
 232                 (match (start-service 'dockerd)
 233                   (#f #f)
 234                   (('service response-parts ...)
 235                    (match (assq-ref response-parts 'running)
 236                      ((pid) (number? pid))))))
 237              marionette))
 238
 239           (test-assert "load system image and run it"
 240             (marionette-eval
 241              `(begin
 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)))
 247                     output))
 248
 249                 (define (docker-cli command . args)
 250                   ;; Run the given Docker COMMAND.
 251                   (apply invoke #$(file-append docker-cli "/bin/docker")
 252                          command args))
 253
 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-3.0 "/bin/guile")
 258                               "-c"
 259                               (object->string
 260                                `(let loop ((n 15))
 261                                   (when (zero? n)
 262                                     (error "file didn't show up" ,file))
 263                                   (unless (file-exists? ,file)
 264                                     (sleep 1)
 265                                     (loop (- n 1)))))))
 266
 267                 (let* ((line (slurp #$(file-append docker-cli "/bin/docker")
 268                                     "load" "-i" #$tarball))
 269                        (repository&tag (string-drop line
 270                                                     (string-length
 271                                                      "Loaded image: ")))
 272                        (container (slurp
 273                                    #$(file-append docker-cli "/bin/docker")
 274                                    "create" repository&tag)))
 275                   (docker-cli "start" container)
 276
 277                   ;; Wait for shepherd to be ready.
 278                   (wait-for-container-file container
 279                                            "/var/run/shepherd/socket")
 280
 281                   (docker-cli "exec" container
 282                               "/run/current-system/profile/bin/herd"
 283                               "status")
 284                   (slurp #$(file-append docker-cli "/bin/docker")
 285                          "exec" container
 286                          "/run/current-system/profile/bin/herd"
 287                          "status" "guix-daemon")))
 288              marionette))
 289
 290           (test-end)
 291           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 292
 293   (gexp->derivation "docker-system-test" test))
 294
 295 (define %test-docker-system
 296   (system-test
 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)))))