;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016-2017, 2019-2023 Ludovic Courtès ;;; Copyright © 2021 Marius Bakke ;;; ;;; 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-transformations) #:use-module (guix tests) #:use-module (guix store) #:use-module ((guix gexp) #:select (lower-object)) #:use-module ((guix profiles) #:select (package->manifest-entry manifest-entry-properties)) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix git-download) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix transformations) #:use-module ((guix gexp) #:select (local-file? local-file-file computed-file? computed-file-gexp gexp-input-thing gexp->approximate-sexp)) #:use-module (guix ui) #:use-module (guix utils) #:use-module (guix git) #:use-module (guix upstream) #:use-module (guix diagnostics) #:use-module (gnu packages) #:use-module (gnu packages base) #:use-module (gnu packages busybox) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64
# GNU Guix --- Functional package management for GNU
# Copyright © 2015 David Thompson <davet@gnu.org>
# Copyright © 2022, 2023 John Kehayias <john.kehayias@protonmail.com>
# Copyright © 2023 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 environment'.
#

set -e

guix environment --version

if ! guile -c '((@ (guix scripts environment) assert-container-features))'
then
    # User containers are not supported; skip this test.
    exit 77
fi

tmpdir="t-guix-environment-$$"
trap 'rm -r "$tmpdir"' EXIT

mkdir "$tmpdir"

# Make sure the exit value is preserved.
if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
        -- guile -c '(exit 42)'
then
    false
else
    test $? = 42
fi

# Try '--root' and '--profile'.
root="$tmpdir/root"
guix environment -C --ad-hoc --bootstrap guile-bootstrap -r "$root" -- guile --version
guix environment -C -p "$root" --bootstrap -- guile --version
path1=$(guix environment -C -p "$root" --bootstrap -- guile -c '(display (getenv "PATH"))')
path2=$(guix environment -C --ad-hoc --bootstrap guile-bootstrap  -- guile -c '(display (getenv "PATH"))')
test "$path1" = "$path2"

# Make sure "localhost" resolves.
guix environment --container --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c '(exit (pair? (getaddrinfo "localhost" "80")))'

