X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/a032b4454b3fc67e11e9fc2d8c2345288065fa29..refs/heads/epiphany-next:/tests/profiles.scm diff --git a/tests/profiles.scm b/tests/profiles.scm index 3a59a0cc4f..9ad03f2b24 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès +;;; Copyright © 2013-2022 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -20,9 +20,9 @@ (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) @@ -46,17 +46,6 @@ ;; 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 @@ -103,10 +92,7 @@ (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") @@ -117,6 +103,20 @@ (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 @@ -153,6 +153,34 @@ (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 @@ -175,8 +203,17 @@ (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) @@ -191,6 +228,14 @@ (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))))) @@ -209,6 +254,23 @@ (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)) @@ -223,6 +285,103 @@ (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 . + (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 "" + (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)) @@ -244,11 +403,10 @@ (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 '() @@ -340,12 +498,22 @@ (test-assert "package->manifest-entry, search paths" ;; See . - (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) @@ -415,14 +583,20 @@ (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) @@ -439,6 +613,48 @@ #:locales? #f))) (return #f))))) +(test-assertm "deduplication of repeated entries" + ;; Make sure the 'manifest' file does not duplicate identical entries. + ;; See . + (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 @@ -543,6 +759,41 @@ get-string-all) "foo!")))))) +(test-assertm "profile-derivation when etc/ is a relative symlink" + ;; See . + (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" ; "does-not-exist" (mlet* %store-monad @@ -566,6 +817,36 @@ (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: