Commit | Line | Data |
---|---|---|
29fa45f4 | 1 | ;;; GNU Guix --- Functional package management for GNU |
15030972 | 2 | ;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
b4abdeb6 | 3 | ;;; Copyright © 2015 David Thompson <davet@gnu.org> |
29fa45f4 LC |
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-syscalls) | |
df3ce5c1 | 21 | #:use-module (guix utils) |
29fa45f4 | 22 | #:use-module (guix build syscalls) |
b7d48312 | 23 | #:use-module (gnu build linux-container) |
4d54785c | 24 | #:use-module (srfi srfi-1) |
381ac93b | 25 | #:use-module (srfi srfi-26) |
7585016f LC |
26 | #:use-module (srfi srfi-64) |
27 | #:use-module (ice-9 match)) | |
29fa45f4 LC |
28 | |
29 | ;; Test the (guix build syscalls) module, although there's not much that can | |
30 | ;; actually be tested without being root. | |
31 | ||
4e0ea3eb LC |
32 | (define temp-file |
33 | (string-append "t-utils-" (number->string (getpid)))) | |
34 | ||
35 | \f | |
29fa45f4 LC |
36 | (test-begin "syscalls") |
37 | ||
38 | (test-equal "mount, ENOENT" | |
39 | ENOENT | |
40 | (catch 'system-error | |
41 | (lambda () | |
42 | (mount "/dev/null" "/does-not-exist" "ext2") | |
43 | #f) | |
44 | (compose system-error-errno list))) | |
45 | ||
35066aa5 | 46 | (test-assert "umount, ENOENT/EPERM" |
29fa45f4 LC |
47 | (catch 'system-error |
48 | (lambda () | |
49 | (umount "/does-not-exist") | |
50 | #f) | |
35066aa5 LC |
51 | (lambda args |
52 | ;; Both return values have been encountered in the wild. | |
53 | (memv (system-error-errno args) (list EPERM ENOENT))))) | |
29fa45f4 | 54 | |
ccea821b | 55 | (test-assert "mount-points" |
381ac93b LC |
56 | ;; Reportedly "/" is not always listed as a mount point, so check a few |
57 | ;; others (see <http://bugs.gnu.org/20261>.) | |
58 | (any (cute member <> (mount-points)) | |
59 | '("/" "/proc" "/sys" "/dev"))) | |
ccea821b | 60 | |
715fc9d4 LC |
61 | (test-assert "swapon, ENOENT/EPERM" |
62 | (catch 'system-error | |
63 | (lambda () | |
64 | (swapon "/does-not-exist") | |
65 | #f) | |
66 | (lambda args | |
67 | (memv (system-error-errno args) (list EPERM ENOENT))))) | |
68 | ||
2793c0fb | 69 | (test-assert "swapoff, ENOENT/EINVAL/EPERM" |
715fc9d4 LC |
70 | (catch 'system-error |
71 | (lambda () | |
72 | (swapoff "/does-not-exist") | |
73 | #f) | |
74 | (lambda args | |
2793c0fb | 75 | (memv (system-error-errno args) (list EPERM EINVAL ENOENT))))) |
715fc9d4 | 76 | |
b4abdeb6 DT |
77 | (test-assert "mkdtemp!" |
78 | (let* ((tmp (or (getenv "TMPDIR") "/tmp")) | |
79 | (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX")))) | |
80 | (and (file-exists? dir) | |
81 | (begin | |
82 | (rmdir dir) | |
83 | #t)))) | |
84 | ||
a1f70878 LC |
85 | (test-equal "statfs, ENOENT" |
86 | ENOENT | |
87 | (catch 'system-error | |
88 | (lambda () | |
89 | (statfs "/does-not-exist")) | |
90 | (compose system-error-errno list))) | |
91 | ||
92 | (test-assert "statfs" | |
93 | (let ((fs (statfs "/"))) | |
94 | (and (file-system? fs) | |
95 | (> (file-system-block-size fs) 0) | |
96 | (>= (file-system-blocks-available fs) 0) | |
97 | (>= (file-system-blocks-free fs) | |
98 | (file-system-blocks-available fs))))) | |
99 | ||
8950ed11 DT |
100 | (define (user-namespace pid) |
101 | (string-append "/proc/" (number->string pid) "/ns/user")) | |
102 | ||
b7d48312 DT |
103 | (define perform-container-tests? |
104 | (and (user-namespace-supported?) | |
105 | (unprivileged-user-namespace-supported?))) | |
106 | ||
107 | (unless perform-container-tests? | |
b62a3ebc | 108 | (test-skip 1)) |
8950ed11 DT |
109 | (test-assert "clone" |
110 | (match (clone (logior CLONE_NEWUSER SIGCHLD)) | |
111 | (0 (primitive-exit 42)) | |
112 | (pid | |
113 | ;; Check if user namespaces are different. | |
114 | (and (not (equal? (readlink (user-namespace pid)) | |
115 | (readlink (user-namespace (getpid))))) | |
116 | (match (waitpid pid) | |
117 | ((_ . status) | |
118 | (= 42 (status:exit-val status)))))))) | |
119 | ||
b7d48312 | 120 | (unless perform-container-tests? |
b62a3ebc | 121 | (test-skip 1)) |
43ace6ea DT |
122 | (test-assert "setns" |
123 | (match (clone (logior CLONE_NEWUSER SIGCHLD)) | |
124 | (0 (primitive-exit 0)) | |
125 | (clone-pid | |
126 | (match (pipe) | |
127 | ((in . out) | |
128 | (match (primitive-fork) | |
129 | (0 | |
130 | (close in) | |
131 | ;; Join the user namespace. | |
132 | (call-with-input-file (user-namespace clone-pid) | |
133 | (lambda (port) | |
134 | (setns (port->fdes port) 0))) | |
135 | (write 'done out) | |
136 | (close out) | |
137 | (primitive-exit 0)) | |
138 | (fork-pid | |
139 | (close out) | |
140 | ;; Wait for the child process to join the namespace. | |
141 | (read in) | |
142 | (let ((result (and (equal? (readlink (user-namespace clone-pid)) | |
143 | (readlink (user-namespace fork-pid)))))) | |
144 | ;; Clean up. | |
145 | (waitpid clone-pid) | |
146 | (waitpid fork-pid) | |
147 | result)))))))) | |
8950ed11 | 148 | |
a91d75ec LC |
149 | ;; XXX: Skip this test when running Linux > 4.7.5 to work around |
150 | ;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>. | |
151 | (when (or (not perform-container-tests?) | |
152 | (version>? (utsname:release (uname)) "4.7.5")) | |
b62a3ebc | 153 | (test-skip 1)) |
fe9bdb58 LC |
154 | (test-equal "pivot-root" |
155 | #t | |
df3ce5c1 DT |
156 | (match (pipe) |
157 | ((in . out) | |
158 | (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD)) | |
159 | (0 | |
fe9bdb58 LC |
160 | (dynamic-wind |
161 | (const #t) | |
162 | (lambda () | |
163 | (close in) | |
164 | (call-with-temporary-directory | |
165 | (lambda (root) | |
166 | (let ((put-old (string-append root "/real-root"))) | |
167 | (mount "none" root "tmpfs") | |
168 | (mkdir put-old) | |
169 | (call-with-output-file (string-append root "/test") | |
170 | (lambda (port) | |
171 | (display "testing\n" port))) | |
172 | (pivot-root root put-old) | |
173 | ;; The test file should now be located inside the root directory. | |
174 | (write (file-exists? "/test") out) | |
175 | (close out))))) | |
176 | (lambda () | |
177 | (primitive-exit 0)))) | |
df3ce5c1 DT |
178 | (pid |
179 | (close out) | |
180 | (let ((result (read in))) | |
181 | (close in) | |
182 | (and (zero? (match (waitpid pid) | |
183 | ((_ . status) | |
184 | (status:exit-val status)))) | |
185 | (eq? #t result)))))))) | |
186 | ||
4e0ea3eb LC |
187 | (false-if-exception (delete-file temp-file)) |
188 | (test-equal "fcntl-flock wait" | |
189 | 42 ; the child's exit status | |
190 | (let ((file (open-file temp-file "w0b"))) | |
191 | ;; Acquire an exclusive lock. | |
192 | (fcntl-flock file 'write-lock) | |
193 | (match (primitive-fork) | |
194 | (0 | |
195 | (dynamic-wind | |
196 | (const #t) | |
197 | (lambda () | |
198 | ;; Reopen FILE read-only so we can have a read lock. | |
199 | (let ((file (open-file temp-file "r0b"))) | |
200 | ;; Wait until we can acquire the lock. | |
201 | (fcntl-flock file 'read-lock) | |
202 | (primitive-exit (read file))) | |
203 | (primitive-exit 1)) | |
204 | (lambda () | |
205 | (primitive-exit 2)))) | |
206 | (pid | |
207 | ;; Write garbage and wait. | |
208 | (display "hello, world!" file) | |
209 | (force-output file) | |
210 | (sleep 1) | |
211 | ||
212 | ;; Write the real answer. | |
213 | (seek file 0 SEEK_SET) | |
214 | (truncate-file file 0) | |
215 | (write 42 file) | |
216 | (force-output file) | |
217 | ||
218 | ;; Unlock, which should let the child continue. | |
219 | (fcntl-flock file 'unlock) | |
220 | ||
221 | (match (waitpid pid) | |
222 | ((_ . status) | |
223 | (let ((result (status:exit-val status))) | |
224 | (close-port file) | |
225 | result))))))) | |
226 | ||
227 | (test-equal "fcntl-flock non-blocking" | |
228 | EAGAIN ; the child's exit status | |
229 | (match (pipe) | |
230 | ((input . output) | |
231 | (match (primitive-fork) | |
232 | (0 | |
233 | (dynamic-wind | |
234 | (const #t) | |
235 | (lambda () | |
236 | (close-port output) | |
237 | ||
238 | ;; Wait for the green light. | |
239 | (read-char input) | |
240 | ||
241 | ;; Open FILE read-only so we can have a read lock. | |
242 | (let ((file (open-file temp-file "w0"))) | |
243 | (catch 'flock-error | |
244 | (lambda () | |
245 | ;; This attempt should throw EAGAIN. | |
246 | (fcntl-flock file 'write-lock #:wait? #f)) | |
247 | (lambda (key errno) | |
248 | (primitive-exit (pk 'errno errno))))) | |
249 | (primitive-exit -1)) | |
250 | (lambda () | |
251 | (primitive-exit -2)))) | |
252 | (pid | |
253 | (close-port input) | |
254 | (let ((file (open-file temp-file "w0"))) | |
255 | ;; Acquire an exclusive lock. | |
256 | (fcntl-flock file 'write-lock) | |
257 | ||
258 | ;; Tell the child to continue. | |
259 | (write 'green-light output) | |
260 | (force-output output) | |
261 | ||
262 | (match (waitpid pid) | |
263 | ((_ . status) | |
264 | (let ((result (status:exit-val status))) | |
265 | (fcntl-flock file 'unlock) | |
266 | (close-port file) | |
267 | result))))))))) | |
268 | ||
b89e7405 LC |
269 | (test-assert "all-network-interface-names" |
270 | (match (all-network-interface-names) | |
4d54785c LC |
271 | (((? string? names) ..1) |
272 | (member "lo" names)))) | |
273 | ||
b89e7405 LC |
274 | (test-assert "network-interface-names" |
275 | (match (network-interface-names) | |
7585016f | 276 | (((? string? names) ..1) |
b89e7405 | 277 | (lset<= string=? names (all-network-interface-names))))) |
7585016f | 278 | |
973eea34 | 279 | (test-assert "network-interface-flags" |
c9bf64d6 | 280 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) |
973eea34 LC |
281 | (flags (network-interface-flags sock "lo"))) |
282 | (close-port sock) | |
283 | (and (not (zero? (logand flags IFF_LOOPBACK))) | |
284 | (not (zero? (logand flags IFF_UP)))))) | |
285 | ||
286 | (test-equal "loopback-network-interface?" | |
287 | ENODEV | |
288 | (and (loopback-network-interface? "lo") | |
289 | (catch 'system-error | |
290 | (lambda () | |
291 | (loopback-network-interface? "nonexistent") | |
292 | #f) | |
293 | (lambda args | |
294 | (system-error-errno args))))) | |
295 | ||
c9bf64d6 | 296 | (test-skip (if (zero? (getuid)) 1 0)) |
d35c5e29 | 297 | (test-assert "set-network-interface-flags" |
c9bf64d6 LC |
298 | (let ((sock (socket AF_INET SOCK_STREAM 0))) |
299 | (catch 'system-error | |
300 | (lambda () | |
301 | (set-network-interface-flags sock "lo" IFF_UP)) | |
302 | (lambda args | |
303 | (close-port sock) | |
d35c5e29 LC |
304 | ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32. |
305 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
c9bf64d6 LC |
306 | |
307 | (test-equal "network-interface-address lo" | |
308 | (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0) | |
309 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) | |
310 | (addr (network-interface-address sock "lo"))) | |
311 | (close-port sock) | |
312 | addr)) | |
313 | ||
54e515eb | 314 | (test-skip (if (zero? (getuid)) 1 0)) |
d35c5e29 | 315 | (test-assert "set-network-interface-address" |
c9bf64d6 LC |
316 | (let ((sock (socket AF_INET SOCK_STREAM 0))) |
317 | (catch 'system-error | |
318 | (lambda () | |
319 | (set-network-interface-address sock "nonexistent" | |
320 | (make-socket-address | |
321 | AF_INET | |
322 | (inet-pton AF_INET "127.12.14.15") | |
323 | 0))) | |
324 | (lambda args | |
325 | (close-port sock) | |
d35c5e29 LC |
326 | ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32. |
327 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
c9bf64d6 | 328 | |
67e5f3b7 LC |
329 | (test-equal "network-interface-netmask lo" |
330 | (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0) | |
331 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) | |
332 | (addr (network-interface-netmask sock "lo"))) | |
333 | (close-port sock) | |
334 | addr)) | |
335 | ||
336 | (test-skip (if (zero? (getuid)) 1 0)) | |
337 | (test-assert "set-network-interface-netmask" | |
338 | (let ((sock (socket AF_INET SOCK_STREAM 0))) | |
339 | (catch 'system-error | |
340 | (lambda () | |
341 | (set-network-interface-netmask sock "nonexistent" | |
342 | (make-socket-address | |
343 | AF_INET | |
344 | (inet-pton AF_INET "255.0.0.0") | |
345 | 0))) | |
346 | (lambda args | |
347 | (close-port sock) | |
348 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
349 | ||
e7f5691d LC |
350 | (test-equal "network-interfaces returns one or more interfaces" |
351 | '(#t #t #t) | |
352 | (match (network-interfaces) | |
353 | ((interfaces ..1) | |
354 | (list (every interface? interfaces) | |
355 | (every string? (map interface-name interfaces)) | |
7adbe85e LC |
356 | (every (lambda (sockaddr) |
357 | ;; Sometimes interfaces have no associated address. | |
358 | (or (vector? sockaddr) | |
359 | (not sockaddr))) | |
360 | (map interface-address interfaces)))))) | |
e7f5691d LC |
361 | |
362 | (test-equal "network-interfaces returns \"lo\"" | |
363 | (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)) | |
364 | (match (filter (lambda (interface) | |
365 | (string=? "lo" (interface-name interface))) | |
366 | (network-interfaces)) | |
367 | ((loopbacks ..1) | |
368 | (list (every (lambda (lo) | |
369 | (not (zero? (logand IFF_LOOPBACK (interface-flags lo))))) | |
370 | loopbacks) | |
371 | (match (find (lambda (lo) | |
372 | (= AF_INET (sockaddr:fam (interface-address lo)))) | |
373 | loopbacks) | |
374 | (#f #f) | |
375 | (lo (interface-address lo))))))) | |
376 | ||
9e38e3cf LC |
377 | (test-skip (if (zero? (getuid)) 1 0)) |
378 | (test-assert "add-network-route/gateway" | |
379 | (let ((sock (socket AF_INET SOCK_STREAM 0)) | |
380 | (gateway (make-socket-address AF_INET | |
381 | (inet-pton AF_INET "192.168.0.1") | |
382 | 0))) | |
383 | (catch 'system-error | |
384 | (lambda () | |
385 | (add-network-route/gateway sock gateway)) | |
386 | (lambda args | |
387 | (close-port sock) | |
388 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
389 | ||
390 | (test-skip (if (zero? (getuid)) 1 0)) | |
391 | (test-assert "delete-network-route" | |
392 | (let ((sock (socket AF_INET SOCK_STREAM 0)) | |
393 | (destination (make-socket-address AF_INET INADDR_ANY 0))) | |
394 | (catch 'system-error | |
395 | (lambda () | |
396 | (delete-network-route sock destination)) | |
397 | (lambda args | |
398 | (close-port sock) | |
399 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
400 | ||
ae4ff9f3 LC |
401 | (test-equal "tcgetattr ENOTTY" |
402 | ENOTTY | |
403 | (catch 'system-error | |
404 | (lambda () | |
405 | (call-with-input-file "/dev/null" | |
406 | (lambda (port) | |
407 | (tcgetattr (fileno port))))) | |
408 | (compose system-error-errno list))) | |
409 | ||
410 | (test-skip (if (and (file-exists? "/proc/self/fd/0") | |
411 | (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0"))) | |
412 | 0 | |
413 | 2)) | |
414 | ||
415 | (test-assert "tcgetattr" | |
416 | (let ((termios (tcgetattr 0))) | |
417 | (and (termios? termios) | |
418 | (> (termios-input-speed termios) 0) | |
419 | (> (termios-output-speed termios) 0)))) | |
420 | ||
421 | (test-assert "tcsetattr" | |
422 | (let ((first (tcgetattr 0))) | |
a8f3424b | 423 | (tcsetattr 0 (tcsetattr-action TCSANOW) first) |
ae4ff9f3 LC |
424 | (equal? first (tcgetattr 0)))) |
425 | ||
5cd25aad | 426 | (test-assert "terminal-window-size ENOTTY" |
29ff6d9f LC |
427 | (call-with-input-file "/dev/null" |
428 | (lambda (port) | |
429 | (catch 'system-error | |
430 | (lambda () | |
431 | (terminal-window-size port)) | |
432 | (lambda args | |
5cd25aad LC |
433 | ;; Accept EINVAL, which some old Linux versions might return. |
434 | (memv (system-error-errno args) | |
435 | (list ENOTTY EINVAL))))))) | |
29ff6d9f LC |
436 | |
437 | (test-assert "terminal-columns" | |
438 | (> (terminal-columns) 0)) | |
439 | ||
6d2b4391 LC |
440 | (test-assert "terminal-columns non-file port" |
441 | (> (terminal-columns (open-input-string "Join us now, share the software!")) | |
442 | 0)) | |
443 | ||
15030972 LC |
444 | (test-assert "utmpx-entries" |
445 | (match (utmpx-entries) | |
446 | (((? utmpx? entries) ...) | |
447 | (every (lambda (entry) | |
448 | (match (utmpx-user entry) | |
449 | ((? string?) | |
450 | (> (utmpx-pid entry) 0)) | |
451 | (#f ;might be DEAD_PROCESS | |
452 | #t))) | |
453 | entries)))) | |
454 | ||
3483f004 LC |
455 | (test-assert "read-utmpx, EOF" |
456 | (eof-object? (read-utmpx (%make-void-port "r")))) | |
457 | ||
458 | (unless (access? "/var/run/utmpx" O_RDONLY) | |
459 | (tes-skip 1)) | |
460 | (test-assert "read-utmpx" | |
461 | (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx))) | |
462 | (or (utmpx? result) (eof-object? result)))) | |
463 | ||
29fa45f4 | 464 | (test-end) |
4e0ea3eb LC |
465 | |
466 | (false-if-exception (delete-file temp-file)) |