1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
3 ;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (test-containers)
21 #:use-module (guix utils)
22 #:use-module (guix build syscalls)
23 #:use-module (gnu build linux-container)
24 #:use-module ((gnu system linux-container)
25 #:select (eval/container))
26 #:use-module (gnu system file-systems)
27 #:use-module (guix store)
28 #:use-module (guix monads)
29 #:use-module (guix gexp)
30 #:use-module (guix derivations)
31 #:use-module (guix tests)
32 #:use-module (srfi srfi-1)
33 #:use-module (srfi srfi-64)
34 #:use-module (ice-9 match))
36 (define (assert-exit x)
37 (primitive-exit (if x 0 1)))
39 (test-begin "containers")
41 ;; Skip these tests unless user namespaces are available and the setgroups
42 ;; file (introduced in Linux 3.19 to address a security issue) exists.
43 (define (skip-if-unsupported)
44 (unless (and (user-namespace-supported?)
45 (unprivileged-user-namespace-supported?)
46 (setgroups-supported?))
50 (test-assert "call-with-container, exit with 0 when there is no error"
52 (call-with-container '() (const #t) #:namespaces '(user))))
55 (test-assert "call-with-container, user namespace"
57 (call-with-container '()
59 ;; The user is root within the new user namespace.
60 (assert-exit (and (zero? (getuid)) (zero? (getgid)))))
61 #:namespaces '(user))))
64 (test-assert "call-with-container, user namespace, guest UID/GID"
66 (call-with-container '()
68 (assert-exit (and (= 42 (getuid)) (= 77 (getgid)))))
71 #:namespaces '(user))))
74 (test-assert "call-with-container, uts namespace"
76 (call-with-container '()
78 ;; The user is root within the container and should be able to change
79 ;; the hostname of that container.
80 (sethostname "test-container")
82 #:namespaces '(user uts))))
85 (test-assert "call-with-container, pid namespace"
87 (call-with-container '()
89 (match (primitive-fork)
91 ;; The first forked process in the new pid namespace is pid 2.
92 (assert-exit (= 2 (getpid))))
97 (status:exit-val status)))))))
98 #:namespaces '(user pid))))
100 (skip-if-unsupported)
101 (test-assert "call-with-container, mnt namespace"
103 (call-with-container (list (file-system
105 (mount-point "/testing")
109 (assert-exit (file-exists? "/testing")))
110 #:namespaces '(user mnt))))
112 (skip-if-unsupported)
113 (test-equal "call-with-container, mnt namespace, wrong bind mount"
114 `(system-error ,ENOENT)
115 ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
118 (call-with-container (list (file-system
119 (device "/does-not-exist")
122 (flags '(bind-mount))
125 #:namespaces '(user mnt)))
127 (list 'system-error (system-error-errno args)))))
129 (skip-if-unsupported)
130 (test-assert "call-with-container, all namespaces"
132 (call-with-container '()
134 (primitive-exit 0)))))
136 (skip-if-unsupported)
137 (test-assert "call-with-container, mnt namespace, root permissions"
139 (call-with-container '()
141 (assert-exit (= #o755 (stat:perms (lstat "/")))))
142 #:namespaces '(user mnt))))
144 (skip-if-unsupported)
145 (test-assert "container-excursion"
146 (call-with-temporary-directory
148 ;; Two pipes: One for the container to signal that the test can begin,
149 ;; and one for the parent to signal to the container that the test is
151 (match (list (pipe) (pipe))
152 (((start-in . start-out) (end-in . end-out))
156 ;; Signal for the test to start.
157 (write 'ready start-out)
159 ;; Wait for test completion.
163 (define (namespaces pid)
164 (let ((pid (number->string pid)))
166 (readlink (string-append "/proc/" pid "/ns/" ns)))
167 '("user" "ipc" "uts" "net" "pid" "mnt"))))
169 (let* ((pid (run-container root '() %namespaces 1 container))
170 (container-namespaces (namespaces pid))
174 ;; Wait for container to be ready.
177 (container-excursion pid
179 ;; Fork again so that the pid is within the context of
180 ;; the joined pid namespace instead of the original pid
182 (match (primitive-fork)
184 ;; Check that all of the namespace identifiers are
185 ;; the same as the container process.
187 (equal? container-namespaces
188 (namespaces (getpid)))))
190 (match (waitpid fork-pid)
193 (status:exit-val status)))))))))))
195 ;; Stop the container.
196 (write 'done end-out)
201 (skip-if-unsupported)
202 (test-equal "container-excursion, same namespaces"
204 ;; The parent and child are in the same namespaces. 'container-excursion'
205 ;; should notice that and avoid calling 'setns' since that would fail.
206 (container-excursion (getpid)
208 (primitive-exit 42))))
210 (skip-if-unsupported)
211 (test-assert "container-excursion*"
212 (call-with-temporary-directory
214 (define (namespaces pid)
215 (let ((pid (number->string pid)))
217 (readlink (string-append "/proc/" pid "/ns/" ns)))
218 '("user" "ipc" "uts" "net" "pid" "mnt"))))
220 (let* ((pid (run-container root '()
224 (expected (namespaces pid))
225 (result (container-excursion* pid
229 (equal? result expected)))))
231 (skip-if-unsupported)
232 (test-equal "container-excursion*, same namespaces"
234 (container-excursion* (getpid)
238 (skip-if-unsupported)
239 (test-equal "eval/container, exit status"
241 (let* ((store (open-connection-for-tests))
242 (status (run-with-store store
243 (eval/container #~(exit 42)))))
244 (close-connection store)
245 (status:exit-val status)))
247 (skip-if-unsupported)
248 (test-assert "eval/container, writable user mapping"
249 (call-with-temporary-directory
252 (open-connection-for-tests))
254 (string-append directory "/r"))
256 (store-lift requisites))
258 (call-with-output-file result (const #t))
259 (run-with-store store
260 (mlet %store-monad ((status (eval/container
262 (use-modules (ice-9 ftw))
263 (call-with-output-file "/result"
265 (write (scandir #$(%store-prefix))
268 (list (file-system-mapping
273 (list (derivation->output-path
274 (%guile-for-build))))))
275 (close-connection store)
276 (return (and (zero? (pk 'status status))
277 (lset= string=? (cons* "." ".." (map basename reqs))
278 (pk (call-with-input-file result read))))))))))
280 (skip-if-unsupported)
281 (test-assert "eval/container, non-empty load path"
282 (call-with-temporary-directory
285 (open-connection-for-tests))
287 (string-append directory "/r"))
289 (store-lift requisites))
292 (run-with-store store
293 (mlet %store-monad ((status (eval/container
294 (with-imported-modules '((guix build utils))
296 (use-modules (guix build utils))
297 (mkdir-p "/result/a/b/c")))
299 (list (file-system-mapping
303 (close-connection store)
304 (return (and (zero? status)
306 (string-append result "/a/b/c")))))))))