;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
#: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)
;; 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
(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
+ (and (equal? e
(manifest-matching-entries m
(list (manifest-pattern
(name "guile")
(name "guile")
(version "2.0.9"))))))))
+(test-assert "manifest-matching-entries, no match"
+ (let ((m (manifest (list guile-2.0.9)))
+ (p (manifest-pattern (name "python"))))
+ (guard (c ((unmatched-pattern-error? c)
+ (and (eq? p (unmatched-pattern-error-pattern c))
+ (eq? m (unmatched-pattern-error-manifest c)))))
+ (manifest-matching-entries m (list p))
+ #f)))
+
+(test-equal "concatenate-manifests"
+ (manifest (list guile-2.0.9 glibc))
+ (concatenate-manifests (list (manifest (list guile-2.0.9))
+ (manifest (list glibc)))))
+
(test-assert "manifest-remove"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(m1 (manifest-remove m0
(manifest-entries (manifest-add (manifest '())
(list guile-2.0.9 guile-2.0.9))))
+(test-equal "manifest->code, simple"
+ '(begin
+ (specifications->manifest (list "guile" "guile:debug" "glibc")))
+ (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))))
+
+(test-equal "manifest->code, simple, versions"
+ '(begin
+ (specifications->manifest (list "guile@2.0.9" "guile@2.0.9:debug"
+ "glibc@2.19")))
+ (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))
+ #:entry-package-version manifest-entry-version))
+
+(test-equal "manifest->code, transformations"
+ '(begin
+ (use-modules (guix transformations))
+
+ (define transform1
+ (options->transformation '((foo . "bar"))))
+
+ (packages->manifest
+ (list (transform1 (specification->package "guile"))
+ (specification->package "glibc"))))
+ (manifest->code (manifest (list (manifest-entry
+ (inherit guile-2.0.9)
+ (properties `((transformations
+ . ((foo . "bar"))))))
+ glibc))))
+
(test-assert "manifest-perform-transaction"
(let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
(t1 (manifest-transaction
(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")))))))
+ (install (list guile-2.0.9 glibc)))))
+ (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 no double install or upgrades"
+ (let* ((m0 (manifest (list guile-1.8.8)))
+ (t (manifest-transaction
+ (install (list guile-2.0.9 glibc glibc)))))
(let-values (((remove install upgrade downgrade)
(manifest-transaction-effects m0 t)))
(and (null? remove) (null? downgrade)
(and (null? remove) (null? install) (null? upgrade)
(equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
+(test-assert "manifest-transaction-effects no double downgrade"
+ (let* ((m0 (manifest (list guile-2.0.9)))
+ (t (manifest-transaction (install (list guile-1.8.8 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)))))
(and (manifest-transaction-removal-candidate? guile-2.0.9 t)
(not (manifest-transaction-removal-candidate? glibc t)))))
+(test-assert "manifest-transaction-effects no double removal"
+ (let* ((m0 (manifest (list guile-2.0.9)))
+ (t (manifest-transaction
+ (remove (list (manifest-pattern (name "guile")))))))
+ (let-values (((remove install upgrade downgrade)
+ (manifest-transaction-effects m0 t)))
+ (and (= 1 (length remove))
+ (manifest-transaction-removal-candidate? guile-2.0.9 t)
+ (null? install) (null? downgrade) (null? upgrade)))))
+
+(test-assert "package->development-manifest"
+ (let ((manifest (package->development-manifest packages:hello)))
+ (every (lambda (name)
+ (manifest-installed? manifest
+ (manifest-pattern (name name))))
+ '("gcc" "binutils" "glibc" "coreutils" "grep" "sed"))))
+
(test-assertm "profile-derivation"
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))
(string=? (dirname (readlink bindir))
(derivation->output-path guile))))))
+(test-assertm "profile-derivation format version 3"
+ ;; Make sure we can create and read a version 3 manifest.
+ (mlet* %store-monad
+ ((entry -> (package->manifest-entry %bootstrap-guile
+ #:properties '((answer . 42))))
+ (manifest -> (manifest (list entry)))
+ (drv1 (profile-derivation manifest
+ #:format-version 3 ;old version
+ #:hooks '()
+ #:locales? #f))
+ (drv2 (profile-derivation manifest
+ #:hooks '()
+ #:locales? #f))
+ (profile1 -> (derivation->output-path drv1))
+ (profile2 -> (derivation->output-path drv2))
+ (_ (built-derivations (list drv1 drv2))))
+ (return (let ((manifest1 (profile-manifest profile1))
+ (manifest2 (profile-manifest profile2)))
+ (match (manifest-entries manifest1)
+ ((entry1)
+ (match (manifest-entries manifest2)
+ ((entry2)
+ (and (manifest-entry=? entry1 entry2)
+ (equal? (manifest-entry-properties entry1)
+ '((answer . 42)))
+ (equal? (manifest-entry-properties entry2)
+ '((answer . 42))))))))))))
+
+(test-assertm "profile-derivation, ordering & collisions"
+ ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision. Make sure
+ ;; ENTRY1 "wins" over ENTRY2. See <https://bugs.gnu.org/49102>.
+ (mlet* %store-monad
+ ((entry1 -> (package->manifest-entry %bootstrap-guile))
+ (entry2 -> (manifest-entry
+ (name "fake-guile")
+ (version "0")
+ (item (computed-file
+ "fake-guile"
+ #~(begin
+ (mkdir #$output)
+ (mkdir (string-append #$output "/bin"))
+ (call-with-output-file
+ (string-append #$output "/bin/guile")
+ (lambda (port)
+ (display "Fake!\n" port))))
+ #:guile %bootstrap-guile))))
+ (guile (package->derivation %bootstrap-guile))
+ (drv (profile-derivation (manifest (list entry1 entry2))
+ #:hooks '()
+ #:locales? #f))
+ (profile -> (derivation->output-path drv))
+ (bindir -> (string-append profile "/bin"))
+ (file -> (string-append bindir "/guile"))
+ (_ (built-derivations (list drv))))
+ (return (string=? (readlink file)
+ (string-append
+ (derivation->output-path guile)
+ "/bin/guile")))))
+
+(test-assertm "load-profile"
+ (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))))
+ (define-syntax-rule (with-environment-excursion exp ...)
+ (let ((env (environ)))
+ (dynamic-wind
+ (const #t)
+ (lambda () exp ...)
+ (lambda () (environ env)))))
+
+ (return (and (with-environment-excursion
+ (load-profile profile)
+ (and (string-prefix? (string-append bindir ":")
+ (getenv "PATH"))
+ (getenv "GUILE_LOAD_PATH")))
+ (with-environment-excursion
+ (load-profile profile #:pure? #t #:white-list '())
+ (equal? (list (string-append "PATH=" bindir))
+ (environ)))))))
+
+(test-assertm "<profile>"
+ (mlet* %store-monad
+ ((entry -> (package->manifest-entry %bootstrap-guile))
+ (profile -> (profile (hooks '()) (locales? #f)
+ (content (manifest (list entry)))))
+ (drv (lower-object profile))
+ (profile -> (derivation->output-path drv))
+ (bindir -> (string-append profile "/bin"))
+ (_ (built-derivations (list drv))))
+ (return (file-exists? (string-append bindir "/guile")))))
+
(test-assertm "profile-derivation relative symlinks, one entry"
(mlet* %store-monad
((entry -> (package->manifest-entry %bootstrap-guile))
(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)))
+ ((manifest -> (packages->manifest
+ (list %bootstrap-guile gnu-make-for-tests)))
(guile (package->derivation %bootstrap-guile))
- (make (package->derivation gnu-make-boot0))
+ (make (package->derivation gnu-make-for-tests))
(drv (profile-derivation manifest
#:relative-symlinks? #t
#:hooks '()
(test-assert "package->manifest-entry, search paths"
;; See <http://bugs.gnu.org/22073>.
- (let ((mpl (@ (gnu packages python) python2-matplotlib)))
+ (let ((mpl (@ (gnu packages python-xyz) python-matplotlib)))
(lset= eq?
(package-transitive-native-search-paths mpl)
(manifest-entry-search-paths
(package->manifest-entry mpl)))))
+(test-assert "packages->manifest, no duplicates"
+ (let ((expected
+ (manifest
+ (list
+ (package->manifest-entry packages:guile-2.2))))
+ (manifest (packages->manifest
+ (list packages:guile-2.2 packages:guile-2.2))))
+ (every manifest-entry=? (manifest-entries expected)
+ (manifest-entries manifest))))
+
(test-equal "packages->manifest, propagated inputs"
(map (match-lambda
((label package)
(return #f)))))
(test-equal "collision of propagated inputs"
- '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
+ '(("guile-bootstrap" "2.0") "p1"
+ <> ("guile-bootstrap" "42") "p2")
(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))
+ (manifest-entry-name
+ (force (manifest-entry-parent entry1)))
+ '<>
(list (manifest-entry-name entry2)
- (manifest-entry-version entry2))))))
+ (manifest-entry-version entry2))
+ (manifest-entry-name
+ (force (manifest-entry-parent entry2)))))))
(run-with-store %store
(mlet* %store-monad ((p0 -> (package
(inherit %bootstrap-guile)
#:locales? #f)))
(return #f)))))
+(test-assertm "deduplication of repeated entries"
+ ;; Make sure the 'manifest' file does not duplicate identical entries.
+ ;; See <https://issues.guix.gnu.org/55499>.
+ (mlet* %store-monad ((p0 -> (dummy-package "p0"
+ (build-system trivial-build-system)
+ (arguments
+ `(#:guile ,%bootstrap-guile
+ #:builder (mkdir (assoc-ref %outputs "out"))))
+ (propagated-inputs
+ `(("guile" ,%bootstrap-guile)))))
+ (p1 -> (package
+ (inherit p0)
+ (name "p1")))
+ (drv (profile-derivation (packages->manifest
+ (list p0 p1))
+ #:hooks '()
+ #:locales? #f)))
+ (mbegin %store-monad
+ (built-derivations (list drv))
+ (let ((file (string-append (derivation->output-path drv)
+ "/manifest"))
+ (manifest (profile-manifest (derivation->output-path drv))))
+ (define (contains-repeated? sexp)
+ (match sexp
+ (('repeated _ ...) #t)
+ ((lst ...) (any contains-repeated? sexp))
+ (_ #f)))
+
+ (return (and (contains-repeated? (call-with-input-file file read))
+
+ ;; MANIFEST has two entries for %BOOTSTRAP-GUILE since
+ ;; it's propagated both from P0 and from P1. When
+ ;; reading a 'repeated' node, 'read-manifest' should
+ ;; reuse the previously-read entry so the two
+ ;; %BOOTSTRAP-GUILE entries must be 'eq?'.
+ (match (manifest-entries manifest)
+ (((= manifest-entry-dependencies (dep0))
+ (= manifest-entry-dependencies (dep1)))
+ (and (string=? (manifest-entry-name dep0)
+ (package-name %bootstrap-guile))
+ (eq? dep0 dep1))))))))))
+
(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
(built-derivations (list drv))
(return (readlink (readlink (string-append profile "/dangling")))))))
+(test-equalm "profile in profile"
+ '("foo" "0")
+
+ ;; Make sure we can build a profile that has another profile has one of its
+ ;; entries. The new profile's /manifest and /etc/profile must override the
+ ;; other's.
+ (mlet* %store-monad
+ ((prof0 (profile-derivation
+ (manifest
+ (list (package->manifest-entry %bootstrap-guile)))
+ #:hooks '()
+ #:locales? #f))
+ (prof1 (profile-derivation
+ (manifest (list (manifest-entry
+ (name "foo")
+ (version "0")
+ (item prof0))))
+ #:hooks '()
+ #:locales? #f)))
+ (mbegin %store-monad
+ (built-derivations (list prof1))
+ (let ((out (derivation->output-path prof1)))
+ (return (and (file-exists?
+ (string-append out "/bin/guile"))
+ (let ((manifest (profile-manifest out)))
+ (match (manifest-entries manifest)
+ ((entry)
+ (list (manifest-entry-name entry)
+ (manifest-entry-version entry)))))))))))
+
(test-end "profiles")
;;; Local Variables: