gnu/tests/singularity.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2019, 2021 Ludovic Courtès <ludo@gnu.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 singularity)
  20   #:use-module (gnu tests)
  21   #:use-module (gnu system)
  22   #:use-module (gnu system vm)
  23   #:use-module (gnu system shadow)
  24   #:use-module (gnu services)
  25   #:use-module (gnu services docker)
  26   #:use-module (gnu packages bash)
  27   #:use-module (gnu packages guile)
  28   #:use-module (gnu packages linux)               ;singularity
  29   #:use-module (guix gexp)
  30   #:use-module (guix store)
  31   #:use-module (guix grafts)
  32   #:use-module (guix monads)
  33   #:use-module (guix packages)
  34   #:use-module (guix profiles)
  35   #:use-module (guix scripts pack)
  36   #:export (%test-singularity))
  37
  38 (define %singularity-os
  39   (simple-operating-system
  40    (service singularity-service-type)
  41    (simple-service 'guest-account
  42                    account-service-type
  43                    (list (user-account (name "guest") (uid 1000) (group "guest"))
  44                          (user-group (name "guest") (id 1000))))))
  45
  46 (define (run-singularity-test image)
  47   "Load IMAGE, a Squashfs image, as a Singularity image and run it inside
  48 %SINGULARITY-OS."
  49   (define os
  50     (marionette-operating-system %singularity-os))
  51
  52   (define singularity-exec
  53     #~(begin
  54         (use-modules (ice-9 popen) (rnrs io ports))
  55
  56         (let* ((pipe (open-pipe* OPEN_READ
  57                                  #$(file-append singularity
  58                                                 "/bin/singularity")
  59                                  "exec" #$image "/bin/guile"
  60                                  "-c" "(display \"hello, world\")"))
  61                (str  (get-string-all pipe))
  62                (status (close-pipe pipe)))
  63           (and (zero? status)
  64                (string=? str "hello, world")))))
  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 #$(virtual-machine os))))
  74
  75           (test-runner-current (system-test-runner #$output))
  76           (test-begin "singularity")
  77
  78           (test-assert "singularity exec /bin/guile (as root)"
  79             (marionette-eval '#$singularity-exec
  80                              marionette))
  81
  82           (test-equal "singularity exec /bin/guile (unprivileged)"
  83             0
  84             (marionette-eval
  85              `(begin
  86                 (use-modules (ice-9 match))
  87
  88                 (match (primitive-fork)
  89                   (0
  90                    (dynamic-wind
  91                      (const #f)
  92                      (lambda ()
  93                        (setgid 1000)
  94                        (setuid 1000)
  95                        (execl #$(program-file "singularity-exec-test"
  96                                               #~(exit #$singularity-exec))
  97                               "test"))
  98                      (lambda ()
  99                        (primitive-exit 127))))
 100                   (pid
 101                    (cdr (waitpid pid)))))
 102              marionette))
 103
 104           (test-equal "singularity run"           ;test the entry point
 105             42
 106             (marionette-eval
 107              `(status:exit-val
 108                (system* #$(file-append singularity "/bin/singularity")
 109                         "run" #$image "-c" "(exit 42)"))
 110              marionette))
 111
 112           ;; FIXME: Singularity 2.x doesn't directly honor
 113           ;; /.singularity.d/env/*.sh.  Instead, you have to load those files
 114           ;; manually, which we don't do.  Remove 'test-skip' call once we've
 115           ;; switch to Singularity 3.x.
 116           (test-skip 1)
 117           (test-equal "singularity run, with environment"
 118             0
 119             (marionette-eval
 120              ;; Check whether GUILE_LOAD_PATH is properly set, allowing us to
 121              ;; find the (json) module.
 122              `(status:exit-val
 123                (system* #$(file-append singularity "/bin/singularity")
 124                         "--debug" "run" #$image "-c" "(use-modules (json))"))
 125              marionette))
 126
 127           (test-end))))
 128
 129   (gexp->derivation "singularity-test" test))
 130
 131 (define (build-tarball&run-singularity-test)
 132   (mlet* %store-monad
 133       ((_        (set-grafting #f))
 134        (guile    (set-guile-for-build (default-guile)))
 135        ;; 'singularity exec' insists on having /bin/sh in the image.
 136        (profile  (profile-derivation (packages->manifest
 137                                       (list bash-minimal
 138                                             guile-2.2 guile-json-3))
 139                                      #:hooks '()
 140                                      #:locales? #f))
 141        (tarball  (squashfs-image "singularity-pack" profile
 142                                  #:entry-point "bin/guile"
 143                                  #:symlinks '(("/bin" -> "bin")))))
 144     (run-singularity-test tarball)))
 145
 146 (define %test-singularity
 147   (system-test
 148    (name "singularity")
 149    (description "Test Singularity container of Guix.")
 150    (value (build-tarball&run-singularity-test))))