Commit | Line | Data |
---|---|---|
08814aec LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2019 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 | (mkdir #$output) | |
76 | (chdir #$output) | |
77 | ||
78 | (test-begin "singularity") | |
79 | ||
80 | (test-assert "singularity exec /bin/guile (as root)" | |
81 | (marionette-eval '#$singularity-exec | |
82 | marionette)) | |
83 | ||
84 | (test-equal "singularity exec /bin/guile (unprivileged)" | |
85 | 0 | |
86 | (marionette-eval | |
87 | `(begin | |
88 | (use-modules (ice-9 match)) | |
89 | ||
90 | (match (primitive-fork) | |
91 | (0 | |
92 | (dynamic-wind | |
93 | (const #f) | |
94 | (lambda () | |
95 | (setgid 1000) | |
96 | (setuid 1000) | |
97 | (execl #$(program-file "singularity-exec-test" | |
98 | #~(exit #$singularity-exec)) | |
99 | "test")) | |
100 | (lambda () | |
101 | (primitive-exit 127)))) | |
102 | (pid | |
103 | (cdr (waitpid pid))))) | |
104 | marionette)) | |
105 | ||
a0f352b3 LC |
106 | (test-equal "singularity run" ;test the entry point |
107 | 42 | |
108 | (marionette-eval | |
109 | `(status:exit-val | |
110 | (system* #$(file-append singularity "/bin/singularity") | |
111 | "run" #$image "-c" "(exit 42)")) | |
112 | marionette)) | |
113 | ||
dea62932 LC |
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. | |
118 | (test-skip 1) | |
119 | (test-equal "singularity run, with environment" | |
120 | 0 | |
121 | (marionette-eval | |
122 | ;; Check whether GUILE_LOAD_PATH is properly set, allowing us to | |
123 | ;; find the (json) module. | |
124 | `(status:exit-val | |
125 | (system* #$(file-append singularity "/bin/singularity") | |
126 | "--debug" "run" #$image "-c" "(use-modules (json))")) | |
127 | marionette)) | |
128 | ||
08814aec LC |
129 | (test-end) |
130 | (exit (= (test-runner-fail-count (test-runner-current)) 0))))) | |
131 | ||
132 | (gexp->derivation "singularity-test" test)) | |
133 | ||
134 | (define (build-tarball&run-singularity-test) | |
135 | (mlet* %store-monad | |
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 | |
dea62932 | 140 | (list bash-minimal |
f0034427 | 141 | guile-2.2 guile-json-3)) |
08814aec LC |
142 | #:hooks '() |
143 | #:locales? #f)) | |
144 | (tarball (squashfs-image "singularity-pack" profile | |
a0f352b3 | 145 | #:entry-point "bin/guile" |
08814aec LC |
146 | #:symlinks '(("/bin" -> "bin"))))) |
147 | (run-singularity-test tarball))) | |
148 | ||
149 | (define %test-singularity | |
150 | (system-test | |
151 | (name "singularity") | |
152 | (description "Test Singularity container of Guix.") | |
153 | (value (build-tarball&run-singularity-test)))) |