1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 David Thompson <davet@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-syscalls)
21 #:use-module (guix utils)
22 #:use-module (guix build syscalls)
23 #:use-module (srfi srfi-1)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-64)
26 #:use-module (ice-9 match))
28 ;; Test the (guix build syscalls) module, although there's not much that can
29 ;; actually be tested without being root.
31 (test-begin "syscalls")
33 (test-equal "mount, ENOENT"
37 (mount "/dev/null" "/does-not-exist" "ext2")
39 (compose system-error-errno list)))
41 (test-assert "umount, ENOENT/EPERM"
44 (umount "/does-not-exist")
47 ;; Both return values have been encountered in the wild.
48 (memv (system-error-errno args) (list EPERM ENOENT)))))
50 (test-assert "mount-points"
51 ;; Reportedly "/" is not always listed as a mount point, so check a few
52 ;; others (see <http://bugs.gnu.org/20261>.)
53 (any (cute member <> (mount-points))
54 '("/" "/proc" "/sys" "/dev")))
56 (test-assert "swapon, ENOENT/EPERM"
59 (swapon "/does-not-exist")
62 (memv (system-error-errno args) (list EPERM ENOENT)))))
64 (test-assert "swapoff, ENOENT/EINVAL/EPERM"
67 (swapoff "/does-not-exist")
70 (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))
72 (test-assert "mkdtemp!"
73 (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
74 (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX"))))
75 (and (file-exists? dir)
80 (define (user-namespace pid)
81 (string-append "/proc/" (number->string pid) "/ns/user"))
83 (unless (file-exists? (user-namespace (getpid)))
86 (match (clone (logior CLONE_NEWUSER SIGCHLD))
87 (0 (primitive-exit 42))
89 ;; Check if user namespaces are different.
90 (and (not (equal? (readlink (user-namespace pid))
91 (readlink (user-namespace (getpid)))))
94 (= 42 (status:exit-val status))))))))
96 (unless (file-exists? (user-namespace (getpid)))
99 (match (clone (logior CLONE_NEWUSER SIGCHLD))
100 (0 (primitive-exit 0))
104 (match (primitive-fork)
107 ;; Join the user namespace.
108 (call-with-input-file (user-namespace clone-pid)
110 (setns (port->fdes port) 0)))
116 ;; Wait for the child process to join the namespace.
118 (let ((result (and (equal? (readlink (user-namespace clone-pid))
119 (readlink (user-namespace fork-pid))))))
125 (unless (file-exists? (user-namespace (getpid)))
127 (test-assert "pivot-root"
130 (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD))
133 (call-with-temporary-directory
135 (let ((put-old (string-append root "/real-root")))
136 (mount "none" root "tmpfs")
138 (call-with-output-file (string-append root "/test")
140 (display "testing\n" port)))
141 (pivot-root root put-old)
142 ;; The test file should now be located inside the root directory.
143 (write (file-exists? "/test") out)
148 (let ((result (read in)))
150 (and (zero? (match (waitpid pid)
152 (status:exit-val status))))
153 (eq? #t result))))))))
155 (test-assert "all-network-interface-names"
156 (match (all-network-interface-names)
157 (((? string? names) ..1)
158 (member "lo" names))))
160 (test-assert "network-interface-names"
161 (match (network-interface-names)
162 (((? string? names) ..1)
163 (lset<= string=? names (all-network-interface-names)))))
165 (test-assert "network-interface-flags"
166 (let* ((sock (socket AF_INET SOCK_STREAM 0))
167 (flags (network-interface-flags sock "lo")))
169 (and (not (zero? (logand flags IFF_LOOPBACK)))
170 (not (zero? (logand flags IFF_UP))))))
172 (test-equal "loopback-network-interface?"
174 (and (loopback-network-interface? "lo")
177 (loopback-network-interface? "nonexistent")
180 (system-error-errno args)))))
182 (test-skip (if (zero? (getuid)) 1 0))
183 (test-assert "set-network-interface-flags"
184 (let ((sock (socket AF_INET SOCK_STREAM 0)))
187 (set-network-interface-flags sock "lo" IFF_UP))
190 ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
191 (memv (system-error-errno args) (list EPERM EACCES))))))
193 (test-equal "network-interface-address lo"
194 (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0)
195 (let* ((sock (socket AF_INET SOCK_STREAM 0))
196 (addr (network-interface-address sock "lo")))
200 (test-skip (if (zero? (getuid)) 1 0))
201 (test-assert "set-network-interface-address"
202 (let ((sock (socket AF_INET SOCK_STREAM 0)))
205 (set-network-interface-address sock "nonexistent"
208 (inet-pton AF_INET "127.12.14.15")
212 ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
213 (memv (system-error-errno args) (list EPERM EACCES))))))
215 (test-equal "network-interfaces returns one or more interfaces"
217 (match (network-interfaces)
219 (list (every interface? interfaces)
220 (every string? (map interface-name interfaces))
221 (every vector? (map interface-address interfaces))))))
223 (test-equal "network-interfaces returns \"lo\""
224 (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0))
225 (match (filter (lambda (interface)
226 (string=? "lo" (interface-name interface)))
227 (network-interfaces))
229 (list (every (lambda (lo)
230 (not (zero? (logand IFF_LOOPBACK (interface-flags lo)))))
232 (match (find (lambda (lo)
233 (= AF_INET (sockaddr:fam (interface-address lo))))
236 (lo (interface-address lo)))))))
241 (exit (= (test-runner-fail-count (test-runner-current)) 0))