;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (test-profiles)
  #:use-module (guix tests)
  #:use-module (guix profiles)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (guix mona</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>refs</a><a href='/guix/log/guix.scm'>log</a><a href='/guix/tree/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>tree</a><a class='active' href='/guix/commit/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>commit</a><a href='/guix/diff/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/guix.scm'>
<input type='hidden' name='id' value='e2487db60272f148b7ab87ec2f13373b6a3a2134'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/commit/?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>root</a>/<a href='/guix/commit/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>guix.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='e2487db60272f148b7ab87ec2f13373b6a3a2134'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><table summary='commit info' class='commit-info'>
<tr><th>author</th><td>Raphaël Mélotte via Guix-patches &lt;guix-patches@gnu.org&gt;</td><td class='right'>2022-03-01 10:47:23 +0100</td></tr>
<tr><th>committer</th><td>Nicolas Goaziou &lt;mail@nicolasgoaziou.fr&gt;</td><td class='right'>2022-03-11 01:33:03 +0100</td></tr>
<tr><th>commit</th><td colspan='2' class='oid'><a href='/guix/commit/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>e2487db60272f148b7ab87ec2f13373b6a3a2134</a> (<a href='/guix/patch/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>patch</a>)</td></tr>
<tr><th>tree</th><td colspan='2' class='oid'><a href='/guix/tree/?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>5431d41d66733760ef3c773a4534bbb1925481d9</a> /<a href='/guix/tree/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>guix.scm</a></td></tr>
<tr><th>parent</th><td colspan='2' class='oid'><a href='/guix/commit/guix.scm?id=45d36b0e2fa1b883265472297f12f4552e621b32'>45d36b0e2fa1b883265472297f12f4552e621b32</a> (<a href='/guix/diff/guix.scm?id=e2487db60272f148b7ab87ec2f13373b6a3a2134&amp;id2=45d36b0e2fa1b883265472297f12f4552e621b32'>diff</a>)</td></tr><tr><th>download</th><td colspan='2' class='oid'><a href='/guix/snapshot/guix-e2487db60272f148b7ab87ec2f13373b6a3a2134.tar.gz'>guix-e2487db60272f148b7ab87ec2f13373b6a3a2134.tar.gz</a><br/><a href='/guix/snapshot/guix-e2487db60272f148b7ab87ec2f13373b6a3a2134.zip'>guix-e2487db60272f148b7ab87ec2f13373b6a3a2134.zip</a><br/></td></tr></table>
<div class='commit-subject'>gnu: tio: Update to 1.35.</div><div class='commit-msg'>* gnu/packages/terminals.scm (tio): Update to 1.35.
[build-system]: Switch to MESON-BUILD-SYSTEM.

