X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/dedb17ad010ee9ef67f3f4f3997dd17f226c8090..aad16cc1965ab3488449c262455eb29b15c77e95:/tests/profiles.scm?ds=sidebyside diff --git a/tests/profiles.scm b/tests/profiles.scm index 890f09a751..92eb08cb9e 100644 --- a/tests/profiles.scm +++ b/tests/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; This file is part of GNU Guix. @@ -22,14 +22,20 @@ #: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. @@ -37,11 +43,20 @@ (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 @@ -133,6 +148,11 @@ (_ #f)) (equal? m3 m4)))) +(test-equal "manifest-add removes duplicates" ; + (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 @@ -179,12 +199,23 @@ (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 '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv)) (bindir -> (string-append profile "/bin")) (_ (built-derivations (list drv)))) @@ -196,9 +227,49 @@ (mlet* %store-monad ((entry -> (package->manifest-entry packages:glibc "debug")) (drv (profile-derivation (manifest (list entry)) - #:hooks '()))) + #: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 @@ -207,7 +278,8 @@ (package-native-search-paths packages:guile-2.0)))) (entry -> (package->manifest-entry guile)) (drv (profile-derivation (manifest (list entry)) - #:hooks '())) + #:hooks '() + #:locales? #f)) (profile -> (derivation->output-path drv))) (mbegin %store-monad (built-derivations (list drv)) @@ -220,10 +292,234 @@ (manifest-entry-search-paths entry) (package-native-search-paths packages:guile-2.0))))))))) -(test-end "profiles") - -(exit (= (test-runner-fail-count (test-runner-current)) 0)) +(test-assert "package->manifest-entry, search paths" + ;; See . + (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" ; + "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)