diff options
Diffstat (limited to 'tests')
39 files changed, 1147 insertions, 550 deletions
diff --git a/tests/base32.scm b/tests/base32.scm index 194f8da96b..134e578633 100644 --- a/tests/base32.scm +++ b/tests/base32.scm @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (test-base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix utils) #:use-module (srfi srfi-1) diff --git a/tests/builders.scm b/tests/builders.scm index bb9e0fa85b..8b8ef013e7 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -25,7 +25,7 @@ #:use-module (guix utils) #:use-module (guix base32) #:use-module (guix derivations) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module ((guix packages) #:select (package-derivation package-native-search-paths)) diff --git a/tests/challenge.scm b/tests/challenge.scm index 387d205a64..c962800f3f 100644 --- a/tests/challenge.scm +++ b/tests/challenge.scm @@ -18,7 +18,7 @@ (define-module (test-challenge) #:use-module (guix tests) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix derivations) @@ -31,17 +31,9 @@ #:use-module (rnrs bytevectors) #:use-module (ice-9 match)) -(define %store - (open-connection-for-tests)) - (define query-path-hash* (store-lift query-path-hash)) -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (define* (call-with-derivation-narinfo* drv thunk hash) (lambda (store) (with-derivation-narinfo drv (sha256 => hash) diff --git a/tests/cpan.scm b/tests/cpan.scm index 396744e529..189dd027e6 100644 --- a/tests/cpan.scm +++ b/tests/cpan.scm @@ -20,7 +20,7 @@ (define-module (test-cpan) #:use-module (guix import cpan) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module (guix grafts) #:use-module (srfi srfi-64) diff --git a/tests/crate.scm b/tests/crate.scm index eb93822bbb..a1dcfd5e52 100644 --- a/tests/crate.scm +++ b/tests/crate.scm @@ -21,7 +21,7 @@ #:use-module (guix import crate) #:use-module (guix base32) #:use-module (guix build-system cargo) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module (ice-9 iconv) #:use-module (ice-9 match) diff --git a/tests/debug-link.scm b/tests/debug-link.scm index 2dde3cb460..a1ae4f141c 100644 --- a/tests/debug-link.scm +++ b/tests/debug-link.scm @@ -43,14 +43,6 @@ (define read-elf (compose parse-elf get-bytevector-all)) -(define %store - (open-connection-for-tests)) - -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (test-begin "debug-link") diff --git a/tests/derivations.scm b/tests/derivations.scm index 5d83529183..5f294c1827 100644 --- a/tests/derivations.scm +++ b/tests/derivations.scm @@ -23,7 +23,7 @@ #:use-module (guix grafts) #:use-module (guix store) #:use-module (guix utils) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix tests) #:use-module (guix tests http) @@ -1132,6 +1132,16 @@ ((p2 . _) (string<? p1 p2))))))))))))) +(test-equal "derivation-properties" + (list '() '((type . test))) + (let ((drv1 (build-expression->derivation %store "bar" + '(mkdir %output))) + (drv2 (build-expression->derivation %store "foo" + '(mkdir %output) + #:properties '((type . test))))) + (list (derivation-properties drv1) + (derivation-properties drv2)))) + (test-equal "map-derivation" "hello" (let* ((joke (package-derivation %store guile-1.8)) diff --git a/tests/gem.scm b/tests/gem.scm index 4220170ff0..a12edb294c 100644 --- a/tests/gem.scm +++ b/tests/gem.scm @@ -21,7 +21,7 @@ (define-module (test-gem) #:use-module (guix import gem) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module ((guix build utils) #:select (delete-file-recursively)) #:use-module (srfi srfi-41) diff --git a/tests/gexp.scm b/tests/gexp.scm index b22e635805..35a76a496e 100644 --- a/tests/gexp.scm +++ b/tests/gexp.scm @@ -62,11 +62,6 @@ #:target target) #:guile-for-build (%guile-for-build))) -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (define %extension-package ;; Example of a package to use when testing 'with-extensions'. (dummy-package "extension" @@ -481,7 +476,15 @@ (return (and (string=? (readlink (string-append out "/foo")) guile) (string=? (readlink out2) file) (equal? refs (list (dirname (dirname guile)))) - (equal? refs2 (list file)))))) + (equal? refs2 (list file)) + (null? (derivation-properties drv)))))) + +(test-assertm "gexp->derivation properties" + (mlet %store-monad ((drv (gexp->derivation "foo" + #~(mkdir #$output) + #:properties '((type . test))))) + (return (equal? '((type . test)) + (derivation-properties drv))))) (test-assertm "gexp->derivation vs. grafts" (mlet* %store-monad ((graft? (set-grafting #f)) @@ -615,6 +618,8 @@ `(("graph" ,two)) #:modules '((guix build store-copy) + (guix progress) + (guix records) (guix sets) (guix build utils)))) (ok? (built-derivations (list drv))) @@ -654,11 +659,11 @@ (drv (imported-files files))) (define (file=? file1 file2) ;; Assume deduplication is in place. - (= (stat:ino (lstat file1)) - (stat:ino (lstat file2)))) + (= (stat:ino (stat file1)) + (stat:ino (stat file2)))) (mbegin %store-monad - (built-derivations (list drv)) + (built-derivations (list (pk 'drv drv))) (mlet %store-monad ((dir -> (derivation->output-path drv)) (plain* (text-file "foo" "bar!")) (q-scm* (interned-file q-scm "c"))) @@ -678,6 +683,22 @@ #~(foo #$@(list (with-imported-modules '((foo)) #~+) (with-imported-modules '((bar)) #~-))))) +(test-assert "gexp-modules deletes duplicates" ;<https://bugs.gnu.org/32966> + (let ((make-file (lambda () + ;; Use 'eval' to make sure we get an object that's not + ;; 'eq?' nor 'equal?' due to the closures it embeds. + (eval '(scheme-file "bar.scm" #~(define-module (bar))) + (current-module))))) + (define result + ((@@ (guix gexp) gexp-modules) + (with-imported-modules `(((bar) => ,(make-file)) + ((bar) => ,(make-file)) + (foo) (foo)) + #~+))) + + (match result + (((('bar) '=> (? scheme-file?)) ('foo)) #t)))) + (test-equal "gexp-modules and literal Scheme object" '() (gexp-modules #t)) @@ -817,6 +838,8 @@ (two (gexp->derivation "two" #~(symlink #$one #$output:chbouib))) (build -> (with-imported-modules '((guix build store-copy) + (guix progress) + (guix records) (guix sets) (guix build utils)) #~(begin @@ -1093,6 +1116,24 @@ (call-with-input-file out get-string-all)) (equal? refs (list guile)))))))) +(test-assertm "file-union" + (mlet* %store-monad ((union -> (file-union "union" + `(("a" ,(plain-file "a" "1")) + ("b/c/d" ,(plain-file "d" "2")) + ("e" ,(plain-file "e" "3"))))) + (drv (lower-object union)) + (out -> (derivation->output-path drv))) + (define (contents=? file str) + (string=? (call-with-input-file (string-append out "/" file) + get-string-all) + str)) + + (mbegin %store-monad + (built-derivations (list drv)) + (return (and (contents=? "a" "1") + (contents=? "b/c/d" "2") + (contents=? "e" "3")))))) + (test-assert "gexp->derivation vs. %current-target-system" (let ((mval (gexp->derivation "foo" #~(begin diff --git a/tests/grafts.scm b/tests/grafts.scm index abb074d628..f85f3c6913 100644 --- a/tests/grafts.scm +++ b/tests/grafts.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -51,7 +51,8 @@ (test-begin "grafts") -(test-assert "graft-derivation, grafted item is a direct dependency" +(test-equal "graft-derivation, grafted item is a direct dependency" + '((type . graft) (graft (count . 2))) (let* ((build `(begin (mkdir %output) (chdir %output) @@ -76,14 +77,16 @@ (origin %mkdir) (replacement two)))))) (and (build-derivations %store (list grafted)) - (let ((two (derivation->output-path two)) - (grafted (derivation->output-path grafted))) + (let ((properties (derivation-properties grafted)) + (two (derivation->output-path two)) + (grafted (derivation->output-path grafted))) (and (string=? (format #f "foo/~a/bar" two) (call-with-input-file (string-append grafted "/text") get-string-all)) (string=? (readlink (string-append grafted "/sh")) one) (string=? (readlink (string-append grafted "/self")) - grafted)))))) + grafted) + properties))))) (test-assert "graft-derivation, grafted item uses a different name" (let* ((build `(begin diff --git a/tests/gremlin.scm b/tests/gremlin.scm index f1089e7da6..77a5dc1998 100644 --- a/tests/gremlin.scm +++ b/tests/gremlin.scm @@ -18,12 +18,14 @@ (define-module (test-gremlin) #:use-module (guix elf) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (guix build utils) #:use-module (guix build gremlin) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (srfi srfi-64) #:use-module (rnrs io ports) + #:use-module (ice-9 popen) #:use-module (ice-9 match)) (define %guile-executable @@ -37,6 +39,9 @@ (define read-elf (compose parse-elf get-bytevector-all)) +(define c-compiler + (or (which "gcc") (which "cc") (which "g++"))) + (test-begin "gremlin") @@ -63,4 +68,32 @@ "../${ORIGIN}/bar/$ORIGIN/baz" "ORIGIN/foo"))) +(unless c-compiler + (test-skip 1)) +(test-equal "strip-runpath" + "hello\n" + (call-with-temporary-directory + (lambda (directory) + (with-directory-excursion directory + (call-with-output-file "t.c" + (lambda (port) + (display "int main () { puts(\"hello\"); }" port))) + (invoke c-compiler "t.c" + "-Wl,-rpath=/foo" "-Wl,-rpath=/bar") + (let* ((dyninfo (elf-dynamic-info + (parse-elf (call-with-input-file "a.out" + get-bytevector-all)))) + (old (elf-dynamic-info-runpath dyninfo)) + (new (strip-runpath "a.out")) + (new* (strip-runpath "a.out"))) + (validate-needed-in-runpath "a.out") + (and (member "/foo" old) (member "/bar" old) + (not (member "/foo" new)) + (not (member "/bar" new)) + (equal? new* new) + (let* ((pipe (open-input-pipe "./a.out")) + (str (get-string-all pipe))) + (close-pipe pipe) + str))))))) + (test-end "gremlin") diff --git a/tests/guix-build-branch.sh b/tests/guix-build-branch.sh new file mode 100644 index 0000000000..e64782c831 --- /dev/null +++ b/tests/guix-build-branch.sh @@ -0,0 +1,56 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 build --with-branch'. +# + +guix build --version + +# 'guix build --with-branch' requires access to the network to clone the +# Git repository below. + +if ! guile -c '(getaddrinfo "www.gnu.org" "80" AI_NUMERICSERV)' 2> /dev/null +then + # Skipping. + exit 77 +fi + +orig_drv="`guix build guile-gcrypt -d`" +latest_drv="`guix build guile-gcrypt --with-branch=guile-gcrypt=master -d`" +test -n "$latest_drv" +test "$orig_drv" != "$latest_drv" + +# FIXME: '-S' currently doesn't work with non-derivation source. +# checkout="`guix build guile-gcrypt --with-branch=guile-gcrypt=master -S`" +checkout="`guix gc --references "$latest_drv" | grep guile-gcrypt | grep -v -E '(-builder|\.drv)'`" +test -d "$checkout" +test -f "$checkout/COPYING" + +orig_drv="`guix build guix -d`" +latest_drv="`guix build guix --with-branch=guile-gcrypt=master -d`" +guix gc -R "$latest_drv" | grep guile-gcrypt-git.master +test "$orig_drv" != "$latest_drv" + +v0_1_0_drv="`guix build guix --with-commit=guile-gcrypt=9e3eacdec1d -d`" +guix gc -R "$v0_1_0_drv" | grep guile-gcrypt-git.9e3eacd +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 diff --git a/tests/guix-build.sh b/tests/guix-build.sh index 92e7299321..7842ce87c6 100644 --- a/tests/guix-build.sh +++ b/tests/guix-build.sh @@ -221,6 +221,10 @@ guix build -e "(begin guix build -e '#~(mkdir #$output)' -d guix build -e '#~(mkdir #$output)' -d | grep 'gexp\.drv' +# Same with a file-like object. +guix build -e '(computed-file "foo" #~(mkdir #$output))' -d +guix build -e '(computed-file "foo" #~(mkdir #$output))' -d | grep 'foo\.drv' + # Building from a package file. cat > "$module_dir/package.scm"<<EOF (use-modules (gnu)) diff --git a/tests/guix-describe.sh b/tests/guix-describe.sh new file mode 100644 index 0000000000..af523f0a0b --- /dev/null +++ b/tests/guix-describe.sh @@ -0,0 +1,47 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 describe'. +# + +guix describe --version + +tmpfile="t-guix-describe-$$" +trap "rm -f $tmpfile" EXIT +rm -f "$tmpfile" + +if [ -d "$abs_top_srcdir/.git" ] +then + # Since we're in a Git checkout, we can at least check that these things + # work. + guix describe | grep -i "checkout" + if git --version > /dev/null 2>&1 + then + result="`guix describe | grep commit: | cut -d : -f 2-`" + commit="`git log | head -1 | cut -c 7-`" + test "x$result" = "x$commit" + fi + guix describe -f channels + case "`guix describe -f channels | grep url`" in + *"(url \"$abs_top_srcdir\")") true;; + *) false;; + esac +else + exit 77 +fi diff --git a/tests/guix-pack-localstatedir.sh b/tests/guix-pack-localstatedir.sh new file mode 100644 index 0000000000..b734b0f7e3 --- /dev/null +++ b/tests/guix-pack-localstatedir.sh @@ -0,0 +1,69 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 the 'guix pack --localstatedir' command-line utility. +# + +guix pack --version + +# 'guix pack --localstatedir' produces derivations that depend on +# guile-sqlite3 and guile-gcrypt. To make that relatively inexpensive, run +# the test in the user's global store if possible, on the grounds that +# binaries may already be there or can be built or downloaded inexpensively. + +NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`" +localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`" +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 + +# Build a tarball with '--localstatedir' +the_pack="`guix pack -C none --localstatedir --profile-name=current-guix \ + guile-bootstrap`" +test_directory="`mktemp -d`" +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT + +cd "$test_directory" +tar -xf "$the_pack" + +profile="`find -name current-guix`" +test "`readlink $profile`" = "current-guix-1-link" +test -s "`dirname $profile`/../../../db/db.sqlite" +test -x ".`guix build guile-bootstrap`/bin/guile" +cd - + +# Make sure the store database is not completely bogus. +guile -c "(use-modules (sqlite3) (guix config) (ice-9 match)) + + (define db + (sqlite-open (string-append \"$test_directory\" + %localstatedir + \"/guix/db/db.sqlite\") + SQLITE_OPEN_READONLY)) + + (define stmt + (sqlite-prepare db \"SELECT * FROM ValidPaths;\")) + + (match (sqlite-fold cons '() stmt) + ((#(ids paths hashes times derivers sizes) ...) + (exit (member \"`guix build guile-bootstrap`\" paths))))" diff --git a/tests/guix-pack-relocatable.sh b/tests/guix-pack-relocatable.sh new file mode 100644 index 0000000000..554416627b --- /dev/null +++ b/tests/guix-pack-relocatable.sh @@ -0,0 +1,61 @@ +# GNU Guix --- Functional package management for GNU +# Copyright © 2018 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 the 'guix pack --relocatable' using the external store, if any. +# + +guix pack --version + +# 'guix pack --relocatable' requires a C compiler and libc.a, which our +# bootstrap binaries don't provide. To make the test relatively inexpensive, +# run it on the user's global store if possible, on the grounds that binaries +# may already be there or can be built or downloaded inexpensively. + +NIX_STORE_DIR="`guile -c '(use-modules (guix config))(display %storedir)'`" +localstatedir="`guile -c '(use-modules (guix config))(display %localstatedir)'`" +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 + +STORE_PARENT="`dirname $NIX_STORE_DIR`" +export STORE_PARENT +if test "$STORE_PARENT" = "/"; then exit 77; fi + +# This test requires user namespaces and associated command-line tools. +if ! unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"' +then + exit 77 +fi + +test_directory="`mktemp -d`" +export test_directory +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT + +tarball="`guix pack -R -S /Bin=bin sed`" +(cd "$test_directory"; tar xvf "$tarball") + +# Run that relocatable 'sed' in a user namespace where we "erase" the store by +# mounting an empty file system on top of it. That way, we exercise the +# wrapper code that creates the user namespace and bind-mounts the store. +unshare -mrf sh -c 'mount -t tmpfs none "$STORE_PARENT"; echo "$STORE_PARENT"/*; "$test_directory/Bin/sed" --version > "$test_directory/output"' +grep 'GNU sed' "$test_directory/output" diff --git a/tests/guix-pack.sh b/tests/guix-pack.sh index bf367fa429..a43f4d128f 100644 --- a/tests/guix-pack.sh +++ b/tests/guix-pack.sh @@ -1,5 +1,6 @@ # GNU Guix --- Functional package management for GNU # Copyright © 2018 Chris Marusich <cmmarusich@gmail.com> +# Copyright © 2018 Ludovic Courtès <ludo@gnu.org> # # This file is part of GNU Guix. # @@ -28,11 +29,6 @@ fi guix pack --version -# FIXME: Starting from commit 66e9944e078cbb9e0d618377dd6df6e639640efa, -# '--bootstrap' is mostly ineffective since 'guix pack' produces derivations -# that refer to guile-sqlite3 and libgcrypt. For now we just skip the test. -exit 77 - # Use --no-substitutes because we need to verify we can do this ourselves. GUIX_BUILD_OPTIONS="--no-substitutes" export GUIX_BUILD_OPTIONS @@ -53,7 +49,7 @@ the_pack="`guix pack --bootstrap -S /opt/gnu/bin=bin guile-bootstrap`" # exists because /opt/gnu/bin may be an absolute symlink to a store item that # has been GC'd. test_directory="`mktemp -d`" -trap 'rm -rf "$test_directory"' EXIT +trap 'chmod -Rf +w "$test_directory"; rm -rf "$test_directory"' EXIT cd "$test_directory" tar -xf "$the_pack" test -L opt/gnu/bin diff --git a/tests/guix-package.sh b/tests/guix-package.sh index cef3b3452e..7eeb4304d1 100644 --- a/tests/guix-package.sh +++ b/tests/guix-package.sh @@ -106,6 +106,10 @@ guix package --show=guile | grep "^name: guile" # Ensure `--show' doesn't fail for packages with non-package inputs. 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 + # Search. LC_MESSAGES=C export LC_MESSAGES @@ -358,6 +362,21 @@ EOF guix package --bootstrap -m "$module_dir/manifest.scm" guix package -I | grep guile test `guix package -I | wc -l` -eq 1 +guix package --rollback --bootstrap + +# Applying a manifest file with inferior packages. +cat > "$module_dir/manifest.scm"<<EOF +(use-modules (guix inferior)) + +(define i + (open-inferior "$abs_top_srcdir" #:command "scripts/guix")) + +(let ((guile (car (lookup-inferior-packages i "guile-bootstrap")))) + (packages->manifest (list guile))) +EOF +guix package --bootstrap -m "$module_dir/manifest.scm" +guix package -I | grep guile +test `guix package -I | wc -l` -eq 1 # Error reporting. cat > "$module_dir/manifest.scm"<<EOF diff --git a/tests/guix-system.sh b/tests/guix-system.sh index 36ba5fbd5f..23d2da4903 100644 --- a/tests/guix-system.sh +++ b/tests/guix-system.sh @@ -153,8 +153,8 @@ cat > "$tmpfile" <<EOF (operating-system $OS_BASE - (services (cons* (dhcp-client-service) - (dhcp-client-service) ;twice! + (services (cons* (service dhcp-client-service-type) + (service dhcp-client-service-type) ;twice! %base-services))) EOF @@ -232,6 +232,14 @@ guix system build "$tmpfile" -d | grep '\.drv$' guix system vm "$tmpfile" -d # succeeds guix system vm "$tmpfile" -d | grep '\.drv$' +# Make sure the behavior is deterministic (<https://bugs.gnu.org/32652>). +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`" +test "$drv1" = "$drv2" + make_user_config "group-that-does-not-exist" "users" if guix system build "$tmpfile" -n 2> "$errorfile" then false diff --git a/tests/hash.scm b/tests/hash.scm deleted file mode 100644 index 47dff3915b..0000000000 --- a/tests/hash.scm +++ /dev/null @@ -1,128 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2017, 2018 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/>. - -(define-module (test-hash) - #:use-module (guix hash) - #:use-module (guix base16) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-64) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports)) - -;; Test the (guix hash) module. - -(define %empty-sha256 - ;; SHA256 hash of the empty string. - (base16-string->bytevector - "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855")) - -(define %hello-sha256 - ;; SHA256 hash of "hello world" - (base16-string->bytevector - "b94d27b9934d3e08a52e52d7da7dabfac484efe37a5380ee9088f7ace2efcde9")) - - -(test-begin "hash") - -(test-equal "sha1, empty" - (base16-string->bytevector "da39a3ee5e6b4b0d3255bfef95601890afd80709") - (sha1 #vu8())) - -(test-equal "sha1, hello" - (base16-string->bytevector "2aae6c35c94fcfb415dbe95f408b9ce91ee846ed") - (sha1 (string->utf8 "hello world"))) - -(test-equal "sha256, empty" - %empty-sha256 - (sha256 #vu8())) - -(test-equal "sha256, hello" - %hello-sha256 - (sha256 (string->utf8 "hello world"))) - -(test-equal "open-sha256-port, empty" - %empty-sha256 - (let-values (((port get) - (open-sha256-port))) - (close-port port) - (get))) - -(test-equal "open-sha256-port, hello" - (list %hello-sha256 (string-length "hello world")) - (let-values (((port get) - (open-sha256-port))) - (put-bytevector port (string->utf8 "hello world")) - (force-output port) - (list (get) (port-position port)))) - -(test-assert "port-sha256" - (let* ((file (search-path %load-path "ice-9/psyntax.scm")) - (size (stat:size (stat file))) - (contents (call-with-input-file file get-bytevector-all))) - (equal? (sha256 contents) - (call-with-input-file file port-sha256)))) - -(test-equal "open-sha256-input-port, empty" - `("" ,%empty-sha256) - (let-values (((port get) - (open-sha256-input-port (open-string-input-port "")))) - (let ((str (get-string-all port))) - (list str (get))))) - -(test-equal "open-sha256-input-port, hello" - `("hello world" ,%hello-sha256) - (let-values (((port get) - (open-sha256-input-port - (open-bytevector-input-port - (string->utf8 "hello world"))))) - (let ((str (get-string-all port))) - (list str (get))))) - -(test-equal "open-sha256-input-port, hello, one two" - (list (string->utf8 "hel") (string->utf8 "lo") - (base16-string->bytevector ; echo -n hello | sha256sum - "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824") - " world") - (let-values (((port get) - (open-sha256-input-port - (open-bytevector-input-port (string->utf8 "hello world"))))) - (let* ((one (get-bytevector-n port 3)) - (two (get-bytevector-n port 2)) - (hash (get)) - (three (get-string-all port))) - (list one two hash three)))) - -(test-equal "open-sha256-input-port, hello, read from wrapped port" - (list (string->utf8 "hello") - (base16-string->bytevector ; echo -n hello | sha256sum - "2cf24dba5fb0a30e26e83b2ac5b9e29e1b161e5c1fa7425e73043362938b9824") - " world") - (let*-values (((wrapped) - (open-bytevector-input-port (string->utf8 "hello world"))) - ((port get) - (open-sha256-input-port wrapped))) - (let* ((hello (get-bytevector-n port 5)) - (hash (get)) - - ;; Now read from WRAPPED to make sure its current position is - ;; correct. - (world (get-string-all wrapped))) - (list hello hash world)))) - -(test-end) diff --git a/tests/inferior.scm b/tests/inferior.scm index 5e0f8ae66e..d5a894ca8f 100644 --- a/tests/inferior.scm +++ b/tests/inferior.scm @@ -17,11 +17,18 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (test-inferior) + #:use-module (guix tests) #:use-module (guix inferior) #:use-module (guix packages) + #:use-module (guix store) + #:use-module (guix profiles) + #:use-module (guix derivations) #:use-module (gnu packages) + #:use-module (gnu packages bootstrap) + #:use-module (gnu packages guile) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-64)) + #:use-module (srfi srfi-64) + #:use-module (ice-9 match)) (define %top-srcdir (dirname (search-path %load-path "guix.scm"))) @@ -29,6 +36,16 @@ (define %top-builddir (dirname (search-path %load-compiled-path "guix.go"))) +(define %store + (open-connection-for-tests)) + +(define (manifest-entry->list entry) + (list (manifest-entry-name entry) + (manifest-entry-version entry) + (manifest-entry-output entry) + (manifest-entry-search-paths entry) + (map manifest-entry->list (manifest-entry-dependencies entry)))) + (test-begin "inferior") @@ -45,9 +62,11 @@ (test-equal "inferior-packages" (take (sort (fold-packages (lambda (package lst) - (alist-cons (package-name package) + (cons (list (package-name package) (package-version package) - lst)) + (package-home-page package) + (package-location package)) + lst)) '()) (lambda (x y) (string<? (car x) (car y)))) @@ -56,14 +75,131 @@ #:command "scripts/guix")) (packages (inferior-packages inferior))) (and (every string? (map inferior-package-synopsis packages)) - (begin + (let () + (define result + (take (sort (map (lambda (package) + (list (inferior-package-name package) + (inferior-package-version package) + (inferior-package-home-page package) + (inferior-package-location package))) + packages) + (lambda (x y) + (string<? (car x) (car y)))) + 10)) (close-inferior inferior) - (take (sort (map (lambda (package) - (cons (inferior-package-name package) - (inferior-package-version package))) - packages) - (lambda (x y) - (string<? (car x) (car y)))) - 10))))) + result)))) + +(test-equal "lookup-inferior-packages" + (let ((->list (lambda (package) + (list (package-name package) + (package-version package) + (package-location package))))) + (list (map ->list (find-packages-by-name "guile" #f)) + (map ->list (find-packages-by-name "guile" "2.2")))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (->list (lambda (package) + (list (inferior-package-name package) + (inferior-package-version package) + (inferior-package-location package)))) + (lst1 (map ->list + (lookup-inferior-packages inferior "guile"))) + (lst2 (map ->list + (lookup-inferior-packages inferior + "guile" "2.2")))) + (close-inferior inferior) + (list lst1 lst2))) + +(test-assert "lookup-inferior-packages and eq?-ness" + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (lst1 (lookup-inferior-packages inferior "guile")) + (lst2 (lookup-inferior-packages inferior "guile"))) + (close-inferior inferior) + (every eq? lst1 lst2))) + +(test-equal "inferior-package-inputs" + (let ((->list (match-lambda + ((label (? package? package) . rest) + `(,label + (package ,(package-name package) + ,(package-version package) + ,(package-location package)) + ,@rest))))) + (list (map ->list (package-inputs guile-2.2)) + (map ->list (package-native-inputs guile-2.2)) + (map ->list (package-propagated-inputs guile-2.2)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (->list (match-lambda + ((label (? inferior-package? package) . rest) + `(,label + (package ,(inferior-package-name package) + ,(inferior-package-version package) + ,(inferior-package-location package)) + ,@rest)))) + (result (list (map ->list (inferior-package-inputs guile)) + (map ->list + (inferior-package-native-inputs guile)) + (map ->list + (inferior-package-propagated-inputs + guile))))) + (close-inferior inferior) + result)) + +(test-equal "inferior-package-search-paths" + (package-native-search-paths guile-2.2) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (result (inferior-package-native-search-paths guile))) + (close-inferior inferior) + result)) + +(test-equal "inferior-eval-with-store" + (add-text-to-store %store "foo" "Hello, world!") + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix"))) + (inferior-eval-with-store inferior %store + '(lambda (store) + (add-text-to-store store "foo" + "Hello, world!"))))) + +(test-equal "inferior-package-derivation" + (map derivation-file-name + (list (package-derivation %store %bootstrap-guile "x86_64-linux") + (package-derivation %store %bootstrap-guile "armhf-linux"))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (packages (inferior-packages inferior)) + (guile (find (lambda (package) + (string=? (package-name %bootstrap-guile) + (inferior-package-name package))) + packages))) + (map derivation-file-name + (list (inferior-package-derivation %store guile "x86_64-linux") + (inferior-package-derivation %store guile "armhf-linux"))))) + +(test-equal "inferior-package->manifest-entry" + (manifest-entry->list (package->manifest-entry + (first (find-best-packages-by-name "guile" #f)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (entry (inferior-package->manifest-entry guile))) + (close-inferior inferior) + (manifest-entry->list entry))) + +(test-equal "packages->manifest" + (map manifest-entry->list + (manifest-entries (packages->manifest + (find-best-packages-by-name "guile" #f)))) + (let* ((inferior (open-inferior %top-builddir + #:command "scripts/guix")) + (guile (first (lookup-inferior-packages inferior "guile"))) + (manifest (packages->manifest (list guile)))) + (close-inferior inferior) + (map manifest-entry->list (manifest-entries manifest)))) (test-end "inferior") diff --git a/tests/lint.scm b/tests/lint.scm index ab0e8b9a8c..300153e24e 100644 --- a/tests/lint.scm +++ b/tests/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2013 Cyril Roelandt <tipecaml@gmail.com> ;;; Copyright © 2014, 2015, 2016 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> ;;; Copyright © 2017 Alex Kost <alezost@gmail.com> @@ -365,7 +365,7 @@ (arguments '(#:imported-modules (invalid-module)))))) (check-derivation pkg))) - "failed to create derivation"))) + "failed to create"))) (test-assert "license: invalid license" (string-contains diff --git a/tests/nar.scm b/tests/nar.scm index 9b5fb984b4..5ffe68c9e2 100644 --- a/tests/nar.scm +++ b/tests/nar.scm @@ -21,10 +21,12 @@ #:use-module (guix nar) #:use-module (guix serialization) #:use-module (guix store) - #:use-module ((guix hash) + #:use-module ((gcrypt hash) #:select (open-sha256-port open-sha256-input-port)) #:use-module ((guix packages) #:select (base32)) + #:use-module ((guix build utils) + #:select (find-files)) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (srfi srfi-1) @@ -332,13 +334,6 @@ (lambda () (rmdir input))))) -;; 'restore-file-set' depends on 'open-sha256-input-port', which in turn -;; relies on a Guile 2.0.10+ feature. -(test-skip (if (false-if-exception - (open-sha256-input-port (%make-void-port "r"))) - 0 - 3)) - (test-assert "restore-file-set (signed, valid)" (with-store store (let* ((texts (unfold (cut >= <> 10) @@ -361,7 +356,43 @@ (map (lambda (file) (call-with-input-file file get-string-all)) - files)))))))) + files)) + (every canonical-file? files))))))) + +(test-assert "restore-file-set with directories (signed, valid)" + ;; <https://bugs.gnu.org/33361> describes a bug whereby directories + ;; containing files subject to deduplication were not canonicalized--i.e., + ;; their mtime and permissions were not reset. Ensure that this bug is + ;; gone. + (with-store store + (let* ((text1 (random-text)) + (text2 (random-text)) + (tree `("tree" directory + ("a" regular (data ,text1)) + ("b" directory + ("c" regular (data ,text2)) + ("d" regular (data ,text1))))) ;duplicate + (file (add-file-tree-to-store store tree)) + (dump (call-with-bytevector-output-port + (cute export-paths store (list file) <>)))) + (delete-paths store (list file)) + (and (not (file-exists? file)) + (let* ((source (open-bytevector-input-port dump)) + (imported (restore-file-set source))) + (and (equal? imported (list file)) + (file-exists? file) + (valid-path? store file) + (string=? text1 + (call-with-input-file (string-append file "/a") + get-string-all)) + (string=? text2 + (call-with-input-file + (string-append file "/b/c") + get-string-all)) + (= (stat:ino (stat (string-append file "/a"))) ;deduplication + (stat:ino (stat (string-append file "/b/d")))) + (every canonical-file? + (find-files file #:directories? #t)))))))) (test-assert "restore-file-set (missing signature)" (let/ec return diff --git a/tests/opam.scm b/tests/opam.scm index 26832174a8..a1320abfdc 100644 --- a/tests/opam.scm +++ b/tests/opam.scm @@ -19,7 +19,7 @@ (define-module (test-opam) #:use-module (guix import opam) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module ((guix build utils) #:select (delete-file-recursively mkdir-p which)) #:use-module (srfi srfi-64) diff --git a/tests/pack.scm b/tests/pack.scm index d4596f863a..40473a9fe9 100644 --- a/tests/pack.scm +++ b/tests/pack.scm @@ -22,11 +22,13 @@ #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix profiles) + #:use-module (guix packages) #:use-module (guix monads) #:use-module (guix grafts) #:use-module (guix tests) #:use-module (guix gexp) #:use-module (gnu packages bootstrap) + #:use-module ((gnu packages compression) #:select (squashfs-tools-next)) #:use-module (srfi srfi-64)) (define %store @@ -35,10 +37,11 @@ ;; Globally disable grafts because they can trigger early builds. (%graft? #f) -(define-syntax-rule (test-assertm name exp) +(define-syntax-rule (test-assertm name store exp) (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) + (let ((guile (package-derivation store %bootstrap-guile))) + (run-with-store store exp + #:guile-for-build guile)))) (define %gzip-compressor ;; Compressor that uses the bootstrap 'gzip'. @@ -52,7 +55,7 @@ (test-begin "pack") (unless (network-reachable?) (test-skip 1)) -(test-assertm "self-contained-tarball" +(test-assertm "self-contained-tarball" %store (mlet* %store-monad ((profile (profile-derivation (packages->manifest (list %bootstrap-guile)) @@ -65,18 +68,151 @@ #:archiver %tar-bootstrap)) (check (gexp->derivation "check-tarball" - #~(let ((bin (string-append "." #$profile "/bin"))) - (setenv "PATH" - (string-append #$%tar-bootstrap "/bin")) - (system* "tar" "xvf" #$tarball) - (mkdir #$output) - (exit - (and (file-exists? (string-append bin "/guile")) - (string=? (string-append #$%bootstrap-guile "/bin") - (readlink bin)) - (string=? (string-append ".." #$profile - "/bin/guile") - (readlink "bin/Guile")))))))) + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-1)) + + (define store + ;; The unpacked store. + (string-append "." (%store-directory) "/")) + + (define (canonical? file) + ;; Return #t if FILE is read-only and its mtime is 1. + (let ((st (lstat file))) + (or (not (string-prefix? store file)) + (eq? 'symlink (stat:type st)) + (and (= 1 (stat:mtime st)) + (zero? (logand #o222 + (stat:mode st))))))) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? (string-append bin "/guile")) + (file-exists? store) + (every canonical? + (find-files "." (const #t) + #:directories? #t)) + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)) + (string=? (string-append ".." #$profile + "/bin/guile") + (readlink "bin/Guile"))))))))) (built-derivations (list check)))) +;; The following test needs guile-sqlite3, libgcrypt, etc. as a consequence of +;; commit c45477d2a1a651485feede20fe0f3d15aec48b39 and related changes. Thus, +;; run it on the user's store, if it's available, on the grounds that these +;; dependencies may be already there, or we can get substitutes or build them +;; quite inexpensively; see <https://bugs.gnu.org/32184>. + +(with-external-store store + (unless store (test-skip 1)) + (test-assertm "self-contained-tarball + localstatedir" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (self-contained-tarball "tar-pack" profile + #:localstatedir? #t)) + (check (gexp->derivation + "check-tarball" + #~(let ((bin (string-append "." #$profile "/bin"))) + (setenv "PATH" + (string-append #$%tar-bootstrap "/bin")) + (system* "tar" "xvf" #$tarball) + (mkdir #$output) + (exit + (and (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (readlink bin)))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "docker-image + localstatedir" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (tarball (docker-image "docker-pack" profile + #:symlinks '(("/bin/Guile" -> "bin/guile")) + #:localstatedir? #t)) + (check (gexp->derivation + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" (string-append #$%tar-bootstrap "/bin")) + (mkdir "base") + (with-directory-excursion "base" + (invoke "tar" "xvf" #$tarball)) + + (match (find-files "base" "layer.tar") + ((layer) + (invoke "tar" "xvf" layer))) + + (when + (and (file-exists? (string-append bin "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + (string=? (string-append #$profile "/bin/guile") + (pk 'guilelink (readlink "bin/Guile")))) + (mkdir #$output))))))) + (built-derivations (list check)))) + + (unless store (test-skip 1)) + (test-assertm "squashfs-image + localstatedir" store + (mlet* %store-monad + ((guile (set-guile-for-build (default-guile))) + (profile (profile-derivation (packages->manifest + (list %bootstrap-guile)) + #:hooks '() + #:locales? #f)) + (image (squashfs-image "squashfs-pack" profile + #:symlinks '(("/bin" -> "bin")) + #:localstatedir? #t)) + (check (gexp->derivation + "check-tarball" + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (ice-9 match)) + + (define bin + (string-append "." #$profile "/bin")) + + (setenv "PATH" + (string-append #$squashfs-tools-next "/bin")) + (invoke "unsquashfs" #$image) + (with-directory-excursion "squashfs-root" + (when (and (file-exists? (string-append bin + "/guile")) + (file-exists? "var/guix/db/db.sqlite") + (string=? (string-append #$%bootstrap-guile "/bin") + (pk 'binlink (readlink bin))) + (string=? (string-append #$profile "/bin") + (pk 'guilelink (readlink "bin")))) + (mkdir #$output)))))))) + (built-derivations (list check))))) + (test-end) + +;; Local Variables: +;; eval: (put 'test-assertm 'scheme-indent-function 2) +;; End: diff --git a/tests/packages.scm b/tests/packages.scm index 65ccb14889..237feb7aba 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -28,7 +28,7 @@ #:renamer (lambda (name) (cond ((eq? name 'location) 'make-location) (else name)))) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix derivations) #:use-module (guix packages) #:use-module (guix grafts) diff --git a/tests/pk-crypto.scm b/tests/pk-crypto.scm deleted file mode 100644 index fe33a6f7b5..0000000000 --- a/tests/pk-crypto.scm +++ /dev/null @@ -1,290 +0,0 @@ -;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2017 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/>. - -(define-module (test-pk-crypto) - #:use-module (guix pk-crypto) - #:use-module (guix utils) - #:use-module (guix base16) - #:use-module (guix hash) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-64) - #:use-module (rnrs bytevectors) - #:use-module (rnrs io ports) - #:use-module (ice-9 match)) - -;; Test the (guix pk-crypto) module. - -(define %key-pair - ;; RSA key pair that was generated with: - ;; (generate-key (string->canonical-sexp "(genkey (rsa (nbits 4:1024)))")) - ;; which takes a bit of time. - "(key-data - (public-key - (rsa - (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#) - (e #010001#))) - (private-key - (rsa - (n #00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45#) - (e #010001#) - (d #58CAD84653D0046A8EC3F9AA82D9C829B145422109FC3F12DA01A694B92FA296E70D366FB166454D30E632CEE3A033B4C41781BA10325F69FCDC0250CA19C8EEB352FA085992494098DB133E682ED38A931701F0DED1A1E508F4341A4FB446A04F019427C7CB3C44F251EEA9D386100DA80F125E0FD5CE1B0DFEC6D21516EACD#) - (p #00D47F185147EC39393CCDA4E7323FFC20FC8B8073E2A54DD63BA392A66975E4204CA48572496A9DFD7522436B852C07472A5AB25B7706F7C14E6F33FBC420FF3B#) - (q #00E9AD22F158060BC9AE3601DA623AFC60FFF3058795802CA92371C00097335CF9A23D7782DE353C9DBA93D7BB99E6A24A411107605E722481C5C191F80D7EB77F#) - (u #59B45B95AE01A7A7370FAFDB08FE73A4793CE37F228961B09B1B1E7DDAD9F8D3E28F5C5E8B4B067E6B8E0BBF3F690B42991A79E46108DDCDA2514323A66964DE#))))") - -(define %ecc-key-pair - ;; Ed25519 key pair generated with: - ;; (generate-key (string->canonical-sexp "(genkey (ecdsa (curve Ed25519) (flags rfc6979 transient)))")) - "(key-data - (public-key - (ecc - (curve Ed25519) - (q #94869C1B9E69DB8DD910B7F7F4D6E56A63A964A59AE8F90F6703ACDDF6F50C81#))) - (private-key - (ecc - (curve Ed25519) - (q #94869C1B9E69DB8DD910B7F7F4D6E56A63A964A59AE8F90F6703ACDDF6F50C81#) - (d #6EFB32D0B4EC6B3237B523539F1979379B82726AAA605EB2FBA6775B2B777B78#))))") - -(test-begin "pk-crypto") - -(test-assert "version" - (gcrypt-version)) - -(let ((sexps '("(foo bar)" - - ;; In Libgcrypt 1.5.3 the following integer is rendered as - ;; binary, whereas in 1.6.0 it's rendered as is (hexadecimal.) - ;;"#C0FFEE#" - - "(genkey \n (rsa \n (nbits \"1024\")\n )\n )"))) - (test-equal "string->canonical-sexp->string" - sexps - (let ((sexps (map string->canonical-sexp sexps))) - (and (every canonical-sexp? sexps) - (map (compose string-trim-both canonical-sexp->string) sexps))))) - -(gc) ; stress test! - -(let ((sexps `(("(foo bar)" foo -> "(foo bar)") - ("(foo (bar (baz 3:123)))" baz -> "(baz \"123\")") - ("(foo (bar 3:123))" baz -> #f)))) - (test-equal "find-sexp-token" - (map (match-lambda - ((_ _ '-> expected) - expected)) - sexps) - (map (match-lambda - ((input token '-> _) - (let ((sexp (find-sexp-token (string->canonical-sexp input) token))) - (and sexp - (string-trim-both (canonical-sexp->string sexp)))))) - sexps))) - -(gc) - -(test-equal "canonical-sexp-length" - '(0 1 2 4 0 0) - (map (compose canonical-sexp-length string->canonical-sexp) - '("()" "(a)" "(a b)" "(a #616263# b #C001#)" "a" "#123456#"))) - -(test-equal "canonical-sexp-list?" - '(#t #f #t #f) - (map (compose canonical-sexp-list? string->canonical-sexp) - '("()" "\"abc\"" "(a b c)" "#123456#"))) - -(gc) - -(test-equal "canonical-sexp-car + cdr" - '("(b \n (c xyz)\n )") - (let ((lst (string->canonical-sexp "(a (b (c xyz)))"))) - (map (lambda (sexp) - (and sexp (string-trim-both (canonical-sexp->string sexp)))) - ;; Note: 'car' returns #f when the first element is an atom. - (list (canonical-sexp-car (canonical-sexp-cdr lst)))))) - -(gc) - -(test-equal "canonical-sexp-nth" - '("(b pqr)" "(c \"456\")" "(d xyz)" #f #f) - - (let ((lst (string->canonical-sexp "(a (b 3:pqr) (c 3:456) (d 3:xyz))"))) - ;; XXX: In Libgcrypt 1.5.3, (canonical-sexp-nth lst 0) returns LST, whereas in - ;; 1.6.0 it returns #f. - (map (lambda (sexp) - (and sexp (string-trim-both (canonical-sexp->string sexp)))) - (unfold (cut > <> 5) - (cut canonical-sexp-nth lst <>) - 1+ - 1)))) - -(gc) - -(test-equal "canonical-sexp-nth-data" - `(Name Otto Meier #f ,(base16-string->bytevector "123456") #f) - (let ((lst (string->canonical-sexp - "(Name Otto Meier (address Burgplatz) #123456#)"))) - (unfold (cut > <> 5) - (cut canonical-sexp-nth-data lst <>) - 1+ - 0))) - -(let ((bv (base16-string->bytevector - "5eff0b55c9c5f5e87b4e34cd60a2d5654ca1eb78c7b3c67c3179fed1cff07b4c"))) - (test-equal "hash corrupt due to restrictive locale encoding" - bv - - ;; In Guix up to 0.6 included this test would fail because at some point - ;; the hash value would be cropped to ASCII. In practice 'guix - ;; authenticate' would produce invalid signatures that would fail - ;; signature verification. See <http://bugs.gnu.org/17312>. - (let ((locale (setlocale LC_ALL))) - (dynamic-wind - (lambda () - (setlocale LC_ALL "C")) - (lambda () - (hash-data->bytevector - (string->canonical-sexp - (canonical-sexp->string - (bytevector->hash-data bv "sha256"))))) - (lambda () - (setlocale LC_ALL locale)))))) - -(gc) - -;; XXX: The test below is typically too long as it needs to gather enough entropy. - -;; (test-assert "generate-key" -;; (let ((key (generate-key (string->canonical-sexp -;; "(genkey (rsa (nbits 3:128)))")))) -;; (and (canonical-sexp? key) -;; (find-sexp-token key 'key-data) -;; (find-sexp-token key 'public-key) -;; (find-sexp-token key 'private-key)))) - -(test-assert "bytevector->hash-data->bytevector" - (let* ((bv (sha256 (string->utf8 "Hello, world."))) - (data (bytevector->hash-data bv "sha256"))) - (and (canonical-sexp? data) - (let-values (((value algo) (hash-data->bytevector data))) - (and (string=? algo "sha256") - (bytevector=? value bv)))))) - -(test-equal "key-type" - '(rsa ecc) - (map (compose key-type - (cut find-sexp-token <> 'public-key) - string->canonical-sexp) - (list %key-pair %ecc-key-pair))) - -(test-assert "sign + verify" - (let* ((pair (string->canonical-sexp %key-pair)) - (secret (find-sexp-token pair 'private-key)) - (public (find-sexp-token pair 'public-key)) - (data (bytevector->hash-data - (sha256 (string->utf8 "Hello, world.")) - #:key-type (key-type public))) - (sig (sign data secret))) - (and (verify sig data public) - (not (verify sig - (bytevector->hash-data - (sha256 (string->utf8 "Hi!")) - #:key-type (key-type public)) - public))))) - -;; Ed25519 appeared in libgcrypt 1.6.0. -(test-skip (if (version>? (gcrypt-version) "1.6.0") 0 1)) -(test-assert "sign + verify, Ed25519" - (let* ((pair (string->canonical-sexp %ecc-key-pair)) - (secret (find-sexp-token pair 'private-key)) - (public (find-sexp-token pair 'public-key)) - (data (bytevector->hash-data - (sha256 (string->utf8 "Hello, world.")))) - (sig (sign data secret))) - (and (verify sig data public) - (not (verify sig - (bytevector->hash-data - (sha256 (string->utf8 "Hi!"))) - public))))) - -(gc) - -(test-equal "canonical-sexp->sexp" - `((data - (flags pkcs1) - (hash sha256 - ,(base16-string->bytevector - "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))) - - (public-key - (rsa - (n ,(base16-string->bytevector - (string-downcase - "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) - (e ,(base16-string->bytevector - "010001"))))) - - (list (canonical-sexp->sexp - (string->canonical-sexp - "(data - (flags pkcs1) - (hash \"sha256\" - #2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb#))")) - - (canonical-sexp->sexp - (find-sexp-token (string->canonical-sexp %key-pair) - 'public-key)))) - - -(let ((lst - `((data - (flags pkcs1) - (hash sha256 - ,(base16-string->bytevector - "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb"))) - - (public-key - (rsa - (n ,(base16-string->bytevector - (string-downcase - "00C1F764069F54FFE93A126B02328903E984E4AE3AF6DF402B5B6B3907911B88C385F1BA76A002EC9DEA109A5228EF0E62EE31A06D1A5861CAB474F6C857AC66EB65A1905F25BBA1869579E73A3B7FED13AF5A1667326F88CDFC2FF24B03C14FD1384AA7E73CA89572880B606E3A974E15347963FC7B6378574936A47580DBCB45"))) - (e ,(base16-string->bytevector - "010001")))) - - ,(base16-string->bytevector - "2749f0ea9f26c6c7be746a9cff8fa4c2f2a02b000070dba78429e9a11f87c6eb")))) - (test-equal "sexp->canonical-sexp->sexp" - lst - (map (compose canonical-sexp->sexp sexp->canonical-sexp) - lst))) - -(let ((sexp `(signature - (public-key - (rsa - (n ,(make-bytevector 1024 1)) - (e ,(base16-string->bytevector "010001"))))))) - (test-equal "https://bugs.g10code.com/gnupg/issue1594" - ;; The gcrypt bug above was primarily affecting our uses in - ;; 'canonical-sexp->sexp', typically when applied to a signature sexp (in - ;; 'guix authenticate -verify') with a "big" RSA key, such as 4096 bits. - sexp - (canonical-sexp->sexp (sexp->canonical-sexp sexp)))) - -(test-end) diff --git a/tests/pki.scm b/tests/pki.scm index 876ad98d73..d6a6b476c7 100644 --- a/tests/pki.scm +++ b/tests/pki.scm @@ -18,8 +18,8 @@ (define-module (test-pki) #:use-module (guix pki) - #:use-module (guix pk-crypto) - #:use-module (guix hash) + #:use-module (gcrypt pk-crypto) + #:use-module (gcrypt hash) #:use-module (rnrs io ports) #:use-module (srfi srfi-64)) diff --git a/tests/processes.scm b/tests/processes.scm new file mode 100644 index 0000000000..40454bcbc7 --- /dev/null +++ b/tests/processes.scm @@ -0,0 +1,86 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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/>. + +(define-module (test-processes) + #:use-module (guix scripts processes) + #:use-module (guix store) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module ((guix utils) #:select (call-with-temporary-directory)) + #:use-module (gnu packages bootstrap) + #:use-module (guix tests) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match) + #:use-module (ice-9 threads)) + +(test-begin "processes") + +(test-assert "not a client" + (not (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions)))) + +(test-assert "client" + (with-store store + (let* ((session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (daemon (daemon-session-process session))) + (and (kill (process-id daemon) 0) + (string-suffix? "guix-daemon" (first (process-command daemon))))))) + +(test-assert "client + lock" + (with-store store + (call-with-temporary-directory + (lambda (directory) + (let* ((token1 (string-append directory "/token1")) + (token2 (string-append directory "/token2")) + (exp #~(begin #$(random-text) + (mkdir #$token1) + (let loop () + (unless (file-exists? #$token2) + (sleep 1) + (loop))) + (mkdir #$output))) + (guile (package-derivation store %bootstrap-guile)) + (drv (run-with-store store + (gexp->derivation "foo" exp + #:guile-for-build guile))) + (thread (call-with-new-thread + (lambda () + (build-derivations store (list drv))))) + (_ (let loop () + (unless (file-exists? token1) + (usleep 200) + (loop)))) + (session (find (lambda (session) + (= (getpid) + (process-id (daemon-session-client session)))) + (daemon-sessions))) + (locks (daemon-session-locks-held (pk 'session session)))) + (call-with-output-file token2 (const #t)) + (equal? (list (string-append (derivation->output-path drv) ".lock")) + locks)))))) + +(test-end "processes") diff --git a/tests/profiles.scm b/tests/profiles.scm index 3a59a0cc4f..1f9bbd099d 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -20,6 +20,7 @@ (define-module (test-profiles) #:use-module (guix tests) #:use-module (guix profiles) + #:use-module (guix gexp) #:use-module (guix store) #:use-module (guix monads) #:use-module (guix grafts) @@ -46,17 +47,6 @@ ;; Globally disable grafts because they can trigger early builds. (%graft? #f) -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - -(define-syntax-rule (test-equalm name value exp) - (test-equal name - value - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - ;; Example manifest entries. (define guile-1.8.8 @@ -543,6 +533,41 @@ get-string-all) "foo!")))))) +(test-assertm "profile-derivation when etc/ is a relative symlink" + ;; See <https://bugs.gnu.org/32686>. + (mlet* %store-monad + ((etc (gexp->derivation + "etc" + #~(begin + (mkdir #$output) + (call-with-output-file (string-append #$output "/foo") + (lambda (port) + (display "Heya!" port)))))) + (thing -> (dummy-package "dummy" + (build-system trivial-build-system) + (inputs + `(("etc" ,etc))) + (arguments + `(#:guile ,%bootstrap-guile + #:builder + (let ((out (assoc-ref %outputs "out")) + (etc (assoc-ref %build-inputs "etc"))) + (mkdir out) + (symlink etc (string-append out "/etc")) + #t))))) + (entry -> (package->manifest-entry thing)) + (drv (profile-derivation (manifest (list entry)) + #:relative-symlinks? #t + #:hooks '() + #:locales? #f)) + (profile -> (derivation->output-path drv))) + (mbegin %store-monad + (built-derivations (list drv)) + (return (string=? (call-with-input-file + (string-append profile "/etc/foo") + get-string-all) + "Heya!"))))) + (test-equalm "union vs. dangling symlink" ;<https://bugs.gnu.org/26949> "does-not-exist" (mlet* %store-monad diff --git a/tests/publish.scm b/tests/publish.scm index 1ed8308076..0e793c1ee5 100644 --- a/tests/publish.scm +++ b/tests/publish.scm @@ -25,7 +25,7 @@ #:use-module (guix tests) #:use-module (guix config) #:use-module (guix utils) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix store) #:use-module (guix derivations) #:use-module (guix gexp) @@ -33,7 +33,7 @@ #:use-module (guix base64) #:use-module ((guix records) #:select (recutils->alist)) #:use-module ((guix serialization) #:select (restore-file)) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module ((guix pki) #:select (%public-key-file %private-key-file)) #:use-module (guix zlib) #:use-module (web uri) diff --git a/tests/pypi.scm b/tests/pypi.scm index 310c6c8f29..6daa44a6e7 100644 --- a/tests/pypi.scm +++ b/tests/pypi.scm @@ -20,7 +20,7 @@ (define-module (test-pypi) #:use-module (guix import pypi) #:use-module (guix base32) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix tests) #:use-module (guix build-system python) #:use-module ((guix build utils) #:select (delete-file-recursively which)) @@ -81,7 +81,7 @@ baz > 13.37") (dummy-package "foo" (source (dummy-origin (uri - "https://pypi.io/packages/source/p/psutil/psutil-4.3.0.tar.gz")))))) + "https://pypi.org/packages/source/p/psutil/psutil-4.3.0.tar.gz")))))) (test-equal "guix-package->pypi-name, new URL style" "certbot" diff --git a/tests/records.scm b/tests/records.scm index 80e08a9a5f..09ada70c2d 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -313,8 +313,9 @@ (lambda () (eval '(foo? (make-me-a-record)) module) #f) - (lambda (key rtd . _) - (eq? rtd (eval '<foo> module)))))) + (match-lambda* + ((key 'abi-check (? string? message) (rtd) . _) + (eq? rtd (eval '<foo> module))))))) (test-equal "recutils->alist" '((("Name" . "foo") diff --git a/tests/services.scm b/tests/services.scm index b146a0dec2..5827dee80d 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -138,6 +138,31 @@ (equal? (list s1 s2) (instantiate-missing-services (list s1 s2)))))) +(test-assert "instantiate-missing-services, indirect" + (let* ((t1 (service-type (name 't1) (extensions '()) + (default-value 'dflt) + (compose concatenate) + (extend cons))) + (t2 (service-type (name 't2) (extensions '()) + (default-value 'dflt2) + (compose concatenate) + (extend cons) + (extensions + (list (service-extension t1 list))))) + (t3 (service-type (name 't3) + (extensions + (list (service-extension t2 list))))) + (s1 (service t1)) + (s2 (service t2)) + (s3 (service t3 42)) + (== (cut lset= equal? <...>))) + (and (== (list s1 s2 s3) + (instantiate-missing-services (list s3))) + (== (list s1 s2 s3) + (instantiate-missing-services (list s1 s3))) + (== (list s1 s2 s3) + (instantiate-missing-services (list s2 s3)))))) + (test-assert "instantiate-missing-services, no default value" (let* ((t1 (service-type (name 't1) (extensions '()))) (t2 (service-type (name 't2) @@ -182,13 +207,14 @@ list)) (test-equal "shepherd-service-upgrade: one unchanged, one upgraded, one new" - '(((bar)) ;unload - ((bar) (baz))) ;load + '(() ;unload + ((foo))) ;restart (call-with-values (lambda () - ;; Here 'foo' is not upgraded because it is still running, whereas - ;; 'bar' is upgraded because it is not currently running. 'baz' is - ;; loaded because it's a new service. + ;; Here 'foo' is replaced and must be explicitly restarted later + ;; because it is still running, whereas 'bar' is upgraded right away + ;; because it is not currently running. 'baz' is loaded because it's + ;; a new service. (shepherd-service-upgrade (list (live-service '(foo) '() #t) (live-service '(bar) '() #f) @@ -199,30 +225,31 @@ (start #t)) (shepherd-service (provision '(baz)) (start #t))))) - (lambda (unload load) + (lambda (unload restart) (list (map live-service-provision unload) - (map shepherd-service-provision load))))) + (map shepherd-service-provision restart))))) (test-equal "shepherd-service-upgrade: service depended on is not unloaded" '(((baz)) ;unload - ()) ;load + ((foo))) ;restart (call-with-values (lambda () ;; Service 'bar' is not among the target services; yet, it must not be - ;; unloaded because 'foo' depends on it. + ;; unloaded because 'foo' depends on it. 'foo' gets replaced but it + ;; must be restarted manually. (shepherd-service-upgrade (list (live-service '(foo) '(bar) #t) (live-service '(bar) '() #t) ;still used! (live-service '(baz) '() #t)) (list (shepherd-service (provision '(foo)) (start #t))))) - (lambda (unload load) + (lambda (unload restart) (list (map live-service-provision unload) - (map shepherd-service-provision load))))) + (map shepherd-service-provision restart))))) (test-equal "shepherd-service-upgrade: obsolete services that depend on each other" '(((foo) (bar) (baz)) ;unload - ((qux))) ;load + ()) ;restart (call-with-values (lambda () ;; 'foo', 'bar', and 'baz' depend on each other, but all of them are @@ -233,9 +260,9 @@ (live-service '(baz) '() #t)) ;obsolete (list (shepherd-service (provision '(qux)) (start #t))))) - (lambda (unload load) + (lambda (unload restart) (list (map live-service-provision unload) - (map shepherd-service-provision load))))) + (map shepherd-service-provision restart))))) (test-eq "lookup-service-types" system-service-type diff --git a/tests/size.scm b/tests/size.scm index 575b1abfdd..0aaa8fbc29 100644 --- a/tests/size.scm +++ b/tests/size.scm @@ -30,14 +30,6 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-64)) -(define %store - (open-connection-for-tests)) - -(define-syntax-rule (test-assertm name exp) - (test-assert name - (run-with-store %store exp - #:guile-for-build (%guile-for-build)))) - (test-begin "size") diff --git a/tests/status.scm b/tests/status.scm new file mode 100644 index 0000000000..99abb41c8b --- /dev/null +++ b/tests/status.scm @@ -0,0 +1,183 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 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/>. + +(define-module (test-status) + #:use-module (guix status) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-64) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:use-module (ice-9 match)) + +(test-begin "status") + +(test-equal "compute-status, no-op" + (build-status) + (let-values (((port get-status) + (build-event-output-port compute-status))) + (display "foo\nbar\n\baz\n" port) + (get-status))) + +(test-equal "compute-status, builds + substitutes" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 500 + #:start 'now)))) + (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 500 + #:transferred 42 + #:start 'now)))) + (build-status + (builds-completed '("foo.drv")) + (downloads-completed (list (download "bar" "http://example.org/bar" + #:size 500 + #:transferred 500 + #:start 'now + #:end 'now))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv\n" port) + (display "@ substituter-started bar\n" port) + (display "@ download-started bar http://example.org/bar 500\n" port) + (display "various\nthings\nget\nwritten\n" port) + (let ((first (get-status))) + (display "@ download-progress bar http://example.org/bar 500 42\n" + port) + (let ((second (get-status))) + (display "@ download-progress bar http://example.org/bar 500 84\n" + port) + (display "@ build-succeeded foo.drv\n" port) + (display "@ download-succeeded bar http://example.org/bar 500\n" port) + (display "Almost done!\n" port) + (display "@ substituter-succeeded bar\n" port) + (list first second (get-status)))))) + +(test-equal "compute-status, missing events" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "baz" "http://example.org/baz" + #:size 500 + #:transferred 42 + #:start 'now) + (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 0 + #:start 'now)))) + (build-status + (builds-completed '("foo.drv")) + (downloads-completed (list (download "baz" "http://example.org/baz" + #:size 500 + #:transferred 500 + #:start 'now + #:end 'now) + (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 999 + #:start 'now + #:end 'now))))) + ;; Below we omit 'substituter-started' events and the like. + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) + (display "@ build-started foo.drv\n" port) + (display "@ download-started bar http://example.org/bar 999\n" port) + (display "various\nthings\nget\nwritten\n" port) + (display "@ download-progress baz http://example.org/baz 500 42\n" + port) + (let ((first (get-status))) + (display "@ build-succeeded foo.drv\n" port) + (display "@ download-succeeded bar http://example.org/bar 999\n" port) + (display "Almost done!\n" port) + (display "@ substituter-succeeded baz\n" port) + (list first (get-status))))) + +(test-equal "build-output-port, UTF-8" + '((build-log #f "lambda is λ!\n")) + (let-values (((port get-status) (build-event-output-port cons '())) + ((bv) (string->utf8 "lambda is λ!\n"))) + (put-bytevector port bv) + (force-output port) + (get-status))) + +(test-equal "current-build-output-port, UTF-8 + garbage" + ;; What about a mixture of UTF-8 + garbage? + (let ((replacement (cond-expand + ((and guile-2 (not guile-2.2)) "?") + (else "�")))) + `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n")))) + (let-values (((port get-status) (build-event-output-port cons '()))) + (display "garbage: " port) + (put-bytevector port #vu8(128)) + (put-bytevector port (string->utf8 "lambda: λ\n")) + (force-output port) + (get-status))) + +(test-equal "compute-status, multiplexed build output" + (list (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:start 'now)))) + (build-status + (building '("foo.drv")) + (downloading (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 42 + #:start 'now)))) + (build-status + ;; XXX: Should "bar.drv" be present twice? + (builds-completed '("bar.drv" "foo.drv")) + (downloads-completed (list (download "bar" "http://example.org/bar" + #:size 999 + #:transferred 999 + #:start 'now + #:end 'now))))) + (let-values (((port get-status) + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now) + #:derivation-path->output-path + (match-lambda + ("bar.drv" "bar"))))))) + (display "@ build-started foo.drv 121\n" port) + (display "@ build-started bar.drv 144\n" port) + (display "@ build-log 121 6\nHello!" port) + (display "@ build-log 144 50 +@ download-started bar http://example.org/bar 999\n" port) + (let ((first (get-status))) + (display "@ build-log 121 30\n@ build-started FAKE!.drv 555\n") + (display "@ build-log 144 54 +@ download-progress bar http://example.org/bar 999 42\n" + port) + (let ((second (get-status))) + (display "@ download-succeeded bar http://example.org/bar 999\n" port) + (display "@ build-succeeded foo.drv\n" port) + (display "@ build-succeeded bar.drv\n" port) + (list first second (get-status)))))) + +(test-end "status") diff --git a/tests/store-deduplication.scm b/tests/store-deduplication.scm index 4ca2ec0f61..e438aa84c6 100644 --- a/tests/store-deduplication.scm +++ b/tests/store-deduplication.scm @@ -19,7 +19,7 @@ (define-module (test-store-deduplication) #:use-module (guix tests) #:use-module (guix store deduplication) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module ((guix utils) #:select (call-with-temporary-directory)) #:use-module (guix build utils) #:use-module (rnrs bytevectors) diff --git a/tests/store.scm b/tests/store.scm index 47fab0df18..3ff526cdcf 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -21,7 +21,7 @@ #:use-module (guix store) #:use-module (guix utils) #:use-module (guix monads) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix base32) #:use-module (guix packages) #:use-module (guix derivations) @@ -31,6 +31,7 @@ #:use-module (gnu packages) #:use-module (gnu packages bootstrap) #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (web uri) @@ -45,6 +46,9 @@ (define %store (open-connection-for-tests)) +(define %shell + (or (getenv "SHELL") (getenv "CONFIG_SHELL"))) + (test-begin "store") @@ -220,7 +224,8 @@ ("./foo/c" directory #t) ("./foo/c/p" regular "file p") ("./foo/c/q" directory #t) - ("./foo/c/q/x" regular "#!/bin/sh\nexit 42") + ("./foo/c/q/x" regular + ,(string-append "#!" %shell "\nexit 42")) ("./foo/c/q/y" symlink "..") ("./foo/c/q/z" directory #t)) (let* ((tree `("file-tree" directory @@ -231,7 +236,7 @@ ("p" regular (data ,(string->utf8 "file p"))) ("q" directory ("x" executable - (data "#!/bin/sh\nexit 42")) + (data ,(string-append "#!" %shell "\nexit 42"))) ("y" symlink "..") ("z" directory)))) ("bar" directory))) @@ -1017,4 +1022,66 @@ (call-with-input-file (derivation->output-path drv2) read)))))) +(test-equal "multiplexed-build-output" + '("Hello from first." "Hello from second.") + (with-store store + (let* ((build (add-text-to-store store "build.sh" + "echo Hello from $NAME.; echo > $out")) + (bash (add-to-store store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (drv1 (derivation store "one" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("NAME" . "first") + ("x" . ,(random-text))))) + (drv2 (derivation store "two" bash + `("-e" ,build) + #:inputs `((,bash) (,build)) + #:env-vars `(("NAME" . "second") + ("x" . ,(random-text)))))) + (set-build-options store + #:print-build-trace #t + #:multiplexed-build-output? #t + #:max-build-jobs 10) + (let ((port (open-output-string))) + ;; Send the build log to PORT. + (parameterize ((current-build-output-port port)) + (build-derivations store (list drv1 drv2))) + + ;; Retrieve the build log; make sure it contains valid "@ build-log" + ;; traces that allow us to retrieve each builder's output (we assume + ;; there's exactly one "build-output" trace for each builder, which is + ;; reasonable.) + (let* ((log (get-output-string port)) + (started (fold-matches + (make-regexp "@ build-started ([^ ]+) - ([^ ]+) ([^ ]+) ([0-9]+)") + log '() cons)) + (done (fold-matches + (make-regexp "@ build-succeeded (.*) - (.*) (.*) (.*)") + log '() cons)) + (output (fold-matches + (make-regexp "@ build-log ([[:digit:]]+) ([[:digit:]]+)\n([A-Za-z .*]+)\n") + log '() cons)) + (drv-pid (lambda (name) + (lambda (m) + (let ((drv (match:substring m 1)) + (pid (string->number + (match:substring m 4)))) + (and (string-suffix? name drv) pid))))) + (pid-log (lambda (pid) + (lambda (m) + (let ((n (string->number + (match:substring m 1))) + (len (string->number + (match:substring m 2))) + (str (match:substring m 3))) + (and (= pid n) + (= (string-length str) (- len 1)) + str))))) + (pid1 (any (drv-pid "one.drv") started)) + (pid2 (any (drv-pid "two.drv") started))) + (list (any (pid-log pid1) output) + (any (pid-log pid2) output))))))) + (test-end "store") diff --git a/tests/substitute.scm b/tests/substitute.scm index 0ad6247954..964a57f30b 100644 --- a/tests/substitute.scm +++ b/tests/substitute.scm @@ -20,9 +20,9 @@ (define-module (test-substitute) #:use-module (guix scripts substitute) #:use-module (guix base64) - #:use-module (guix hash) + #:use-module (gcrypt hash) #:use-module (guix serialization) - #:use-module (guix pk-crypto) + #:use-module (gcrypt pk-crypto) #:use-module (guix pki) #:use-module (guix config) #:use-module (guix base32) |