Note: the build system changed to meson in the following commit:
https://github.com/tio/tio/commit/e9208d693ee21a062dc2b3f2dd16a9d6b8926b90
Signed-off-by: Nicolas Goaziou &lt;mail@nicolasgoaziou.fr&gt;
</div><div class='diffstat-header'><a href='/guix/diff/?id=e2487db60272f148b7ab87ec2f13373b6a3a2134'>Diffstat</a> (limited to 'guix.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
uile-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
              (install (list guile-1.8.8))
              (remove (list (manifest-pattern (name "guile")
                                              (output "debug"))))))
         (t2 (manifest-transaction
              (remove (list (manifest-pattern (name "guile")
                                              (version "2.0.9")
                                              (output #f))))))
         (m1 (manifest-perform-transaction m0 t1))
         (m2 (manifest-perform-transaction m1 t2))
         (m3 (manifest-perform-transaction m0 t2)))
    (and (match (manifest-entries m1)
           ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
           (_ #f))
         (equal? m1 m2)
         (null? (manifest-entries m3)))))

(test-assert "manifest-transaction-effects"
  (let* ((m0 (manifest (list guile-1.8.8)))
         (t  (manifest-transaction
              (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)
           (equal? (list glibc) install)
           (equal? (list (cons guile-1.8.8 guile-2.0.9)) upgrade)))))

(test-assert "manifest-transaction-effects and downgrades"
  (let* ((m0 (manifest (list guile-2.0.9)))
         (t  (manifest-transaction (install (list 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 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)))))
    (let-values (((remove install upgrade downgrade)
                  (manifest-transaction-effects m0 t)))
      (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-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))
       (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))))
    (return (and (file-exists? (string-append bindir "/guile"))
                 (string=? (dirname (readlink bindir))
                           (derivation->output-path guile))))))

(test-assertm "profile-derivation format version 3"
  ;; Make sure we can create and read a version 3 manifest.
  (mlet* %store-monad
      ((entry ->    (package->manifest-entry %bootstrap-guile
                                             #:properties '((answer . 42))))
       (manifest -> (manifest (list entry)))
       (drv1        (profile-derivation manifest
                                        #:format-version 3 ;old version
                                        #:hooks '()
                                        #:locales? #f))
       (drv2        (profile-derivation manifest
                                        #:hooks '()
                                        #:locales? #f))
       (profile1 -> (derivation->output-path drv1))
       (profile2 -> (derivation->output-path drv2))
       (_          (built-derivations (list drv1 drv2))))
    (return (let ((manifest1 (profile-manifest profile1))
                  (manifest2 (profile-manifest profile2)))
              (match (manifest-entries manifest1)
                ((entry1)
                 (match (manifest-entries manifest2)
                   ((entry2)
                    (and (manifest-entry=? entry1 entry2)
                         (equal? (manifest-entry-properties entry1)
                                 '((answer . 42)))
                         (equal? (manifest-entry-properties entry2)
                                 '((answer . 42))))))))))))

(test-assertm "profile-derivation, ordering & collisions"
  ;; ENTRY1 and ENTRY2 both provide 'bin/guile'--a collision.  Make sure
  ;; ENTRY1 "wins" over ENTRY2.  See <https://bugs.gnu.org/49102>.
  (mlet* %store-monad
      ((entry1 ->  (package->manifest-entry %bootstrap-guile))
       (entry2 ->  (manifest-entry
                     (name "fake-guile")
                     (version "0")
                     (item (computed-file
                            "fake-guile"
                            #~(begin
                                (mkdir #$output)
                                (mkdir (string-append #$output "/bin"))
                                (call-with-output-file
                                    (string-append #$output "/bin/guile")
                                  (lambda (port)
                                    (display "Fake!\n" port))))
                            #:guile %bootstrap-guile))))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry1 entry2))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (file ->    (string-append bindir "/guile"))
       (_          (built-derivations (list drv))))
    (return (string=? (readlink file)
                      (string-append
                       (derivation->output-path guile)
                       "/bin/guile")))))

(test-assertm "load-profile"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (define-syntax-rule (with-environment-excursion exp ...)
      (let ((env (environ)))
        (dynamic-wind
          (const #t)
          (lambda () exp ...)
          (lambda () (environ env)))))

    (return (and (with-environment-excursion
                  (load-profile profile)
                  (and (string-prefix? (string-append bindir ":")
                                       (getenv "PATH"))
                       (getenv "GUILE_LOAD_PATH")))
                 (with-environment-excursion
                  (load-profile profile #:pure? #t #:white-list '())
                  (equal? (list (string-append "PATH=" bindir))
                          (environ)))))))

(test-assertm "<profile>"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (profile -> (profile (hooks '()) (locales? #f)
                            (content (manifest (list entry)))))
       (drv        (lower-object profile))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (return (file-exists? (string-append bindir "/guile")))))

(test-assertm "profile-derivation relative symlinks, one entry"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry %bootstrap-guile))
       (guile      (package->derivation %bootstrap-guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:relative-symlinks? #t
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv))
       (bindir ->  (string-append profile "/bin"))
       (_          (built-derivations (list drv))))
    (return (and (file-exists? (string-append bindir "/guile"))
                 (string=? (readlink bindir)
                           (string-append "../"
                                          (basename
                                           (derivation->output-path guile))
                                          "/bin"))))))

(unless (network-reachable?) (test-skip 1))
(test-assertm "profile-derivation relative symlinks, two entries"
  (mlet* %store-monad
      ((manifest -> (packages->manifest
                     (list %bootstrap-guile gnu-make-for-tests)))
       (guile       (package->derivation %bootstrap-guile))
       (make        (package->derivation gnu-make-for-tests))
       (drv         (profile-derivation manifest
                                        #:relative-symlinks? #t
                                        #:hooks '()
                                        #:locales? #f))
       (profile ->  (derivation->output-path drv))
       (bindir ->   (string-append profile "/bin"))
       (_           (built-derivations (list drv))))
    (return (and (file-exists? (string-append bindir "/guile"))
                 (file-exists? (string-append bindir "/make"))
                 (string=? (readlink (string-append bindir "/guile"))
                           (string-append "../../"
                                          (basename
                                           (derivation->output-path guile))
                                          "/bin/guile"))
                 (string=? (readlink (string-append bindir "/make"))
                           (string-append "../../"
                                          (basename
                                           (derivation->output-path make))
                                          "/bin/make"))))))

(test-assertm "profile-derivation, inputs"
  (mlet* %store-monad
      ((entry ->   (package->manifest-entry packages:glibc "debug"))
       (drv        (profile-derivation (manifest (list entry))
                                       #: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 package)
      (let ((name (string-append (package-full-name package "-") ".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 packages:grep)
                           (derivation-file-name grep))
                 (string=? (find-input packages:sed)
                           (derivation-file-name sed))
                 (string=? (find-input 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
                     (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))

      ;; Read the manifest back and make sure search paths are preserved.
      (let ((manifest (profile-manifest profile)))
        (match (manifest-entries manifest)
          ((result)
           (return (equal? (manifest-entry-search-paths result)
                           (manifest-entry-search-paths entry)
                           (package-native-search-paths
                            packages:guile-2.0)))))))))

(test-assert "package->manifest-entry, search paths"
  ;; See <http://bugs.gnu.org/22073>.
  (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)
          (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") "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-name
                      (force (manifest-entry-parent 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 "deduplication of repeated entries"
  ;; Make sure the 'manifest' file does not duplicate identical entries.
  ;; See <https://issues.guix.gnu.org/55499>.
  (mlet* %store-monad ((p0 -> (dummy-package "p0"
                                (build-system trivial-build-system)
                                (arguments
                                 `(#:guile ,%bootstrap-guile
                                   #:builder (mkdir (assoc-ref %outputs "out"))))
                                (propagated-inputs
                                 `(("guile" ,%bootstrap-guile)))))
                       (p1 -> (package
                                (inherit p0)
                                (name "p1")))
                       (drv (profile-derivation (packages->manifest
                                                 (list p0 p1))
                                                #:hooks '()
                                                #:locales? #f)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (let ((file     (string-append (derivation->output-path drv)
                                     "/manifest"))
            (manifest (profile-manifest (derivation->output-path drv))))
        (define (contains-repeated? sexp)
          (match sexp
            (('repeated _ ...) #t)
            ((lst ...) (any contains-repeated? sexp))
            (_ #f)))

        (return (and (contains-repeated? (call-with-input-file file read))

                     ;; MANIFEST has two entries for %BOOTSTRAP-GUILE since
                     ;; it's propagated both from P0 and from P1.  When
                     ;; reading a 'repeated' node, 'read-manifest' should
                     ;; reuse the previously-read entry so the two
                     ;; %BOOTSTRAP-GUILE entries must be 'eq?'.
                     (match (manifest-entries manifest)
                       (((= manifest-entry-dependencies (dep0))
                         (= manifest-entry-dependencies (dep1)))
                        (and (string=? (manifest-entry-name dep0)
                                       (package-name %bootstrap-guile))
                             (eq? dep0 dep1))))))))))

(test-assertm "no collision"
  ;; Here we have an entry that is "lowered" (its 'item' field is a store file
  ;; name) and another entry (its 'item' field is a package) that is
  ;; 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)))
                          #t)))))
       (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)))
                          #t)))))
       (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-assertm "profile-derivation when etc/ is a relative symlink"
  ;; See <https://bugs.gnu.org/32686>.
  (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"        ;<https://bugs.gnu.org/26949>
  "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-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:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End: