435603a1d6
Fixes <https://bugs.gnu.org/30569>. Reported by Andreas Enge <andreas@enge.fr>. * guix/profiles.scm (manifest-add): Don't append ENTRIES as is. Instead, cons each element of ENTRIES as we fold over it. Remove unneeded ellispes in 'match' patterns.
527 lines
23 KiB
Scheme
527 lines
23 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; 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.
|
||
;;;
|
||
;;; 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-profiles)
|
||
#:use-module (guix tests)
|
||
#:use-module (guix profiles)
|
||
#: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))
|
||
|
||
;; 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
|
||
(manifest-entry
|
||
(name "guile")
|
||
(version "1.8.8")
|
||
(item "/gnu/store/...")
|
||
(output "out")))
|
||
|
||
(define guile-2.0.9
|
||
(manifest-entry
|
||
(name "guile")
|
||
(version "2.0.9")
|
||
(item "/gnu/store/...")
|
||
(output "out")))
|
||
|
||
(define guile-2.0.9:debug
|
||
(manifest-entry (inherit guile-2.0.9)
|
||
(output "debug")))
|
||
|
||
(define glibc
|
||
(manifest-entry
|
||
(name "glibc")
|
||
(version "2.19")
|
||
(item "/gnu/store/...")
|
||
(output "out")))
|
||
|
||
|
||
(test-begin "profiles")
|
||
|
||
(test-assert "manifest-installed?"
|
||
(let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
|
||
(and (manifest-installed? m (manifest-pattern (name "guile")))
|
||
(manifest-installed? m (manifest-pattern
|
||
(name "guile") (output "debug")))
|
||
(manifest-installed? m (manifest-pattern
|
||
(name "guile") (output "out")
|
||
(version "2.0.9")))
|
||
(not (manifest-installed?
|
||
m (manifest-pattern (name "guile") (version "1.8.8"))))
|
||
(not (manifest-installed?
|
||
m (manifest-pattern (name "guile") (output "foobar")))))))
|
||
|
||
(test-assert "manifest-matching-entries"
|
||
(let* ((e (list guile-2.0.9 guile-2.0.9:debug))
|
||
(m (manifest e)))
|
||
(and (null? (manifest-matching-entries m
|
||
(list (manifest-pattern
|
||
(name "python")))))
|
||
(equal? e
|
||
(manifest-matching-entries m
|
||
(list (manifest-pattern
|
||
(name "guile")
|
||
(output #f)))))
|
||
(equal? (list guile-2.0.9)
|
||
(manifest-matching-entries m
|
||
(list (manifest-pattern
|
||
(name "guile")
|
||
(version "2.0.9"))))))))
|
||
|
||
(test-assert "manifest-remove"
|
||
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
|
||
(m1 (manifest-remove m0
|
||
(list (manifest-pattern (name "guile")))))
|
||
(m2 (manifest-remove m1
|
||
(list (manifest-pattern (name "guile"))))) ; same
|
||
(m3 (manifest-remove m2
|
||
(list (manifest-pattern
|
||
(name "guile") (output "debug")))))
|
||
(m4 (manifest-remove m3
|
||
(list (manifest-pattern (name "guile"))))))
|
||
(match (manifest-entries m2)
|
||
((($ <manifest-entry> "guile" "2.0.9" "debug"))
|
||
(and (equal? m1 m2)
|
||
(null? (manifest-entries m3))
|
||
(null? (manifest-entries m4)))))))
|
||
|
||
(test-assert "manifest-add"
|
||
(let* ((m0 (manifest '()))
|
||
(m1 (manifest-add m0 (list guile-1.8.8)))
|
||
(m2 (manifest-add m1 (list guile-2.0.9)))
|
||
(m3 (manifest-add m2 (list guile-2.0.9:debug)))
|
||
(m4 (manifest-add m3 (list guile-2.0.9:debug))))
|
||
(and (match (manifest-entries m1)
|
||
((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
|
||
(_ #f))
|
||
(match (manifest-entries m2)
|
||
((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
|
||
(_ #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
|
||
(install (list guile-1.8.8))
|
||
(remove (list (manifest-pattern (name "guile")
|
||
(output "debug"))))))
|
||
(t2 (manifest-transaction
|
||
(remove (list (manifest-pattern (name "guile")
|
||
(version "2.0.9")
|
||
(output #f))))))
|
||
(m1 (manifest-perform-transaction m0 t1))
|
||
(m2 (manifest-perform-transaction m1 t2))
|
||
(m3 (manifest-perform-transaction m0 t2)))
|
||
(and (match (manifest-entries m1)
|
||
((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
|
||
(_ #f))
|
||
(equal? m1 m2)
|
||
(null? (manifest-entries m3)))))
|
||
|
||
(test-assert "manifest-transaction-effects"
|
||
(let* ((m0 (manifest (list guile-1.8.8)))
|
||
(t (manifest-transaction
|
||
(install (list guile-2.0.9 glibc))
|
||
(remove (list (manifest-pattern (name "coreutils")))))))
|
||
(let-values (((remove install upgrade downgrade)
|
||
(manifest-transaction-effects m0 t)))
|
||
(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))
|
||
#: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=? (dirname (readlink bindir))
|
||
(derivation->output-path guile))))))
|
||
|
||
(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 name)
|
||
(let ((name (string-append name ".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 (package-full-name packages:grep))
|
||
(derivation-file-name grep))
|
||
(string=? (find-input (package-full-name packages:sed))
|
||
(derivation-file-name sed))
|
||
(string=? (find-input
|
||
(package-full-name 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) 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))))))))
|
||
(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))))))))
|
||
(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-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)
|
||
;;; End:
|