tests/syscalls.scm

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