projects/guix·blob python-team · refs

150 lines · 5.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2019, 2021 Ludovic Courtès <[email protected]>
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))))