gnu/tests/docker.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (gnu tests docker)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system file-systems)
  23   #:use-module (gnu system vm)
  24   #:use-module (gnu services)
  25   #:use-module (gnu services dbus)
  26   #:use-module (gnu services networking)
  27   #:use-module (gnu services docker)
  28   #:use-module (gnu services desktop)
  29   #:use-module (gnu packages bootstrap) ; %bootstrap-guile
  30   #:use-module (gnu packages docker)
  31   #:use-module (guix gexp)
  32   #:use-module (guix grafts)
  33   #:use-module (guix monads)
  34   #:use-module (guix packages)
  35   #:use-module (guix profiles)
  36   #:use-module (guix scripts pack)
  37   #:use-module (guix store)
  38   #:use-module (guix tests)
  39   #:use-module (guix build-system trivial)
  40   #:export (%test-docker))
  41
  42 (define %docker-os
  43   (simple-operating-system
  44    (service dhcp-client-service-type)
  45    (dbus-service)
  46    (polkit-service)
  47    (service elogind-service-type)
  48    (service docker-service-type)))
  49
  50 (define (run-docker-test docker-tarball)
  51   "Load DOCKER-TARBALL as Docker image and run it in a Docker container,
  52 inside %DOCKER-OS."
  53   (define os
  54     (marionette-operating-system
  55      %docker-os
  56      #:imported-modules '((gnu services herd)
  57                           (guix combinators))))
  58
  59   (define vm
  60     (virtual-machine
  61      (operating-system os)
  62      (memory-size 700)
  63      (disk-image-size (* 1500 (expt 2 20)))
  64      (port-forwardings '())))
  65
  66   (define test
  67     (with-imported-modules '((gnu build marionette))
  68       #~(begin
  69           (use-modules (srfi srfi-11) (srfi srfi-64)
  70                        (gnu build marionette))
  71
  72           (define marionette
  73             (make-marionette (list #$vm)))
  74
  75           (mkdir #$output)
  76           (chdir #$output)
  77
  78           (test-begin "docker")
  79
  80           (test-assert "service running"
  81             (marionette-eval
  82              '(begin
  83                 (use-modules (gnu services herd))
  84                 (match (start-service 'dockerd)
  85                   (#f #f)
  86                   (('service response-parts ...)
  87                    (match (assq-ref response-parts 'running)
  88                      ((pid) (number? pid))))))
  89              marionette))
  90
  91           (test-eq "fetch version"
  92             0
  93             (marionette-eval
  94              `(begin
  95                 (system* ,(string-append #$docker-cli "/bin/docker")
  96                          "version"))
  97              marionette))
  98
  99           (test-equal "Load docker image and run it"
 100             "hello world"
 101             (marionette-eval
 102              `(begin
 103                 (define slurp
 104                   (lambda args
 105                     (let* ((port (apply open-pipe* OPEN_READ args))
 106                            (output (read-line port))
 107                            (status (close-pipe port)))
 108                       output)))
 109                 (let* ((raw-line (slurp ,(string-append #$docker-cli
 110                                                         "/bin/docker")
 111                                                         "load" "-i"
 112                                                         ,#$docker-tarball))
 113                        (repository&tag (string-drop raw-line
 114                                                     (string-length
 115                                                      "Loaded image: ")))
 116                        (response (slurp
 117                                   ,(string-append #$docker-cli "/bin/docker")
 118                                   "run" "--entrypoint" "bin/Guile"
 119                                   repository&tag
 120                                   "/aa.scm")))
 121                   response))
 122              marionette))
 123
 124           (test-end)
 125           (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
 126
 127   (gexp->derivation "docker-test" test))
 128
 129 (define (build-tarball&run-docker-test)
 130   (mlet* %store-monad
 131       ((_ (set-grafting #f))
 132        (guile (set-guile-for-build (default-guile)))
 133        (guest-script-package ->
 134         (dummy-package "guest-script"
 135                        (build-system trivial-build-system)
 136                        (arguments
 137                         `(#:guile ,%bootstrap-guile
 138                           #:builder
 139                           (let ((out (assoc-ref %outputs "out")))
 140                             (mkdir out)
 141                             (call-with-output-file (string-append out "/a.scm")
 142                               (lambda (port)
 143                                 (display "(display \"hello world\n\")" port)))
 144                             #t)))))
 145        (profile (profile-derivation (packages->manifest
 146                                      (list %bootstrap-guile
 147                                            guest-script-package))
 148                                     #:hooks '()
 149                                     #:locales? #f))
 150        (tarball (docker-image "docker-pack" profile
 151                               #:symlinks '(("/bin/Guile" -> "bin/guile")
 152                                            ("aa.scm" -> "a.scm"))
 153                               #:localstatedir? #t)))
 154     (run-docker-test tarball)))
 155
 156 (define %test-docker
 157   (system-test
 158    (name "docker")
 159    (description "Test Docker container of Guix.")
 160    (value (build-tarball&run-docker-test))))