;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
(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)
#: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-1)
#:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-64))
;; Test the (guix profiles) module.
(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))))
+;; Globally disable grafts because they can trigger early builds.
+(%graft? #f)
;; Example manifest entries.
(_ #f))
(equal? m3 m4))))
+(test-equal "manifest-add removes duplicates" ;<https://bugs.gnu.org/30569>
+ (list guile-2.0.9)
+ (manifest-entries (manifest-add (manifest '())
+ (list guile-2.0.9 guile-2.0.9))))
+
(test-assert "manifest-perform-transaction"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(t1 (manifest-transaction
(t (manifest-transaction
(install (list guile-2.0.9 glibc))
(remove (list (manifest-pattern (name "coreutils")))))))
- (let-values (((remove install upgrade)
+ (let-values (((remove install upgrade downgrade)
(manifest-transaction-effects m0 t)))
- (and (null? remove)
+ (and (null? remove) (null? downgrade)
(equal? (list glibc) install)
(equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
+(test-assert "manifest-transaction-effects and downgrades"
+ (let* ((m0 (manifest (list guile-2.0.9)))
+ (t (manifest-transaction (install (list guile-1.8.8)))))
+ (let-values (((remove install upgrade downgrade)
+ (manifest-transaction-effects m0 t)))
+ (and (null? remove) (null? install) (null? upgrade)
+ (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
+
+(test-assert "manifest-transaction-effects and pseudo-upgrades"
+ (let* ((m0 (manifest (list guile-2.0.9)))
+ (t (manifest-transaction (install (list guile-2.0.9)))))
+ (let-values (((remove install upgrade downgrade)
+ (manifest-transaction-effects m0 t)))
+ (and (null? remove) (null? install) (null? downgrade)
+ (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
+
+(test-assert "manifest-transaction-null?"
+ (manifest-transaction-null? (manifest-transaction)))
+
+(test-assert "manifest-transaction-removal-candidate?"
+ (let ((m (manifest (list guile-2.0.9)))
+ (t (manifest-transaction
+ (remove (list (manifest-pattern (name "guile")))))))
+ (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
+ (not (manifest-transaction-removal-candidate? glibc t)))))
+
(test-assertm "profile-derivation"
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))
(guile (package->derivation %bootstrap-guile))
(drv (profile-derivation (manifest (list entry))
- #:info-dir? #f))
+ #:hooks '()
+ #:locales? #f))
(profile -> (derivation->output-path drv))
(bindir -> (string-append profile "/bin"))
(_ (built-derivations (list drv))))
(string=? (dirname (readlink bindir))
(derivation->output-path guile))))))
-(test-end "profiles")
+(test-assertm "profile-derivation relative symlinks, one entry"
+ (mlet* %store-monad
+ ((entry -> (package->manifest-entry %bootstrap-guile))
+ (guile (package->derivation %bootstrap-guile))
+ (drv (profile-derivation (manifest (list entry))
+ #:relative-symlinks? #t
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv))
+ (bindir -> (string-append profile "/bin"))
+ (_ (built-derivations (list drv))))
+ (return (and (file-exists? (string-append bindir "/guile"))
+ (string=? (readlink bindir)
+ (string-append "../"
+ (basename
+ (derivation->output-path guile))
+ "/bin"))))))
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
+(unless (network-reachable?) (test-skip 1))
+(test-assertm "profile-derivation relative symlinks, two entries"
+ (mlet* %store-monad
+ ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0))
+ (manifest -> (packages->manifest
+ (list %bootstrap-guile gnu-make-boot0)))
+ (guile (package->derivation %bootstrap-guile))
+ (make (package->derivation gnu-make-boot0))
+ (drv (profile-derivation manifest
+ #:relative-symlinks? #t
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv))
+ (bindir -> (string-append profile "/bin"))
+ (_ (built-derivations (list drv))))
+ (return (and (file-exists? (string-append bindir "/guile"))
+ (file-exists? (string-append bindir "/make"))
+ (string=? (readlink (string-append bindir "/guile"))
+ (string-append "../../"
+ (basename
+ (derivation->output-path guile))
+ "/bin/guile"))
+ (string=? (readlink (string-append bindir "/make"))
+ (string-append "../../"
+ (basename
+ (derivation->output-path make))
+ "/bin/make"))))))
+
+(test-assertm "profile-derivation, inputs"
+ (mlet* %store-monad
+ ((entry -> (package->manifest-entry packages:glibc "debug"))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()
+ #:locales? #f)))
+ (return (derivation-inputs drv))))
+
+(test-assertm "profile-derivation, cross-compilation"
+ (mlet* %store-monad
+ ((manifest -> (packages->manifest (list packages:sed packages:grep)))
+ (target -> "arm-linux-gnueabihf")
+ (grep (package->cross-derivation packages:grep target))
+ (sed (package->cross-derivation packages:sed target))
+ (locales (package->derivation packages:glibc-utf8-locales))
+ (drv (profile-derivation manifest
+ #:hooks '()
+ #:locales? #t
+ #:target target)))
+ (define (find-input package)
+ (let ((name (string-append (package-full-name package "-") ".drv")))
+ (any (lambda (input)
+ (let ((input (derivation-input-path input)))
+ (and (string-suffix? name input) input)))
+ (derivation-inputs drv))))
+
+ ;; The inputs for grep and sed should be cross-build derivations, but that
+ ;; for the glibc-utf8-locales should be a native build.
+ (return (and (string=? (derivation-system drv) (%current-system))
+ (string=? (find-input packages:grep)
+ (derivation-file-name grep))
+ (string=? (find-input packages:sed)
+ (derivation-file-name sed))
+ (string=? (find-input packages:glibc-utf8-locales)
+ (derivation-file-name locales))))))
+
+(test-assert "package->manifest-entry defaults to \"out\""
+ (let ((outputs (package-outputs packages:glibc)))
+ (equal? (manifest-entry-output
+ (package->manifest-entry (package
+ (inherit packages:glibc)
+ (outputs (reverse outputs)))))
+ (manifest-entry-output
+ (package->manifest-entry packages:glibc))
+ "out")))
+
+(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 '()
+ #:locales? #f))
+ (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-assert "package->manifest-entry, search paths"
+ ;; See <http://bugs.gnu.org/22073>.
+ (let ((mpl (@ (gnu packages python-xyz) python2-matplotlib)))
+ (lset= eq?
+ (package-transitive-native-search-paths mpl)
+ (manifest-entry-search-paths
+ (package->manifest-entry mpl)))))
+
+(test-equal "packages->manifest, propagated inputs"
+ (map (match-lambda
+ ((label package)
+ (list (package-name package) (package-version package)
+ package)))
+ (package-propagated-inputs packages:guile-2.2))
+ (map (lambda (entry)
+ (list (manifest-entry-name entry)
+ (manifest-entry-version entry)
+ (manifest-entry-item entry)))
+ (manifest-entry-dependencies
+ (package->manifest-entry packages:guile-2.2))))
+
+(test-assert "manifest-entry-parent"
+ (let ((entry (package->manifest-entry packages:guile-2.2)))
+ (match (manifest-entry-dependencies entry)
+ ((dependencies ..1)
+ (and (every (lambda (parent)
+ (eq? entry (force parent)))
+ (map manifest-entry-parent dependencies))
+ (not (force (manifest-entry-parent entry))))))))
+
+(test-assertm "read-manifest"
+ (mlet* %store-monad ((manifest -> (packages->manifest
+ (list (package
+ (inherit %bootstrap-guile)
+ (native-search-paths
+ (package-native-search-paths
+ packages:guile-2.0))))))
+ (drv (profile-derivation manifest
+ #:hooks '()
+ #:locales? #f))
+ (out -> (derivation->output-path drv)))
+ (define (entry->sexp entry)
+ (list (manifest-entry-name entry)
+ (manifest-entry-version entry)
+ (manifest-entry-search-paths entry)
+ (manifest-entry-dependencies entry)
+ (force (manifest-entry-parent entry))))
+
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let ((manifest2 (profile-manifest out)))
+ (return (equal? (map entry->sexp (manifest-entries manifest))
+ (map entry->sexp (manifest-entries manifest2))))))))
+
+(test-equal "collision"
+ '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
+ (guard (c ((profile-collision-error? c)
+ (let ((entry1 (profile-collision-error-entry c))
+ (entry2 (profile-collision-error-conflict c)))
+ (list (list (manifest-entry-name entry1)
+ (manifest-entry-version entry1))
+ (list (manifest-entry-name entry2)
+ (manifest-entry-version entry2))))))
+ (run-with-store %store
+ (mlet* %store-monad ((p0 -> (package
+ (inherit %bootstrap-guile)
+ (version "42")))
+ (p1 -> (dummy-package "p1"
+ (propagated-inputs `(("p0" ,p0)))))
+ (manifest -> (packages->manifest
+ (list %bootstrap-guile p1)))
+ (drv (profile-derivation manifest
+ #:hooks '()
+ #:locales? #f)))
+ (return #f)))))
+
+(test-equal "collision of propagated inputs"
+ '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
+ (guard (c ((profile-collision-error? c)
+ (let ((entry1 (profile-collision-error-entry c))
+ (entry2 (profile-collision-error-conflict c)))
+ (list (list (manifest-entry-name entry1)
+ (manifest-entry-version entry1))
+ (list (manifest-entry-name entry2)
+ (manifest-entry-version entry2))))))
+ (run-with-store %store
+ (mlet* %store-monad ((p0 -> (package
+ (inherit %bootstrap-guile)
+ (version "42")))
+ (p1 -> (dummy-package "p1"
+ (propagated-inputs
+ `(("guile" ,%bootstrap-guile)))))
+ (p2 -> (dummy-package "p2"
+ (propagated-inputs
+ `(("guile" ,p0)))))
+ (manifest -> (packages->manifest (list p1 p2)))
+ (drv (profile-derivation manifest
+ #:hooks '()
+ #:locales? #f)))
+ (return #f)))))
+
+(test-assertm "no collision"
+ ;; Here we have an entry that is "lowered" (its 'item' field is a store file
+ ;; name) and another entry (its 'item' field is a package) that is
+ ;; equivalent.
+ (mlet* %store-monad ((p -> (dummy-package "p"
+ (propagated-inputs
+ `(("guile" ,%bootstrap-guile)))))
+ (guile (package->derivation %bootstrap-guile))
+ (entry -> (manifest-entry
+ (inherit (package->manifest-entry
+ %bootstrap-guile))
+ (item (derivation->output-path guile))))
+ (manifest -> (manifest
+ (list entry
+ (package->manifest-entry p))))
+ (drv (profile-derivation manifest)))
+ (return (->bool drv))))
+
+(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 '()
+ #:locales? #f))
+ (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)))
+ #t)))))
+ (entry -> (package->manifest-entry thing))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()
+ #:locales? #f))
+ (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)))
+ #t)))))
+ (entry -> (package->manifest-entry thing))
+ (drv (profile-derivation (manifest (list entry))
+ #:hooks '()
+ #:locales? #f))
+ (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-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
+ ((thing1 -> (dummy-package "dummy"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder
+ (let ((out (assoc-ref %outputs "out")))
+ (mkdir out)
+ (symlink "does-not-exist"
+ (string-append out "/dangling"))
+ #t)))))
+ (thing2 -> (package (inherit thing1) (name "dummy2")))
+ (drv (profile-derivation (packages->manifest
+ (list thing1 thing2))
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (return (readlink (readlink (string-append profile "/dangling")))))))
+
+(test-end "profiles")
;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
HCoop / jackhill / guix / guix.git / blobdiff