tests/syscalls.scm

   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>
   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)
  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))
  27
  28 ;; Test the (guix build syscalls) module, although there's not much that can
  29 ;; actually be tested without being root.
  30
  31 (test-begin "syscalls")
  32
  33 (test-equal "mount, ENOENT"
  34   ENOENT
  35   (catch 'system-error
  36     (lambda ()
  37       (mount "/dev/null" "/does-not-exist" "ext2")
  38       #f)
  39     (compose system-error-errno list)))
  40
  41 (test-assert "umount, ENOENT/EPERM"
  42   (catch 'system-error
  43     (lambda ()
  44       (umount "/does-not-exist")
  45       #f)
  46     (lambda args
  47       ;; Both return values have been encountered in the wild.
  48       (memv (system-error-errno args) (list EPERM ENOENT)))))
  49
  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")))
  55
  56 (test-assert "swapon, ENOENT/EPERM"
  57   (catch 'system-error
  58     (lambda ()
  59       (swapon "/does-not-exist")
  60       #f)
  61     (lambda args
  62       (memv (system-error-errno args) (list EPERM ENOENT)))))
  63
  64 (test-assert "swapoff, ENOENT/EINVAL/EPERM"
  65   (catch 'system-error
  66     (lambda ()
  67       (swapoff "/does-not-exist")
  68       #f)
  69     (lambda args
  70       (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))
  71
  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)
  76          (begin
  77            (rmdir dir)
  78            #t))))
  79
  80 (define (user-namespace pid)
  81   (string-append "/proc/" (number->string pid) "/ns/user"))
  82
  83 (unless (file-exists? (user-namespace (getpid)))
  84   (test-skip 1))
  85 (test-assert "clone"
  86   (match (clone (logior CLONE_NEWUSER SIGCHLD))
  87     (0 (primitive-exit 42))
  88     (pid
  89      ;; Check if user namespaces are different.
  90      (and (not (equal? (readlink (user-namespace pid))
  91                        (readlink (user-namespace (getpid)))))
  92           (match (waitpid pid)
  93             ((_ . status)
  94              (= 42 (status:exit-val status))))))))
  95
  96 (unless (file-exists? (user-namespace (getpid)))
  97   (test-skip 1))
  98 (test-assert "setns"
  99   (match (clone (logior CLONE_NEWUSER SIGCHLD))
 100     (0 (primitive-exit 0))
 101     (clone-pid
 102      (match (pipe)
 103        ((in . out)
 104         (match (primitive-fork)
 105           (0
 106            (close in)
 107            ;; Join the user namespace.
 108            (call-with-input-file (user-namespace clone-pid)
 109              (lambda (port)
 110                (setns (port->fdes port) 0)))
 111            (write 'done out)
 112            (close out)
 113            (primitive-exit 0))
 114           (fork-pid
 115            (close out)
 116            ;; Wait for the child process to join the namespace.
 117            (read in)
 118            (let ((result (and (equal? (readlink (user-namespace clone-pid))
 119                                       (readlink (user-namespace fork-pid))))))
 120              ;; Clean up.
 121              (waitpid clone-pid)
 122              (waitpid fork-pid)
 123              result))))))))
 124
 125 (unless (file-exists? (user-namespace (getpid)))
 126   (test-skip 1))
 127 (test-assert "pivot-root"
 128   (match (pipe)
 129     ((in . out)
 130      (match (clone (logior CLONE_NEWUSER CLONE_NEWNS SIGCHLD))
 131        (0
 132         (close in)
 133         (call-with-temporary-directory
 134          (lambda (root)
 135            (let ((put-old (string-append root "/real-root")))
 136              (mount "none" root "tmpfs")
 137              (mkdir put-old)
 138              (call-with-output-file (string-append root "/test")
 139                (lambda (port)
 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)
 144              (close out))))
 145         (primitive-exit 0))
 146        (pid
 147         (close out)
 148         (let ((result (read in)))
 149           (close in)
 150           (and (zero? (match (waitpid pid)
 151                         ((_ . status)
 152                          (status:exit-val status))))
 153                (eq? #t result))))))))
 154
 155 (test-assert "all-network-interface-names"
 156   (match (all-network-interface-names)
 157     (((? string? names) ..1)
 158      (member "lo" names))))
 159
 160 (test-assert "network-interface-names"
 161   (match (network-interface-names)
 162     (((? string? names) ..1)
 163      (lset<= string=? names (all-network-interface-names)))))
 164
 165 (test-assert "network-interface-flags"
 166   (let* ((sock  (socket AF_INET SOCK_STREAM 0))
 167          (flags (network-interface-flags sock "lo")))
 168     (close-port sock)
 169     (and (not (zero? (logand flags IFF_LOOPBACK)))
 170          (not (zero? (logand flags IFF_UP))))))
 171
 172 (test-equal "loopback-network-interface?"
 173   ENODEV
 174   (and (loopback-network-interface? "lo")
 175        (catch 'system-error
 176          (lambda ()
 177            (loopback-network-interface? "nonexistent")
 178            #f)
 179          (lambda args
 180            (system-error-errno args)))))
 181
 182 (test-skip (if (zero? (getuid)) 1 0))
 183 (test-assert "set-network-interface-flags"
 184   (let ((sock (socket AF_INET SOCK_STREAM 0)))
 185     (catch 'system-error
 186       (lambda ()
 187         (set-network-interface-flags sock "lo" IFF_UP))
 188       (lambda args
 189         (close-port sock)
 190         ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
 191         (memv (system-error-errno args) (list EPERM EACCES))))))
 192
 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")))
 197     (close-port sock)
 198     addr))
 199
 200 (test-skip (if (zero? (getuid)) 1 0))
 201 (test-assert "set-network-interface-address"
 202   (let ((sock (socket AF_INET SOCK_STREAM 0)))
 203     (catch 'system-error
 204       (lambda ()
 205         (set-network-interface-address sock "nonexistent"
 206                                        (make-socket-address
 207                                         AF_INET
 208                                         (inet-pton AF_INET "127.12.14.15")
 209                                         0)))
 210       (lambda args
 211         (close-port sock)
 212         ;; We get EPERM with Linux 3.18ish and EACCES with 2.6.32.
 213         (memv (system-error-errno args) (list EPERM EACCES))))))
 214
 215 (test-equal "network-interfaces returns one or more interfaces"
 216   '(#t #t #t)
 217   (match (network-interfaces)
 218     ((interfaces ..1)
 219      (list (every interface? interfaces)
 220            (every string? (map interface-name interfaces))
 221            (every vector? (map interface-address interfaces))))))
 222
 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))
 228     ((loopbacks ..1)
 229      (list (every (lambda (lo)
 230                     (not (zero? (logand IFF_LOOPBACK (interface-flags lo)))))
 231                   loopbacks)
 232            (match (find (lambda (lo)
 233                           (= AF_INET (sockaddr:fam (interface-address lo))))
 234                         loopbacks)
 235              (#f #f)
 236              (lo (interface-address lo)))))))
 237
 238 (test-end)
 239
 240 \f
 241 (exit (= (test-runner-fail-count (test-runner-current)) 0))