Commit | Line | Data |
---|---|---|
29fa45f4 | 1 | ;;; GNU Guix --- Functional package management for GNU |
7e9d9f28 | 2 | ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
b4abdeb6 | 3 | ;;; Copyright © 2015 David Thompson <davet@gnu.org> |
cb21c14b | 4 | ;;; Copyright © 2020 Simon South <simon@simonsouth.net> |
ea924134 | 5 | ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com> |
29fa45f4 LC |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
22 | (define-module (test-syscalls) | |
df3ce5c1 | 23 | #:use-module (guix utils) |
29fa45f4 | 24 | #:use-module (guix build syscalls) |
b7d48312 | 25 | #:use-module (gnu build linux-container) |
4d54785c | 26 | #:use-module (srfi srfi-1) |
381ac93b | 27 | #:use-module (srfi srfi-26) |
7585016f | 28 | #:use-module (srfi srfi-64) |
f87371bf | 29 | #:use-module (srfi srfi-71) |
fa73c193 LC |
30 | #:use-module (system foreign) |
31 | #:use-module ((ice-9 ftw) #:select (scandir)) | |
7585016f | 32 | #:use-module (ice-9 match)) |
29fa45f4 LC |
33 | |
34 | ;; Test the (guix build syscalls) module, although there's not much that can | |
35 | ;; actually be tested without being root. | |
36 | ||
4e0ea3eb LC |
37 | (define temp-file |
38 | (string-append "t-utils-" (number->string (getpid)))) | |
39 | ||
40 | \f | |
29fa45f4 LC |
41 | (test-begin "syscalls") |
42 | ||
43 | (test-equal "mount, ENOENT" | |
44 | ENOENT | |
45 | (catch 'system-error | |
46 | (lambda () | |
47 | (mount "/dev/null" "/does-not-exist" "ext2") | |
48 | #f) | |
49 | (compose system-error-errno list))) | |
50 | ||
35066aa5 | 51 | (test-assert "umount, ENOENT/EPERM" |
29fa45f4 LC |
52 | (catch 'system-error |
53 | (lambda () | |
54 | (umount "/does-not-exist") | |
55 | #f) | |
35066aa5 LC |
56 | (lambda args |
57 | ;; Both return values have been encountered in the wild. | |
58 | (memv (system-error-errno args) (list EPERM ENOENT))))) | |
29fa45f4 | 59 | |
7e9d9f28 LC |
60 | (test-assert "mounts" |
61 | ;; Check for one of the common mount points. | |
62 | (let ((mounts (mounts))) | |
63 | (any (match-lambda | |
64 | ((point . type) | |
65 | (let ((mount (find (lambda (mount) | |
66 | (string=? (mount-point mount) point)) | |
67 | mounts))) | |
68 | (and mount | |
69 | (string=? (mount-type mount) type))))) | |
70 | '(("/proc" . "proc") | |
71 | ("/sys" . "sysfs") | |
72 | ("/dev/shm" . "tmpfs"))))) | |
73 | ||
ccea821b | 74 | (test-assert "mount-points" |
381ac93b LC |
75 | ;; Reportedly "/" is not always listed as a mount point, so check a few |
76 | ;; others (see <http://bugs.gnu.org/20261>.) | |
77 | (any (cute member <> (mount-points)) | |
78 | '("/" "/proc" "/sys" "/dev"))) | |
ccea821b | 79 | |
25c7ff6a LC |
80 | (false-if-exception (delete-file temp-file)) |
81 | (test-equal "utime with AT_SYMLINK_NOFOLLOW" | |
82 | '(0 0) | |
83 | (begin | |
84 | ;; Test libguile's utime with AT_SYMLINK_NOFOLLOW, which libguile does not | |
85 | ;; define as of Guile 2.2.4. | |
86 | (symlink "/nowhere" temp-file) | |
87 | (utime temp-file 0 0 0 0 AT_SYMLINK_NOFOLLOW) | |
88 | (let ((st (lstat temp-file))) | |
89 | (delete-file temp-file) | |
90 | ;; Note: 'utimensat' does not change 'ctime'. | |
91 | (list (stat:mtime st) (stat:atime st))))) | |
92 | ||
cb21c14b | 93 | (test-assert "swapon, ENOSYS/ENOENT/EPERM" |
715fc9d4 LC |
94 | (catch 'system-error |
95 | (lambda () | |
96 | (swapon "/does-not-exist") | |
97 | #f) | |
98 | (lambda args | |
cb21c14b | 99 | (memv (system-error-errno args) (list EPERM ENOENT ENOSYS))))) |
715fc9d4 | 100 | |
cb21c14b | 101 | (test-assert "swapoff, ENOSYS/ENOENT/EINVAL/EPERM" |
715fc9d4 LC |
102 | (catch 'system-error |
103 | (lambda () | |
104 | (swapoff "/does-not-exist") | |
105 | #f) | |
106 | (lambda args | |
cb21c14b | 107 | (memv (system-error-errno args) (list EPERM EINVAL ENOENT ENOSYS))))) |
715fc9d4 | 108 | |
b4abdeb6 DT |
109 | (test-assert "mkdtemp!" |
110 | (let* ((tmp (or (getenv "TMPDIR") "/tmp")) | |
111 | (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX")))) | |
112 | (and (file-exists? dir) | |
113 | (begin | |
114 | (rmdir dir) | |
115 | #t)))) | |
116 | ||
a1f70878 LC |
117 | (test-equal "statfs, ENOENT" |
118 | ENOENT | |
119 | (catch 'system-error | |
120 | (lambda () | |
121 | (statfs "/does-not-exist")) | |
122 | (compose system-error-errno list))) | |
123 | ||
124 | (test-assert "statfs" | |
125 | (let ((fs (statfs "/"))) | |
126 | (and (file-system? fs) | |
127 | (> (file-system-block-size fs) 0) | |
128 | (>= (file-system-blocks-available fs) 0) | |
129 | (>= (file-system-blocks-free fs) | |
130 | (file-system-blocks-available fs))))) | |
131 | ||
8950ed11 DT |
132 | (define (user-namespace pid) |
133 | (string-append "/proc/" (number->string pid) "/ns/user")) | |
134 | ||
b7d48312 DT |
135 | (define perform-container-tests? |
136 | (and (user-namespace-supported?) | |
137 | (unprivileged-user-namespace-supported?))) | |
138 | ||
139 | (unless perform-container-tests? | |
b62a3ebc | 140 | (test-skip 1)) |
8950ed11 DT |
141 | (test-assert "clone" |
142 | (match (clone (logior CLONE_NEWUSER SIGCHLD)) | |
143 | (0 (primitive-exit 42)) | |
144 | (pid | |
145 | ;; Check if user namespaces are different. | |
146 | (and (not (equal? (readlink (user-namespace pid)) | |
147 | (readlink (user-namespace (getpid))))) | |
148 | (match (waitpid pid) | |
149 | ((_ . status) | |
150 | (= 42 (status:exit-val status)))))))) | |
151 | ||
b7d48312 | 152 | (unless perform-container-tests? |
b62a3ebc | 153 | (test-skip 1)) |
43ace6ea DT |
154 | (test-assert "setns" |
155 | (match (clone (logior CLONE_NEWUSER SIGCHLD)) | |
156 | (0 (primitive-exit 0)) | |
157 | (clone-pid | |
158 | (match (pipe) | |
159 | ((in . out) | |
160 | (match (primitive-fork) | |
161 | (0 | |
162 | (close in) | |
163 | ;; Join the user namespace. | |
164 | (call-with-input-file (user-namespace clone-pid) | |
165 | (lambda (port) | |
166 | (setns (port->fdes port) 0))) | |
167 | (write 'done out) | |
168 | (close out) | |
169 | (primitive-exit 0)) | |
170 | (fork-pid | |
171 | (close out) | |
172 | ;; Wait for the child process to join the namespace. | |
173 | (read in) | |
174 | (let ((result (and (equal? (readlink (user-namespace clone-pid)) | |
175 | (readlink (user-namespace fork-pid)))))) | |
176 | ;; Clean up. | |
177 | (waitpid clone-pid) | |
178 | (waitpid fork-pid) | |
179 | result)))))))) | |
8950ed11 | 180 | |
1deca767 | 181 | (when (not perform-container-tests?) |
b62a3ebc | 182 | (test-skip 1)) |
fe9bdb58 | 183 | (test-equal "pivot-root" |
1deca767 LC |
184 | 'success! |
185 | (match (socketpair AF_UNIX SOCK_STREAM 0) | |
186 | ((parent . child) | |
df3ce5c1 DT |
187 | (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD)) |
188 | (0 | |
fe9bdb58 LC |
189 | (dynamic-wind |
190 | (const #t) | |
191 | (lambda () | |
1deca767 | 192 | (close parent) |
fe9bdb58 LC |
193 | (call-with-temporary-directory |
194 | (lambda (root) | |
1deca767 LC |
195 | (display "ready\n" child) |
196 | (read child) ;wait for "go!" | |
fe9bdb58 LC |
197 | (let ((put-old (string-append root "/real-root"))) |
198 | (mount "none" root "tmpfs") | |
199 | (mkdir put-old) | |
200 | (call-with-output-file (string-append root "/test") | |
201 | (lambda (port) | |
202 | (display "testing\n" port))) | |
203 | (pivot-root root put-old) | |
204 | ;; The test file should now be located inside the root directory. | |
1deca767 LC |
205 | (write (and (file-exists? "/test") 'success!) child) |
206 | (close child))))) | |
fe9bdb58 LC |
207 | (lambda () |
208 | (primitive-exit 0)))) | |
df3ce5c1 | 209 | (pid |
1deca767 LC |
210 | (close child) |
211 | (match (read parent) | |
212 | ('ready | |
213 | ;; Set up the UID/GID mapping so that we can mkdir on the tmpfs: | |
214 | ;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>. | |
215 | (call-with-output-file (format #f "/proc/~d/setgroups" pid) | |
216 | (lambda (port) | |
217 | (display "deny" port))) | |
218 | (call-with-output-file (format #f "/proc/~d/uid_map" pid) | |
219 | (lambda (port) | |
220 | (format port "0 ~d 1" (getuid)))) | |
221 | (call-with-output-file (format #f "/proc/~d/gid_map" pid) | |
222 | (lambda (port) | |
223 | (format port "0 ~d 1" (getgid)))) | |
224 | (display "go!\n" parent) | |
225 | (let ((result (read parent))) | |
226 | (close parent) | |
227 | (and (zero? (match (waitpid pid) | |
228 | ((_ . status) | |
229 | (status:exit-val status)))) | |
230 | result))))))))) | |
df3ce5c1 | 231 | |
fa73c193 LC |
232 | (test-equal "scandir*, ENOENT" |
233 | ENOENT | |
234 | (catch 'system-error | |
235 | (lambda () | |
236 | (scandir* "/does/not/exist")) | |
237 | (lambda args | |
238 | (system-error-errno args)))) | |
239 | ||
240 | (test-equal "scandir*, ASCII file names" | |
241 | (scandir (dirname (search-path %load-path "guix/base32.scm")) | |
242 | (const #t) string<?) | |
243 | (match (scandir* (dirname (search-path %load-path "guix/base32.scm"))) | |
244 | (((names . properties) ...) | |
245 | names))) | |
246 | ||
247 | (test-equal "scandir*, UTF-8 file names" | |
248 | '("." ".." "α" "λ") | |
249 | (call-with-temporary-directory | |
250 | (lambda (directory) | |
251 | ;; Wrap 'creat' to make sure that we really pass a UTF-8-encoded file | |
252 | ;; name to the system call. | |
253 | (let ((creat (pointer->procedure int | |
254 | (dynamic-func "creat" (dynamic-link)) | |
255 | (list '* int)))) | |
256 | (creat (string->pointer (string-append directory "/α") | |
257 | "UTF-8") | |
258 | #o644) | |
259 | (creat (string->pointer (string-append directory "/λ") | |
260 | "UTF-8") | |
261 | #o644) | |
262 | (let ((locale (setlocale LC_ALL))) | |
263 | (dynamic-wind | |
264 | (lambda () | |
265 | ;; Make sure that even in a C locale we get the right result. | |
266 | (setlocale LC_ALL "C")) | |
267 | (lambda () | |
268 | (match (scandir* directory) | |
269 | (((names . properties) ...) | |
270 | names))) | |
271 | (lambda () | |
272 | (setlocale LC_ALL locale)))))))) | |
273 | ||
274 | (test-assert "scandir*, properties" | |
275 | (let ((directory (dirname (search-path %load-path "guix/base32.scm")))) | |
276 | (every (lambda (entry name) | |
277 | (match entry | |
278 | ((name2 . properties) | |
279 | (and (string=? name2 name) | |
280 | (let* ((full (string-append directory "/" name)) | |
281 | (stat (lstat full)) | |
282 | (inode (assoc-ref properties 'inode)) | |
283 | (type (assoc-ref properties 'type))) | |
284 | (and (= inode (stat:ino stat)) | |
285 | (or (eq? type 'unknown) | |
286 | (eq? type (stat:type stat))))))))) | |
287 | (scandir* directory) | |
288 | (scandir directory (const #t) string<?)))) | |
289 | ||
df058423 JN |
290 | (false-if-exception (delete-file temp-file)) |
291 | (test-assert "getxattr, setxattr" | |
292 | (let ((key "user.translator") | |
293 | (value "/hurd/pfinet\0") | |
294 | (file (open-file temp-file "w0"))) | |
ea924134 MO |
295 | (catch 'system-error |
296 | (lambda () | |
297 | (setxattr temp-file key value) | |
298 | (string=? (getxattr temp-file key) value)) | |
299 | (lambda args | |
300 | ;; Accept ENOTSUP, if the file-system does not support extended user | |
301 | ;; attributes. | |
302 | (memv (system-error-errno args) (list ENOTSUP)))))) | |
df058423 | 303 | |
4e0ea3eb LC |
304 | (false-if-exception (delete-file temp-file)) |
305 | (test-equal "fcntl-flock wait" | |
306 | 42 ; the child's exit status | |
307 | (let ((file (open-file temp-file "w0b"))) | |
308 | ;; Acquire an exclusive lock. | |
309 | (fcntl-flock file 'write-lock) | |
310 | (match (primitive-fork) | |
311 | (0 | |
312 | (dynamic-wind | |
313 | (const #t) | |
314 | (lambda () | |
315 | ;; Reopen FILE read-only so we can have a read lock. | |
316 | (let ((file (open-file temp-file "r0b"))) | |
317 | ;; Wait until we can acquire the lock. | |
318 | (fcntl-flock file 'read-lock) | |
319 | (primitive-exit (read file))) | |
320 | (primitive-exit 1)) | |
321 | (lambda () | |
322 | (primitive-exit 2)))) | |
323 | (pid | |
324 | ;; Write garbage and wait. | |
325 | (display "hello, world!" file) | |
326 | (force-output file) | |
327 | (sleep 1) | |
328 | ||
329 | ;; Write the real answer. | |
330 | (seek file 0 SEEK_SET) | |
331 | (truncate-file file 0) | |
332 | (write 42 file) | |
333 | (force-output file) | |
334 | ||
335 | ;; Unlock, which should let the child continue. | |
336 | (fcntl-flock file 'unlock) | |
337 | ||
338 | (match (waitpid pid) | |
339 | ((_ . status) | |
340 | (let ((result (status:exit-val status))) | |
341 | (close-port file) | |
342 | result))))))) | |
343 | ||
344 | (test-equal "fcntl-flock non-blocking" | |
345 | EAGAIN ; the child's exit status | |
346 | (match (pipe) | |
347 | ((input . output) | |
348 | (match (primitive-fork) | |
349 | (0 | |
350 | (dynamic-wind | |
351 | (const #t) | |
352 | (lambda () | |
353 | (close-port output) | |
354 | ||
355 | ;; Wait for the green light. | |
356 | (read-char input) | |
357 | ||
358 | ;; Open FILE read-only so we can have a read lock. | |
359 | (let ((file (open-file temp-file "w0"))) | |
360 | (catch 'flock-error | |
361 | (lambda () | |
362 | ;; This attempt should throw EAGAIN. | |
363 | (fcntl-flock file 'write-lock #:wait? #f)) | |
364 | (lambda (key errno) | |
365 | (primitive-exit (pk 'errno errno))))) | |
366 | (primitive-exit -1)) | |
367 | (lambda () | |
368 | (primitive-exit -2)))) | |
369 | (pid | |
370 | (close-port input) | |
371 | (let ((file (open-file temp-file "w0"))) | |
372 | ;; Acquire an exclusive lock. | |
373 | (fcntl-flock file 'write-lock) | |
374 | ||
375 | ;; Tell the child to continue. | |
376 | (write 'green-light output) | |
377 | (force-output output) | |
378 | ||
379 | (match (waitpid pid) | |
380 | ((_ . status) | |
381 | (let ((result (status:exit-val status))) | |
382 | (fcntl-flock file 'unlock) | |
383 | (close-port file) | |
384 | result))))))))) | |
385 | ||
aa401f9b LC |
386 | (test-equal "set-thread-name" |
387 | "Syscall Test" | |
388 | (let ((name (thread-name))) | |
389 | (set-thread-name "Syscall Test") | |
390 | (let ((new-name (thread-name))) | |
391 | (set-thread-name name) | |
392 | new-name))) | |
393 | ||
b89e7405 LC |
394 | (test-assert "all-network-interface-names" |
395 | (match (all-network-interface-names) | |
4d54785c LC |
396 | (((? string? names) ..1) |
397 | (member "lo" names)))) | |
398 | ||
b89e7405 | 399 | (test-assert "network-interface-names" |
5e113cf4 MB |
400 | (match (remove (lambda (interface) |
401 | ;; Ignore interface aliases since they don't show up in | |
402 | ;; (all-network-interface-names). | |
403 | (string-contains interface ":")) | |
404 | (network-interface-names)) | |
7585016f | 405 | (((? string? names) ..1) |
b89e7405 | 406 | (lset<= string=? names (all-network-interface-names))))) |
7585016f | 407 | |
973eea34 | 408 | (test-assert "network-interface-flags" |
c9bf64d6 | 409 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) |
973eea34 LC |
410 | (flags (network-interface-flags sock "lo"))) |
411 | (close-port sock) | |
412 | (and (not (zero? (logand flags IFF_LOOPBACK))) | |
413 | (not (zero? (logand flags IFF_UP)))))) | |
414 | ||
415 | (test-equal "loopback-network-interface?" | |
416 | ENODEV | |
417 | (and (loopback-network-interface? "lo") | |
418 | (catch 'system-error | |
419 | (lambda () | |
420 | (loopback-network-interface? "nonexistent") | |
421 | #f) | |
422 | (lambda args | |
423 | (system-error-errno args))))) | |
424 | ||
0bc6fe32 DM |
425 | (test-equal "loopback-network-interface-running?" |
426 | ENODEV | |
427 | (and (network-interface-running? "lo") | |
428 | (catch 'system-error | |
429 | (lambda () | |
430 | (network-interface-running? "nonexistent") | |
431 | #f) | |
432 | (lambda args | |
433 | (system-error-errno args))))) | |
434 | ||
c9bf64d6 | 435 | (test-skip (if (zero? (getuid)) 1 0)) |
d35c5e29 | 436 | (test-assert "set-network-interface-flags" |
c9bf64d6 LC |
437 | (let ((sock (socket AF_INET SOCK_STREAM 0))) |
438 | (catch 'system-error | |
439 | (lambda () | |
440 | (set-network-interface-flags sock "lo" IFF_UP)) | |
441 | (lambda args | |
442 | (close-port sock) | |
d35c5e29 LC |
443 | ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32. |
444 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
c9bf64d6 LC |
445 | |
446 | (test-equal "network-interface-address lo" | |
447 | (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0) | |
448 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) | |
449 | (addr (network-interface-address sock "lo"))) | |
450 | (close-port sock) | |
451 | addr)) | |
452 | ||
54e515eb | 453 | (test-skip (if (zero? (getuid)) 1 0)) |
d35c5e29 | 454 | (test-assert "set-network-interface-address" |
c9bf64d6 LC |
455 | (let ((sock (socket AF_INET SOCK_STREAM 0))) |
456 | (catch 'system-error | |
457 | (lambda () | |
458 | (set-network-interface-address sock "nonexistent" | |
459 | (make-socket-address | |
460 | AF_INET | |
461 | (inet-pton AF_INET "127.12.14.15") | |
462 | 0))) | |
463 | (lambda args | |
464 | (close-port sock) | |
d35c5e29 LC |
465 | ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32. |
466 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
c9bf64d6 | 467 | |
67e5f3b7 LC |
468 | (test-equal "network-interface-netmask lo" |
469 | (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0) | |
470 | (let* ((sock (socket AF_INET SOCK_STREAM 0)) | |
471 | (addr (network-interface-netmask sock "lo"))) | |
472 | (close-port sock) | |
473 | addr)) | |
474 | ||
475 | (test-skip (if (zero? (getuid)) 1 0)) | |
476 | (test-assert "set-network-interface-netmask" | |
477 | (let ((sock (socket AF_INET SOCK_STREAM 0))) | |
478 | (catch 'system-error | |
479 | (lambda () | |
480 | (set-network-interface-netmask sock "nonexistent" | |
481 | (make-socket-address | |
482 | AF_INET | |
483 | (inet-pton AF_INET "255.0.0.0") | |
484 | 0))) | |
485 | (lambda args | |
486 | (close-port sock) | |
487 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
488 | ||
e7f5691d LC |
489 | (test-equal "network-interfaces returns one or more interfaces" |
490 | '(#t #t #t) | |
491 | (match (network-interfaces) | |
492 | ((interfaces ..1) | |
493 | (list (every interface? interfaces) | |
494 | (every string? (map interface-name interfaces)) | |
7adbe85e LC |
495 | (every (lambda (sockaddr) |
496 | ;; Sometimes interfaces have no associated address. | |
497 | (or (vector? sockaddr) | |
498 | (not sockaddr))) | |
499 | (map interface-address interfaces)))))) | |
e7f5691d LC |
500 | |
501 | (test-equal "network-interfaces returns \"lo\"" | |
502 | (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)) | |
503 | (match (filter (lambda (interface) | |
504 | (string=? "lo" (interface-name interface))) | |
505 | (network-interfaces)) | |
506 | ((loopbacks ..1) | |
507 | (list (every (lambda (lo) | |
508 | (not (zero? (logand IFF_LOOPBACK (interface-flags lo))))) | |
509 | loopbacks) | |
510 | (match (find (lambda (lo) | |
511 | (= AF_INET (sockaddr:fam (interface-address lo)))) | |
512 | loopbacks) | |
513 | (#f #f) | |
514 | (lo (interface-address lo))))))) | |
515 | ||
9e38e3cf LC |
516 | (test-skip (if (zero? (getuid)) 1 0)) |
517 | (test-assert "add-network-route/gateway" | |
518 | (let ((sock (socket AF_INET SOCK_STREAM 0)) | |
519 | (gateway (make-socket-address AF_INET | |
520 | (inet-pton AF_INET "192.168.0.1") | |
521 | 0))) | |
522 | (catch 'system-error | |
523 | (lambda () | |
524 | (add-network-route/gateway sock gateway)) | |
525 | (lambda args | |
526 | (close-port sock) | |
527 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
528 | ||
529 | (test-skip (if (zero? (getuid)) 1 0)) | |
530 | (test-assert "delete-network-route" | |
531 | (let ((sock (socket AF_INET SOCK_STREAM 0)) | |
532 | (destination (make-socket-address AF_INET INADDR_ANY 0))) | |
533 | (catch 'system-error | |
534 | (lambda () | |
535 | (delete-network-route sock destination)) | |
536 | (lambda args | |
537 | (close-port sock) | |
538 | (memv (system-error-errno args) (list EPERM EACCES)))))) | |
539 | ||
ae4ff9f3 LC |
540 | (test-equal "tcgetattr ENOTTY" |
541 | ENOTTY | |
542 | (catch 'system-error | |
543 | (lambda () | |
544 | (call-with-input-file "/dev/null" | |
545 | (lambda (port) | |
546 | (tcgetattr (fileno port))))) | |
547 | (compose system-error-errno list))) | |
548 | ||
549 | (test-skip (if (and (file-exists? "/proc/self/fd/0") | |
550 | (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0"))) | |
551 | 0 | |
552 | 2)) | |
553 | ||
554 | (test-assert "tcgetattr" | |
555 | (let ((termios (tcgetattr 0))) | |
556 | (and (termios? termios) | |
557 | (> (termios-input-speed termios) 0) | |
558 | (> (termios-output-speed termios) 0)))) | |
559 | ||
560 | (test-assert "tcsetattr" | |
561 | (let ((first (tcgetattr 0))) | |
a8f3424b | 562 | (tcsetattr 0 (tcsetattr-action TCSANOW) first) |
ae4ff9f3 LC |
563 | (equal? first (tcgetattr 0)))) |
564 | ||
5cd25aad | 565 | (test-assert "terminal-window-size ENOTTY" |
29ff6d9f LC |
566 | (call-with-input-file "/dev/null" |
567 | (lambda (port) | |
568 | (catch 'system-error | |
569 | (lambda () | |
570 | (terminal-window-size port)) | |
571 | (lambda args | |
5cd25aad LC |
572 | ;; Accept EINVAL, which some old Linux versions might return. |
573 | (memv (system-error-errno args) | |
574 | (list ENOTTY EINVAL))))))) | |
29ff6d9f LC |
575 | |
576 | (test-assert "terminal-columns" | |
577 | (> (terminal-columns) 0)) | |
578 | ||
6d2b4391 LC |
579 | (test-assert "terminal-columns non-file port" |
580 | (> (terminal-columns (open-input-string "Join us now, share the software!")) | |
581 | 0)) | |
582 | ||
4593f5a6 LC |
583 | (test-assert "terminal-rows" |
584 | (> (terminal-rows) 0)) | |
585 | ||
f87371bf LC |
586 | (test-assert "openpty" |
587 | (let ((head inferior (openpty))) | |
588 | (and (integer? head) (integer? inferior) | |
589 | (let ((port (fdopen inferior "r+0"))) | |
590 | (and (isatty? port) | |
591 | (begin | |
592 | (close-port port) | |
593 | (close-fdes head) | |
594 | #t)))))) | |
595 | ||
596 | (test-equal "openpty + login-tty" | |
597 | '(hello world) | |
598 | (let ((head inferior (openpty))) | |
599 | (match (primitive-fork) | |
600 | (0 | |
601 | (dynamic-wind | |
602 | (const #t) | |
603 | (lambda () | |
604 | (setvbuf (current-input-port) 'none) | |
605 | (close-fdes head) | |
606 | (login-tty inferior) | |
607 | (write (read)) | |
608 | (read)) ;this gets EIO when HEAD is closed | |
609 | (lambda () | |
610 | (primitive-_exit 42)))) | |
611 | (pid | |
612 | (close-fdes inferior) | |
613 | (let ((head (fdopen head "r+0"))) | |
614 | (write '(hello world) head) | |
615 | (let ((result (read head))) | |
616 | (close-port head) | |
617 | (waitpid pid) | |
618 | result)))))) | |
619 | ||
15030972 LC |
620 | (test-assert "utmpx-entries" |
621 | (match (utmpx-entries) | |
622 | (((? utmpx? entries) ...) | |
623 | (every (lambda (entry) | |
624 | (match (utmpx-user entry) | |
625 | ((? string?) | |
4aac8d05 LC |
626 | ;; Ensure we have a valid PID for those entries where it |
627 | ;; makes sense. | |
628 | (or (not (memv (utmpx-login-type entry) | |
629 | (list (login-type INIT_PROCESS) | |
630 | (login-type LOGIN_PROCESS) | |
631 | (login-type USER_PROCESS)))) | |
a1a8b7f2 | 632 | (> (utmpx-pid entry) 0))) |
15030972 LC |
633 | (#f ;might be DEAD_PROCESS |
634 | #t))) | |
635 | entries)))) | |
636 | ||
3483f004 LC |
637 | (test-assert "read-utmpx, EOF" |
638 | (eof-object? (read-utmpx (%make-void-port "r")))) | |
639 | ||
640 | (unless (access? "/var/run/utmpx" O_RDONLY) | |
f18eded8 | 641 | (test-skip 1)) |
3483f004 LC |
642 | (test-assert "read-utmpx" |
643 | (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx))) | |
644 | (or (utmpx? result) (eof-object? result)))) | |
645 | ||
5e5f7167 LC |
646 | (when (zero? (getuid)) |
647 | (test-skip 1)) | |
648 | (test-equal "add-to-entropy-count" | |
649 | EPERM | |
650 | (call-with-output-file "/dev/urandom" | |
651 | (lambda (port) | |
652 | (catch 'system-error | |
653 | (lambda () | |
654 | (add-to-entropy-count port 77) | |
655 | #f) | |
656 | (lambda args | |
657 | (system-error-errno args)))))) | |
658 | ||
29fa45f4 | 659 | (test-end) |
4e0ea3eb LC |
660 | |
661 | (false-if-exception (delete-file temp-file)) |