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