diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/boot-parameters.scm | 256 | ||||
| -rw-r--r-- | tests/channels.scm | 1 | ||||
| -rw-r--r-- | tests/containers.scm | 8 | ||||
| -rw-r--r-- | tests/guix-archive.sh | 9 | ||||
| -rw-r--r-- | tests/guix-authenticate.sh | 9 | ||||
| -rw-r--r-- | tests/guix-build-branch.sh | 3 | ||||
| -rw-r--r-- | tests/guix-build.sh | 60 | ||||
| -rw-r--r-- | tests/guix-daemon.sh | 2 | ||||
| -rw-r--r-- | tests/guix-download.sh | 12 | ||||
| -rw-r--r-- | tests/guix-environment-container.sh | 25 | ||||
| -rw-r--r-- | tests/guix-environment.sh | 8 | ||||
| -rw-r--r-- | tests/guix-gc.sh | 13 | ||||
| -rw-r--r-- | tests/guix-git-authenticate.sh | 5 | ||||
| -rw-r--r-- | tests/guix-graph.sh | 7 | ||||
| -rw-r--r-- | tests/guix-hash.sh | 12 | ||||
| -rw-r--r-- | tests/guix-lint.sh | 18 | ||||
| -rw-r--r-- | tests/guix-pack-relocatable.sh | 3 | ||||
| -rw-r--r-- | tests/guix-pack.sh | 3 | ||||
| -rw-r--r-- | tests/guix-package-aliases.sh | 20 | ||||
| -rw-r--r-- | tests/guix-package-net.sh | 9 | ||||
| -rw-r--r-- | tests/guix-package.sh | 66 | ||||
| -rw-r--r-- | tests/guix-repl.sh | 4 | ||||
| -rw-r--r-- | tests/guix-system.sh | 23 | ||||
| -rw-r--r-- | tests/opam.scm | 139 | ||||
| -rw-r--r-- | tests/openpgp.scm | 12 | ||||
| -rw-r--r-- | tests/packages.scm | 192 | ||||
| -rw-r--r-- | tests/scripts-build.scm | 108 |
27 files changed, 819 insertions, 208 deletions
diff --git a/tests/boot-parameters.scm b/tests/boot-parameters.scm new file mode 100644 index 0000000000..d7e579bc89 --- /dev/null +++ b/tests/boot-parameters.scm @@ -0,0 +1,256 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019, 2020 Miguel Ángel Arruga Vivas <rosen644835@gmail.com> +;;; +;;; 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/>. + +;;; Commentary: +;;; +;;; Test boot parameters value storage and compatibility. +;;; +;;; Code: + +(define-module (test-boot-parameters) + #:use-module (gnu bootloader) + #:use-module (gnu bootloader grub) + #:use-module (gnu system) + #:use-module (gnu system file-systems) + #:use-module (gnu system uuid) + #:use-module (guix gexp) + #:use-module (guix store) + #:use-module (guix tests) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors)) + +(define %default-label "GNU with Linux-libre 99.1.2") +(define %default-kernel-path + (string-append (%store-prefix) + "/zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz-linux-libre-99.1.2")) +(define %default-kernel + (string-append %default-kernel-path "/" (system-linux-image-file-name))) +(define %default-kernel-arguments '()) +(define %default-initrd-path + (string-append (%store-prefix) "/wwwwwwwwwwwwwwwwwwwwwwwwwwwwwwww-initrd")) +(define %default-initrd (string-append %default-initrd-path "/initrd.cpio.gz")) +(define %default-root-device (uuid "abcdef12-3456-7890-abcd-ef1234567890")) +(define %default-store-device (uuid "01234567-89ab-cdef-0123-456789abcdef")) +(define %default-store-mount-point (%store-prefix)) +(define %default-multiboot-modules '()) +(define %default-locale "es_ES.utf8") +(define %root-path "/") + +(define %grub-boot-parameters + (boot-parameters + (bootloader-name 'grub) + (bootloader-menu-entries '()) + (root-device %default-root-device) + (label %default-label) + (kernel %default-kernel) + (kernel-arguments %default-kernel-arguments) + (initrd %default-initrd) + (multiboot-modules %default-multiboot-modules) + (locale %default-locale) + (store-device %default-store-device) + (store-mount-point %default-store-mount-point))) + +(define %default-operating-system + (operating-system + (host-name "host") + (timezone "Europe/Berlin") + (locale %default-locale) + + (bootloader (bootloader-configuration + (bootloader grub-bootloader) + (target "/dev/sda"))) + (file-systems (cons* (file-system + (device %default-root-device) + (mount-point %root-path) + (type "ext4")) + (file-system + (device %default-store-device) + (mount-point %default-store-mount-point) + (type "btrfs")) + %base-file-systems)))) + +(define (quote-uuid uuid) + (list 'uuid (uuid-type uuid) (uuid-bytevector uuid))) + +;; Call read-boot-parameters with the desired string as input. +(define* (test-read-boot-parameters + #:key + (version 0) + (bootloader-name 'grub) + (bootloader-menu-entries '()) + (label %default-label) + (root-device (quote-uuid %default-root-device)) + (kernel %default-kernel) + (kernel-arguments %default-kernel-arguments) + (initrd %default-initrd) + (multiboot-modules %default-multiboot-modules) + (locale %default-locale) + (with-store #t) + (store-device + (quote-uuid %default-store-device)) + (store-mount-point %default-store-mount-point)) + (define (generate-boot-parameters) + (define (sexp-or-nothing fmt val) + (cond ((eq? 'false val) (format #false fmt #false)) + (val (format #false fmt val)) + (else ""))) + (format #false "(boot-parameters~a~a~a~a~a~a~a~a~a~a)" + (sexp-or-nothing " (version ~S)" version) + (sexp-or-nothing " (label ~S)" label) + (sexp-or-nothing " (root-device ~S)" root-device) + (sexp-or-nothing " (kernel ~S)" kernel) + (sexp-or-nothing " (kernel-arguments ~S)" kernel-arguments) + (sexp-or-nothing " (initrd ~S)" initrd) + (if with-store + (format #false " (store~a~a)" + (sexp-or-nothing " (device ~S)" store-device) + (sexp-or-nothing " (mount-point ~S)" + store-mount-point)) + "") + (sexp-or-nothing " (locale ~S)" locale) + (sexp-or-nothing " (bootloader-name ~a)" bootloader-name) + (sexp-or-nothing " (bootloader-menu-entries ~S)" + bootloader-menu-entries))) + (let ((str (generate-boot-parameters))) + (call-with-input-string str read-boot-parameters))) + +(test-begin "boot-parameters") + +;; XXX: <warning: unrecognized boot parameters at '#f'> +(test-assert "read, construction, mandatory fields" + (not (or (test-read-boot-parameters #:version #false) + (test-read-boot-parameters #:version 'false) + (test-read-boot-parameters #:version -1) + (test-read-boot-parameters #:version "0") + (test-read-boot-parameters #:root-device #false) + (test-read-boot-parameters #:kernel #false) + (test-read-boot-parameters #:label #false)))) + +(test-assert "read, construction, optional fields" + (and (test-read-boot-parameters #:bootloader-name #false) + (test-read-boot-parameters #:bootloader-menu-entries #false) + (test-read-boot-parameters #:kernel-arguments #false) + (test-read-boot-parameters #:with-store #false) + (test-read-boot-parameters #:store-device #false) + (test-read-boot-parameters #:store-device 'false) + (test-read-boot-parameters #:store-mount-point #false) + (test-read-boot-parameters #:multiboot-modules #false) + (test-read-boot-parameters #:locale #false) + (test-read-boot-parameters #:bootloader-name #false + #:kernel-arguments #false + #:with-store #false + #:locale #false))) + +(test-equal "read, default equality" + %grub-boot-parameters + (test-read-boot-parameters)) + +(test-equal "read, root-device, label" + (file-system-label "my-root") + (boot-parameters-root-device + (test-read-boot-parameters #:root-device '(file-system-label "my-root")))) + +(test-equal "read, root-device, /dev node" + "/dev/sda2" + (boot-parameters-root-device + (test-read-boot-parameters #:root-device "/dev/sda2"))) + +(test-equal "read, kernel, only store path" + %default-kernel + (boot-parameters-kernel + (test-read-boot-parameters #:kernel %default-kernel-path))) + +(test-equal "read, kernel, full-path" + %default-kernel + (boot-parameters-kernel + (test-read-boot-parameters #:kernel %default-kernel))) + +(test-assert "read, construction, missing initrd" + (not (boot-parameters-initrd (test-read-boot-parameters #:initrd #false)))) + +(test-equal "read, initrd, old format" + "/a/b" + (boot-parameters-initrd + (test-read-boot-parameters #:initrd (list 'string-append "/a" "/b")))) + + ;; Compatibility reasons specified in gnu/system.scm. +(test-eq "read, bootloader-name, default value" + 'grub + (boot-parameters-bootloader-name + (test-read-boot-parameters #:bootloader-name #false))) + +(test-eq "read, bootloader-menu-entries, default value" + '() + (boot-parameters-bootloader-menu-entries + (test-read-boot-parameters #:bootloader-menu-entries #false))) + +(test-eq "read, kernel-arguments, default value" + '() + (boot-parameters-kernel-arguments + (test-read-boot-parameters #:kernel-arguments #false))) + +(test-assert "read, store-device, filter /dev" + (not (boot-parameters-store-device + (test-read-boot-parameters #:store-device "/dev/sda3")))) + +(test-assert "read, no-store, filter /dev from root" + (not (boot-parameters-store-device + (test-read-boot-parameters #:root-device "/dev/sda3" + #:with-store #false)))) + +(test-assert "read, no store-device, filter /dev from root" + (not (boot-parameters-store-device + (test-read-boot-parameters #:root-device "/dev/sda3" + #:store-device #false)))) + +(test-assert "read, store-device #false, filter /dev from root" + (not (boot-parameters-store-device + (test-read-boot-parameters #:root-device "/dev/sda3" + #:store-device 'false)))) + +(test-equal "read, store-device, label (legacy)" + (file-system-label "my-store") + (boot-parameters-store-device + (test-read-boot-parameters #:store-device "my-store"))) + +(test-equal "read, store-device, from root" + %default-root-device + (boot-parameters-store-device + (test-read-boot-parameters #:with-store #false))) + +(test-equal "read, no store-mount-point, default" + %root-path + (boot-parameters-store-mount-point + (test-read-boot-parameters #:store-mount-point #false))) + +(test-equal "read, no store, default store-mount-point" + %root-path + (boot-parameters-store-mount-point + (test-read-boot-parameters #:with-store #false))) + +;; For whitebox testing +(define operating-system-boot-parameters + (@@ (gnu system) operating-system-boot-parameters)) + +(test-equal "from os, locale" + %default-locale + (boot-parameters-locale + (operating-system-boot-parameters %default-operating-system + %default-root-device))) + +(test-end "boot-parameters") diff --git a/tests/channels.scm b/tests/channels.scm index 1b6f640c4a..0264369d9e 100644 --- a/tests/channels.scm +++ b/tests/channels.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; diff --git a/tests/containers.scm b/tests/containers.scm index 7b63e5c108..608902c41a 100644 --- a/tests/containers.scm +++ b/tests/containers.scm @@ -134,6 +134,14 @@ (primitive-exit 0))))) (skip-if-unsupported) +(test-assert "call-with-container, mnt namespace, root permissions" + (zero? + (call-with-container '() + (lambda () + (assert-exit (= #o755 (stat:perms (lstat "/"))))) + #:namespaces '(user mnt)))) + +(skip-if-unsupported) (test-assert "container-excursion" (call-with-temporary-directory (lambda (root) diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh index 4c5eea05cf..e796c62f9a 100644 --- a/tests/guix-archive.sh +++ b/tests/guix-archive.sh @@ -44,8 +44,7 @@ cmp "$archive" "$archive_alt" # Check the exit value upon import. guix archive --import < "$archive" -if guix archive something-that-does-not-exist -then false; else true; fi +! guix archive something-that-does-not-exist # This one must not be listed as missing. guix build guile-bootstrap > "$archive" @@ -62,8 +61,7 @@ cmp "$archive" "$archive_alt" # This is not a valid store file name, so an error. echo something invalid > "$archive" -if guix archive --missing < "$archive" -then false; else true; fi +! guix archive --missing < "$archive" # Check '--extract'. guile -c "(use-modules (guix serialization)) @@ -79,5 +77,4 @@ guix archive -t < "$archive" | grep "^D /share/guile" guix archive -t < "$archive" | grep "^x /bin/guile" guix archive -t < "$archive" | grep "^r /share/guile.*/boot-9\.scm" -if echo foo | guix archive --authorize -then false; else true; fi +! echo foo | guix archive --authorize diff --git a/tests/guix-authenticate.sh b/tests/guix-authenticate.sh index f3b36ee41d..3a05b232c1 100644 --- a/tests/guix-authenticate.sh +++ b/tests/guix-authenticate.sh @@ -61,6 +61,15 @@ sed -i "$sig" \ code="$(echo "verify $(cat $sig)" | guix authenticate | cut -f1 -d ' ')" test "$code" -ne 0 +# Make sure byte strings are correctly encoded. The hash string below is +# "café" repeated 8 times. Libgcrypt would normally choose to write it as a +# string rather than a hex sequence. We want that string to be Latin-1 +# encoded independently of the current locale: <https://bugs.gnu.org/43421>. +hash="636166e9636166e9636166e9636166e9636166e9636166e9636166e9636166e9" +latin1_cafe="caf$(printf '\351')" +echo "sign 21:tests/signing-key.sec 64:$hash" | guix authenticate \ + | LC_ALL=C grep "hash sha256 \"$latin1_cafe" + # Test for <http://bugs.gnu.org/17312>: make sure 'guix authenticate' produces # valid signatures when run in the C locale. hash="5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c" diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh index c5b07e07c6..79aa06a58f 100644 --- a/tests/guix-build-branch.sh +++ b/tests/guix-build-branch.sh @@ -58,5 +58,4 @@ guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-8fe64e8 # this is the tag ID test "$v0_1_0_drv" != "$latest_drv" test "$v0_1_0_drv" != "$orig_drv" -if guix build guix --with-commit=guile-gcrypt=000 -d -then false; else true; fi +! guix build guix --with-commit=guile-gcrypt=000 -d diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 6c08857358..4a58ea1476 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -24,8 +24,7 @@ guix build --version # Should fail. -if guix build -e +; -then false; else true; fi +! guix build -e + # Source-less packages are accepted; they just return nothing. guix build -e '(@ (gnu packages bootstrap) %bootstrap-glibc)' -S @@ -178,7 +177,7 @@ cat > "$module_dir/foo.scm" <<EOF (inputs (quasiquote (("sed" ,sed)))))) ;unbound variable EOF -if guix build package-with-something-wrong -n; then false; else true; fi +! guix build package-with-something-wrong -n guix build package-with-something-wrong -n 2> "$module_dir/err" || true grep "unbound" "$module_dir/err" # actual error grep "forget.*(gnu packages base)" "$module_dir/err" # hint @@ -199,6 +198,33 @@ grep "forget.*(guix build-system gnu)" "$module_dir/err" # hint rm -f "$module_dir"/* +# Unbound variable: don't suggest modules that do not export the variable. +cat > "$module_dir/aa-private.scm" <<EOF +(define-module (aa-private)) +(define make-thing #f) +(set! make-thing make-thing) ;don't inline +EOF + +cat > "$module_dir/bb-public.scm" <<EOF +(define-module (bb-public) #:export (make-thing)) +(define make-thing identity) +EOF + +cat > "$module_dir/cc-user.scm" <<EOF +;; Make those module available in the global name space. +(load-from-path "aa-private.scm") +(load-from-path "bb-public.scm") + +(define-module (cc-user)) +(make-thing 42) +EOF +! guix build -f "$module_dir/cc-user.scm" -n 2> "$module_dir/err" +cat "$module_dir/err" +grep "make-thing.*unbound" "$module_dir/err" # actual error +grep "forget.*(bb-public)" "$module_dir/err" # hint + +rm -f "$module_dir"/* + # Wrong 'define-module' clause reported by 'warn-about-load-error'. cat > "$module_dir/foo.scm" <<EOF (define-module (something foo) @@ -222,7 +248,7 @@ test "`guix build --log-file guile-bootstrap`" = "$log" test "`guix build --log-file $out`" = "$log" # Should fail because the name/version combination could not be found. -if guix build hello-0.0.1 -n; then false; else true; fi +! guix build hello-0.0.1 -n # Keep a symlink to the result, registered as a root. result="t-result-$$" @@ -231,8 +257,7 @@ guix build -r "$result" \ test -x "$result/bin/guile" # Should fail, because $result already exists. -if guix build -r "$result" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' -then false; else true; fi +! guix build -r "$result" -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' rm -f "$result" @@ -259,8 +284,18 @@ drv1=`guix build guile -d` drv2=`guix build guile --with-input=gimp=ruby -d` test "$drv1" = "$drv2" -if guix build guile --with-input=libunistring=something-really-silly -then false; else true; fi +# See <https://bugs.gnu.org/42156>. +drv1=`guix build glib -d` +drv2=`guix build glib -d --with-input=libreoffice=inkscape` +test "$drv1" = "$drv2" + +# Rewriting implicit inputs. +drv1=`guix build hello -d` +drv2=`guix build hello -d --with-input=gcc=gcc-toolchain` +test "$drv1" != "$drv2" +guix gc -R "$drv2" | grep `guix build -d gcc-toolchain` + +! guix build guile --with-input=libunistring=something-really-silly # Deprecated/superseded packages. test "`guix build superseded -d`" = "`guix build bar -d`" @@ -268,10 +303,8 @@ test "`guix build superseded -d`" = "`guix build bar -d`" # Parsing package names and versions. guix build -n time # PASS guix build -n time@1.9 # PASS, version found -if guix build -n time@3.2; # FAIL, version not found -then false; else true; fi -if guix build -n something-that-will-never-exist; # FAIL -then false; else true; fi +! guix build -n time@3.2 # FAIL, version not found +! guix build -n something-that-will-never-exist # FAIL # Invoking a monadic procedure. guix build -e "(begin @@ -343,5 +376,4 @@ export GUIX_BUILD_OPTIONS guix build emacs GUIX_BUILD_OPTIONS="--something-completely-crazy" -if guix build emacs; -then false; else true; fi +! guix build emacs diff --git a/tests/guix-daemon.sh b/tests/guix-daemon.sh index b58500966b..330ad68835 100644 --- a/tests/guix-daemon.sh +++ b/tests/guix-daemon.sh @@ -224,7 +224,7 @@ daemon_pid=$! GUIX_DAEMON_SOCKET="guix://$tcp_socket" export GUIX_DAEMON_SOCKET -if guix gc; then false; else true; fi +! guix gc unset GUIX_DAEMON_SOCKET kill "$daemon_pid" diff --git a/tests/guix-download.sh b/tests/guix-download.sh index 30f55fbe2b..5475d43e60 100644 --- a/tests/guix-download.sh +++ b/tests/guix-download.sh @@ -23,14 +23,11 @@ guix download --version # Make sure it fails here. -if guix download http://does.not/exist -then false; else true; fi +! guix download http://does.not/exist -if guix download unknown://some/where; -then false; else true; fi +! guix download unknown://some/where; -if guix download /does-not-exist -then false; else true; fi +! guix download /does-not-exist # This one should succeed. guix download "file://$abs_top_srcdir/README" @@ -46,5 +43,4 @@ GUIX_DAEMON_SOCKET="/nowhere" guix download -o "$output" \ cmp "$output" "$abs_top_srcdir/README" # This one should fail. -if guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" -then false; else true; fi +! guix download "file:///does-not-exist" "file://$abs_top_srcdir/README" diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh index 45264d4978..f2d15c8d0c 100644 --- a/tests/guix-environment-container.sh +++ b/tests/guix-environment-container.sh @@ -44,6 +44,21 @@ else test $? = 42 fi +# 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\"))'`" @@ -127,11 +142,15 @@ grep -e "$NIX_STORE_DIR/.*-bash" $tmpdir/mounts # bootstrap bash rm $tmpdir/mounts -# Make sure 'GUIX_ENVIRONMENT' is linked to '~/.guix-profile' when requested +# Make sure 'GUIX_ENVIRONMENT' is set to '~/.guix-profile' when requested # within a container. ( - linktest='(exit (string=? (getenv "GUIX_ENVIRONMENT") -(readlink (string-append (getenv "HOME") "/.guix-profile"))))' + 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 \ diff --git a/tests/guix-environment.sh b/tests/guix-environment.sh index 2faf38df06..f8be48f0c0 100644 --- a/tests/guix-environment.sh +++ b/tests/guix-environment.sh @@ -60,7 +60,7 @@ guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ grep '^PATH=' "$tmpdir/a" grep '^GUIX_TEST_ABC=' "$tmpdir/a" grep '^GUIX_TEST_DEF=' "$tmpdir/a" -if grep '^GUIX_TEST_XYZ=' "$tmpdir/a"; then false; else true; fi +! grep '^GUIX_TEST_XYZ=' "$tmpdir/a" # Make sure the exit value is preserved. if guix environment --bootstrap --ad-hoc guile-bootstrap --pure \ @@ -194,8 +194,7 @@ then done # 'make-boot0' itself must not be listed. - if guix gc --references "$profile" | grep make-boot0 - then false; else true; fi + ! guix gc --references "$profile" | grep make-boot0 # Make sure that the shell spawned with '--exec' sees the same environment # as returned by '--search-paths'. @@ -212,8 +211,7 @@ then test "x$make_boot0_debug" != "x" # Make sure the "debug" output is not listed. - if guix gc --references "$profile" | grep "$make_boot0_debug" - then false; else true; fi + ! guix gc --references "$profile" | grep "$make_boot0_debug" # Compute the build environment for the initial GNU Make, but add in the # bootstrap Guile as an ad-hoc addition. diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh index 8284287730..f40619876d 100644 --- a/tests/guix-gc.sh +++ b/tests/guix-gc.sh @@ -36,11 +36,11 @@ unset out # For some operations, passing extra arguments is an error. for option in "" "-C 500M" "--verify" "--optimize" "--list-roots" do - if guix gc $option whatever; then false; else true; fi + ! guix gc $option whatever done # This should fail. -if guix gc --verify=foo; then false; else true; fi +! guix gc --verify=foo # Check the references of a .drv. drv="`guix build guile-bootstrap -d`" @@ -51,8 +51,7 @@ guix gc --references "$drv" | grep -e -bash guix gc --references "$out" guix gc --references "$out/bin/guile" -if guix gc --references /dev/null; -then false; else true; fi +! guix gc --references /dev/null; # Check derivers. guix gc --derivers "$out" | grep "$drv" @@ -72,8 +71,7 @@ test -f "$drv" && test -L guix-gc-root guix gc --list-roots | grep "$PWD/guix-gc-root" guix gc --list-live | grep "$drv" -if guix gc --delete "$drv"; -then false; else true; fi +! guix gc --delete "$drv"; rm guix-gc-root guix gc --list-dead | grep "$drv" @@ -84,8 +82,7 @@ guix gc --delete "$drv" guix gc -C 1KiB # Check trivial error cases. -if guix gc --delete /dev/null; -then false; else true; fi +! guix gc --delete /dev/null; # Bug #19757 out="`guix build guile-bootstrap`" diff --git a/tests/guix-git-authenticate.sh b/tests/guix-git-authenticate.sh index 1c76e240b5..8ebbea398b 100644 --- a/tests/guix-git-authenticate.sh +++ b/tests/guix-git-authenticate.sh @@ -46,9 +46,8 @@ v1_0_0_signer="3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5" # civodul v1_0_1_commit="d68de958b60426798ed62797ff7c96c327a672ac" # This should fail because these commits lack '.guix-authorizations'. -if guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \ - --cache-key="$cache_key" --end="$v1_0_1_commit"; -then false; else true; fi +! guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \ + --cache-key="$cache_key" --end="$v1_0_1_commit" # This should work thanks to '--historical-authorizations'. guix git authenticate "$v1_0_0_commit" "$v1_0_0_signer" \ diff --git a/tests/guix-graph.sh b/tests/guix-graph.sh index ccb4933c88..666660ab4b 100644 --- a/tests/guix-graph.sh +++ b/tests/guix-graph.sh @@ -60,7 +60,7 @@ guix graph -t references guile-bootstrap | grep guile-bootstrap guix graph -e '(@ (gnu packages bootstrap) %bootstrap-guile)' \ | grep guile-bootstrap -if guix graph -e +; then false; else true; fi +! guix graph -e + # Try passing store file names. @@ -77,14 +77,13 @@ cmp "$tmpfile1" "$tmpfile2" # Try package transformation options. guix graph git | grep 'label = "openssl' guix graph git --with-input=openssl=libressl | grep 'label = "libressl' -if guix graph git --with-input=openssl=libressl | grep 'label = "openssl' -then false; else true; fi +! guix graph git --with-input=openssl=libressl | grep 'label = "openssl' # Try --load-path guix graph -L $module_dir dummy | grep 'label = "dummy' # Displaying shortest paths (or lack thereof). -if guix graph --path emacs vim; then false; else true; fi +! guix graph --path emacs vim path="\ emacs diff --git a/tests/guix-hash.sh b/tests/guix-hash.sh index 3538b9aeda..346355539f 100644 --- a/tests/guix-hash.sh +++ b/tests/guix-hash.sh @@ -34,8 +34,7 @@ test `guix hash -f base32 /dev/null` = 4oymiquy7qobjgx36tejs35zeqt24qpemsnzgtfes test `guix hash -H sha512 -f hex /dev/null` = cf83e1357eefb8bdf1542850d66d8007d620e4050b5715dc83f4a921d36ce9ce47d0d13c5d85f2b0ff8318d2877eec2f63b931bd47417a81a538327af927da3e test `guix hash -H sha1 -f base64 /dev/null` = "2jmj7l5rSw0yVb/vlWAYkK/YBwk=" -if guix hash -H abcd1234 /dev/null; -then false; else true; fi +! guix hash -H abcd1234 /dev/null mkdir "$tmpdir" echo -n executable > "$tmpdir/exe" @@ -46,13 +45,11 @@ mkdir "$tmpdir/subdir" test `guix hash -r "$tmpdir"` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p # Without '-r', this should fail. -if guix hash "$tmpdir" -then false; else true; fi +! guix hash "$tmpdir" # This should fail because /dev/null is a character device, which # the archive format doesn't support. -if guix hash -r /dev/null -then false; else true; fi +! guix hash -r /dev/null # Adding a .git directory mkdir "$tmpdir/.git" @@ -65,6 +62,5 @@ test `guix hash -r $tmpdir` = 0a50z04zyzf7pidwxv0nwbj82pgzbrhdy9562kncnvkcfvb48m test `guix hash -r $tmpdir -x` = 10k1lw41wyrjf9mxydi0is5nkpynlsvgslinics4ppir13g7d74p # Without '-r', this should fail. -if guix hash "$tmpdir" -then false; else true; fi +! guix hash "$tmpdir" diff --git a/tests/guix-lint.sh b/tests/guix-lint.sh index ebe79efb84..fdf548fbf1 100644 --- a/tests/guix-lint.sh +++ b/tests/guix-lint.sh @@ -58,24 +58,19 @@ grep_warning () # 3) the description has a single space following the end-of-sentence period. out=`guix lint -c synopsis,description dummy 2>&1` -if [ `grep_warning "$out"` -ne 3 ] -then false; else true; fi +test `grep_warning "$out"` -eq 3 out=`guix lint -c synopsis dummy 2>&1` -if [ `grep_warning "$out"` -ne 2 ] -then false; else true; fi +test `grep_warning "$out"` -eq 2 out=`guix lint -c description dummy 2>&1` -if [ `grep_warning "$out"` -ne 1 ] -then false; else true; fi +test `grep_warning "$out"` -eq 1 out=`guix lint -c description,synopsis dummy 2>&1` -if [ `grep_warning "$out"` -ne 3 ] -then false; else true; fi +test `grep_warning "$out"` -eq 3 -if guix lint -c synopsis,invalid-checker dummy 2>&1 | \ +guix lint -c synopsis,invalid-checker dummy 2>&1 | \ grep -q 'invalid-checker: invalid checker' -then true; else false; fi # Make sure specifying multiple packages works. guix lint -c inputs-should-be-native dummy dummy@42 dummy @@ -85,8 +80,7 @@ guix lint -c inputs-should-be-native dummy dummy@42 dummy unset GUIX_PACKAGE_PATH out=`guix lint -L $module_dir -c synopsis,description dummy 2>&1` -if [ `grep_warning "$out"` -ne 3 ] -then false; else true; fi +test `grep_warning "$out"` -eq 3 # Make sure specifying multiple packages works. guix lint -L $module_dir -c inputs-should-be-native dummy dummy@42 dummy diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh index b8d36a02c6..a960ecd209 100644 --- a/tests/guix-pack-relocatable.sh +++ b/tests/guix-pack-relocatable.sh @@ -77,8 +77,7 @@ then grep 'GNU sed' "$test_directory/output" # Check whether the exit code is preserved. - if run_without_store "$test_directory/Bin/sed" --does-not-exist; - then false; else true; fi + ! run_without_store "$test_directory/Bin/sed" --does-not-exist chmod -Rf +w "$test_directory"; rm -rf "$test_directory"/* else diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index 39b64791e2..0339221ac2 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -45,8 +45,7 @@ guix gc -R "$drv" | grep "`guix build coreutils -d --no-grafts`" drv="`guix pack idutils -d --no-grafts --target=arm-linux-gnueabihf`" guix gc -R "$drv" | \ grep "`guix build idutils --target=arm-linux-gnueabihf -d --no-grafts`" -if guix gc -R "$drv" | grep "`guix build idutils -d --no-grafts`"; -then false; else true; fi +! guix gc -R "$drv" | grep "`guix build idutils -d --no-grafts`" # Build a tarball with no compression. guix pack --compression=none --bootstrap guile-bootstrap diff --git a/tests/guix-package-aliases.sh b/tests/guix-package-aliases.sh index e24bff3a56..311838b768 100644 --- a/tests/guix-package-aliases.sh +++ b/tests/guix-package-aliases.sh @@ -36,26 +36,28 @@ guix install --bootstrap guile-bootstrap -p "$profile" test -x "$profile/bin/guile" # Make sure '-r' isn't passed as-is to 'guix package'. -if guix install -r guile-bootstrap -p "$profile" --bootstrap -then false; else true; fi +! guix install -r guile-bootstrap -p "$profile" --bootstrap test -x "$profile/bin/guile" +# Use a package transformation option and make sure it's recorded. +guix install --bootstrap guile-bootstrap -p "$profile" \ + --with-input=libreoffice=inkscape +test -x "$profile/bin/guile" +grep "libreoffice=inkscape" "$profile/manifest" + guix upgrade --version guix upgrade -n guix upgrade gui.e -n -if guix upgrade foo bar -n; -then false; else true; fi +! guix upgrade foo bar -n; guix remove --version guix remove --bootstrap guile-bootstrap -p "$profile" ! test -x "$profile/bin/guile" test `guix package -p "$profile" -I | wc -l` -eq 0 -if guix remove -p "$profile" this-is-not-installed --bootstrap -then false; else true; fi +! guix remove -p "$profile" this-is-not-installed --bootstrap -if guix remove -i guile-bootstrap -p "$profile" --bootstrap -then false; else true; fi +! guix remove -i guile-bootstrap -p "$profile" --bootstrap guix search '\<board\>' game | grep '^name: gnubg' @@ -64,7 +66,7 @@ guix show guile guix show python@3 | grep "^name: python" # "python@2" exists but is deprecated; make sure it doesn't show up. -if guix show python@2; then false; else true; fi +! guix show python@2 # Specifying multiple packages. output="`guix show sed grep | grep ^name:`" diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh index 3876701fa2..6d21c6cff6 100644 --- a/tests/guix-package-net.sh +++ b/tests/guix-package-net.sh @@ -95,10 +95,8 @@ test "`guix package -p "$profile" -l | cut -f1 | grep guile | head -n1`" \ = " guile-bootstrap" # Exit with 1 when a generation does not exist. -if guix package -p "$profile" --list-generations=42; -then false; else true; fi -if guix package -p "$profile" --switch-generation=99; -then false; else true; fi +! guix package -p "$profile" --list-generations=42 +! guix package -p "$profile" --switch-generation=99 # Remove a package. guix package --bootstrap -p "$profile" -r "guile-bootstrap" @@ -174,8 +172,7 @@ test -z "`guix package -p "$profile" -l 3`" rm "$profile" guix package --bootstrap -p "$profile" -i guile-bootstrap guix package --bootstrap -p "$profile_alt" -i gcc-bootstrap -if guix package -p "$profile" --search-paths | grep LIBRARY_PATH -then false; fi +! guix package -p "$profile" --search-paths | grep LIBRARY_PATH guix package -p "$profile" -p "$profile_alt" --search-paths \ | grep "LIBRARY_PATH.*$profile/lib.$profile_alt/lib" diff --git a/tests/guix-package.sh b/tests/guix-package.sh index 1f955257be..3e5fa71d20 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -1,5 +1,5 @@ # GNU Guix --- Functional package management for GNU -# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> +# Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> # Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org> # # This file is part of GNU Guix. @@ -36,8 +36,7 @@ rm -f "$profile" "$tmpfile" trap 'rm -f "$profile" "$profile.lock" "$profile-"[0-9]* "$tmpfile"; rm -rf "$module_dir" t-home-'"$$" EXIT # Use `-e' with a non-package expression. -if guix package --bootstrap -e +; -then false; else true; fi +! guix package --bootstrap -e + # Install a store item and make sure the version and output in the manifest # are correct. @@ -62,8 +61,7 @@ test -f "$profile/bin/guile" # Collisions are properly flagged (in this case, 'g-wrap' propagates # guile@2.2, which conflicts with guile@2.0.) -if guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 -then false; else true; fi +! guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 guix package --bootstrap -n -p "$profile" -i g-wrap guile@2.0 \ --allow-collisions @@ -78,8 +76,7 @@ test "`guix package -p "$profile" --search-paths | wc -l`" = 1 # $PATH type -P rm ) # Exit with 1 when a generation does not exist. -if guix package -p "$profile" --delete-generations=42; -then false; else true; fi +! guix package -p "$profile" --delete-generations=42 # Exit with 0 when trying to delete the zeroth generation. guix package -p "$profile" --delete-generations=0 @@ -92,15 +89,12 @@ guix package --bootstrap -i "glibc:debug" -p "$profile" -n # Make sure nonexistent outputs are reported. guix package --bootstrap -i "guile-bootstrap:out" -p "$profile" -n -if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n; -then false; else true; fi -if guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile"; -then false; else true; fi +! guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" -n +! guix package --bootstrap -i "guile-bootstrap:does-not-exist" -p "$profile" # Make sure we get an error when trying to remove something that's not # installed. -if guix package --bootstrap -r something-not-installed -p "$profile"; -then false; else true; fi +! guix package --bootstrap -r something-not-installed -p "$profile" # Check whether `--list-available' returns something sensible. guix package -p "$profile" -A 'gui.*e' | grep guile @@ -112,8 +106,8 @@ guix package --show=guile | grep "^name: guile" guix package --show=texlive # Fail for non-existent packages or package/version pairs. -if guix package --show=does-not-exist; then false; else true; fi -if guix package --show=emacs@42; then false; else true; fi +! guix package --show=does-not-exist +! guix package --show=emacs@42 # Search. LC_MESSAGES=C @@ -157,22 +151,19 @@ guix package --search="" > /dev/null # There's no generation older than 12 months, so the following command should # have no effect. generation="`readlink_base "$profile"`" -if guix package -p "$profile" --delete-generations=12m; -then false; else true; fi +! guix package -p "$profile" --delete-generations=12m test "`readlink_base "$profile"`" = "$generation" # The following command should not delete the current generation, even though # it matches the given pattern (see <http://bugs.gnu.org/19978>.) And since # there's nothing else to delete, it should just fail. guix package --list-generations -p "$profile" -if guix package --bootstrap -p "$profile" --delete-generations=1.. -then false; else true; fi +! guix package --bootstrap -p "$profile" --delete-generations=1.. test "`readlink_base "$profile"`" = "$generation" # Make sure $profile is a GC root at this point. real_profile="`readlink -f "$profile"`" -if guix gc -d "$real_profile" -then false; else true; fi +! guix gc -d "$real_profile" test -d "$real_profile" # Now, let's remove all the symlinks to $real_profile, and make sure @@ -193,6 +184,21 @@ grep -E 'emacs[[:blank:]]+42\.5\.9rc7' "$tmpfile" rm "$emacs_tarball" "$tmpfile" rmdir "$module_dir" +# Install with package transformations. +guix install --bootstrap -p "$profile" sed --with-input=sed=guile-bootstrap +grep "sed=guile-bootstrap" "$profile/manifest" +test "$(readlink -f "$profile/bin/guile")" \ + = "$(guix build guile-bootstrap)/bin/guile" +test ! -f "$profile/bin/sed" + +# Make sure the package transformation is preserved. +guix package --bootstrap -p "$profile" -u +grep "sed=guile-bootstrap" "$profile/manifest" +test "$(readlink -f "$profile/bin/guile")" \ + = "$(guix build guile-bootstrap)/bin/guile" +test ! -f "$profile/bin/sed" +rm "$profile" "$profile"-[0-9]-link + # Profiles with a relative file name. Make sure we don't create dangling # symlinks--see bug report at # <https://lists.gnu.org/archive/html/guix-devel/2018-07/msg00036.html>. @@ -238,16 +244,15 @@ done # Check whether '-p ~/.guix-profile' makes any difference. # See <http://bugs.gnu.org/17939>. -if test -e "$HOME/.guix-profile-0-link"; then false; fi -if test -e "$HOME/.guix-profile-1-link"; then false; fi +! test -e "$HOME/.guix-profile-0-link" +! test -e "$HOME/.guix-profile-1-link" guix package --bootstrap -p "$HOME/.guix-profile" -i guile-bootstrap -if test -e "$HOME/.guix-profile-1-link"; then false; fi +! test -e "$HOME/.guix-profile-1-link" guix package --bootstrap --roll-back -p "$HOME/.guix-profile" -if test -e "$HOME/.guix-profile-0-link"; then false; fi +! test -e "$HOME/.guix-profile-0-link" # Extraneous argument. -if guix package install foo-bar; -then false; else true; fi +! guix package install foo-bar # Make sure the "broken pipe" doesn't yield an error. # Note: 'pipefail' is a Bash-specific option. @@ -267,7 +272,7 @@ cat > "$module_dir/foo.scm"<<EOF (define-public x (package (inherit emacs) (name "emacs-foo-bar") - (version "42"))) + (version "42.77.0"))) EOF guix package -A emacs-foo-bar -L "$module_dir" | grep 42 @@ -308,7 +313,7 @@ cat > "$module_dir/foo.scm"<<EOF (source (origin (inherit (package-source emacs)) (patches (list (search-patch "emacs.patch"))))) (name "emacs-foo-bar-patched") - (version "42"))) + (version "42.42.42"))) (define-public y (package (inherit emacs) @@ -336,8 +341,7 @@ cat > "$module_dir/package.scm"<<EOF (define my-package coreutils) ;returns *unspecified* EOF -if guix package --bootstrap --install-from-file="$module_dir/package.scm" -then false; else true; fi +! guix package --bootstrap --install-from-file="$module_dir/package.scm" rm "$module_dir/package.scm" diff --git a/tests/guix-repl.sh b/tests/guix-repl.sh index e1c2b8241f..d4ebb5f6c6 100644 --- a/tests/guix-repl.sh +++ b/tests/guix-repl.sh @@ -45,6 +45,10 @@ EOF test "`guix repl "$tmpfile"`" = "coreutils" +# Make sure that the file can also be loaded when passed as a relative file +# name. +(cd "$(dirname "$tmpfile")"; test "$(guix repl "$(basename "$tmpfile")")" = "coreutils") + cat > "$module_dir/foo.scm"<<EOF (define-module (foo) diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 0e22686a34..957479ede0 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -261,8 +261,8 @@ guix system vm "$tmpfile" -d | grep '\.drv$' drv1="`guix system vm "$tmpfile" -d`" drv2="`guix system vm "$tmpfile" -d`" test "$drv1" = "$drv2" -drv1="`guix system disk-image --file-system-type=iso9660 "$tmpfile" -d`" -drv2="`guix system disk-image --file-system-type=iso9660 "$tmpfile" -d`" +drv1="`guix system disk-image -t iso9660 "$tmpfile" -d`" +drv2="`guix system disk-image -t iso9660 "$tmpfile" -d`" test "$drv1" = "$drv2" make_user_config "group-that-does-not-exist" "users" @@ -297,6 +297,20 @@ EOF guix system build "$tmpdir/config.scm" -n (cd "$tmpdir"; guix system build "config.scm" -n) +# Check that we get a warning when passing 'local-file' a non-literal relative +# file name. +cat > "$tmpdir/config.scm" <<EOF +(use-modules (guix)) + +(define (bad-local-file file) + (local-file file)) + +(bad-local-file "whatever.scm") +EOF +! guix system build "$tmpdir/config.scm" -n +guix system build "$tmpdir/config.scm" -n 2>&1 | \ + grep "config\.scm:4:2: warning:.*whatever.*relative to current directory" + # Searching. guix system search tor | grep "^name: tor" guix system search tor | grep "^shepherdnames: tor" @@ -320,5 +334,8 @@ guix system -n vm gnu/system/examples/vm-image.tmpl guix system -n vm-image gnu/system/examples/vm-image.tmpl # This invocation was taken care of in the loop above: # guix system -n disk-image gnu/system/examples/bare-bones.tmpl -guix system -n disk-image --file-system-type=iso9660 gnu/system/examples/bare-bones.tmpl +guix system -n disk-image -t iso9660 gnu/system/examples/bare-bones.tmpl guix system -n docker-image gnu/system/examples/docker-image.tmpl + +# Verify that at least the raw image type is available. +guix system --list-image-types | grep "raw" diff --git a/tests/opam.scm b/tests/opam.scm index 68b5908e3f..ec2a668307 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -116,81 +116,76 @@ url { ;; Test the opam file parser ;; We fold over some test cases. Each case is a pair of the string to parse and the ;; expected result. -(test-assert "parse-strings" - (fold (lambda (test acc) - (display test) (newline) - (and acc - (let ((result (peg:tree (match-pattern string-pat (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("\"hello\"" . (string-pat "hello")) - ("\"hello world\"" . (string-pat "hello world")) - ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) - ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) - ("\"今日は\"" . (string-pat "今日は"))))) +(define (test-opam-syntax name pattern test-cases) + (test-assert name + (fold (lambda (test acc) + (display test) (newline) + (match test + ((str . expected) + (and acc + (let ((result (peg:tree (match-pattern pattern str)))) + (if (equal? result expected) + #t + (pk 'fail (list str result expected) #f))))))) + #t test-cases))) -(test-assert "parse-multiline-strings" - (fold (lambda (test acc) - (display test) (newline) - (and acc - (let ((result (peg:tree (match-pattern multiline-string (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("\"\"\"hello\"\"\"" . (multiline-string "hello")) - ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) - ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!"))))) +(test-opam-syntax + "parse-strings" string-pat + '(("" . #f) + ("\"hello\"" . (string-pat "hello")) + ("\"hello world\"" . (string-pat "hello world")) + ("\"The dreaded \\\"é\\\"\"" . (string-pat "The dreaded \"é\"")) + ("\"Have some \\\\\\\\ :)\"" . (string-pat "Have some \\\\ :)")) + ("\"今日は\"" . (string-pat "今日は")))) -(test-assert "parse-lists" - (fold (lambda (test acc) - (and acc - (let ((result (peg:tree (match-pattern list-pat (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("[]" . list-pat) - ("[make]" . (list-pat (var "make"))) - ("[\"make\"]" . (list-pat (string-pat "make"))) - ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) - ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c")))))) +(test-opam-syntax + "parse-multiline-strings" multiline-string + '(("" . #f) + ("\"\"\"hello\"\"\"" . (multiline-string "hello")) + ("\"\"\"hello \"world\"!\"\"\"" . (multiline-string "hello \"world\"!")) + ("\"\"\"hello \"\"world\"\"!\"\"\"" . (multiline-string "hello \"\"world\"\"!")))) -(test-assert "parse-dicts" - (fold (lambda (test acc) - (and acc - (let ((result (peg:tree (match-pattern dict (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("{}" . dict) - ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) - ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d"))))))) +(test-opam-syntax + "parse-lists" list-pat + '(("" . #f) + ("[]" . list-pat) + ("[make]" . (list-pat (var "make"))) + ("[\"make\"]" . (list-pat (string-pat "make"))) + ("[\n a\n b\n c]" . (list-pat (var "a") (var "b") (var "c"))) + ("[a b \"c\"]" . (list-pat (var "a") (var "b") (string-pat "c"))) + ;; complex lists + ("[(a & b)]" . (list-pat (choice-pat (group-pat (var "a") (var "b"))))) + ("[(a | b & c)]" . (list-pat (choice-pat (var "a") (group-pat (var "b") (var "c"))))) + ("[a (b | c) d]" . (list-pat (var "a") (choice-pat (var "b") (var "c")) (var "d"))))) -(test-assert "parse-conditions" - (fold (lambda (test acc) - (and acc - (let ((result (peg:tree (match-pattern condition (car test))))) - (if (equal? result (cdr test)) - #t - (pk 'fail (list (car test) result (cdr test)) #f))))) - #t '(("" . #f) - ("{}" . #f) - ("{build}" . (condition-var "build")) - ("{>= \"0.2.0\"}" . (condition-greater-or-equal - (condition-string "0.2.0"))) - ("{>= \"0.2.0\" & test}" . (condition-and - (condition-greater-or-equal - (condition-string "0.2.0")) - (condition-var "test"))) - ("{>= \"0.2.0\" | build}" . (condition-or - (condition-greater-or-equal - (condition-string "0.2.0")) - (condition-var "build"))) - ("{ = \"1.0+beta19\" }" . (condition-eq - (condition-string "1.0+beta19")))))) +(test-opam-syntax + "parse-dicts" dict + '(("" . #f) + ("{}" . dict) + ("{a: \"b\"}" . (dict (record "a" (string-pat "b")))) + ("{a: \"b\"\nc: \"d\"}" . (dict (record "a" (string-pat "b")) (record "c" (string-pat "d")))))) + +(test-opam-syntax + "parse-conditions" condition + '(("" . #f) + ("{}" . #f) + ("{build}" . (condition-var "build")) + ("{>= \"0.2.0\"}" . (condition-greater-or-equal + (condition-string "0.2.0"))) + ("{>= \"0.2.0\" & test}" . (condition-and + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "test"))) + ("{>= \"0.2.0\" | build}" . (condition-or + (condition-greater-or-equal + (condition-string "0.2.0")) + (condition-var "build"))) + ("{ = \"1.0+beta19\" }" . (condition-eq + (condition-string "1.0+beta19"))))) + +(test-opam-syntax + "parse-comment" list-pat + '(("" . #f) + ("[#comment\n]" . list-pat))) (test-end "opam") diff --git a/tests/openpgp.scm b/tests/openpgp.scm index 0beab6f88b..c2be26fa49 100644 --- a/tests/openpgp.scm +++ b/tests/openpgp.scm @@ -50,6 +50,12 @@ vBSFjNSiVHsuAA== =AAAA -----END PGP MESSAGE-----\n") +(define %binary-sample + ;; Same message as %radix-64-sample, decoded into bytevector. + (base16-string->bytevector + "c838013b6d96c411efecef17ecefe3ca0004ce8979ea250a897995f979a9\ +0ad9a9a9050a890ac5a9c945a940c1a2fcd2bc14858cd4a2547b2e00")) + (define %civodul-fingerprint "3CE4 6455 8A84 FDC6 9DB4 0CFB 090B 1199 3D9A EBB5") @@ -155,6 +161,12 @@ Pz7oopeN72xgggYUNT37ezqN3MeCqw0= read-radix-64)) list)) +(test-assert "port-ascii-armored?, #t" + (call-with-input-string %radix-64-sample port-ascii-armored?)) + +(test-assert "port-ascii-armored?, #f" + (not (port-ascii-armored? (open-bytevector-input-port %binary-sample)))) + (test-assert "get-openpgp-keyring" (let* ((key (search-path %load-path "tests/civodul.key")) (keyring (get-openpgp-keyring diff --git a/tests/packages.scm b/tests/packages.scm index 2649c2497f..a9560a99a3 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -38,6 +38,7 @@ #:use-module (guix build-system) #:use-module (guix build-system trivial) #:use-module (guix build-system gnu) + #:use-module (guix build-system python) #:use-module (guix memoization) #:use-module (guix profiles) #:use-module (guix scripts package) @@ -45,6 +46,7 @@ #:use-module (gnu packages base) #:use-module (gnu packages guile) #:use-module (gnu packages bootstrap) + #:use-module (gnu packages python) #:use-module (gnu packages version-control) #:use-module (gnu packages xml) #:use-module (srfi srfi-1) @@ -185,6 +187,29 @@ (string=? (manifest-pattern-version pattern) "1") (string=? (manifest-pattern-output pattern) "out"))))))) +(test-equal "transaction-upgrade-entry, transformation options preserved" + (derivation-file-name (package-derivation %store grep)) + + (let* ((old (dummy-package "emacs" (version "1"))) + (props '((transformations . ((with-input . "emacs=grep"))))) + (tx (transaction-upgrade-entry + %store + (manifest-entry + (inherit (package->manifest-entry old)) + (properties props) + (item (string-append (%store-prefix) "/" + (make-string 32 #\e) "-foo-1"))) + (manifest-transaction)))) + (match (manifest-transaction-install tx) + (((? manifest-entry? entry)) + (and (string=? (manifest-entry-version entry) + (package-version grep)) + (string=? (manifest-entry-name entry) + (package-name grep)) + (equal? (manifest-entry-properties entry) props) + (derivation-file-name + (package-derivation %store (manifest-entry-item entry)))))))) + (test-assert "transaction-upgrade-entry, grafts" ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't ;; try to build stuff. @@ -1185,15 +1210,24 @@ (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) (p0 (dummy-package "example" + (source 77) (inputs `(("foo" ,coreutils) ("bar" ,grep) ("baz" ,dep))))) (transform (lambda (p) (package (inherit p) (source 42)))) (rewrite (package-mapping transform)) - (p1 (rewrite p0))) + (p1 (rewrite p0)) + (bag0 (package->bag p0)) + (bag1 (package->bag p1))) (and (eq? p1 (rewrite p0)) (eqv? 42 (package-source p1)) + + ;; Implicit inputs should be left unchanged (skip "source", "foo", + ;; "bar", and "baz" in this comparison). + (equal? (drop (bag-direct-inputs bag0) 4) + (drop (bag-direct-inputs bag1) 4)) + (match (package-inputs p1) ((("foo" dep1) ("bar" dep2) ("baz" dep3)) (and (eq? dep1 (rewrite coreutils)) ;memoization @@ -1207,6 +1241,31 @@ (and (eq? dep (rewrite grep)) (package-source dep)))))))))) +(test-equal "package-mapping, deep" + '(42) + (let* ((p0 (dummy-package "example" + (inputs `(("foo" ,coreutils) + ("bar" ,grep))))) + (transform (lambda (p) + (package (inherit p) (source 42)))) + (rewrite (package-mapping transform #:deep? #t)) + (p1 (rewrite p0)) + (bag (package->bag p1))) + (and (eq? p1 (rewrite p0)) + (match (bag-direct-inputs bag) + ((("source" 42) ("foo" dep1) ("bar" dep2) rest ..1) + (and (eq? dep1 (rewrite coreutils)) ;memoization + (eq? dep2 (rewrite grep)) + (= 42 (package-source dep1)) + (= 42 (package-source dep2)) + + ;; Check that implicit inputs of P0 also got rewritten. + (delete-duplicates + (map (match-lambda + ((_ package . _) + (package-source package))) + rest)))))))) + (test-assert "package-input-rewriting" (let* ((dep (dummy-package "chbouib" (native-inputs `(("x" ,grep))))) @@ -1216,7 +1275,8 @@ ("baz" ,dep))))) (rewrite (package-input-rewriting `((,coreutils . ,sed) (,grep . ,findutils)) - (cut string-append "r-" <>))) + (cut string-append "r-" <>) + #:deep? #f)) (p1 (rewrite p0)) (p2 (rewrite p0))) (and (not (eq? p1 p0)) @@ -1230,7 +1290,22 @@ (eq? dep3 (rewrite dep)) ;memoization (match (package-native-inputs dep3) ((("x" dep)) - (eq? dep findutils))))))))) + (eq? dep findutils)))))) + + ;; Make sure implicit inputs were left unchanged. + (equal? (drop (bag-direct-inputs (package->bag p1)) 3) + (drop (bag-direct-inputs (package->bag p0)) 3))))) + +(test-eq "package-input-rewriting, deep" + (derivation-file-name (package-derivation %store sed)) + (let* ((p0 (dummy-package "chbouib" + (build-system python-build-system) + (arguments `(#:python ,python)))) + (rewrite (package-input-rewriting `((,python . ,sed)))) + (p1 (rewrite p0))) + (match (bag-direct-inputs (package->bag p1)) + ((("python" python) _ ...) + (derivation-file-name (package-derivation %store python)))))) (test-assert "package-input-rewriting/spec" (let* ((dep (dummy-package "chbouib" @@ -1241,7 +1316,8 @@ ("baz" ,dep))))) (rewrite (package-input-rewriting/spec `(("coreutils" . ,(const sed)) - ("grep" . ,(const findutils))))) + ("grep" . ,(const findutils))) + #:deep? #f)) (p1 (rewrite p0)) (p2 (rewrite p0))) (and (not (eq? p1 p0)) @@ -1258,7 +1334,11 @@ (match (package-native-inputs dep3) ((("x" dep)) (string=? (package-full-name dep) - (package-full-name findutils)))))))))) + (package-full-name findutils))))))) + + ;; Make sure implicit inputs were left unchanged. + (equal? (drop (bag-direct-inputs (package->bag p1)) 3) + (drop (bag-direct-inputs (package->bag p0)) 3))))) (test-assert "package-input-rewriting/spec, partial match" (let* ((dep (dummy-package "chbouib" @@ -1269,7 +1349,8 @@ ("bar" ,dep))))) (rewrite (package-input-rewriting/spec `(("chbouib@123" . ,(const sed)) ;not matched - ("grep" . ,(const findutils))))) + ("grep" . ,(const findutils))) + #:deep? #f)) (p1 (rewrite p0))) (and (not (eq? p1 p0)) (string=? "example" (package-name p1)) @@ -1283,6 +1364,105 @@ (string=? (package-full-name dep) (package-full-name findutils)))))))))) +(test-assert "package-input-rewriting/spec, deep" + (let* ((dep (dummy-package "chbouib")) + (p0 (dummy-package "example" + (build-system gnu-build-system) + (inputs `(("dep" ,dep))))) + (rewrite (package-input-rewriting/spec + `(("tar" . ,(const sed)) + ("gzip" . ,(const findutils))))) + (p1 (rewrite p0)) + (p2 (rewrite p0))) + (and (not (eq? p1 p0)) + (eq? p1 p2) ;memoization + (string=? "example" (package-name p1)) + (match (package-inputs p1) + ((("dep" dep1)) + (and (string=? (package-full-name dep1) + (package-full-name dep)) + (eq? dep1 (rewrite dep))))) ;memoization + + ;; Make sure implicit inputs were replaced. + (match (bag-direct-inputs (package->bag p1)) + ((("dep" dep1) ("tar" tar) ("gzip" gzip) _ ...) + (and (eq? dep1 (rewrite dep)) + (string=? (package-full-name tar) + (package-full-name sed)) + (string=? (package-full-name gzip) + (package-full-name findutils)))))))) + +(test-assert "package-input-rewriting/spec, no duplicates" + ;; Ensure that deep input rewriting does not forget implicit inputs. Doing + ;; so could lead to duplicates in a package's inputs: in the example below, + ;; P0's transitive inputs would contain one rewritten "python" and one + ;; original "python". These two "python" packages are thus not 'eq?' but + ;; they lower to the same derivation. See <https://bugs.gnu.org/42156>, + ;; which can be reproduced by passing #:deep? #f. + (let* ((dep0 (dummy-package "dep0" + (build-system trivial-build-system) + (propagated-inputs `(("python" ,python))))) + (p0 (dummy-package "chbouib" + (build-system python-build-system) + (arguments `(#:python ,python)) + (inputs `(("dep0" ,dep0))))) + (rewrite (package-input-rewriting/spec '() #:deep? #t)) + (p1 (rewrite p0)) + (bag1 (package->bag p1)) + (pythons (filter-map (match-lambda + (("python" python) python) + (_ #f)) + (bag-transitive-inputs bag1)))) + (match (delete-duplicates pythons eq?) + ((p) (eq? p (rewrite python)))))) + +(test-equal "package-input-rewriting/spec, graft" + (derivation-file-name (package-derivation %store sed)) + + ;; Make sure replacements are rewritten. + (let* ((dep0 (dummy-package "dep" + (version "1") + (build-system trivial-build-system) + (inputs `(("coreutils" ,coreutils))))) + (dep1 (dummy-package "dep" + (version "0") + (build-system trivial-build-system) + (replacement dep0))) + (p0 (dummy-package "p" + (build-system trivial-build-system) + (inputs `(("dep" ,dep1))))) + (rewrite (package-input-rewriting/spec + `(("coreutils" . ,(const sed))))) + (p1 (rewrite p0))) + (match (package-inputs p1) + ((("dep" dep)) + (match (package-inputs (package-replacement dep)) + ((("coreutils" coreutils)) + ;; COREUTILS is not 'eq?' to SED, so the most reliable way to check + ;; for equality is to lower to a derivation. + (derivation-file-name + (package-derivation %store coreutils)))))))) + +(test-assert "package-with-c-toolchain" + (let* ((dep (dummy-package "chbouib" + (build-system gnu-build-system) + (native-inputs `(("x" ,grep))))) + (p0 (dummy-package "thingie" + (build-system gnu-build-system) + (inputs `(("foo" ,grep) + ("bar" ,dep))))) + (tc (dummy-package "my-toolchain")) + (p1 (package-with-c-toolchain p0 `(("toolchain" ,tc))))) + (define toolchain-packages + '("gcc" "binutils" "glibc" "ld-wrapper")) + + (match (bag-build-inputs (package->bag p1)) + ((("foo" foo) ("bar" bar) (_ (= package-name packages) . _) ...) + (and (not (any (cut member <> packages) toolchain-packages)) + (member "my-toolchain" packages) + (eq? foo grep) + (eq? bar dep)))))) + (test-equal "package-patched-vulnerabilities" '(("CVE-2015-1234") ("CVE-2016-1234" "CVE-2018-4567") diff --git a/tests/scripts-build.scm b/tests/scripts-build.scm index 32876e956a..6925374baa 100644 --- a/tests/scripts-build.scm +++ b/tests/scripts-build.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2016, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,8 +19,11 @@ (define-module (test-scripts-build) #:use-module (guix tests) #:use-module (guix store) + #: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 scripts build) #:use-module (guix ui) #:use-module (guix utils) @@ -29,6 +32,8 @@ #: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-64)) @@ -163,11 +168,16 @@ ((("foo" dep1) ("bar" dep2)) (and (string=? (package-full-name dep1) (package-full-name grep)) - (eq? (package-replacement dep1) findutils) + (string=? (package-full-name (package-replacement dep1)) + (package-full-name findutils)) (string=? (package-name dep2) "chbouib") (match (package-native-inputs dep2) ((("x" dep)) - (eq? (package-replacement dep) findutils))))))))))) + (with-store store + (string=? (derivation-file-name + (package-derivation store findutils)) + (derivation-file-name + (package-derivation store dep)))))))))))))) (test-equal "options->transformation, with-branch" (git-checkout (url "https://example.org") @@ -264,5 +274,97 @@ ((("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. + (with-store store + (let ((new (t store 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"))))) + (with-store store + (let ((new (t store 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. + (with-store store + (eq? (t store p) p)))) + +(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"))))) + (with-store store + (let ((new (t store p))) + (match (bag-direct-inputs (package->bag new)) + ((("dep" dep) ("tar" tar) _ ...) + ;; TODO: Check whether TAR has #:tests? #f when transformations + ;; apply to implicit inputs. + (equal? (package-arguments dep) + '(#:tests? #f)))))))) (test-end) + +;;; Local Variables: +;;; eval: (put 'dummy-package 'scheme-indent-function 1) +;;; End: |