# We should get ECONNREFUSED, not ENETUNREACH, which would indicate that "lo"
# is down.
guix environment --container --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c "(exit (= ECONNREFUSED
  (catch 'system-error
    (lambda ()
      (let ((sock (socket AF_INET SOCK_STREAM 0)))
        (connect sock AF_INET INADDR_LOOPBACK 12345)))
    (lambda args
      (pk 'errno (system-error-errno args))))))"

# Make sure '--preserve' is honored.
result="`FOOBAR=42; export FOOBAR; guix environment -C --ad-hoc --bootstrap \
   guile-bootstrap -E ^FOO -- guile -c '(display (getenv \"FOOBAR\"))'`"
test "$result" = "42"

# By default, the UID inside the container should be the same as outside.
uid="`id -u`"
inner_uid="`guix environment -C --ad-hoc --bootstrap guile-bootstrap \
  -- guile -c '(display (getuid))'`"
test $inner_uid = $uid

# When '--user' is passed, the UID should be 1000.  (Note: Use a separate HOME
# so that we don't run into problems when the test directory is under /home.)
export tmpdir
inner_uid="`HOME=$tmpdir guix environment -C --ad-hoc --bootstrap guile-bootstrap \
  --user=gnu-guix -- guile -c '(display (getuid))'`"
test $inner_uid = 1000

if test "x$USER" = "x"; then USER="`id -un`"; fi

# Check whether /etc/passwd and /etc/group are valid.
guix environment -C --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c "(exit (string=? \"$USER\" (passwd:name (getpwuid (getuid)))))"
guix environment -C --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c '(exit (string? (group:name (getgrgid (getgid)))))'
guix environment -C --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c '(use-modules (srfi srfi-1))
                  (exit (every group:name
                               (map getgrgid (vector->list (getgroups)))))'

# Make sure file-not-found errors in mounts are reported.
if guix environment --container --ad-hoc --bootstrap guile-bootstrap \
	--expose=/does-not-exist -- guile -c 1 2> "$tmpdir/error"
then
    false
else
    grep "/does-not-exist" "$tmpdir/error"
    grep "[Nn]o such file" "$tmpdir/error"
fi

# Make sure that the right directories are mapped.
mount_test_code="
(use-modules (ice-9 rdelim)
             (ice-9 match)
             (srfi srfi-1))

(define mappings
  (filter-map (lambda (line)
                (match (string-split line #\space)
                  ;; Empty line.
                  ((\"\") #f)
                  ;; Ignore the root file system.
                  ((_ \"/\" _ _ _ _)
                   #f)
                  ;; Ignore these types of file systems, except if they
                  ;; correspond to a parent file system.
                  ((_ mount (or \"tmpfs\" \"proc\" \"sysfs\" \"devtmpfs\"
                                \"devpts\" \"cgroup\" \"mqueue\") _ _ _)
                   (and (string-prefix? (getcwd) mount)
		        mount))
                  ((_ mount _ _ _ _)
                   mount)))
              (string-split (call-with-input-file \"/proc/mounts\" read-string)
                            #\newline)))

(for-each (lambda (mount)
            (display mount)
            (newline))
          mappings)"

guix environment --container --ad-hoc --bootstrap guile-bootstrap \
     -- guile -c "$mount_test_code" > $tmpdir/mounts

cat "$tmpdir/mounts"
test `wc -l < $tmpdir/mounts` -eq 4

current_dir="`cd $PWD; pwd -P`"
grep -e "$current_dir$" $tmpdir/mounts # current directory
grep $(guix build guile-bootstrap) $tmpdir/mounts
grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash

rm $tmpdir/mounts

# Make sure 'GUIX_ENVIRONMENT' is set to '~/.guix-profile' when requested
# within a container.
(
  linktest='
(exit (and (string=? (getenv "GUIX_ENVIRONMENT")
                     (string-append (getenv "HOME") "/.guix-profile"))
           (string-prefix? "'"$NIX_STORE_DIR"'"
                           (readlink (string-append (getenv "HOME")
                                                    "/.guix-profile")))))'

  cd "$tmpdir" \
     && guix environment --bootstrap --container --link-profile \
             --ad-hoc guile-bootstrap --pure \
             -- guile -c "$linktest"
)

# Test that user can be mocked.
usertest='(exit (and (string=? (getenv "HOME") "/home/foognu")
                     (string=? (passwd:name (getpwuid 1000)) "foognu")
                     (file-exists? "/home/foognu/umock")))'
touch "$tmpdir/umock"
HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \
     --ad-hoc guile-bootstrap --pure \
     --share="$tmpdir/umock" \
     -- guile -c "$usertest"

# if not sharing CWD, chdir home
(
  cd "$tmpdir" \
    && guix environment --bootstrap --container --no-cwd --user=foo  \
            --ad-hoc guile-bootstrap --pure \
            -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir"
)

# Check the exit code.

abnormal_exit_code="
(use-modules (system foreign))
;; Purposely make Guile crash with a segfault. :)
(pointer->string (make-pointer 123) 123)"

if guix environment --bootstrap --container \
	--ad-hoc guile-bootstrap -- guile -c "$abnormal_exit_code"
then false;
else
    test $? -gt 127
fi

# Test the Filesystem Hierarchy Standard (FHS) container option, --emulate-fhs (-F)

# As this option requires a glibc package (glibc-for-fhs), try to run these
# tests with the user's global store to make it easier to build or download a
# substitute.
storedir="`guile -c '(use-modules (guix config))(display %storedir)'`"
localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`"
NIX_STORE_DIR="$storedir"
GUIX_DAEMON_SOCKET="$localstatedir/guix/daemon-socket/socket"
export NIX_STORE_DIR GUIX_DAEMON_SOCKET

if ! guile -c '(use-modules (guix)) (exit (false-if-exception (open-connection)))'
then
    exit 77
fi

# Test that the container has FHS specific files/directories.  Note that /bin
# exists in a non-FHS container as it will contain sh, a symlink to the bash
# package, so we don't test for it.
guix shell -C --emulate-fhs --bootstrap guile-bootstrap \
     -- guile -c '(exit (and (file-exists? "/etc/ld.so.cache")
                             (file-exists? "/lib")
                             (file-exists? "/sbin")
                             (file-exists? "/usr/bin")
                             (file-exists? "/usr/include")
                             (file-exists? "/usr/lib")
                             (file-exists? "/usr/libexec")
                             (file-exists? "/usr/sbin")
                             (file-exists? "/usr/share")))'

# Test that the ld cache was generated and can be successfully read.
guix shell -CF --bootstrap guile-bootstrap \
     -- guile -c '(execlp "ldconfig" "ldconfig" "-p")'

# Test that the package glibc-for-fhs is in the container even if there is the
# regular glibc package from another source.  See
# <https://issues.guix.gnu.org/58861>.
guix shell -CF --bootstrap guile-bootstrap glibc \
     -- guile -c '(exit (if (string-contains (readlink "/lib/libc.so")
                            "glibc-for-fhs")
                           0
                           1))'

# Test that $PATH inside the container includes the FHS directories.
guix shell -CF coreutils -- env | grep ^PATH=/bin:/usr/bin:/sbin:/usr/sbin.*

# Make sure '--preserve' is honored for $PATH, which the '--emulate-fhs'
# option modifies.  We can't (easily) check the whole $PATH as it will differ
# inside and outside the container, so just check our test $PATH is still
# present.  See <https://issues.guix.gnu.org/60566>.
PATH=/foo $(type -P guix) shell -CF -E ^PATH$ coreutils \
     -- env | grep ^PATH=.*:/foo

# '--symlink' works.
echo "TESTING SYMLINK IN CONTAINER"
guix shell --bootstrap guile-bootstrap --container \
     --symlink=/usr/bin/guile=bin/guile -- \
     /usr/bin/guile --version

# A dangling symlink causes the command to fail.
guix shell --bootstrap -CS /usr/bin/python=bin/python guile-bootstrap -- exit && false

# An invalid symlink spec causes the command to fail.
guix shell --bootstrap -CS bin/guile=/usr/bin/guile guile-bootstrap -- exit && false

# Check whether '--nesting' works.
guix build hello -d
env="$(type -P pre-inst-env)"
guix shell -C -D guix -- "$env" guix build hello -d && false # cannot work
hello_drv="$(guix build hello -d)"
hello_drv_nested="$(cd "$(dirname env)" && guix shell --bootstrap -E GUIX_BUILD_OPTIONS -CW -D guix -- "$env" guix build hello -d)"
test "$hello_drv" = "$hello_drv_nested"
generated by cgit
(recursive? #t)))) (list source source)) (let* ((p (dummy-package "guix.scm" (inputs `(("foo" ,grep) ("bar" ,(dummy-package "chbouib" (native-inputs `(("x" ,grep))))))))) (t (options->transformation (reverse '((with-git-url . "grep=https://example.org") (with-branch . "grep=BRANCH")))))) (let ((new (t p))) (and (not (eq? new p)) (match (package-inputs new) ((("foo" dep1) ("bar" dep2)) (and (string=? (package-name dep1) "grep") (string=? (package-name dep2) "chbouib") (match (package-native-inputs dep2) ((("x" dep3)) (map package-source (list dep1 dep3))))))))))) (define* (depends-on-toolchain? p #:optional (toolchain "gcc-toolchain")) "Return true if P depends on TOOLCHAIN instead of the default tool chain." (define toolchain-packages '("gcc" "binutils" "glibc" "ld-wrapper")) (define (package-name* obj) (and (package? obj) (package-name obj))) (match (bag-build-inputs (package->bag p)) (((_ (= package-name* packages) . _) ...) (and (not (any (cut member <> packages) toolchain-packages)) (member toolchain packages))))) (test-assert "options->transformation, with-c-toolchain" (let* ((dep0 (dummy-package "chbouib" (build-system gnu-build-system) (native-inputs `(("y" ,grep))))) (dep1 (dummy-package "stuff" (native-inputs `(("x" ,dep0))))) (p (dummy-package "thingie" (build-system gnu-build-system) (inputs `(("foo" ,grep) ("bar" ,dep1))))) (t (options->transformation '((with-c-toolchain . "chbouib=gcc-toolchain"))))) ;; Here we check that the transformation applies to DEP0 and all its ;; dependents: DEP0 must use GCC-TOOLCHAIN, DEP1 must use GCC-TOOLCHAIN ;; and the DEP0 that uses GCC-TOOLCHAIN, and so on. (let ((new (t p))) (and (depends-on-toolchain? new "gcc-toolchain") (match (bag-build-inputs (package->bag new)) ((("foo" dep0) ("bar" dep1) _ ...) (and (depends-on-toolchain? dep1 "gcc-toolchain") (not (depends-on-toolchain? dep0 "gcc-toolchain")) (string=? (package-full-name dep0) (package-full-name grep)) (match (bag-build-inputs (package->bag dep1)) ((("x" dep) _ ...) (and (depends-on-toolchain? dep "gcc-toolchain") (match (bag-build-inputs (package->bag dep)) ((("y" dep) _ ...) ;this one is unchanged (eq? dep grep))))))))))))) (test-equal "options->transformation, with-c-toolchain twice" (package-full-name grep) (let* ((dep0 (dummy-package "chbouib")) (dep1 (dummy-package "stuff")) (p (dummy-package "thingie" (build-system gnu-build-system) (inputs `(("foo" ,dep0) ("bar" ,dep1) ("baz" ,grep))))) (t (options->transformation '((with-c-toolchain . "chbouib=clang-toolchain") (with-c-toolchain . "stuff=clang-toolchain"))))) (let ((new (t p))) (and (depends-on-toolchain? new "clang-toolchain") (match (bag-build-inputs (package->bag new)) ((("foo" dep0) ("bar" dep1) ("baz" dep2) _ ...) (and (depends-on-toolchain? dep0 "clang-toolchain") (depends-on-toolchain? dep1 "clang-toolchain") (not (depends-on-toolchain? dep2 "clang-toolchain")) (package-full-name dep2)))))))) (test-assert "options->transformation, with-c-toolchain, no effect" (let ((p (dummy-package "thingie")) (t (options->transformation '((with-c-toolchain . "does-not-exist=gcc-toolchain"))))) ;; When it has no effect, '--with-c-toolchain' returns P. (eq? (t p) p))) (test-equal "options->transformation, with-debug-info" '(#:strip-binaries? #f) (let* ((dep (dummy-package "chbouib")) (p (dummy-package "thingie" (build-system gnu-build-system) (inputs `(("foo" ,dep) ("bar" ,grep))))) (t (options->transformation '((with-debug-info . "chbouib"))))) (let ((new (t p))) (match (package-inputs new) ((("foo" dep0) ("bar" dep1)) (and (string=? (package-full-name dep1) (package-full-name grep)) (package-arguments (package-replacement dep0)))))))) (test-equal "options->transformation, with-configure-flag" '(append '() '("--flag=42")) (let* ((p (dummy-package "foo" (build-system gnu-build-system))) (t (options->transformation '((with-configure-flag . "foo=--flag=42"))))) (let ((new (t p))) (match (package-arguments new) ((#:configure-flags flags) (gexp->approximate-sexp flags)))))) (test-assert "options->transformation, without-tests" (let* ((dep (dummy-package "dep")) (p (dummy-package "foo" (inputs `(("dep" ,dep))))) (t (options->transformation '((without-tests . "dep") (without-tests . "tar"))))) (let ((new (t p))) (match (bag-direct-inputs (package->bag new)) ((("dep" dep) ("tar" tar) _ ...) (and (equal? (package-arguments dep) '(#:tests? #f)) (match (memq #:tests? (package-arguments tar)) ((#:tests? #f _ ...) #t)))))))) (test-equal "options->transformation, with-patch" (search-patches "glibc-locales.patch" "guile-relocatable.patch") (let* ((dep (dummy-package "dep" (source (dummy-origin)))) (p (dummy-package "foo" (inputs `(("dep" ,dep))))) (patch1 (search-patch "glibc-locales.patch")) (patch2 (search-patch "guile-relocatable.patch")) (t (options->transformation `((with-patch . ,(string-append "dep=" patch1)) (with-patch . ,(string-append "dep=" patch2)) (with-patch . ,(string-append "tar=" patch1)))))) (let ((new (t p))) (match (bag-direct-inputs (package->bag new)) ((("dep" dep) ("tar" tar) _ ...) (and (member patch1 (filter-map (lambda (patch) (and (local-file? patch) (local-file-file patch))) (origin-patches (package-source tar)))) (map local-file-file (origin-patches (package-source dep))))))))) (test-equal "options->transformation, with-commit + with-patch" '(#t #t) (let* ((patch (search-patch "glibc-locales.patch")) (commit "f8934ec94df5868ee8baf1fb0f8ed0f24e7e91eb") (t (options->transformation ;; Note: options are applied in reverse order, so ;; 'with-patch' comes on top. `((with-patch . ,(string-append "guile-gcrypt=" patch)) (with-commit . ,(string-append "guile-gcrypt=" commit)))))) (let ((new (t (@ (gnu packages gnupg) guile-gcrypt)))) (match (package-source new) ((? computed-file? source) (let* ((gexp (computed-file-gexp source)) (inputs (map gexp-input-thing ((@@ (guix gexp) gexp-inputs) gexp)))) (list (any (lambda (input) (and (git-checkout? input) (string=? commit (git-checkout-commit input)))) inputs) (any (lambda (input) (and (local-file? input) (string=? (local-file-file input) patch))) inputs)))))))) (test-equal "options->transformation, property order" ;; See . '((with-debug-info . "does-not-exist") (with-commit . "does-not-exist=aaaaaaa") (without-tests . "does-not-exist")) (let* ((t (options->transformation '((with-debug-info . "does-not-exist") (with-commit . "does-not-exist=aaaaaaa") (without-tests . "does-not-exist"))))) (let ((new (t coreutils))) (assq-ref (package-properties new) 'transformations)))) (test-equal "options->transformation, with-latest" "42.0" (mock ((guix upstream) %updaters (delay (list (upstream-updater (name 'dummy) (pred (const #t)) (description "") (import (const (upstream-source (package "foo") (version "42.0") (urls '("http://example.org"))))))))) (let* ((p (dummy-package "foo" (version "1.0"))) (t (options->transformation `((with-latest . "foo"))))) (package-version (t p))))) (test-equal "options->transformation, with-version" "1.0" (mock ((guix upstream) %updaters (delay (list (upstream-updater (name 'dummy) (pred (const #t)) (description "") (import (const (upstream-source (package "foo") (version "1.0") (urls '("http://example.org"))))))))) (let* ((p0 (dummy-package "foo" (version "7.7"))) (p1 (dummy-package "bar" (inputs (list p0)))) (t (options->transformation `((with-version . "foo=1.0"))))) (package-version (lookup-package-input (t p1) "foo"))))) (test-equal "options->transformation, tune" '(cpu-tuning . "superfast") (let* ((p0 (dummy-package "p0")) (p1 (dummy-package "p1" (inputs `(("p0" ,p0))) (properties '((tunable? . #t))))) (p2 (dummy-package "p2" (inputs `(("p1" ,p1))))) (t (options->transformation '((tune . "superfast")))) (p3 (t p2))) (and (not (package-replacement p3)) (match (package-inputs p3) ((("p1" tuned)) (match (package-inputs tuned) ((("p0" p0)) (and (not (package-replacement p0)) (assq 'cpu-tuning (package-properties (package-replacement tuned))))))))))) (test-assert "options->transformations, tune, wrong micro-architecture" (let ((p (dummy-package "tunable" (properties '((tunable? . #t))))) (t (options->transformation '((tune . "nonexistent-superfast"))))) ;; Because GCC used by P's build system does not support ;; '-march=nonexistent-superfast', we should see an error when lowering ;; the tuned package. (guard (c ((formatted-message? c) (member "nonexistent-superfast" (formatted-message-arguments c)))) (package->bag (t p)) #f))) (test-equal "options->transformation + package->manifest-entry" '((transformations . ((without-tests . "foo")))) (let* ((p (dummy-package "foo")) (t (options->transformation '((without-tests . "foo")))) (e (package->manifest-entry (t p)))) (manifest-entry-properties e))) (test-end) ;;; Local Variables: ;;; eval: (put 'dummy-package 'scheme-indent-function 1) ;;; End: