X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/5ade90ba6976a5ce8715de07344985c70c0eda8b..c26fd5648c2a24dbd71f4c0851f8b5eced75e0f1:/tests/syscalls.scm

diff --git a/tests/syscalls.scm b/tests/syscalls.scm
index f26331e164..7fe0cd1545 100644
--- a/tests/syscalls.scm
+++ b/tests/syscalls.scm
@@ -1,5 +1,6 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,14 +18,23 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (test-syscalls)
+  #:use-module (guix utils)
   #:use-module (guix build syscalls)
+  #:use-module (gnu build linux-container)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-64)
+  #:use-module (system foreign)
+  #:use-module ((ice-9 ftw) #:select (scandir))
   #:use-module (ice-9 match))
 
 ;; Test the (guix build syscalls) module, although there's not much that can
 ;; actually be tested without being root.
 
+(define temp-file
+  (string-append "t-utils-" (number->string (getpid))))
+
+
 (test-begin "syscalls")
 
 (test-equal "mount, ENOENT"
@@ -45,7 +55,23 @@
       (memv (system-error-errno args) (list EPERM ENOENT)))))
 
 (test-assert "mount-points"
-  (member "/" (mount-points)))
+  ;; Reportedly "/" is not always listed as a mount point, so check a few
+  ;; others (see <http://bugs.gnu.org/20261>.)
+  (any (cute member <> (mount-points))
+       '("/" "/proc" "/sys" "/dev")))
+
+(false-if-exception (delete-file temp-file))
+(test-equal "utime with AT_SYMLINK_NOFOLLOW"
+  '(0 0)
+  (begin
+    ;; Test libguile's utime with AT_SYMLINK_NOFOLLOW, which libguile does not
+    ;; define as of Guile 2.2.4.
+    (symlink "/nowhere" temp-file)
+    (utime temp-file 0 0 0 0 AT_SYMLINK_NOFOLLOW)
+    (let ((st (lstat temp-file)))
+      (delete-file temp-file)
+      ;; Note: 'utimensat' does not change 'ctime'.
+      (list (stat:mtime st) (stat:atime st)))))
 
 (test-assert "swapon, ENOENT/EPERM"
   (catch 'system-error
@@ -63,15 +89,286 @@
     (lambda args
       (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))
 
-(test-assert "all-network-interfaces"
-  (match (all-network-interfaces)
+(test-assert "mkdtemp!"
+  (let* ((tmp (or (getenv "TMPDIR") "/tmp"))
+         (dir (mkdtemp! (string-append tmp "/guix-test-XXXXXX"))))
+    (and (file-exists? dir)
+         (begin
+           (rmdir dir)
+           #t))))
+
+(test-equal "statfs, ENOENT"
+  ENOENT
+  (catch 'system-error
+    (lambda ()
+      (statfs "/does-not-exist"))
+    (compose system-error-errno list)))
+
+(test-assert "statfs"
+  (let ((fs (statfs "/")))
+    (and (file-system? fs)
+         (> (file-system-block-size fs) 0)
+         (>= (file-system-blocks-available fs) 0)
+         (>= (file-system-blocks-free fs)
+             (file-system-blocks-available fs)))))
+
+(define (user-namespace pid)
+  (string-append "/proc/" (number->string pid) "/ns/user"))
+
+(define perform-container-tests?
+  (and (user-namespace-supported?)
+       (unprivileged-user-namespace-supported?)))
+
+(unless perform-container-tests?
+  (test-skip 1))
+(test-assert "clone"
+  (match (clone (logior CLONE_NEWUSER SIGCHLD))
+    (0 (primitive-exit 42))
+    (pid
+     ;; Check if user namespaces are different.
+     (and (not (equal? (readlink (user-namespace pid))
+                       (readlink (user-namespace (getpid)))))
+          (match (waitpid pid)
+            ((_ . status)
+             (= 42 (status:exit-val status))))))))
+
+(unless perform-container-tests?
+  (test-skip 1))
+(test-assert "setns"
+  (match (clone (logior CLONE_NEWUSER SIGCHLD))
+    (0 (primitive-exit 0))
+    (clone-pid
+     (match (pipe)
+       ((in . out)
+        (match (primitive-fork)
+          (0
+           (close in)
+           ;; Join the user namespace.
+           (call-with-input-file (user-namespace clone-pid)
+             (lambda (port)
+               (setns (port->fdes port) 0)))
+           (write 'done out)
+           (close out)
+           (primitive-exit 0))
+          (fork-pid
+           (close out)
+           ;; Wait for the child process to join the namespace.
+           (read in)
+           (let ((result (and (equal? (readlink (user-namespace clone-pid))
+                                      (readlink (user-namespace fork-pid))))))
+             ;; Clean up.
+             (waitpid clone-pid)
+             (waitpid fork-pid)
+             result))))))))
+
+(when (not perform-container-tests?)
+  (test-skip 1))
+(test-equal "pivot-root"
+  'success!
+  (match (socketpair AF_UNIX SOCK_STREAM 0)
+    ((parent . child)
+     (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD))
+       (0
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close parent)
+            (call-with-temporary-directory
+             (lambda (root)
+               (display "ready\n" child)
+               (read child)                       ;wait for "go!"
+               (let ((put-old (string-append root "/real-root")))
+                 (mount "none" root "tmpfs")
+                 (mkdir put-old)
+                 (call-with-output-file (string-append root "/test")
+                   (lambda (port)
+                     (display "testing\n" port)))
+                 (pivot-root root put-old)
+                 ;; The test file should now be located inside the root directory.
+                 (write (and (file-exists? "/test") 'success!) child)
+                 (close child)))))
+          (lambda ()
+            (primitive-exit 0))))
+       (pid
+        (close child)
+        (match (read parent)
+          ('ready
+           ;; Set up the UID/GID mapping so that we can mkdir on the tmpfs:
+           ;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>.
+           (call-with-output-file (format #f "/proc/~d/setgroups" pid)
+             (lambda (port)
+               (display "deny" port)))
+           (call-with-output-file (format #f "/proc/~d/uid_map" pid)
+             (lambda (port)
+               (format port "0 ~d 1" (getuid))))
+           (call-with-output-file (format #f "/proc/~d/gid_map" pid)
+             (lambda (port)
+               (format port "0 ~d 1" (getgid))))
+           (display "go!\n" parent)
+           (let ((result (read parent)))
+             (close parent)
+             (and (zero? (match (waitpid pid)
+                           ((_ . status)
+                            (status:exit-val status))))
+                  result)))))))))
+
+(test-equal "scandir*, ENOENT"
+  ENOENT
+  (catch 'system-error
+    (lambda ()
+      (scandir* "/does/not/exist"))
+    (lambda args
+      (system-error-errno args))))
+
+(test-equal "scandir*, ASCII file names"
+  (scandir (dirname (search-path %load-path "guix/base32.scm"))
+           (const #t) string<?)
+  (match (scandir* (dirname (search-path %load-path "guix/base32.scm")))
+    (((names . properties) ...)
+     names)))
+
+(test-equal "scandir*, UTF-8 file names"
+  '("." ".." "α" "λ")
+  (call-with-temporary-directory
+   (lambda (directory)
+     ;; Wrap 'creat' to make sure that we really pass a UTF-8-encoded file
+     ;; name to the system call.
+     (let ((creat (pointer->procedure int
+                                      (dynamic-func "creat" (dynamic-link))
+                                      (list '* int))))
+       (creat (string->pointer (string-append directory "/α")
+                               "UTF-8")
+              #o644)
+       (creat (string->pointer (string-append directory "/λ")
+                               "UTF-8")
+              #o644)
+       (let ((locale (setlocale LC_ALL)))
+         (dynamic-wind
+           (lambda ()
+             ;; Make sure that even in a C locale we get the right result.
+             (setlocale LC_ALL "C"))
+           (lambda ()
+             (match (scandir* directory)
+               (((names . properties) ...)
+                names)))
+           (lambda ()
+             (setlocale LC_ALL locale))))))))
+
+(test-assert "scandir*, properties"
+  (let ((directory (dirname (search-path %load-path "guix/base32.scm"))))
+    (every (lambda (entry name)
+             (match entry
+               ((name2 . properties)
+                (and (string=? name2 name)
+                     (let* ((full  (string-append directory "/" name))
+                            (stat  (lstat full))
+                            (inode (assoc-ref properties 'inode))
+                            (type  (assoc-ref properties 'type)))
+                       (and (= inode (stat:ino stat))
+                            (or (eq? type 'unknown)
+                                (eq? type (stat:type stat)))))))))
+           (scandir* directory)
+           (scandir directory (const #t) string<?))))
+
+(false-if-exception (delete-file temp-file))
+(test-equal "fcntl-flock wait"
+  42                                              ; the child's exit status
+  (let ((file (open-file temp-file "w0b")))
+    ;; Acquire an exclusive lock.
+    (fcntl-flock file 'write-lock)
+    (match (primitive-fork)
+      (0
+       (dynamic-wind
+         (const #t)
+         (lambda ()
+           ;; Reopen FILE read-only so we can have a read lock.
+           (let ((file (open-file temp-file "r0b")))
+             ;; Wait until we can acquire the lock.
+             (fcntl-flock file 'read-lock)
+             (primitive-exit (read file)))
+           (primitive-exit 1))
+         (lambda ()
+           (primitive-exit 2))))
+      (pid
+       ;; Write garbage and wait.
+       (display "hello, world!"  file)
+       (force-output file)
+       (sleep 1)
+
+       ;; Write the real answer.
+       (seek file 0 SEEK_SET)
+       (truncate-file file 0)
+       (write 42 file)
+       (force-output file)
+
+       ;; Unlock, which should let the child continue.
+       (fcntl-flock file 'unlock)
+
+       (match (waitpid pid)
+         ((_  . status)
+          (let ((result (status:exit-val status)))
+            (close-port file)
+            result)))))))
+
+(test-equal "fcntl-flock non-blocking"
+  EAGAIN                                          ; the child's exit status
+  (match (pipe)
+    ((input . output)
+     (match (primitive-fork)
+       (0
+        (dynamic-wind
+          (const #t)
+          (lambda ()
+            (close-port output)
+
+            ;; Wait for the green light.
+            (read-char input)
+
+            ;; Open FILE read-only so we can have a read lock.
+            (let ((file (open-file temp-file "w0")))
+              (catch 'flock-error
+                (lambda ()
+                  ;; This attempt should throw EAGAIN.
+                  (fcntl-flock file 'write-lock #:wait? #f))
+                (lambda (key errno)
+                  (primitive-exit (pk 'errno errno)))))
+            (primitive-exit -1))
+          (lambda ()
+            (primitive-exit -2))))
+       (pid
+        (close-port input)
+        (let ((file (open-file temp-file "w0")))
+          ;; Acquire an exclusive lock.
+          (fcntl-flock file 'write-lock)
+
+          ;; Tell the child to continue.
+          (write 'green-light output)
+          (force-output output)
+
+          (match (waitpid pid)
+            ((_  . status)
+             (let ((result (status:exit-val status)))
+               (fcntl-flock file 'unlock)
+               (close-port file)
+               result)))))))))
+
+(test-equal "set-thread-name"
+  "Syscall Test"
+  (let ((name (thread-name)))
+    (set-thread-name "Syscall Test")
+    (let ((new-name (thread-name)))
+      (set-thread-name name)
+      new-name)))
+
+(test-assert "all-network-interface-names"
+  (match (all-network-interface-names)
     (((? string? names) ..1)
      (member "lo" names))))
 
-(test-assert "network-interfaces"
-  (match (network-interfaces)
+(test-assert "network-interface-names"
+  (match (network-interface-names)
     (((? string? names) ..1)
-     (lset<= string=? names (all-network-interfaces)))))
+     (lset<= string=? names (all-network-interface-names)))))
 
 (test-assert "network-interface-flags"
   (let* ((sock  (socket AF_INET SOCK_STREAM 0))
@@ -90,6 +387,16 @@
          (lambda args
            (system-error-errno args)))))
 
+(test-equal "loopback-network-interface-running?"
+  ENODEV
+  (and (network-interface-running? "lo")
+       (catch 'system-error
+         (lambda ()
+           (network-interface-running? "nonexistent")
+           #f)
+         (lambda args
+           (system-error-errno args)))))
+
 (test-skip (if (zero? (getuid)) 1 0))
 (test-assert "set-network-interface-flags"
   (let ((sock (socket AF_INET SOCK_STREAM 0)))
@@ -108,6 +415,7 @@
     (close-port sock)
     addr))
 
+(test-skip (if (zero? (getuid)) 1 0))
 (test-assert "set-network-interface-address"
   (let ((sock (socket AF_INET SOCK_STREAM 0)))
     (catch 'system-error
@@ -122,7 +430,163 @@
         ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
         (memv (system-error-errno args) (list EPERM EACCES))))))
 
+(test-equal "network-interface-netmask lo"
+  (make-socket-address AF_INET (inet-pton AF_INET "255.0.0.0") 0)
+  (let* ((sock (socket AF_INET SOCK_STREAM 0))
+         (addr (network-interface-netmask sock "lo")))
+    (close-port sock)
+    addr))
+
+(test-skip (if (zero? (getuid)) 1 0))
+(test-assert "set-network-interface-netmask"
+  (let ((sock (socket AF_INET SOCK_STREAM 0)))
+    (catch 'system-error
+      (lambda ()
+        (set-network-interface-netmask sock "nonexistent"
+                                       (make-socket-address
+                                        AF_INET
+                                        (inet-pton AF_INET "255.0.0.0")
+                                        0)))
+      (lambda args
+        (close-port sock)
+        (memv (system-error-errno args) (list EPERM EACCES))))))
+
+(test-equal "network-interfaces returns one or more interfaces"
+  '(#t #t #t)
+  (match (network-interfaces)
+    ((interfaces ..1)
+     (list (every interface? interfaces)
+           (every string? (map interface-name interfaces))
+           (every (lambda (sockaddr)
+                    ;; Sometimes interfaces have no associated address.
+                    (or (vector? sockaddr)
+                        (not sockaddr)))
+                  (map interface-address interfaces))))))
+
+(test-equal "network-interfaces returns \"lo\""
+  (list #t (make-socket-address AF_INET (inet-pton AF_INET "127.0.0.1") 0))
+  (match (filter (lambda (interface)
+                   (string=? "lo" (interface-name interface)))
+                 (network-interfaces))
+    ((loopbacks ..1)
+     (list (every (lambda (lo)
+                    (not (zero? (logand IFF_LOOPBACK (interface-flags lo)))))
+                  loopbacks)
+           (match (find (lambda (lo)
+                          (= AF_INET (sockaddr:fam (interface-address lo))))
+                        loopbacks)
+             (#f #f)
+             (lo (interface-address lo)))))))
+
+(test-skip (if (zero? (getuid)) 1 0))
+(test-assert "add-network-route/gateway"
+  (let ((sock    (socket AF_INET SOCK_STREAM 0))
+        (gateway (make-socket-address AF_INET
+                                      (inet-pton AF_INET "192.168.0.1")
+                                      0)))
+    (catch 'system-error
+      (lambda ()
+        (add-network-route/gateway sock gateway))
+      (lambda args
+        (close-port sock)
+        (memv (system-error-errno args) (list EPERM EACCES))))))
+
+(test-skip (if (zero? (getuid)) 1 0))
+(test-assert "delete-network-route"
+  (let ((sock        (socket AF_INET SOCK_STREAM 0))
+        (destination (make-socket-address AF_INET INADDR_ANY 0)))
+    (catch 'system-error
+      (lambda ()
+        (delete-network-route sock destination))
+      (lambda args
+        (close-port sock)
+        (memv (system-error-errno args) (list EPERM EACCES))))))
+
+(test-equal "tcgetattr ENOTTY"
+  ENOTTY
+  (catch 'system-error
+    (lambda ()
+      (call-with-input-file "/dev/null"
+        (lambda (port)
+          (tcgetattr (fileno port)))))
+    (compose system-error-errno list)))
+
+(test-skip (if (and (file-exists? "/proc/self/fd/0")
+                    (string-prefix? "/dev/pts/" (readlink "/proc/self/fd/0")))
+               0
+               2))
+
+(test-assert "tcgetattr"
+  (let ((termios (tcgetattr 0)))
+    (and (termios? termios)
+         (> (termios-input-speed termios) 0)
+         (> (termios-output-speed termios) 0))))
+
+(test-assert "tcsetattr"
+  (let ((first (tcgetattr 0)))
+    (tcsetattr 0 (tcsetattr-action TCSANOW) first)
+    (equal? first (tcgetattr 0))))
+
+(test-assert "terminal-window-size ENOTTY"
+  (call-with-input-file "/dev/null"
+    (lambda (port)
+      (catch 'system-error
+        (lambda ()
+          (terminal-window-size port))
+        (lambda args
+          ;; Accept EINVAL, which some old Linux versions might return.
+          (memv (system-error-errno args)
+                (list ENOTTY EINVAL)))))))
+
+(test-assert "terminal-columns"
+  (> (terminal-columns) 0))
+
+(test-assert "terminal-columns non-file port"
+  (> (terminal-columns (open-input-string "Join us now, share the software!"))
+     0))
+
+(test-assert "terminal-rows"
+  (> (terminal-rows) 0))
+
+(test-assert "utmpx-entries"
+  (match (utmpx-entries)
+    (((? utmpx? entries) ...)
+     (every (lambda (entry)
+              (match (utmpx-user entry)
+                ((? string?)
+                 ;; Ensure we have a valid PID for those entries where it
+                 ;; makes sense.
+                 (or (not (memv (utmpx-login-type entry)
+                                (list (login-type INIT_PROCESS)
+                                      (login-type LOGIN_PROCESS)
+                                      (login-type USER_PROCESS))))
+                     (> (utmpx-pid entry) 0)))
+                (#f                               ;might be DEAD_PROCESS
+                 #t)))
+            entries))))
+
+(test-assert "read-utmpx, EOF"
+  (eof-object? (read-utmpx (%make-void-port "r"))))
+
+(unless (access? "/var/run/utmpx" O_RDONLY)
+  (test-skip 1))
+(test-assert "read-utmpx"
+  (let ((result (call-with-input-file "/var/run/utmpx" read-utmpx)))
+    (or (utmpx? result) (eof-object? result))))
+
+(when (zero? (getuid))
+  (test-skip 1))
+(test-equal "add-to-entropy-count"
+  EPERM
+  (call-with-output-file "/dev/urandom"
+    (lambda (port)
+      (catch 'system-error
+        (lambda ()
+          (add-to-entropy-count port 77)
+          #f)
+        (lambda args
+          (system-error-errno args))))))
+
 (test-end)
 
-
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+(false-if-exception (delete-file temp-file))