tests/profiles.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-profiles)
  21   #:use-module (guix tests)
  22   #:use-module (guix profiles)
  23   #:use-module (guix gexp)
  24   #:use-module (guix store)
  25   #:use-module (guix monads)
  26   #:use-module (guix grafts)
  27   #:use-module (guix packages)
  28   #:use-module (guix derivations)
  29   #:use-module (guix build-system trivial)
  30   #:use-module (gnu packages bootstrap)
  31   #:use-module ((gnu packages base) #:prefix packages:)
  32   #:use-module ((gnu packages guile) #:prefix packages:)
  33   #:use-module (ice-9 match)
  34   #:use-module (ice-9 regex)
  35   #:use-module (ice-9 popen)
  36   #:use-module (rnrs io ports)
  37   #:use-module (srfi srfi-1)
  38   #:use-module (srfi srfi-11)
  39   #:use-module (srfi srfi-34)
  40   #:use-module (srfi srfi-64))
  41
  42 ;; Test the (guix profiles) module.
  43
  44 (define %store
  45   (open-connection-for-tests))
  46
  47 ;; Globally disable grafts because they can trigger early builds.
  48 (%graft? #f)
  49
  50 ;; Example manifest entries.
  51
  52 (define guile-1.8.8
  53   (manifest-entry
  54     (name "guile")
  55     (version "1.8.8")
  56     (item "/gnu/store/...")
  57     (output "out")))
  58
  59 (define guile-2.0.9
  60   (manifest-entry
  61     (name "guile")
  62     (version "2.0.9")
  63     (item "/gnu/store/...")
  64     (output "out")))
  65
  66 (define guile-2.0.9:debug
  67   (manifest-entry (inherit guile-2.0.9)
  68     (output "debug")))
  69
  70 (define glibc
  71   (manifest-entry
  72     (name "glibc")
  73     (version "2.19")
  74     (item "/gnu/store/...")
  75     (output "out")))
  76
  77 \f
  78 (test-begin "profiles")
  79
  80 (test-assert "manifest-installed?"
  81   (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
  82     (and (manifest-installed? m (manifest-pattern (name "guile")))
  83          (manifest-installed? m (manifest-pattern
  84                                   (name "guile") (output "debug")))
  85          (manifest-installed? m (manifest-pattern
  86                                   (name "guile") (output "out")
  87                                   (version "2.0.9")))
  88          (not (manifest-installed?
  89                m (manifest-pattern (name "guile") (version "1.8.8"))))
  90          (not (manifest-installed?
  91                m (manifest-pattern (name "guile") (output "foobar")))))))
  92
  93 (test-assert "manifest-matching-entries"
  94   (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
  95          (m (manifest e)))
  96     (and (equal? e
  97                  (manifest-matching-entries m
  98                                             (list (manifest-pattern
  99                                                     (name "guile")
 100                                                     (output #f)))))
 101          (equal? (list guile-2.0.9)
 102                  (manifest-matching-entries m
 103                                             (list (manifest-pattern
 104                                                     (name "guile")
 105                                                     (version "2.0.9"))))))))
 106
 107 (test-assert "manifest-matching-entries, no match"
 108   (let ((m (manifest (list guile-2.0.9)))
 109         (p (manifest-pattern (name "python"))))
 110     (guard (c ((unmatched-pattern-error? c)
 111                (and (eq? p (unmatched-pattern-error-pattern c))
 112                     (eq? m (unmatched-pattern-error-manifest c)))))
 113       (manifest-matching-entries m (list p))
 114       #f)))
 115
 116 (test-equal "concatenate-manifests"
 117   (manifest (list guile-2.0.9 glibc))
 118   (concatenate-manifests (list (manifest (list guile-2.0.9))
 119                                (manifest (list glibc)))))
 120
 121 (test-assert "manifest-remove"
 122   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
 123          (m1 (manifest-remove m0
 124                               (list (manifest-pattern (name "guile")))))
 125          (m2 (manifest-remove m1
 126                               (list (manifest-pattern (name "guile"))))) ; same
 127          (m3 (manifest-remove m2
 128                               (list (manifest-pattern
 129                                       (name "guile") (output "debug")))))
 130          (m4 (manifest-remove m3
 131                               (list (manifest-pattern (name "guile"))))))
 132     (match (manifest-entries m2)
 133       ((($ <manifest-entry> "guile" "2.0.9" "debug"))
 134        (and (equal? m1 m2)
 135             (null? (manifest-entries m3))
 136             (null? (manifest-entries m4)))))))
 137
 138 (test-assert "manifest-add"
 139   (let* ((m0 (manifest '()))
 140          (m1 (manifest-add m0 (list guile-1.8.8)))
 141          (m2 (manifest-add m1 (list guile-2.0.9)))
 142          (m3 (manifest-add m2 (list guile-2.0.9:debug)))
 143          (m4 (manifest-add m3 (list guile-2.0.9:debug))))
 144     (and (match (manifest-entries m1)
 145            ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
 146            (_ #f))
 147          (match (manifest-entries m2)
 148            ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
 149            (_ #f))
 150          (equal? m3 m4))))
 151
 152 (test-equal "manifest-add removes duplicates"    ;<https://bugs.gnu.org/30569>
 153   (list guile-2.0.9)
 154   (manifest-entries (manifest-add (manifest '())
 155                                   (list guile-2.0.9 guile-2.0.9))))
 156
 157 (test-equal "manifest->code, simple"
 158   '(begin
 159      (specifications->manifest (list "guile" "guile:debug" "glibc")))
 160   (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))))
 161
 162 (test-equal "manifest->code, simple, versions"
 163   '(begin
 164      (specifications->manifest (list "guile@2.0.9" "guile@2.0.9:debug"
 165                                      "glibc@2.19")))
 166   (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))
 167                   #:entry-package-version manifest-entry-version))
 168
 169 (test-equal "manifest->code, transformations"
 170   '(begin
 171      (use-modules (guix transformations))
 172
 173      (define transform1
 174        (options->transformation '((foo . "bar"))))
 175
 176      (packages->manifest
 177       (list (transform1 (specification->package "guile"))
 178             (specification->package "glibc"))))
 179   (manifest->code (manifest (list (manifest-entry
 180                                     (inherit guile-2.0.9)
 181                                     (properties `((transformations
 182                                                    . ((foo . "bar"))))))
 183                                   glibc))))
 184
 185 (test-assert "manifest-perform-transaction"
 186   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
 187          (t1 (manifest-transaction
 188               (install (list guile-1.8.8))
 189               (remove (list (manifest-pattern (name "guile")
 190                                               (output "debug"))))))
 191          (t2 (manifest-transaction
 192               (remove (list (manifest-pattern (name "guile")
 193                                               (version "2.0.9")
 194                                               (output #f))))))
 195          (m1 (manifest-perform-transaction m0 t1))
 196          (m2 (manifest-perform-transaction m1 t2))
 197          (m3 (manifest-perform-transaction m0 t2)))
 198     (and (match (manifest-entries m1)
 199            ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
 200            (_ #f))
 201          (equal? m1 m2)
 202          (null? (manifest-entries m3)))))
 203
 204 (test-assert "manifest-transaction-effects"
 205   (let* ((m0 (manifest (list guile-1.8.8)))
 206          (t  (manifest-transaction
 207               (install (list guile-2.0.9 glibc)))))
 208     (let-values (((remove install upgrade downgrade)
 209                   (manifest-transaction-effects m0 t)))
 210       (and (null? remove) (null? downgrade)
 211            (equal? (list glibc) install)
 212            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 213
 214 (test-assert "manifest-transaction-effects no double install or upgrades"
 215   (let* ((m0 (manifest (list guile-1.8.8)))
 216          (t  (manifest-transaction
 217               (install (list guile-2.0.9 glibc glibc)))))
 218     (let-values (((remove install upgrade downgrade)
 219                   (manifest-transaction-effects m0 t)))
 220       (and (null? remove) (null? downgrade)
 221            (equal? (list glibc) install)
 222            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 223
 224 (test-assert "manifest-transaction-effects and downgrades"
 225   (let* ((m0 (manifest (list guile-2.0.9)))
 226          (t  (manifest-transaction (install (list guile-1.8.8)))))
 227     (let-values (((remove install upgrade downgrade)
 228                   (manifest-transaction-effects m0 t)))
 229       (and (null? remove) (null? install) (null? upgrade)
 230            (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
 231
 232 (test-assert "manifest-transaction-effects no double downgrade"
 233   (let* ((m0 (manifest (list guile-2.0.9)))
 234          (t  (manifest-transaction (install (list guile-1.8.8 guile-1.8.8)))))
 235     (let-values (((remove install upgrade downgrade)
 236                   (manifest-transaction-effects m0 t)))
 237       (and (null? remove) (null? install) (null? upgrade)
 238            (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
 239
 240 (test-assert "manifest-transaction-effects and pseudo-upgrades"
 241   (let* ((m0 (manifest (list guile-2.0.9)))
 242          (t  (manifest-transaction (install (list guile-2.0.9)))))
 243     (let-values (((remove install upgrade downgrade)
 244                   (manifest-transaction-effects m0 t)))
 245       (and (null? remove) (null? install) (null? downgrade)
 246            (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
 247
 248 (test-assert "manifest-transaction-null?"
 249   (manifest-transaction-null? (manifest-transaction)))
 250
 251 (test-assert "manifest-transaction-removal-candidate?"
 252   (let ((m (manifest (list guile-2.0.9)))
 253         (t (manifest-transaction
 254             (remove (list (manifest-pattern (name "guile")))))))
 255     (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
 256          (not (manifest-transaction-removal-candidate? glibc t)))))
 257
 258 (test-assert "manifest-transaction-effects no double removal"
 259   (let* ((m0 (manifest (list guile-2.0.9)))
 260          (t  (manifest-transaction
 261               (remove (list (manifest-pattern (name "guile")))))))
 262     (let-values (((remove install upgrade downgrade)
 263                   (manifest-transaction-effects m0 t)))
 264       (and (= 1 (length remove))
 265            (manifest-transaction-removal-candidate? guile-2.0.9 t)
 266            (null? install) (null? downgrade) (null? upgrade)))))
 267
 268 (test-assert "package->development-manifest"
 269   (let ((manifest (package->development-manifest packages:hello)))
 270     (every (lambda (name)
 271              (manifest-installed? manifest
 272                                   (manifest-pattern (name name))))
 273            '("gcc" "binutils" "glibc" "coreutils" "grep" "sed"))))
 274
 275 (test-assertm "profile-derivation"
 276   (mlet* %store-monad
 277       ((entry ->   (package->manifest-entry %bootstrap-guile))
 278        (guile      (package->derivation %bootstrap-guile))
 279        (drv        (profile-derivation (manifest (list entry))
 280                                        #:hooks '()
 281                                        #:locales? #f))
 282        (profile -> (derivation->output-path drv))
 283        (bindir ->  (string-append profile "/bin"))
 284        (_          (built-derivations (list drv))))
 285     (return (and (file-exists? (string-append bindir "/guile"))
 286                  (string=? (dirname (readlink bindir))
 287                            (derivation->output-path guile))))))
 288
 289 (test-assertm "profile-derivation, ordering & collisions"
 290   ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision.  Make sure
 291   ;; ENTRY1 "wins" over ENTRY2.  See <https://bugs.gnu.org/49102>.
 292   (mlet* %store-monad
 293       ((entry1 ->  (package->manifest-entry %bootstrap-guile))
 294        (entry2 ->  (manifest-entry
 295                      (name "fake-guile")
 296                      (version "0")
 297                      (item (computed-file
 298                             "fake-guile"
 299                             #~(begin
 300                                 (mkdir #$output)
 301                                 (mkdir (string-append #$output "/bin"))
 302                                 (call-with-output-file
 303                                     (string-append #$output "/bin/guile")
 304                                   (lambda (port)
 305                                     (display "Fake!\n" port))))
 306                             #:guile %bootstrap-guile))))
 307        (guile      (package->derivation %bootstrap-guile))
 308        (drv        (profile-derivation (manifest (list entry1 entry2))
 309                                        #:hooks '()
 310                                        #:locales? #f))
 311        (profile -> (derivation->output-path drv))
 312        (bindir ->  (string-append profile "/bin"))
 313        (file ->    (string-append bindir "/guile"))
 314        (_          (built-derivations (list drv))))
 315     (return (string=? (readlink file)
 316                       (string-append
 317                        (derivation->output-path guile)
 318                        "/bin/guile")))))
 319
 320 (test-assertm "load-profile"
 321   (mlet* %store-monad
 322       ((entry ->   (package->manifest-entry %bootstrap-guile))
 323        (guile      (package->derivation %bootstrap-guile))
 324        (drv        (profile-derivation (manifest (list entry))
 325                                        #:hooks '()
 326                                        #:locales? #f))
 327        (profile -> (derivation->output-path drv))
 328        (bindir ->  (string-append profile "/bin"))
 329        (_          (built-derivations (list drv))))
 330     (define-syntax-rule (with-environment-excursion exp ...)
 331       (let ((env (environ)))
 332         (dynamic-wind
 333           (const #t)
 334           (lambda () exp ...)
 335           (lambda () (environ env)))))
 336
 337     (return (and (with-environment-excursion
 338                   (load-profile profile)
 339                   (and (string-prefix? (string-append bindir ":")
 340                                        (getenv "PATH"))
 341                        (getenv "GUILE_LOAD_PATH")))
 342                  (with-environment-excursion
 343                   (load-profile profile #:pure? #t #:white-list '())
 344                   (equal? (list (string-append "PATH=" bindir))
 345                           (environ)))))))
 346
 347 (test-assertm "<profile>"
 348   (mlet* %store-monad
 349       ((entry ->   (package->manifest-entry %bootstrap-guile))
 350        (profile -> (profile (hooks '()) (locales? #f)
 351                             (content (manifest (list entry)))))
 352        (drv        (lower-object profile))
 353        (profile -> (derivation->output-path drv))
 354        (bindir ->  (string-append profile "/bin"))
 355        (_          (built-derivations (list drv))))
 356     (return (file-exists? (string-append bindir "/guile")))))
 357
 358 (test-assertm "profile-derivation relative symlinks, one entry"
 359   (mlet* %store-monad
 360       ((entry ->   (package->manifest-entry %bootstrap-guile))
 361        (guile      (package->derivation %bootstrap-guile))
 362        (drv        (profile-derivation (manifest (list entry))
 363                                        #:relative-symlinks? #t
 364                                        #:hooks '()
 365                                        #:locales? #f))
 366        (profile -> (derivation->output-path drv))
 367        (bindir ->  (string-append profile "/bin"))
 368        (_          (built-derivations (list drv))))
 369     (return (and (file-exists? (string-append bindir "/guile"))
 370                  (string=? (readlink bindir)
 371                            (string-append "../"
 372                                           (basename
 373                                            (derivation->output-path guile))
 374                                           "/bin"))))))
 375
 376 (unless (network-reachable?) (test-skip 1))
 377 (test-assertm "profile-derivation relative symlinks, two entries"
 378   (mlet* %store-monad
 379       ((manifest -> (packages->manifest
 380                      (list %bootstrap-guile gnu-make-for-tests)))
 381        (guile       (package->derivation %bootstrap-guile))
 382        (make        (package->derivation gnu-make-for-tests))
 383        (drv         (profile-derivation manifest
 384                                         #:relative-symlinks? #t
 385                                         #:hooks '()
 386                                         #:locales? #f))
 387        (profile ->  (derivation->output-path drv))
 388        (bindir ->   (string-append profile "/bin"))
 389        (_           (built-derivations (list drv))))
 390     (return (and (file-exists? (string-append bindir "/guile"))
 391                  (file-exists? (string-append bindir "/make"))
 392                  (string=? (readlink (string-append bindir "/guile"))
 393                            (string-append "../../"
 394                                           (basename
 395                                            (derivation->output-path guile))
 396                                           "/bin/guile"))
 397                  (string=? (readlink (string-append bindir "/make"))
 398                            (string-append "../../"
 399                                           (basename
 400                                            (derivation->output-path make))
 401                                           "/bin/make"))))))
 402
 403 (test-assertm "profile-derivation, inputs"
 404   (mlet* %store-monad
 405       ((entry ->   (package->manifest-entry packages:glibc "debug"))
 406        (drv        (profile-derivation (manifest (list entry))
 407                                        #:hooks '()
 408                                        #:locales? #f)))
 409     (return (derivation-inputs drv))))
 410
 411 (test-assertm "profile-derivation, cross-compilation"
 412   (mlet* %store-monad
 413       ((manifest -> (packages->manifest (list packages:sed packages:grep)))
 414        (target ->   "arm-linux-gnueabihf")
 415        (grep        (package->cross-derivation packages:grep target))
 416        (sed         (package->cross-derivation packages:sed target))
 417        (locales     (package->derivation packages:glibc-utf8-locales))
 418        (drv         (profile-derivation manifest
 419                                         #:hooks '()
 420                                         #:locales? #t
 421                                         #:target target)))
 422     (define (find-input package)
 423       (let ((name (string-append (package-full-name package "-") ".drv")))
 424         (any (lambda (input)
 425                (let ((input (derivation-input-path input)))
 426                  (and (string-suffix? name input) input)))
 427              (derivation-inputs drv))))
 428
 429     ;; The inputs for grep and sed should be cross-build derivations, but that
 430     ;; for the glibc-utf8-locales should be a native build.
 431     (return (and (string=? (derivation-system drv) (%current-system))
 432                  (string=? (find-input packages:grep)
 433                            (derivation-file-name grep))
 434                  (string=? (find-input packages:sed)
 435                            (derivation-file-name sed))
 436                  (string=? (find-input packages:glibc-utf8-locales)
 437                            (derivation-file-name locales))))))
 438
 439 (test-assert "package->manifest-entry defaults to \"out\""
 440   (let ((outputs (package-outputs packages:glibc)))
 441     (equal? (manifest-entry-output
 442              (package->manifest-entry (package
 443                                         (inherit packages:glibc)
 444                                         (outputs (reverse outputs)))))
 445             (manifest-entry-output
 446              (package->manifest-entry packages:glibc))
 447             "out")))
 448
 449 (test-assertm "profile-manifest, search-paths"
 450   (mlet* %store-monad
 451       ((guile ->   (package
 452                      (inherit %bootstrap-guile)
 453                      (native-search-paths
 454                       (package-native-search-paths packages:guile-2.0))))
 455        (entry ->   (package->manifest-entry guile))
 456        (drv        (profile-derivation (manifest (list entry))
 457                                        #:hooks '()
 458                                        #:locales? #f))
 459        (profile -> (derivation->output-path drv)))
 460     (mbegin %store-monad
 461       (built-derivations (list drv))
 462
 463       ;; Read the manifest back and make sure search paths are preserved.
 464       (let ((manifest (profile-manifest profile)))
 465         (match (manifest-entries manifest)
 466           ((result)
 467            (return (equal? (manifest-entry-search-paths result)
 468                            (manifest-entry-search-paths entry)
 469                            (package-native-search-paths
 470                             packages:guile-2.0)))))))))
 471
 472 (test-assert "package->manifest-entry, search paths"
 473   ;; See <http://bugs.gnu.org/22073>.
 474   (let ((mpl (@ (gnu packages python-xyz) python-matplotlib)))
 475     (lset= eq?
 476            (package-transitive-native-search-paths mpl)
 477            (manifest-entry-search-paths
 478             (package->manifest-entry mpl)))))
 479
 480 (test-assert "packages->manifest, no duplicates"
 481   (let ((expected
 482          (manifest
 483           (list
 484            (package->manifest-entry packages:guile-2.2))))
 485         (manifest (packages->manifest
 486                    (list packages:guile-2.2 packages:guile-2.2))))
 487     (every manifest-entry=? (manifest-entries expected)
 488            (manifest-entries manifest))))
 489
 490 (test-equal "packages->manifest, propagated inputs"
 491   (map (match-lambda
 492          ((label package)
 493           (list (package-name package) (package-version package)
 494                 package)))
 495        (package-propagated-inputs packages:guile-2.2))
 496   (map (lambda (entry)
 497          (list (manifest-entry-name entry)
 498                (manifest-entry-version entry)
 499                (manifest-entry-item entry)))
 500        (manifest-entry-dependencies
 501         (package->manifest-entry packages:guile-2.2))))
 502
 503 (test-assert "manifest-entry-parent"
 504   (let ((entry (package->manifest-entry packages:guile-2.2)))
 505     (match (manifest-entry-dependencies entry)
 506       ((dependencies ..1)
 507        (and (every (lambda (parent)
 508                      (eq? entry (force parent)))
 509                    (map manifest-entry-parent dependencies))
 510             (not (force (manifest-entry-parent entry))))))))
 511
 512 (test-assertm "read-manifest"
 513   (mlet* %store-monad ((manifest -> (packages->manifest
 514                                      (list (package
 515                                              (inherit %bootstrap-guile)
 516                                              (native-search-paths
 517                                               (package-native-search-paths
 518                                                packages:guile-2.0))))))
 519                        (drv (profile-derivation manifest
 520                                                 #:hooks '()
 521                                                 #:locales? #f))
 522                        (out -> (derivation->output-path drv)))
 523     (define (entry->sexp entry)
 524       (list (manifest-entry-name entry)
 525             (manifest-entry-version entry)
 526             (manifest-entry-search-paths entry)
 527             (manifest-entry-dependencies entry)
 528             (force (manifest-entry-parent entry))))
 529
 530     (mbegin %store-monad
 531       (built-derivations (list drv))
 532       (let ((manifest2 (profile-manifest out)))
 533         (return (equal? (map entry->sexp (manifest-entries manifest))
 534                         (map entry->sexp (manifest-entries manifest2))))))))
 535
 536 (test-equal "collision"
 537   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 538   (guard (c ((profile-collision-error? c)
 539              (let ((entry1 (profile-collision-error-entry c))
 540                    (entry2 (profile-collision-error-conflict c)))
 541                (list (list (manifest-entry-name entry1)
 542                            (manifest-entry-version entry1))
 543                      (list (manifest-entry-name entry2)
 544                            (manifest-entry-version entry2))))))
 545     (run-with-store %store
 546       (mlet* %store-monad ((p0 -> (package
 547                                     (inherit %bootstrap-guile)
 548                                     (version "42")))
 549                            (p1 -> (dummy-package "p1"
 550                                     (propagated-inputs `(("p0" ,p0)))))
 551                            (manifest -> (packages->manifest
 552                                          (list %bootstrap-guile p1)))
 553                            (drv (profile-derivation manifest
 554                                                     #:hooks '()
 555                                                     #:locales? #f)))
 556         (return #f)))))
 557
 558 (test-equal "collision of propagated inputs"
 559   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 560   (guard (c ((profile-collision-error? c)
 561              (let ((entry1 (profile-collision-error-entry c))
 562                    (entry2 (profile-collision-error-conflict c)))
 563                (list (list (manifest-entry-name entry1)
 564                            (manifest-entry-version entry1))
 565                      (list (manifest-entry-name entry2)
 566                            (manifest-entry-version entry2))))))
 567     (run-with-store %store
 568       (mlet* %store-monad ((p0 -> (package
 569                                     (inherit %bootstrap-guile)
 570                                     (version "42")))
 571                            (p1 -> (dummy-package "p1"
 572                                     (propagated-inputs
 573                                      `(("guile" ,%bootstrap-guile)))))
 574                            (p2 -> (dummy-package "p2"
 575                                     (propagated-inputs
 576                                      `(("guile" ,p0)))))
 577                            (manifest -> (packages->manifest (list p1 p2)))
 578                            (drv (profile-derivation manifest
 579                                                     #:hooks '()
 580                                                     #:locales? #f)))
 581         (return #f)))))
 582
 583 (test-assertm "no collision"
 584   ;; Here we have an entry that is "lowered" (its 'item' field is a store file
 585   ;; name) and another entry (its 'item' field is a package) that is
 586   ;; equivalent.
 587   (mlet* %store-monad ((p -> (dummy-package "p"
 588                                (propagated-inputs
 589                                 `(("guile" ,%bootstrap-guile)))))
 590                        (guile    (package->derivation %bootstrap-guile))
 591                        (entry -> (manifest-entry
 592                                    (inherit (package->manifest-entry
 593                                              %bootstrap-guile))
 594                                    (item (derivation->output-path guile))))
 595                        (manifest -> (manifest
 596                                      (list entry
 597                                            (package->manifest-entry p))))
 598                        (drv (profile-derivation manifest)))
 599     (return (->bool drv))))
 600
 601 (test-assertm "etc/profile"
 602   ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
 603   (mlet* %store-monad
 604       ((guile ->   (package
 605                      (inherit %bootstrap-guile)
 606                      (native-search-paths
 607                       (package-native-search-paths packages:guile-2.0))))
 608        (entry ->   (package->manifest-entry guile))
 609        (drv        (profile-derivation (manifest (list entry))
 610                                        #:hooks '()
 611                                        #:locales? #f))
 612        (profile -> (derivation->output-path drv)))
 613     (mbegin %store-monad
 614       (built-derivations (list drv))
 615       (let* ((pipe (open-input-pipe
 616                     (string-append "unset GUIX_PROFILE; "
 617                                    ;; 'source' is a Bashism; use '.' (dot).
 618                                    ". " profile "/etc/profile; "
 619                                    ;; Don't try to parse set(1) output because
 620                                    ;; it differs among shells; just use echo.
 621                                    "echo $PATH")))
 622              (path (get-string-all pipe)))
 623         (return
 624          (and (zero? (close-pipe pipe))
 625               (string-contains path (string-append profile "/bin"))))))))
 626
 627 (test-assertm "etc/profile when etc/ already exists"
 628   ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
 629   ;; etc/ directory, which makes it read-only.  Make sure the profile build
 630   ;; handles that.
 631   (mlet* %store-monad
 632       ((thing ->   (dummy-package "dummy"
 633                      (build-system trivial-build-system)
 634                      (arguments
 635                       `(#:guile ,%bootstrap-guile
 636                         #:builder
 637                         (let ((out (assoc-ref %outputs "out")))
 638                           (mkdir out)
 639                           (mkdir (string-append out "/etc"))
 640                           (call-with-output-file (string-append out "/etc/foo")
 641                             (lambda (port)
 642                               (display "foo!" port)))
 643                           #t)))))
 644        (entry ->   (package->manifest-entry thing))
 645        (drv        (profile-derivation (manifest (list entry))
 646                                        #:hooks '()
 647                                        #:locales? #f))
 648        (profile -> (derivation->output-path drv)))
 649     (mbegin %store-monad
 650       (built-derivations (list drv))
 651       (return (and (file-exists? (string-append profile "/etc/profile"))
 652                    (string=? (call-with-input-file
 653                                  (string-append profile "/etc/foo")
 654                                get-string-all)
 655                              "foo!"))))))
 656
 657 (test-assertm "etc/profile when etc/ is a symlink"
 658   ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
 659   ;; gracelessly because 'scandir' would return #f.
 660   (mlet* %store-monad
 661       ((thing ->   (dummy-package "dummy"
 662                      (build-system trivial-build-system)
 663                      (arguments
 664                       `(#:guile ,%bootstrap-guile
 665                         #:builder
 666                         (let ((out (assoc-ref %outputs "out")))
 667                           (mkdir out)
 668                           (mkdir (string-append out "/foo"))
 669                           (symlink "foo" (string-append out "/etc"))
 670                           (call-with-output-file (string-append out "/etc/bar")
 671                             (lambda (port)
 672                               (display "foo!" port)))
 673                           #t)))))
 674        (entry ->   (package->manifest-entry thing))
 675        (drv        (profile-derivation (manifest (list entry))
 676                                        #:hooks '()
 677                                        #:locales? #f))
 678        (profile -> (derivation->output-path drv)))
 679     (mbegin %store-monad
 680       (built-derivations (list drv))
 681       (return (and (file-exists? (string-append profile "/etc/profile"))
 682                    (string=? (call-with-input-file
 683                                  (string-append profile "/etc/bar")
 684                                get-string-all)
 685                              "foo!"))))))
 686
 687 (test-assertm "profile-derivation when etc/ is a relative symlink"
 688   ;; See <https://bugs.gnu.org/32686>.
 689   (mlet* %store-monad
 690       ((etc        (gexp->derivation
 691                     "etc"
 692                     #~(begin
 693                         (mkdir #$output)
 694                         (call-with-output-file (string-append #$output "/foo")
 695                           (lambda (port)
 696                             (display "Heya!" port))))))
 697        (thing ->   (dummy-package "dummy"
 698                      (build-system trivial-build-system)
 699                      (inputs
 700                       `(("etc" ,etc)))
 701                      (arguments
 702                       `(#:guile ,%bootstrap-guile
 703                         #:builder
 704                         (let ((out (assoc-ref %outputs "out"))
 705                               (etc (assoc-ref %build-inputs "etc")))
 706                           (mkdir out)
 707                           (symlink etc (string-append out "/etc"))
 708                           #t)))))
 709        (entry ->   (package->manifest-entry thing))
 710        (drv        (profile-derivation (manifest (list entry))
 711                                        #:relative-symlinks? #t
 712                                        #:hooks '()
 713                                        #:locales? #f))
 714        (profile -> (derivation->output-path drv)))
 715     (mbegin %store-monad
 716       (built-derivations (list drv))
 717       (return (string=? (call-with-input-file
 718                             (string-append profile "/etc/foo")
 719                           get-string-all)
 720                         "Heya!")))))
 721
 722 (test-equalm "union vs. dangling symlink"        ;<https://bugs.gnu.org/26949>
 723   "does-not-exist"
 724   (mlet* %store-monad
 725       ((thing1 ->  (dummy-package "dummy"
 726                      (build-system trivial-build-system)
 727                      (arguments
 728                       `(#:guile ,%bootstrap-guile
 729                         #:builder
 730                         (let ((out (assoc-ref %outputs "out")))
 731                           (mkdir out)
 732                           (symlink "does-not-exist"
 733                                    (string-append out "/dangling"))
 734                           #t)))))
 735        (thing2 ->  (package (inherit thing1) (name "dummy2")))
 736        (drv        (profile-derivation (packages->manifest
 737                                         (list thing1 thing2))
 738                                        #:hooks '()
 739                                        #:locales? #f))
 740        (profile -> (derivation->output-path drv)))
 741     (mbegin %store-monad
 742       (built-derivations (list drv))
 743       (return (readlink (readlink (string-append profile "/dangling")))))))
 744
 745 (test-equalm "profile in profile"
 746   '("foo" "0")
 747
 748   ;; Make sure we can build a profile that has another profile has one of its
 749   ;; entries.  The new profile's /manifest and /etc/profile must override the
 750   ;; other's.
 751   (mlet* %store-monad
 752       ((prof0 (profile-derivation
 753                (manifest
 754                 (list (package->manifest-entry %bootstrap-guile)))
 755                #:hooks '()
 756                #:locales? #f))
 757        (prof1 (profile-derivation
 758                (manifest (list (manifest-entry
 759                                  (name "foo")
 760                                  (version "0")
 761                                  (item prof0))))
 762                #:hooks '()
 763                #:locales? #f)))
 764     (mbegin %store-monad
 765       (built-derivations (list prof1))
 766       (let ((out (derivation->output-path prof1)))
 767         (return (and (file-exists?
 768                       (string-append out "/bin/guile"))
 769                      (let ((manifest (profile-manifest out)))
 770                        (match (manifest-entries manifest)
 771                          ((entry)
 772                           (list (manifest-entry-name entry)
 773                                 (manifest-entry-version entry)))))))))))
 774
 775 (test-end "profiles")
 776
 777 ;;; Local Variables:
 778 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 779 ;;; End: