tests/profiles.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 (define-syntax-rule (test-assertm name exp)
  51   (test-assert name
  52     (run-with-store %store exp
  53                     #:guile-for-build (%guile-for-build))))
  54
  55 (define-syntax-rule (test-equalm name value exp)
  56   (test-equal name
  57     value
  58     (run-with-store %store exp
  59                     #:guile-for-build (%guile-for-build))))
  60
  61 ;; Example manifest entries.
  62
  63 (define guile-1.8.8
  64   (manifest-entry
  65     (name "guile")
  66     (version "1.8.8")
  67     (item "/gnu/store/...")
  68     (output "out")))
  69
  70 (define guile-2.0.9
  71   (manifest-entry
  72     (name "guile")
  73     (version "2.0.9")
  74     (item "/gnu/store/...")
  75     (output "out")))
  76
  77 (define guile-2.0.9:debug
  78   (manifest-entry (inherit guile-2.0.9)
  79     (output "debug")))
  80
  81 (define glibc
  82   (manifest-entry
  83     (name "glibc")
  84     (version "2.19")
  85     (item "/gnu/store/...")
  86     (output "out")))
  87
  88 \f
  89 (test-begin "profiles")
  90
  91 (test-assert "manifest-installed?"
  92   (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
  93     (and (manifest-installed? m (manifest-pattern (name "guile")))
  94          (manifest-installed? m (manifest-pattern
  95                                   (name "guile") (output "debug")))
  96          (manifest-installed? m (manifest-pattern
  97                                   (name "guile") (output "out")
  98                                   (version "2.0.9")))
  99          (not (manifest-installed?
 100                m (manifest-pattern (name "guile") (version "1.8.8"))))
 101          (not (manifest-installed?
 102                m (manifest-pattern (name "guile") (output "foobar")))))))
 103
 104 (test-assert "manifest-matching-entries"
 105   (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
 106          (m (manifest e)))
 107     (and (null? (manifest-matching-entries m
 108                                            (list (manifest-pattern
 109                                                    (name "python")))))
 110          (equal? e
 111                  (manifest-matching-entries m
 112                                             (list (manifest-pattern
 113                                                     (name "guile")
 114                                                     (output #f)))))
 115          (equal? (list guile-2.0.9)
 116                  (manifest-matching-entries m
 117                                             (list (manifest-pattern
 118                                                     (name "guile")
 119                                                     (version "2.0.9"))))))))
 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-assert "manifest-perform-transaction"
 158   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
 159          (t1 (manifest-transaction
 160               (install (list guile-1.8.8))
 161               (remove (list (manifest-pattern (name "guile")
 162                                               (output "debug"))))))
 163          (t2 (manifest-transaction
 164               (remove (list (manifest-pattern (name "guile")
 165                                               (version "2.0.9")
 166                                               (output #f))))))
 167          (m1 (manifest-perform-transaction m0 t1))
 168          (m2 (manifest-perform-transaction m1 t2))
 169          (m3 (manifest-perform-transaction m0 t2)))
 170     (and (match (manifest-entries m1)
 171            ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
 172            (_ #f))
 173          (equal? m1 m2)
 174          (null? (manifest-entries m3)))))
 175
 176 (test-assert "manifest-transaction-effects"
 177   (let* ((m0 (manifest (list guile-1.8.8)))
 178          (t  (manifest-transaction
 179               (install (list guile-2.0.9 glibc))
 180               (remove (list (manifest-pattern (name "coreutils")))))))
 181     (let-values (((remove install upgrade downgrade)
 182                   (manifest-transaction-effects m0 t)))
 183       (and (null? remove) (null? downgrade)
 184            (equal? (list glibc) install)
 185            (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))
 186
 187 (test-assert "manifest-transaction-effects and downgrades"
 188   (let* ((m0 (manifest (list guile-2.0.9)))
 189          (t  (manifest-transaction (install (list guile-1.8.8)))))
 190     (let-values (((remove install upgrade downgrade)
 191                   (manifest-transaction-effects m0 t)))
 192       (and (null? remove) (null? install) (null? upgrade)
 193            (equal? (list (cons guile-2.0.9 guile-1.8.8)) downgrade)))))
 194
 195 (test-assert "manifest-transaction-effects and pseudo-upgrades"
 196   (let* ((m0 (manifest (list guile-2.0.9)))
 197          (t  (manifest-transaction (install (list guile-2.0.9)))))
 198     (let-values (((remove install upgrade downgrade)
 199                   (manifest-transaction-effects m0 t)))
 200       (and (null? remove) (null? install) (null? downgrade)
 201            (equal? (list (cons guile-2.0.9 guile-2.0.9)) upgrade)))))
 202
 203 (test-assert "manifest-transaction-null?"
 204   (manifest-transaction-null? (manifest-transaction)))
 205
 206 (test-assert "manifest-transaction-removal-candidate?"
 207   (let ((m (manifest (list guile-2.0.9)))
 208         (t (manifest-transaction
 209             (remove (list (manifest-pattern (name "guile")))))))
 210     (and (manifest-transaction-removal-candidate? guile-2.0.9 t)
 211          (not (manifest-transaction-removal-candidate? glibc t)))))
 212
 213 (test-assertm "profile-derivation"
 214   (mlet* %store-monad
 215       ((entry ->   (package->manifest-entry %bootstrap-guile))
 216        (guile      (package->derivation %bootstrap-guile))
 217        (drv        (profile-derivation (manifest (list entry))
 218                                        #:hooks '()
 219                                        #:locales? #f))
 220        (profile -> (derivation->output-path drv))
 221        (bindir ->  (string-append profile "/bin"))
 222        (_          (built-derivations (list drv))))
 223     (return (and (file-exists? (string-append bindir "/guile"))
 224                  (string=? (dirname (readlink bindir))
 225                            (derivation->output-path guile))))))
 226
 227 (test-assertm "profile-derivation relative symlinks, one entry"
 228   (mlet* %store-monad
 229       ((entry ->   (package->manifest-entry %bootstrap-guile))
 230        (guile      (package->derivation %bootstrap-guile))
 231        (drv        (profile-derivation (manifest (list entry))
 232                                        #:relative-symlinks? #t
 233                                        #:hooks '()
 234                                        #:locales? #f))
 235        (profile -> (derivation->output-path drv))
 236        (bindir ->  (string-append profile "/bin"))
 237        (_          (built-derivations (list drv))))
 238     (return (and (file-exists? (string-append bindir "/guile"))
 239                  (string=? (readlink bindir)
 240                            (string-append "../"
 241                                           (basename
 242                                            (derivation->output-path guile))
 243                                           "/bin"))))))
 244
 245 (unless (network-reachable?) (test-skip 1))
 246 (test-assertm "profile-derivation relative symlinks, two entries"
 247   (mlet* %store-monad
 248       ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0))
 249        (manifest -> (packages->manifest
 250                      (list %bootstrap-guile gnu-make-boot0)))
 251        (guile       (package->derivation %bootstrap-guile))
 252        (make        (package->derivation gnu-make-boot0))
 253        (drv         (profile-derivation manifest
 254                                         #:relative-symlinks? #t
 255                                         #:hooks '()
 256                                         #:locales? #f))
 257        (profile ->  (derivation->output-path drv))
 258        (bindir ->   (string-append profile "/bin"))
 259        (_           (built-derivations (list drv))))
 260     (return (and (file-exists? (string-append bindir "/guile"))
 261                  (file-exists? (string-append bindir "/make"))
 262                  (string=? (readlink (string-append bindir "/guile"))
 263                            (string-append "../../"
 264                                           (basename
 265                                            (derivation->output-path guile))
 266                                           "/bin/guile"))
 267                  (string=? (readlink (string-append bindir "/make"))
 268                            (string-append "../../"
 269                                           (basename
 270                                            (derivation->output-path make))
 271                                           "/bin/make"))))))
 272
 273 (test-assertm "profile-derivation, inputs"
 274   (mlet* %store-monad
 275       ((entry ->   (package->manifest-entry packages:glibc "debug"))
 276        (drv        (profile-derivation (manifest (list entry))
 277                                        #:hooks '()
 278                                        #:locales? #f)))
 279     (return (derivation-inputs drv))))
 280
 281 (test-assertm "profile-derivation, cross-compilation"
 282   (mlet* %store-monad
 283       ((manifest -> (packages->manifest (list packages:sed packages:grep)))
 284        (target ->   "arm-linux-gnueabihf")
 285        (grep        (package->cross-derivation packages:grep target))
 286        (sed         (package->cross-derivation packages:sed target))
 287        (locales     (package->derivation packages:glibc-utf8-locales))
 288        (drv         (profile-derivation manifest
 289                                         #:hooks '()
 290                                         #:locales? #t
 291                                         #:target target)))
 292     (define (find-input package)
 293       (let ((name (string-append (package-full-name package "-") ".drv")))
 294         (any (lambda (input)
 295                (let ((input (derivation-input-path input)))
 296                  (and (string-suffix? name input) input)))
 297              (derivation-inputs drv))))
 298
 299     ;; The inputs for grep and sed should be cross-build derivations, but that
 300     ;; for the glibc-utf8-locales should be a native build.
 301     (return (and (string=? (derivation-system drv) (%current-system))
 302                  (string=? (find-input packages:grep)
 303                            (derivation-file-name grep))
 304                  (string=? (find-input packages:sed)
 305                            (derivation-file-name sed))
 306                  (string=? (find-input packages:glibc-utf8-locales)
 307                            (derivation-file-name locales))))))
 308
 309 (test-assert "package->manifest-entry defaults to \"out\""
 310   (let ((outputs (package-outputs packages:glibc)))
 311     (equal? (manifest-entry-output
 312              (package->manifest-entry (package
 313                                         (inherit packages:glibc)
 314                                         (outputs (reverse outputs)))))
 315             (manifest-entry-output
 316              (package->manifest-entry packages:glibc))
 317             "out")))
 318
 319 (test-assertm "profile-manifest, search-paths"
 320   (mlet* %store-monad
 321       ((guile ->   (package
 322                      (inherit %bootstrap-guile)
 323                      (native-search-paths
 324                       (package-native-search-paths packages:guile-2.0))))
 325        (entry ->   (package->manifest-entry guile))
 326        (drv        (profile-derivation (manifest (list entry))
 327                                        #:hooks '()
 328                                        #:locales? #f))
 329        (profile -> (derivation->output-path drv)))
 330     (mbegin %store-monad
 331       (built-derivations (list drv))
 332
 333       ;; Read the manifest back and make sure search paths are preserved.
 334       (let ((manifest (profile-manifest profile)))
 335         (match (manifest-entries manifest)
 336           ((result)
 337            (return (equal? (manifest-entry-search-paths result)
 338                            (manifest-entry-search-paths entry)
 339                            (package-native-search-paths
 340                             packages:guile-2.0)))))))))
 341
 342 (test-assert "package->manifest-entry, search paths"
 343   ;; See <http://bugs.gnu.org/22073>.
 344   (let ((mpl (@ (gnu packages python) python2-matplotlib)))
 345     (lset= eq?
 346            (package-transitive-native-search-paths mpl)
 347            (manifest-entry-search-paths
 348             (package->manifest-entry mpl)))))
 349
 350 (test-equal "packages->manifest, propagated inputs"
 351   (map (match-lambda
 352          ((label package)
 353           (list (package-name package) (package-version package)
 354                 package)))
 355        (package-propagated-inputs packages:guile-2.2))
 356   (map (lambda (entry)
 357          (list (manifest-entry-name entry)
 358                (manifest-entry-version entry)
 359                (manifest-entry-item entry)))
 360        (manifest-entry-dependencies
 361         (package->manifest-entry packages:guile-2.2))))
 362
 363 (test-assert "manifest-entry-parent"
 364   (let ((entry (package->manifest-entry packages:guile-2.2)))
 365     (match (manifest-entry-dependencies entry)
 366       ((dependencies ..1)
 367        (and (every (lambda (parent)
 368                      (eq? entry (force parent)))
 369                    (map manifest-entry-parent dependencies))
 370             (not (force (manifest-entry-parent entry))))))))
 371
 372 (test-assertm "read-manifest"
 373   (mlet* %store-monad ((manifest -> (packages->manifest
 374                                      (list (package
 375                                              (inherit %bootstrap-guile)
 376                                              (native-search-paths
 377                                               (package-native-search-paths
 378                                                packages:guile-2.0))))))
 379                        (drv (profile-derivation manifest
 380                                                 #:hooks '()
 381                                                 #:locales? #f))
 382                        (out -> (derivation->output-path drv)))
 383     (define (entry->sexp entry)
 384       (list (manifest-entry-name entry)
 385             (manifest-entry-version entry)
 386             (manifest-entry-search-paths entry)
 387             (manifest-entry-dependencies entry)
 388             (force (manifest-entry-parent entry))))
 389
 390     (mbegin %store-monad
 391       (built-derivations (list drv))
 392       (let ((manifest2 (profile-manifest out)))
 393         (return (equal? (map entry->sexp (manifest-entries manifest))
 394                         (map entry->sexp (manifest-entries manifest2))))))))
 395
 396 (test-equal "collision"
 397   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 398   (guard (c ((profile-collision-error? c)
 399              (let ((entry1 (profile-collision-error-entry c))
 400                    (entry2 (profile-collision-error-conflict c)))
 401                (list (list (manifest-entry-name entry1)
 402                            (manifest-entry-version entry1))
 403                      (list (manifest-entry-name entry2)
 404                            (manifest-entry-version entry2))))))
 405     (run-with-store %store
 406       (mlet* %store-monad ((p0 -> (package
 407                                     (inherit %bootstrap-guile)
 408                                     (version "42")))
 409                            (p1 -> (dummy-package "p1"
 410                                     (propagated-inputs `(("p0" ,p0)))))
 411                            (manifest -> (packages->manifest
 412                                          (list %bootstrap-guile p1)))
 413                            (drv (profile-derivation manifest
 414                                                     #:hooks '()
 415                                                     #:locales? #f)))
 416         (return #f)))))
 417
 418 (test-equal "collision of propagated inputs"
 419   '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
 420   (guard (c ((profile-collision-error? c)
 421              (let ((entry1 (profile-collision-error-entry c))
 422                    (entry2 (profile-collision-error-conflict c)))
 423                (list (list (manifest-entry-name entry1)
 424                            (manifest-entry-version entry1))
 425                      (list (manifest-entry-name entry2)
 426                            (manifest-entry-version entry2))))))
 427     (run-with-store %store
 428       (mlet* %store-monad ((p0 -> (package
 429                                     (inherit %bootstrap-guile)
 430                                     (version "42")))
 431                            (p1 -> (dummy-package "p1"
 432                                     (propagated-inputs
 433                                      `(("guile" ,%bootstrap-guile)))))
 434                            (p2 -> (dummy-package "p2"
 435                                     (propagated-inputs
 436                                      `(("guile" ,p0)))))
 437                            (manifest -> (packages->manifest (list p1 p2)))
 438                            (drv (profile-derivation manifest
 439                                                     #:hooks '()
 440                                                     #:locales? #f)))
 441         (return #f)))))
 442
 443 (test-assertm "no collision"
 444   ;; Here we have an entry that is "lowered" (its 'item' field is a store file
 445   ;; name) and another entry (its 'item' field is a package) that is
 446   ;; equivalent.
 447   (mlet* %store-monad ((p -> (dummy-package "p"
 448                                (propagated-inputs
 449                                 `(("guile" ,%bootstrap-guile)))))
 450                        (guile    (package->derivation %bootstrap-guile))
 451                        (entry -> (manifest-entry
 452                                    (inherit (package->manifest-entry
 453                                              %bootstrap-guile))
 454                                    (item (derivation->output-path guile))))
 455                        (manifest -> (manifest
 456                                      (list entry
 457                                            (package->manifest-entry p))))
 458                        (drv (profile-derivation manifest)))
 459     (return (->bool drv))))
 460
 461 (test-assertm "etc/profile"
 462   ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
 463   (mlet* %store-monad
 464       ((guile ->   (package
 465                      (inherit %bootstrap-guile)
 466                      (native-search-paths
 467                       (package-native-search-paths packages:guile-2.0))))
 468        (entry ->   (package->manifest-entry guile))
 469        (drv        (profile-derivation (manifest (list entry))
 470                                        #:hooks '()
 471                                        #:locales? #f))
 472        (profile -> (derivation->output-path drv)))
 473     (mbegin %store-monad
 474       (built-derivations (list drv))
 475       (let* ((pipe (open-input-pipe
 476                     (string-append "unset GUIX_PROFILE; "
 477                                    ;; 'source' is a Bashism; use '.' (dot).
 478                                    ". " profile "/etc/profile; "
 479                                    ;; Don't try to parse set(1) output because
 480                                    ;; it differs among shells; just use echo.
 481                                    "echo $PATH")))
 482              (path (get-string-all pipe)))
 483         (return
 484          (and (zero? (close-pipe pipe))
 485               (string-contains path (string-append profile "/bin"))))))))
 486
 487 (test-assertm "etc/profile when etc/ already exists"
 488   ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
 489   ;; etc/ directory, which makes it read-only.  Make sure the profile build
 490   ;; handles that.
 491   (mlet* %store-monad
 492       ((thing ->   (dummy-package "dummy"
 493                      (build-system trivial-build-system)
 494                      (arguments
 495                       `(#:guile ,%bootstrap-guile
 496                         #:builder
 497                         (let ((out (assoc-ref %outputs "out")))
 498                           (mkdir out)
 499                           (mkdir (string-append out "/etc"))
 500                           (call-with-output-file (string-append out "/etc/foo")
 501                             (lambda (port)
 502                               (display "foo!" port)))
 503                           #t)))))
 504        (entry ->   (package->manifest-entry thing))
 505        (drv        (profile-derivation (manifest (list entry))
 506                                        #:hooks '()
 507                                        #:locales? #f))
 508        (profile -> (derivation->output-path drv)))
 509     (mbegin %store-monad
 510       (built-derivations (list drv))
 511       (return (and (file-exists? (string-append profile "/etc/profile"))
 512                    (string=? (call-with-input-file
 513                                  (string-append profile "/etc/foo")
 514                                get-string-all)
 515                              "foo!"))))))
 516
 517 (test-assertm "etc/profile when etc/ is a symlink"
 518   ;; When etc/ is a symlink, the unsymlink code in 0.8.2 would fail
 519   ;; gracelessly because 'scandir' would return #f.
 520   (mlet* %store-monad
 521       ((thing ->   (dummy-package "dummy"
 522                      (build-system trivial-build-system)
 523                      (arguments
 524                       `(#:guile ,%bootstrap-guile
 525                         #:builder
 526                         (let ((out (assoc-ref %outputs "out")))
 527                           (mkdir out)
 528                           (mkdir (string-append out "/foo"))
 529                           (symlink "foo" (string-append out "/etc"))
 530                           (call-with-output-file (string-append out "/etc/bar")
 531                             (lambda (port)
 532                               (display "foo!" port)))
 533                           #t)))))
 534        (entry ->   (package->manifest-entry thing))
 535        (drv        (profile-derivation (manifest (list entry))
 536                                        #:hooks '()
 537                                        #:locales? #f))
 538        (profile -> (derivation->output-path drv)))
 539     (mbegin %store-monad
 540       (built-derivations (list drv))
 541       (return (and (file-exists? (string-append profile "/etc/profile"))
 542                    (string=? (call-with-input-file
 543                                  (string-append profile "/etc/bar")
 544                                get-string-all)
 545                              "foo!"))))))
 546
 547 (test-assertm "profile-derivation when etc/ is a relative symlink"
 548   ;; See <https://bugs.gnu.org/32686>.
 549   (mlet* %store-monad
 550       ((etc        (gexp->derivation
 551                     "etc"
 552                     #~(begin
 553                         (mkdir #$output)
 554                         (call-with-output-file (string-append #$output "/foo")
 555                           (lambda (port)
 556                             (display "Heya!" port))))))
 557        (thing ->   (dummy-package "dummy"
 558                      (build-system trivial-build-system)
 559                      (inputs
 560                       `(("etc" ,etc)))
 561                      (arguments
 562                       `(#:guile ,%bootstrap-guile
 563                         #:builder
 564                         (let ((out (assoc-ref %outputs "out"))
 565                               (etc (assoc-ref %build-inputs "etc")))
 566                           (mkdir out)
 567                           (symlink etc (string-append out "/etc"))
 568                           #t)))))
 569        (entry ->   (package->manifest-entry thing))
 570        (drv        (profile-derivation (manifest (list entry))
 571                                        #:relative-symlinks? #t
 572                                        #:hooks '()
 573                                        #:locales? #f))
 574        (profile -> (derivation->output-path drv)))
 575     (mbegin %store-monad
 576       (built-derivations (list drv))
 577       (return (string=? (call-with-input-file
 578                             (string-append profile "/etc/foo")
 579                           get-string-all)
 580                         "Heya!")))))
 581
 582 (test-equalm "union vs. dangling symlink"        ;<https://bugs.gnu.org/26949>
 583   "does-not-exist"
 584   (mlet* %store-monad
 585       ((thing1 ->  (dummy-package "dummy"
 586                      (build-system trivial-build-system)
 587                      (arguments
 588                       `(#:guile ,%bootstrap-guile
 589                         #:builder
 590                         (let ((out (assoc-ref %outputs "out")))
 591                           (mkdir out)
 592                           (symlink "does-not-exist"
 593                                    (string-append out "/dangling"))
 594                           #t)))))
 595        (thing2 ->  (package (inherit thing1) (name "dummy2")))
 596        (drv        (profile-derivation (packages->manifest
 597                                         (list thing1 thing2))
 598                                        #:hooks '()
 599                                        #:locales? #f))
 600        (profile -> (derivation->output-path drv)))
 601     (mbegin %store-monad
 602       (built-derivations (list drv))
 603       (return (readlink (readlink (string-append profile "/dangling")))))))
 604
 605 (test-end "profiles")
 606
 607 ;;; Local Variables:
 608 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
 609 ;;; End: