;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès ;;; Copyright © 2015 David Thompson ;;; ;;; This file is part of GNU Guix. ;;; ;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; ;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . (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" ENOENT (catch 'system-error (lambda () (mount "/dev/null" "/does-not-exist" "ext2") #f) (compose system-error-errno list))) (test-assert "umount, ENOENT/EPERM" (catch 'system-error (lambda () (umount "/does-not-exist") #f) (lambda args ;; Both return values have been encountered in the wild. (memv (system-error-errno args) (list EPERM ENOENT))))) (test-assert "mount-points" ;; Reportedly "/" is not always listed as a mou
# GNU Guix --- Functional package management for GNU
# Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
# GNU Guix is free software; you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or (at
# your option) any later version.
#
# GNU Guix is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

#
# Test 'guix style'.
#

set -e

guix style --version

tmpdir="guix-style-$$"
trap 'rm -r "$tmpdir"' EXIT

tmpfile="$tmpdir/os.scm"
mkdir "$tmpdir"
cat > "$tmpfile" <<EOF
;;; This is a header with three semicolons.
;;;

(define-module (foo bar)
  #:use-module (guix)
  #:use-module (gnu))

;; One blank line and a page break.


;; And now, the OS.
(operating-system
  (host-name "komputilo")
  (locale "eo_EO.UTF-8")

  ;; User accounts.
  (users (cons (user-account
                 (name "alice")
                 (comment "Bob's sister")
                 (group "users")

                 ;; Groups fit on one line.
                 (supplementary-groups '("wheel" "audio" "video")))
               %base-user-accounts))

  ;; The services.
  (services
   (cons (service mcron-service-type) %base-services)))
;; Incomplete package definitions in alphabetical order.

(define-public pkg
  (package
    (name "bar")
    (version "2")))

;; The comment below belongs to the foo package.
(define-public pkg
  (package
    (name "bar")
    (version "1")))
;; Incomplete package definitions in alphabetical order.

(define-public pkg
  (package
    (name "foo")
    (version "2")))
EOF

cp "$tmpfile" "$tmpfile.bak"

initial_hash="$(guix hash "$tmpfile")"

guix style -f "$tmpfile"
if test "$initial_hash" != "$(guix hash "$tmpfile")"
then
    cat "$tmpfile"
    diff -u "$tmpfile.bak" "$tmpfile"
    false
fi

# Introduce random changes and try again.
sed -i "$tmpfile" -e's/ \+/ /g'
test "$initial_hash" != "$(guix hash "$tmpfile")"

guix style -f "$tmpfile"
test "$initial_hash" = "$(guix hash "$tmpfile")"

# Swap foo and bar packages.
sed -i "$tmpfile" -e 's/"foo"/"bar"/g'
sed -i "$tmpfile" -e '0,/"bar"/{s//"foo"/}'
test "$initial_hash" != "$(guix hash "$tmpfile")"

guix style -fA "$tmpfile"
test "$initial_hash" = "$(guix hash "$tmpfile")"
(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: ;; . (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) stringprocedure 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 (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) (false-if-exception (delete-file temp-file))