1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
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))
38 (define %singularity-os
39 (simple-operating-system
40 (service singularity-service-type)
41 (simple-service 'guest-account
43 (list (user-account (name "guest") (uid 1000) (group "guest"))
44 (user-group (name "guest") (id 1000))))))
46 (define (run-singularity-test image)
47 "Load IMAGE, a Squashfs image, as a Singularity image and run it inside
50 (marionette-operating-system %singularity-os))
52 (define singularity-exec
54 (use-modules (ice-9 popen) (rnrs io ports))
56 (let* ((pipe (open-pipe* OPEN_READ
57 #$(file-append singularity
59 "exec" #$image "/bin/guile"
60 "-c" "(display \"hello, world\")"))
61 (str (get-string-all pipe))
62 (status (close-pipe pipe)))
64 (string=? str "hello, world")))))
67 (with-imported-modules '((gnu build marionette))
69 (use-modules (srfi srfi-11) (srfi srfi-64)
70 (gnu build marionette))
73 (make-marionette (list #$(virtual-machine os))))
78 (test-begin "singularity")
80 (test-assert "singularity exec /bin/guile (as root)"
81 (marionette-eval '#$singularity-exec
84 (test-equal "singularity exec /bin/guile (unprivileged)"
88 (use-modules (ice-9 match))
90 (match (primitive-fork)
97 (execl #$(program-file "singularity-exec-test"
98 #~(exit #$singularity-exec))
101 (primitive-exit 127))))
103 (cdr (waitpid pid)))))
106 (test-equal "singularity run" ;test the entry point
110 (system* #$(file-append singularity "/bin/singularity")
111 "run" #$image "-c" "(exit 42)"))
114 ;; FIXME: Singularity 2.x doesn't directly honor
115 ;; /.singularity.d/env/*.sh. Instead, you have to load those files
116 ;; manually, which we don't do. Remove 'test-skip' call once we've
117 ;; switch to Singularity 3.x.
119 (test-equal "singularity run, with environment"
122 ;; Check whether GUILE_LOAD_PATH is properly set, allowing us to
123 ;; find the (json) module.
125 (system* #$(file-append singularity "/bin/singularity")
126 "--debug" "run" #$image "-c" "(use-modules (json))"))
130 (exit (= (test-runner-fail-count (test-runner-current)) 0)))))
132 (gexp->derivation "singularity-test" test))
134 (define (build-tarball&run-singularity-test)
136 ((_ (set-grafting #f))
137 (guile (set-guile-for-build (default-guile)))
138 ;; 'singularity exec' insists on having /bin/sh in the image.
139 (profile (profile-derivation (packages->manifest
141 guile-2.2 guile-json-3))
144 (tarball (squashfs-image "singularity-pack" profile
145 #:entry-point "bin/guile"
146 #:symlinks '(("/bin" -> "bin")))))
147 (run-singularity-test tarball)))
149 (define %test-singularity
152 (description "Test Singularity container of Guix.")
153 (value (build-tarball&run-singularity-test))))