diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/base32.scm | 10 | ||||
| -rw-r--r-- | tests/derivations.scm | 8 | ||||
| -rw-r--r-- | tests/gexp.scm | 10 | ||||
| -rw-r--r-- | tests/guix-archive.sh | 3 | ||||
| -rw-r--r-- | tests/guix-build.sh | 82 | ||||
| -rw-r--r-- | tests/guix-gc.sh | 20 | ||||
| -rw-r--r-- | tests/guix-package-net.sh | 2 | ||||
| -rw-r--r-- | tests/guix-package.sh | 37 | ||||
| -rw-r--r-- | tests/guix-register.sh | 46 | ||||
| -rw-r--r-- | tests/guix-system.sh | 65 | ||||
| -rw-r--r-- | tests/hackage.scm | 88 | ||||
| -rw-r--r-- | tests/monads.scm | 26 | ||||
| -rw-r--r-- | tests/packages.scm | 30 | ||||
| -rw-r--r-- | tests/profiles.scm | 107 | ||||
| -rw-r--r-- | tests/store.scm | 54 | ||||
| -rw-r--r-- | tests/utils.scm | 3 |
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) |