;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;; Copyright © 2020 Simon South <simon@simonsouth.net>
+;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
#: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
;; Both return values have been encountered in the wild.
(memv (system-error-errno args) (list EPERM ENOENT)))))
+(test-assert "mounts"
+ ;; Check for one of the common mount points.
+ (let ((mounts (mounts)))
+ (any (match-lambda
+ ((point . type)
+ (let ((mount (find (lambda (mount)
+ (string=? (mount-point mount) point))
+ mounts)))
+ (and mount
+ (string=? (mount-type mount) type)))))
+ '(("/proc" . "proc")
+ ("/sys" . "sysfs")
+ ("/dev/shm" . "tmpfs")))))
+
(test-assert "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")))
-(test-assert "swapon, ENOENT/EPERM"
+(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, ENOSYS/ENOENT/EPERM"
(catch 'system-error
(lambda ()
(swapon "/does-not-exist")
#f)
(lambda args
- (memv (system-error-errno args) (list EPERM ENOENT)))))
+ (memv (system-error-errno args) (list EPERM ENOENT ENOSYS)))))
-(test-assert "swapoff, ENOENT/EINVAL/EPERM"
+(test-assert "swapoff, ENOSYS/ENOENT/EINVAL/EPERM"
(catch 'system-error
(lambda ()
(swapoff "/does-not-exist")
#f)
(lambda args
- (memv (system-error-errno args) (list EPERM EINVAL ENOENT)))))
+ (memv (system-error-errno args) (list EPERM EINVAL ENOENT ENOSYS)))))
(test-assert "mkdtemp!"
(let* ((tmp (or (getenv "TMPDIR") "/tmp"))
(waitpid fork-pid)
result))))))))
-;; XXX: Skip this test when running Linux > 4.7.5 to work around
-;; <https://bugzilla.kernel.org/show_bug.cgi?id=183461>.
-(when (or (not perform-container-tests?)
- (version>? (utsname:release (uname)) "4.7.5"))
+(when (not perform-container-tests?)
(test-skip 1))
(test-equal "pivot-root"
- #t
- (match (pipe)
- ((in . out)
+ '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 in)
+ (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)
(display "testing\n" port)))
(pivot-root root put-old)
;; The test file should now be located inside the root directory.
- (write (file-exists? "/test") out)
- (close out)))))
+ (write (and (file-exists? "/test") 'success!) child)
+ (close child)))))
(lambda ()
(primitive-exit 0))))
(pid
- (close out)
- (let ((result (read in)))
- (close in)
- (and (zero? (match (waitpid pid)
- ((_ . status)
- (status:exit-val status))))
- (eq? #t result))))))))
+ (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-assert "getxattr, setxattr"
+ (let ((key "user.translator")
+ (value "/hurd/pfinet\0")
+ (file (open-file temp-file "w0")))
+ (catch 'system-error
+ (lambda ()
+ (setxattr temp-file key value)
+ (string=? (getxattr temp-file key) value))
+ (lambda args
+ ;; Accept ENOTSUP, if the file-system does not support extended user
+ ;; attributes.
+ (memv (system-error-errno args) (list ENOTSUP))))))
(false-if-exception (delete-file temp-file))
(test-equal "fcntl-flock wait"
(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-interface-names"
- (match (network-interface-names)
+ (match (remove (lambda (interface)
+ ;; Ignore interface aliases since they don't show up in
+ ;; (all-network-interface-names).
+ (string-contains interface ":"))
+ (network-interface-names))
(((? string? names) ..1)
(lset<= string=? names (all-network-interface-names)))))
(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)))
(> (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?)
- (or (eqv? (login-type BOOT_TIME) (utmpx-login-type entry))
+ ;; 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)))
(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)
(false-if-exception (delete-file temp-file))
HCoop / jackhill / guix / guix.git / blobdiff