projects/guix·blob javascript-team · refs

378 lines · 13.6 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2015 David Thompson <[email protected]>
3;;; Copyright © 2016-2017, 2019, 2023, 2025 Ludovic Courtès <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
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.
11;;;
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.
16;;;
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/>.
19
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)
35 #:use-module ((ice-9 ftw) #:select (scandir)))
36
37(define (assert-exit x)
38 (primitive-exit (if x 0 1)))
39
40(test-begin "containers")
41
42;; Skip these tests unless user namespaces are available and the setgroups
43;; file (introduced in Linux 3.19 to address a security issue) exists.
44(define (skip-if-unsupported)
45 (unless (and (user-namespace-supported?)
46 (unprivileged-user-namespace-supported?)
47 (setgroups-supported?))
48 (test-skip 1)))
49
50(skip-if-unsupported)
51(test-assert "call-with-container, exit with 0 when there is no error"
52 (zero?
53 (call-with-container '() (const #t) #:namespaces '(user))))
54
55(skip-if-unsupported)
56(test-assert "call-with-container, user namespace"
57 (zero?
58 (call-with-container '()
59 (lambda ()
60 ;; The user is root within the new user namespace.
61 (assert-exit (and (zero? (getuid)) (zero? (getgid)))))
62 #:namespaces '(user))))
63
64(skip-if-unsupported)
65(test-assert "call-with-container, user namespace, guest UID/GID"
66 (zero?
67 (call-with-container '()
68 (lambda ()
69 (assert-exit (and (= 42 (getuid)) (= 77 (getgid)))))
70 #:guest-uid 42
71 #:guest-gid 77
72 #:namespaces '(user))))
73
74(skip-if-unsupported)
75(test-assert "call-with-container, uts namespace"
76 (zero?
77 (call-with-container '()
78 (lambda ()
79 ;; The user is root within the container and should be able to change
80 ;; the hostname of that container.
81 (sethostname "test-container")
82 (primitive-exit 0))
83 #:namespaces '(user uts))))
84
85;; (skip-if-unsupported)
86(test-skip 1) ;XXX: work around <https://codeberg.org/guix/guix/issues/7690>
87(test-assert "call-with-container, pid namespace"
88 (zero?
89 (call-with-container '()
90 (lambda ()
91 (match (primitive-fork)
92 (0
93 ;; The first forked process in the new pid namespace is pid 2.
94 (assert-exit (= 2 (getpid))))
95 (pid
96 (primitive-exit
97 (match (waitpid pid)
98 ((_ . status)
99 (status:exit-val status)))))))
100 #:namespaces '(user pid))))
101
102(skip-if-unsupported)
103(test-assert "call-with-container, mnt namespace"
104 (zero?
105 (call-with-container (list (file-system
106 (device "none")
107 (mount-point "/testing")
108 (type "tmpfs")
109 (check? #f)))
110 (lambda ()
111 (assert-exit (file-exists? "/testing")))
112 #:namespaces '(user mnt))))
113
114(skip-if-unsupported)
115(test-equal "call-with-container, mnt namespace, locked mounts"
116 EINVAL
117 ;; umount(2) fails with EINVAL when targeting a mount point that is
118 ;; "locked".
119 (status:exit-val
120 (call-with-container (list (file-system
121 (device "none")
122 (mount-point "/testing")
123 (type "tmpfs")
124 (check? #f)))
125 (lambda ()
126 (primitive-exit (catch 'system-error
127 (lambda ()
128 (umount "/testing")
129 0)
130 (lambda args
131 (system-error-errno args)))))
132 #:namespaces '(user mnt))))
133
134(skip-if-unsupported)
135(test-equal "call-with-container, mnt namespace, wrong bind mount"
136 `(system-error ,ENOENT)
137 ;; An exception should be raised; see <http://bugs.gnu.org/23306>.
138 (catch 'system-error
139 (lambda ()
140 (call-with-container (list (file-system
141 (device "/does-not-exist")
142 (mount-point "/foo")
143 (type "none")
144 (flags '(bind-mount))
145 (check? #f)))
146 (const #t)
147 #:namespaces '(user mnt)))
148 (lambda args
149 (list 'system-error (system-error-errno args)))))
150
151(skip-if-unsupported)
152(test-assert "call-with-container, all namespaces"
153 (zero?
154 (call-with-container '()
155 (lambda ()
156 (primitive-exit 0)))))
157
158(skip-if-unsupported)
159(test-assert "call-with-container, mnt namespace, root permissions"
160 (zero?
161 (call-with-container '()
162 (lambda ()
163 (assert-exit (= #o755 (stat:perms (lstat "/")))))
164 #:namespaces '(user mnt))))
165
166(skip-if-unsupported)
167(test-assert "call-with-container, mnt namespace, read-only root"
168 (zero?
169 (call-with-container '()
170 (lambda ()
171 (assert-exit (and (file-is-directory? "/witness")
172 (catch 'system-error
173 (lambda ()
174 (mkdir "/whatever")
175 #f)
176 (lambda args
177 (= (system-error-errno args) EROFS))))))
178 #:populate-file-system (lambda ()
179 (mkdir "/witness"))
180 #:namespaces '(user mnt))))
181
182(skip-if-unsupported)
183(test-assert "call-with-container, mnt namespace, writable root"
184 (zero?
185 (call-with-container '()
186 (lambda ()
187 (mkdir "whatever")
188 (assert-exit (file-is-directory? "/whatever")))
189 #:writable-root? #t
190 #:namespaces '(user mnt))))
191
192;; (skip-if-unsupported)
193(test-skip 1) ;XXX: work around <https://codeberg.org/guix/guix/issues/7690>
194(test-equal "container-excursion"
195 0
196 (call-with-temporary-directory
197 (lambda (root)
198 ;; Two pipes: One for the container to signal that the test can begin,
199 ;; and one for the parent to signal to the container that the test is
200 ;; over.
201 (match (list (pipe) (pipe))
202 (((start-in . start-out) (end-in . end-out))
203 (define (container)
204 (close end-out)
205 (close start-in)
206 ;; Signal for the test to start.
207 (write 'ready start-out)
208 (close start-out)
209 ;; Wait for test completion.
210 (read end-in)
211 (close end-in))
212
213 (define (namespaces pid)
214 (let ((pid (number->string pid)))
215 (map (lambda (ns)
216 (readlink (string-append "/proc/" pid "/ns/" ns)))
217 '("user" "ipc" "uts" "net" "pid" "mnt"))))
218
219 (let* ((pid (run-container root '() %namespaces 1 container
220 ;; Do not lock mounts so the user namespace
221 ;; appears to be the same seen from inside
222 ;; and from outside.
223 #:lock-mounts? #f))
224 (container-namespaces (namespaces pid))
225 (result
226 (begin
227 (close start-out)
228 ;; Wait for container to be ready.
229 (read start-in)
230 (close start-in)
231 (container-excursion pid
232 (lambda ()
233 ;; Check that all of the namespace identifiers are
234 ;; the same as the container process.
235 (assert-exit
236 (equal? container-namespaces
237 (namespaces (getpid)))))))))
238 (close end-in)
239 ;; Stop the container.
240 (write 'done end-out)
241 (close end-out)
242 (waitpid pid)
243 result))))))
244
245;; (skip-if-unsupported)
246(test-skip 1) ;XXX: work around <https://codeberg.org/guix/guix/issues/7690>
247(test-equal "container-excursion, same namespaces"
248 42
249 ;; The parent and child are in the same namespaces. 'container-excursion'
250 ;; should notice that and avoid calling 'setns' since that would fail.
251 (status:exit-val
252 (container-excursion (getpid)
253 (lambda ()
254 (primitive-exit 42)))))
255
256;; (skip-if-unsupported)
257(test-skip 1) ;XXX: work around <https://codeberg.org/guix/guix/issues/7690>
258(test-assert "container-excursion*"
259 (call-with-temporary-directory
260 (lambda (root)
261 (define (namespaces pid)
262 (let ((pid (number->string pid)))
263 (map (lambda (ns)
264 (readlink (string-append "/proc/" pid "/ns/" ns)))
265 '("user" "ipc" "uts" "net" "pid" "mnt"))))
266
267 (let* ((pid (run-container root '()
268 %namespaces 1
269 (lambda ()
270 (sleep 100))))
271 (expected (namespaces pid))
272 (result (container-excursion* pid
273 (lambda ()
274 (namespaces 1)))))
275 (kill pid SIGKILL)
276 (equal? result expected)))))
277
278;; (skip-if-unsupported)
279(test-skip 1) ;XXX: work around <https://codeberg.org/guix/guix/issues/7690>
280(test-equal "container-excursion*, same namespaces"
281 42
282 (container-excursion* (getpid)
283 (lambda ()
284 (* 6 7))))
285
286;; (skip-if-unsupported)
287(test-skip 1) ;XXX: work around <https://codeberg.org/guix/guix/issues/7690>
288(test-equal "container-excursion*, /proc"
289 '("1" "2")
290 (call-with-temporary-directory
291 (lambda (root)
292 (let* ((pid (run-container root '()
293 %namespaces 1
294 (lambda ()
295 (sleep 100))))
296 (result (container-excursion* pid
297 (lambda ()
298 ;; We expect to see exactly two processes in this
299 ;; namespace.
300 (scandir "/proc"
301 (lambda (file)
302 (char-set-contains?
303 char-set:digit
304 (string-ref file 0))))))))
305 (kill pid SIGKILL)
306 result))))
307
308(skip-if-unsupported)
309(test-equal "eval/container, exit status"
310 42
311 (let* ((store (open-connection-for-tests))
312 (status (run-with-store store
313 (eval/container #~(exit 42)))))
314 (close-connection store)
315 (status:exit-val status)))
316
317(skip-if-unsupported)
318(test-assert "eval/container, writable user mapping"
319 (call-with-temporary-directory
320 (lambda (directory)
321 (define store
322 (open-connection-for-tests))
323 (define result
324 (string-append directory "/r"))
325 (define requisites*
326 (store-lift requisites))
327
328 (call-with-output-file result (const #t))
329 (run-with-store store
330 (mlet %store-monad ((status (eval/container
331 #~(begin
332 (use-modules (ice-9 ftw))
333 (call-with-output-file "/result"
334 (lambda (port)
335 (write (scandir #$(%store-prefix))
336 port))))
337 #:mappings
338 (list (file-system-mapping
339 (source result)
340 (target "/result")
341 (writable? #t)))))
342 (reqs (requisites*
343 (list (derivation->output-path
344 (%guile-for-build))))))
345 (close-connection store)
346 (return (and (zero? (pk 'status status))
347 (lset= string=? (cons* "." ".." (map basename reqs))
348 (pk (call-with-input-file result read))))))))))
349
350(skip-if-unsupported)
351(test-assert "eval/container, non-empty load path"
352 (call-with-temporary-directory
353 (lambda (directory)
354 (define store
355 (open-connection-for-tests))
356 (define result
357 (string-append directory "/r"))
358 (define requisites*
359 (store-lift requisites))
360
361 (mkdir result)
362 (run-with-store store
363 (mlet %store-monad ((status (eval/container
364 (with-imported-modules '((guix build utils))
365 #~(begin
366 (use-modules (guix build utils))
367 (mkdir-p "/result/a/b/c")))
368 #:mappings
369 (list (file-system-mapping
370 (source result)
371 (target "/result")
372 (writable? #t))))))
373 (close-connection store)
374 (return (and (zero? status)
375 (file-is-directory?
376 (string-append result "/a/b/c")))))))))
377
378(test-end)