aboutsummaryrefslogtreecommitdiff
path: root/tests
diff options
context:
space:
mode:
Diffstat (limited to 'tests')
-rw-r--r--tests/base32.scm10
-rw-r--r--tests/derivations.scm8
-rw-r--r--tests/gexp.scm10
-rw-r--r--tests/guix-archive.sh3
-rw-r--r--tests/guix-build.sh82
-rw-r--r--tests/guix-gc.sh20
-rw-r--r--tests/guix-package-net.sh2
-rw-r--r--tests/guix-package.sh37
-rw-r--r--tests/guix-register.sh46
-rw-r--r--tests/guix-system.sh65
-rw-r--r--tests/hackage.scm88
-rw-r--r--tests/monads.scm26
-rw-r--r--tests/packages.scm30
-rw-r--r--tests/profiles.scm107
-rw-r--r--tests/store.scm54
-rw-r--r--tests/utils.scm3
16 files changed, 528 insertions, 63 deletions
diff --git a/tests/base32.scm b/tests/base32.scm
index 81d242355a..dcd926f4b8 100644
--- a/tests/base32.scm
+++ b/tests/base32.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +21,7 @@
#:use-module (guix base32)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-64)
#:use-module (ice-9 rdelim)
#:use-module (ice-9 popen)
@@ -77,6 +78,13 @@
;; Examples from RFC 4648.
(map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
+(test-equal "&invalid-base32-character"
+ #\e
+ (guard (c ((invalid-base32-character? c)
+ (invalid-base32-character-value c)))
+ (nix-base32-string->bytevector
+ (string-append (make-string 51 #\a) "e"))))
+
;; The following test requires `nix-hash' in $PATH.
(unless %have-nix-hash?
(test-skip 1))
diff --git a/tests/derivations.scm b/tests/derivations.scm
index a8cccac34a..df5f07d117 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -499,12 +499,16 @@
(string=? path (derivation-file-name (%guile-for-build)))))
(derivation-prerequisites drv))))
-(test-assert "derivation-prerequisites and derivation-input-is-valid?"
+(test-assert "derivation-prerequisites and valid-derivation-input?"
(let* ((a (build-expression->derivation %store "a" '(mkdir %output)))
(b (build-expression->derivation %store "b" `(list ,(random-text))))
(c (build-expression->derivation %store "c" `(mkdir %output)
#:inputs `(("a" ,a) ("b" ,b)))))
- (build-derivations %store (list a))
+ ;; Make sure both A and %BOOTSTRAP-GUILE are built (the latter could have
+ ;; be removed by tests/guix-gc.sh.)
+ (build-derivations %store
+ (list a (package-derivation %store %bootstrap-guile)))
+
(match (derivation-prerequisites c
(cut valid-derivation-input? %store
<>))
diff --git a/tests/gexp.scm b/tests/gexp.scm
index f81ef39860..7e14073fd4 100644
--- a/tests/gexp.scm
+++ b/tests/gexp.scm
@@ -109,6 +109,16 @@
(eq? x local)))
(equal? `(display ,intd) (gexp->sexp* exp)))))
+(test-assert "one plain file"
+ (let* ((file (plain-file "hi" "Hello, world!"))
+ (exp (gexp (display (ungexp file))))
+ (expected (add-text-to-store %store "hi" "Hello, world!")))
+ (and (gexp? exp)
+ (match (gexp-inputs exp)
+ (((x "out"))
+ (eq? x file)))
+ (equal? `(display ,expected) (gexp->sexp* exp)))))
+
(test-assert "same input twice"
(let ((exp (gexp (begin
(display (ungexp coreutils))
diff --git a/tests/guix-archive.sh b/tests/guix-archive.sh
index d4259b8677..8eacf89338 100644
--- a/tests/guix-archive.sh
+++ b/tests/guix-archive.sh
@@ -1,5 +1,5 @@
# GNU Guix --- Functional package management for GNU
-# Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+# Copyright © 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
#
# This file is part of GNU Guix.
#
@@ -41,7 +41,6 @@ cmp "$archive" "$archive_alt"
# Check the exit value and stderr upon import.
guix archive --import < "$archive"
-guix archive --import < "$archive" 2>&1 | grep "import.*guile-bootstrap"
if guix archive something-that-does-not-exist
then false; else true; fi
diff --git a/tests/guix-build.sh b/tests/guix-build.sh
index 836c45e776..a72ce0911d 100644
--- a/tests/guix-build.sh
+++ b/tests/guix-build.sh
@@ -36,6 +36,88 @@ guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)' | \
guix build hello -d | \
grep -e '-hello-[0-9\.]\+\.drv$'
+# Check --sources option with its arguments
+module_dir="t-guix-build-$$"
+mkdir "$module_dir"
+trap "rm -rf $module_dir" EXIT
+
+cat > "$module_dir/foo.scm"<<EOF
+(define-module (foo)
+ #:use-module (guix packages)
+ #:use-module (guix download)
+ #:use-module (guix build-system trivial))
+
+(define-public foo
+ (package
+ (name "foo")
+ (version "42")
+ (source (origin
+ (method url-fetch)
+ (uri "http://www.example.com/foo.tar.gz")
+ (sha256
+ (base32
+ "xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx"))))
+ (build-system trivial-build-system)
+ (inputs
+ (quasiquote (("bar" ,bar))))
+ (home-page "www.example.com")
+ (synopsis "Dummy package")
+ (description "foo is a dummy package for testing.")
+ (license #f)))
+
+(define-public bar
+ (package
+ (name "bar")
+ (version "9001")
+ (source (origin
+ (method url-fetch)
+ (uri "http://www.example.com/bar.tar.gz")
+ (sha256
+ (base32
+ "yyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyyy"))))
+ (build-system trivial-build-system)
+ (inputs
+ (quasiquote
+ (("data" ,(origin
+ (method url-fetch)
+ (uri "http://www.example.com/bar.dat")
+ (sha256
+ (base32
+ "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz")))))))
+ (home-page "www.example.com")
+ (synopsis "Dummy package")
+ (description "bar is a dummy package for testing.")
+ (license #f)))
+EOF
+
+GUIX_PACKAGE_PATH="$module_dir"
+export GUIX_PACKAGE_PATH
+
+# foo.tar.gz
+guix build -d -S foo
+guix build -d -S foo | grep -e 'foo\.tar\.gz'
+
+guix build -d --sources=package foo
+guix build -d --sources=package foo | grep -e 'foo\.tar\.gz'
+
+# bar.tar.gz and bar.dat
+guix build -d --sources bar
+test `guix build -d --sources bar \
+ | grep -e 'bar\.tar\.gz' -e 'bar\.dat' \
+ | wc -l` -eq 2
+
+# bar.tar.gz and bar.dat
+guix build -d --sources=all bar
+test `guix build -d --sources bar \
+ | grep -e 'bar\.tar\.gz' -e 'bar\.dat' \
+ | wc -l` -eq 2
+
+# Should include foo.tar.gz, bar.tar.gz, and bar.dat
+guix build -d --sources=transitive foo
+test `guix build -d --sources=transitive foo \
+ | grep -e 'foo\.tar\.gz' -e 'bar\.tar\.gz' -e 'bar\.dat' \
+ | wc -l` -eq 3
+
# Should all return valid log files.
drv="`guix build -d -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
out="`guix build -e '(@@ (gnu packages bootstrap) %bootstrap-guile)'`"
diff --git a/tests/guix-gc.sh b/tests/guix-gc.sh
index eac9d82e89..c1eb66cef5 100644
--- a/tests/guix-gc.sh
+++ b/tests/guix-gc.sh
@@ -64,3 +64,23 @@ guix gc -C 1KiB
# Check trivial error cases.
if guix gc --delete /dev/null;
then false; else true; fi
+
+# Bug #19757
+out="`guix build guile-bootstrap`"
+test -d "$out"
+
+guix gc --delete "$out"
+
+! test -d "$out"
+
+out="`guix build guile-bootstrap`"
+test -d "$out"
+
+guix gc --delete "$out/"
+
+! test -d "$out"
+
+out="`guix build guile-bootstrap`"
+test -d "$out"
+
+guix gc --delete "$out/bin/guile"
diff --git a/tests/guix-package-net.sh b/tests/guix-package-net.sh
index cf3233bee2..14222cfd25 100644
--- a/tests/guix-package-net.sh
+++ b/tests/guix-package-net.sh
@@ -147,7 +147,7 @@ test "`readlink_base "$profile"`" = "$profile-2-link"
# Make sure LIBRARY_PATH gets listed by `--search-paths'.
guix package --bootstrap -p "$profile" -i guile-bootstrap -i gcc-bootstrap
-guix package --search-paths -p "$profile" | grep LIBRARY_PATH
+guix package -p "$profile" --search-paths | grep LIBRARY_PATH
# Roll back so we can delete #3 below.
guix package -p "$profile" --switch-generation=2
diff --git a/tests/guix-package.sh b/tests/guix-package.sh
index a732110d5c..b361b1ba00 100644
--- a/tests/guix-package.sh
+++ b/tests/guix-package.sh
@@ -52,8 +52,13 @@ test -L "$profile" && test -L "$profile-1-link"
test -f "$profile/bin/guile"
# No search path env. var. here.
-guix package --search-paths -p "$profile"
-test "`guix package --search-paths -p "$profile" | wc -l`" = 0
+guix package -p "$profile" --search-paths
+guix package -p "$profile" --search-paths | grep '^export PATH='
+test "`guix package -p "$profile" --search-paths | wc -l`" = 1 # $PATH
+( set -e; set -x; \
+ eval `guix package --search-paths=prefix -p "$PWD/$profile"`; \
+ test "`type -P guile`" = "$PWD/$profile/bin/guile" ; \
+ type -P rm )
# Exit with 1 when a generation does not exist.
if guix package -p "$profile" --delete-generations=42;
@@ -237,3 +242,31 @@ export GUIX_BUILD_OPTIONS
available2="`guix package -A | sort`"
test "$available2" = "$available"
guix package -I
+
+unset GUIX_BUILD_OPTIONS
+
+# Applying a manifest file.
+cat > "$module_dir/manifest.scm"<<EOF
+(use-package-modules bootstrap)
+
+(packages->manifest (list %bootstrap-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
+(use-package-modules bootstrap)
+(packages->manifest
+ (list %bootstrap-guile
+ wonderful-package-that-does-not-exist))
+EOF
+if guix package --bootstrap -n -m "$module_dir/manifest.scm" \
+ 2> "$module_dir/stderr"
+then false
+else
+ cat "$module_dir/stderr"
+ grep "manifest.scm:[1-3]:.*[Uu]nbound variable.*wonderful-package" \
+ "$module_dir/stderr"
+fi
diff --git a/tests/guix-register.sh b/tests/guix-register.sh
index 7084ac6b8c..360cf55979 100644
--- a/tests/guix-register.sh
+++ b/tests/guix-register.sh
@@ -56,15 +56,14 @@ guile -c "
(exit (= (stat:ino (stat \"$new_file\"))
(stat:ino (stat \"$new_file2\"))))"
-# Make sure both are valid, and delete them.
+# Make sure both are valid.
guile -c "
(use-modules (guix store))
(define s (open-connection))
(exit (and (valid-path? s \"$new_file\")
(valid-path? s \"$new_file2\")
(null? (references s \"$new_file\"))
- (null? (references s \"$new_file2\"))
- (pair? (delete-paths s (list \"$new_file\" \"$new_file2\")))))"
+ (null? (references s \"$new_file2\"))))"
#
@@ -98,6 +97,33 @@ guix-register --prefix "$new_store" "$closure"
guix-register -p "$new_store" \
--state-directory "$new_store/chbouib" "$closure"
+# Register duplicate files.
+cp "$new_file" "$new_file2" "$new_store_dir"
+guix-register -p "$new_store" <<EOF
+$new_file
+
+0
+EOF
+guix-register -p "$new_store" <<EOF
+$new_file2
+
+0
+EOF
+
+copied_duplicate1="$new_store_dir/`basename $new_file`"
+copied_duplicate2="$new_store_dir/`basename $new_file2`"
+
+# Make sure there is indeed deduplication under $new_store and that there are
+# no cross-store hard links.
+guile -c "
+ (exit (and (= (stat:ino (stat \"$copied_duplicate1\"))
+ (stat:ino (stat \"$copied_duplicate2\")))
+ (not (= (stat:ino (stat \"$new_file\"))
+ (stat:ino (stat \"$copied_duplicate1\"))))))"
+
+# Delete them.
+guix gc -d "$new_file" "$new_file2"
+
# Now make sure this is recognized as valid.
ls -R "$new_store"
@@ -107,12 +133,13 @@ do
NIX_STATE_DIR="$new_store$state_dir"
NIX_LOG_DIR="$new_store$state_dir/log/guix"
NIX_DB_DIR="$new_store$state_dir/db"
+ GUIX_DAEMON_SOCKET="$NIX_STATE_DIR/daemon-socket/socket"
export NIX_IGNORE_SYMLINK_STORE NIX_STORE_DIR NIX_STATE_DIR \
- NIX_LOG_DIR NIX_DB_DIR
+ NIX_LOG_DIR NIX_DB_DIR GUIX_DAEMON_SOCKET
# Check whether we overflow the limitation on local socket name lengths.
- if [ `echo "$NIX_STATE_DIR/daemon-socket/socket" | wc -c` -ge 108 ]
+ if [ `echo "$GUIX_DAEMON_SOCKET" | wc -c` -ge 108 ]
then
# Mark the test as skipped even though we already did some work so
# that the remainder is not silently skipped.
@@ -130,9 +157,12 @@ do
# that name in a 'valid-path?' query because 'assertStorePath' would kill
# us because of the wrong prefix. So we just list dead paths instead.
guile -c "
- (use-modules (guix store))
- (define s (open-connection))
- (exit (equal? (list \"$copied\") (dead-paths s)))"
+ (use-modules (guix store) (srfi srfi-1))
+ (define s (open-connection \"$GUIX_DAEMON_SOCKET\"))
+ (exit (lset= string=?
+ (pk 1 (list \"$copied\" \"$copied_duplicate1\"
+ \"$copied_duplicate2\"))
+ (pk 2 (dead-paths s))))"
# Kill the daemon so we can access the database below (otherwise we may
# get "database is locked" errors.)
diff --git a/tests/guix-system.sh b/tests/guix-system.sh
index 1b77d1a0db..4289db2390 100644
--- a/tests/guix-system.sh
+++ b/tests/guix-system.sh
@@ -45,6 +45,32 @@ else
fi
+# Reporting of unbound variables.
+
+cat > "$tmpfile" <<EOF
+(use-modules (gnu)) ; 1
+(use-service-modules networking) ; 2
+
+(operating-system ; 4
+ (host-name "antelope") ; 5
+ (timezone "Europe/Paris") ; 6
+ (locale "en_US.UTF-8") ; 7
+
+ (bootloader (GRUB-config (device "/dev/sdX"))) ; 9
+ (file-systems (cons (file-system
+ (device "root")
+ (title 'label)
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems)))
+EOF
+
+if guix system build "$tmpfile" -n 2> "$errorfile"
+then false
+else
+ grep "$tmpfile:9:.*[Uu]nbound variable.*GRUB-config" "$errorfile"
+fi
+
# Reporting of duplicate service identifiers.
cat > "$tmpfile" <<EOF
@@ -76,3 +102,42 @@ then
else
grep "service 'networking'.*more than once" "$errorfile"
fi
+
+make_user_config ()
+{
+ cat > "$tmpfile" <<EOF
+(use-modules (gnu))
+(use-service-modules networking)
+
+(operating-system
+ (host-name "antelope")
+ (timezone "Europe/Paris")
+ (locale "en_US.UTF-8")
+
+ (bootloader (grub-configuration (device "/dev/sdX")))
+ (file-systems (cons (file-system
+ (device "root")
+ (title 'label)
+ (mount-point "/")
+ (type "ext4"))
+ %base-file-systems))
+ (users (list (user-account
+ (name "dave")
+ (home-directory "/home/dave")
+ (group "$1")
+ (supplementary-groups '("$2"))))))
+EOF
+}
+
+make_user_config "users" "wheel"
+guix system build "$tmpfile" -n # succeeds
+
+make_user_config "group-that-does-not-exist" "users"
+if guix system build "$tmpfile" -n 2> "$errorfile"
+then false
+else grep "primary group.*group-that-does-not-exist.*undeclared" "$errorfile"; fi
+
+make_user_config "users" "group-that-does-not-exist"
+if guix system build "$tmpfile" -n 2> "$errorfile"
+then false
+else grep "supplementary group.*group-that-does-not-exist.*undeclared" "$errorfile"; fi
diff --git a/tests/hackage.scm b/tests/hackage.scm
index 23b854caa4..229bee35ea 100644
--- a/tests/hackage.scm
+++ b/tests/hackage.scm
@@ -17,6 +17,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-hackage)
+ #:use-module (guix import cabal)
#:use-module (guix import hackage)
#:use-module (guix tests)
#:use-module (srfi srfi-64)
@@ -35,44 +36,44 @@ executable cabal
mtl >= 2.0 && < 3
")
-;; Use TABs to indent lines and to separate keys from value.
(define test-cabal-2
- "name: foo
-version: 1.0.0
-homepage: http://test.org
-synopsis: synopsis
-description: description
-license: BSD3
-executable cabal
- build-depends: HTTP >= 4000.2.5 && < 4000.3,
- mtl >= 2.0 && < 3
-")
-
-;; Use indentation with comma as found, e.g., in 'haddock-api'.
-(define test-cabal-3
"name: foo
version: 1.0.0
homepage: http://test.org
synopsis: synopsis
description: description
license: BSD3
-executable cabal
- build-depends:
- HTTP >= 4000.2.5 && < 4000.3
- , mtl >= 2.0 && < 3
+executable cabal {
+build-depends:
+ HTTP >= 4000.2.5 && < 4000.3,
+ mtl >= 2.0 && < 3
+}
")
-(define test-cond-1
- "(os(darwin) || !(flag(debug))) && flag(cips)")
-
-(define read-cabal
- (@@ (guix import hackage) read-cabal))
-
-(define eval-cabal-keywords
- (@@ (guix import hackage) eval-cabal-keywords))
-
-(define conditional->sexp-like
- (@@ (guix import hackage) conditional->sexp-like))
+;; A fragment of a real Cabal file with minor modification to check precedence
+;; of 'and' over 'or'.
+(define test-read-cabal-1
+ "name: test-me
+library
+ -- Choose which library versions to use.
+ if flag(base4point8)
+ Build-depends: base >= 4.8 && < 5
+ else
+ if flag(base4)
+ Build-depends: base >= 4 && < 4.8
+ else
+ if flag(base3)
+ Build-depends: base >= 3 && < 4
+ else
+ Build-depends: base < 3
+ if flag(base4point8) || flag(base4) && flag(base3)
+ Build-depends: random
+ Build-depends: containers
+
+ -- Modules that are always built.
+ Exposed-Modules:
+ Test.QuickCheck.Exception
+")
(test-begin "hackage")
@@ -115,18 +116,25 @@ executable cabal
(test-assert "hackage->guix-package test 2"
(eval-test-with-cabal test-cabal-2))
-(test-assert "hackage->guix-package test 3"
- (eval-test-with-cabal test-cabal-3))
-
-(test-assert "conditional->sexp-like"
- (match
- (eval-cabal-keywords
- (conditional->sexp-like test-cond-1)
- '(("debug" . "False")))
- (('and ('or ('string-match "darwin" ('%current-system)) ('not '#f)) '#t)
+(test-assert "read-cabal test 1"
+ (match (call-with-input-string test-read-cabal-1 read-cabal)
+ ((("name" ("test-me"))
+ ('section 'library
+ (('if ('flag "base4point8")
+ (("build-depends" ("base >= 4.8 && < 5")))
+ (('if ('flag "base4")
+ (("build-depends" ("base >= 4 && < 4.8")))
+ (('if ('flag "base3")
+ (("build-depends" ("base >= 3 && < 4")))
+ (("build-depends" ("base < 3"))))))))
+ ('if ('or ('flag "base4point8")
+ ('and ('flag "base4") ('flag "base3")))
+ (("build-depends" ("random")))
+ ())
+ ("build-depends" ("containers"))
+ ("exposed-modules" ("Test.QuickCheck.Exception")))))
#t)
- (x
- (pk 'fail x #f))))
+ (x (pk 'fail x #f))))
(test-end "hackage")
diff --git a/tests/monads.scm b/tests/monads.scm
index 57a8e66797..d3ef065f24 100644
--- a/tests/monads.scm
+++ b/tests/monads.scm
@@ -103,6 +103,19 @@
%monads
%monad-run))
+(test-assert ">>= with more than two arguments"
+ (every (lambda (monad run)
+ (let ((1+ (lift1 1+ monad))
+ (2* (lift1 (cut * 2 <>) monad)))
+ (with-monad monad
+ (let ((number (random 777)))
+ (= (run (>>= (return number)
+ 1+ 1+ 1+
+ 2* 2* 2*))
+ (* 8 (+ number 3)))))))
+ %monads
+ %monad-run))
+
(test-assert "mbegin"
(every (lambda (monad run)
(with-monad monad
@@ -163,7 +176,7 @@
(test-assert "mapm"
(every (lambda (monad run)
(with-monad monad
- (equal? (run (mapm monad (lift1 1+ monad) (map return (iota 10))))
+ (equal? (run (mapm monad (lift1 1+ monad) (iota 10)))
(map 1+ (iota 10)))))
%monads
%monad-run))
@@ -202,11 +215,12 @@
(test-assert "anym"
(every (lambda (monad run)
(eq? (run (with-monad monad
- (let ((lst (list (return 1) (return 2) (return 3))))
- (anym monad
- (lambda (x)
- (and (odd? x) 'odd!))
- lst))))
+ (anym monad
+ (lift1 (lambda (x)
+ (and (odd? x) 'odd!))
+ monad)
+ (append (make-list 1000 0)
+ (list 1 2)))))
'odd!))
%monads
%monad-run))
diff --git a/tests/packages.scm b/tests/packages.scm
index 4e52813659..511ad78b6c 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -155,6 +155,36 @@
(package-transitive-supported-systems d)
(package-transitive-supported-systems e))))
+(let* ((o (dummy-origin))
+ (u (dummy-origin))
+ (i (dummy-origin))
+ (a (dummy-package "a"))
+ (b (dummy-package "b"
+ (inputs `(("a" ,a) ("i" ,i)))))
+ (c (package (inherit b) (source o)))
+ (d (dummy-package "d"
+ (build-system trivial-build-system)
+ (source u) (inputs `(("c" ,c))))))
+ (test-assert "package-direct-sources, no source"
+ (null? (package-direct-sources a)))
+ (test-equal "package-direct-sources, #f source"
+ (list i)
+ (package-direct-sources b))
+ (test-equal "package-direct-sources, not input source"
+ (list u)
+ (package-direct-sources d))
+ (test-assert "package-direct-sources"
+ (let ((s (package-direct-sources c)))
+ (and (= (length (pk 's-sources s)) 2)
+ (member o s)
+ (member i s))))
+ (test-assert "package-transitive-sources"
+ (let ((s (package-transitive-sources d)))
+ (and (= (length (pk 'd-sources s)) 3)
+ (member o s)
+ (member i s)
+ (member u s)))))
+
(test-equal "package-transitive-supported-systems, implicit inputs"
%supported-systems
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 54fbaea864..cc9a822cee 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -24,10 +24,14 @@
#:use-module (guix monads)
#:use-module (guix packages)
#:use-module (guix derivations)
+ #:use-module (guix build-system trivial)
#:use-module (gnu packages bootstrap)
#:use-module ((gnu packages base) #:prefix packages:)
+ #:use-module ((gnu packages guile) #:prefix packages:)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 popen)
+ #:use-module (rnrs io ports)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-64))
@@ -198,6 +202,109 @@
#:hooks '())))
(return (derivation-inputs drv))))
+(test-assertm "profile-manifest, search-paths"
+ (mlet* %store-monad
+ ((guile -> (package
+ (inherit %bootstrap-guile)
+ (native-search-paths
+ (package-native-search-paths packages:guile-2.0))))
+ (entry -> (package->manifest-entry guile))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()))
+ (profile -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+
+ ;; Read the manifest back and make sure search paths are preserved.
+ (let ((manifest (profile-manifest profile)))
+ (match (manifest-entries manifest)
+ ((result)
+ (return (equal? (manifest-entry-search-paths result)
+ (manifest-entry-search-paths entry)
+ (package-native-search-paths
+ packages:guile-2.0)))))))))
+
+(test-assertm "etc/profile"
+ ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
+ (mlet* %store-monad
+ ((guile -> (package
+ (inherit %bootstrap-guile)
+ (native-search-paths
+ (package-native-search-paths packages:guile-2.0))))
+ (entry -> (package->manifest-entry guile))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()))
+ (profile -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let* ((pipe (open-input-pipe
+ (string-append "unset GUIX_PROFILE; "
+ ;; 'source' is a Bashism; use '.' (dot).
+ ". " profile "/etc/profile; "
+ ;; Don't try to parse set(1) output because
+ ;; it differs among shells; just use echo.
+ "echo $PATH")))
+ (path (get-string-all pipe)))
+ (return
+ (and (zero? (close-pipe pipe))
+ (string-contains path (string-append profile "/bin"))))))))
+
+(test-assertm "etc/profile when etc/ already exists"
+ ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
+ ;; etc/ directory, which makes it read-only. Make sure the profile build
+ ;; handles that.
+ (mlet* %store-monad
+ ((thing -> (dummy-package "dummy"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (mkdir (string-append out "/etc"))
+ (call-with-output-file (string-append out "/etc/foo")
+ (lambda (port)
+ (display "foo!" port))))))))
+ (entry -> (package->manifest-entry thing))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()))
+ (profile -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (return (and (file-exists? (string-append profile "/etc/profile"))
+ (string=? (call-with-input-file
+ (string-append profile "/etc/foo")
+ get-string-all)
+ "foo!"))))))
+
+(test-assertm "etc/profile when etc/ is a symlink"
+ ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
+ ;; gracelessly because 'scandir' would return #f.
+ (mlet* %store-monad
+ ((thing -> (dummy-package "dummy"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (mkdir (string-append out "/foo"))
+ (symlink "foo" (string-append out "/etc"))
+ (call-with-output-file (string-append out "/etc/bar")
+ (lambda (port)
+ (display "foo!" port))))))))
+ (entry -> (package->manifest-entry thing))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()))
+ (profile -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (return (and (file-exists? (string-append profile "/etc/profile"))
+ (string=? (call-with-input-file
+ (string-append profile "/etc/bar")
+ get-string-all)
+ "foo!"))))))
+
(test-end "profiles")
diff --git a/tests/store.scm b/tests/store.scm
index eeceed45c1..faa924fce9 100644
--- a/tests/store.scm
+++ b/tests/store.scm
@@ -600,6 +600,60 @@
(null? (valid-derivers %store file))
(null? (referrers %store file))))))
+(test-assert "verify-store"
+ (let* ((text (random-text))
+ (file1 (add-text-to-store %store "foo" text))
+ (file2 (add-text-to-store %store "bar" (random-text)
+ (list file1))))
+ (and (pk 'verify1 (verify-store %store)) ;hopefully OK ;
+ (begin
+ (delete-file file1)
+ (not (pk 'verify2 (verify-store %store)))) ;bad! ;
+ (begin
+ ;; Using 'add-text-to-store' here wouldn't work: It would succeed ;
+ ;; without actually creating the file. ;
+ (call-with-output-file file1
+ (lambda (port)
+ (display text port)))
+ (pk 'verify3 (verify-store %store)))))) ;OK again
+
+(test-assert "verify-store + check-contents"
+ ;; XXX: This test is I/O intensive.
+ (with-store s
+ (let* ((text (random-text))
+ (drv (build-expression->derivation
+ s "corrupt"
+ `(let ((out (assoc-ref %outputs "out")))
+ (call-with-output-file out
+ (lambda (port)
+ (display ,text port)))
+ #t)
+ #:guile-for-build
+ (package-derivation s %bootstrap-guile (%current-system))))
+ (file (derivation->output-path drv)))
+ (with-derivation-substitute drv text
+ (and (build-derivations s (list drv))
+ (verify-store s #:check-contents? #t) ;should be OK
+ (begin
+ (chmod file #o644)
+ (call-with-output-file file
+ (lambda (port)
+ (display "corrupt!" port)))
+ #t)
+
+ ;; Make sure the corruption is detected. We don't test repairing
+ ;; because only "trusted" users are allowed to do it, but we
+ ;; don't expose that notion of trusted users that nix-daemon
+ ;; supports because it seems dubious and redundant with what the
+ ;; OS provides (in Nix "trusted" users have additional
+ ;; privileges, such as overriding the set of substitute URLs, but
+ ;; we instead want to allow anyone to modify them, provided
+ ;; substitutes are signed by a root-approved key.)
+ (not (verify-store s #:check-contents? #t))
+
+ ;; Delete the corrupt item to leave the store in a clean state.
+ (delete-paths s (list file)))))))
+
(test-equal "store-lower"
"Lowered."
(let* ((add (store-lower text-file))
diff --git a/tests/utils.scm b/tests/utils.scm
index a662c9a8d3..115868c857 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
;;;
;;; This file is part of GNU Guix.
@@ -21,6 +21,7 @@
#:use-module ((guix config) #:select (%gzip))
#:use-module (guix utils)
#:use-module ((guix store) #:select (%store-prefix store-path-package-name))
+ #:use-module ((guix search-paths) #:select (string-tokenize*))
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-64)
generated by cgit v1.2.3 (git 2.45.0) at 2024-12-12 18:33:32 +0000