code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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-packages)
  #:use-module (guix tests)
  #:use-module (guix store)
  #:use-module (guix monads)
  #:use-module (guix grafts)
  #:use-module ((guix gexp) #:select (local-file local-file-file))
  #:use-module ((guix utils)
                ;; Rename the 'location' binding to allow proper syntax
                ;; matching when setting the 'location' field of a package.
                #:renamer (lambda (name)
                            (cond ((eq? name 'location) 'make-location)
                                  (else name))))
  #:use-module (gcrypt hash)
  #:use-module (guix derivations)
  #:use-module (guix packages)
  #:use-module (guix grafts)
  #:use-module (guix search-paths)
  #:use-module (guix build-system)
  #:use-module (guix build-system trivial)
  #:use-module (guix build-system gnu)
  #:use-module (guix profiles)
  #:use-module (guix scripts package)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages guile)
  #:use-module (gnu packages bootstrap)
  #:use-module (gnu packages version-control)
  #:use-module (gnu packages xml)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-64)
  #:use-module (rnrs io ports)
  #:use-module (ice-9 vlist)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match))

;; Test the high-level packaging layer.

(define %store
  (open-connection-for-tests))

;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
;; can trigger builds early.)
(%graft? #f)

(test-begin "packages")

(test-assert "printer with location"
  (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
                (with-output-to-string
                  (lambda ()
                    (write
                     (dummy-package "foo"
                       (location (make-location "foo.scm" 42 7))))))))

(test-assert "printer without location"
  (string-match "^#<package foo@0 [[:xdigit:]]+>$"
                (with-output-to-string
                  (lambda ()
                    (write
                     (dummy-package "foo" (location #f)))))))

(test-assert "hidden-package"
  (and (hidden-package? (hidden-package (dummy-package "foo")))
       (not (hidden-package? (dummy-package "foo")))))

(test-assert "package-superseded"
  (let* ((new (dummy-package "bar"))
         (old (deprecated-package "foo" new)))
    (and (eq? (package-superseded old) new)
         (mock ((gnu packages) find-best-packages-by-name (const (list old)))
               (specification->package "foo")
               (and (eq? new (specification->package "foo"))
                    (eq? new (specification->package+output "foo")))))))

(test-assert "transaction-upgrade-entry, zero upgrades"
  (let* ((old (dummy-package "foo" (version "1")))
         (tx  (mock ((gnu packages) find-newest-available-packages
                     (const vlist-null))
                    ((@@ (guix scripts package) transaction-upgrade-entry)
                     (manifest-entry
                       (inherit (package->manifest-entry old))
                       (item (string-append (%store-prefix) "/"
                                            (make-string 32 #\e) "-foo-1")))
                     (manifest-transaction)))))
    (manifest-transaction-null? tx)))

(test-assert "transaction-upgrade-entry, one upgrade"
  (let* ((old (dummy-package "foo" (version "1")))
         (new (dummy-package "foo" (version "2")))
         (tx  (mock ((gnu packages) find-newest-available-packages
                     (const (vhash-cons "foo" (list "2" new) vlist-null)))
                    ((@@ (guix scripts package) transaction-upgrade-entry)
                     (manifest-entry
                       (inherit (package->manifest-entry old))
                       (item (string-append (%store-prefix) "/"
                                            (make-string 32 #\e) "-foo-1")))
                     (manifest-transaction)))))
    (and (match (manifest-transaction-install tx)
           ((($ <manifest-entry> "foo" "2" "out" item))
            (eq? item new)))
         (null? (manifest-transaction-remove tx)))))

(test-assert "transaction-upgrade-entry, superseded package"
  (let* ((old (dummy-package "foo" (version "1")))
         (new (dummy-package "bar" (version "2")))
         (dep (deprecated-package "foo" new))
         (tx  (mock ((gnu packages) find-newest-available-packages
                     (const (vhash-cons "foo" (list "2" dep) vlist-null)))
                    ((@@ (guix scripts package) transaction-upgrade-entry)
                     (manifest-entry
                       (inherit (package->manifest-entry old))
                       (item (string-append (%store-prefix) "/"
                                            (make-string 32 #\e) "-foo-1")))
                     (manifest-transaction)))))
    (and (match (manifest-transaction-install tx)
           ((($ <manifest-entry> "bar" "2" "out" item))
            (eq? item new)))
         (match (manifest-transaction-remove tx)
           (((? manifest-pattern? pattern))
            (and (string=? (manifest-pattern-name pattern) "foo")
                 (string=? (manifest-pattern-version pattern) "1")
                 (string=? (manifest-pattern-output pattern) "out")))))))

(test-assert "package-field-location"
  (let ()
    (define (goto port line column)
      (unless (and (= (port-column port) (- column 1))
                   (= (port-line port) (- line 1)))
        (unless (eof-object? (get-char port))
          (goto port line column))))

    (define read-at
      (match-lambda
       (($ <location> file line column)
        (call-with-input-file (search-path %load-path file)
          (lambda (port)
            (goto port line column)
            (read port))))))

    ;; Until Guile 2.0.6 included, source properties were added only to pairs.
    ;; Thus, check against both VALUE and (FIELD VALUE).
    (and (member (read-at (package-field-location %bootstrap-guile 'name))
                 (let ((name (package-name %bootstrap-guile)))
                   (list name `(name ,name))))
         (member (read-at (package-field-location %bootstrap-guile 'version))
                 (let ((version (package-version %bootstrap-guile)))
                   (list version `(version ,version))))
         (not (package-field-location %bootstrap-guile 'does-not-exist)))))

;; Make sure we don't change the file name to an absolute file name.
(test-equal "package-field-location, relative file name"
  (location-file (package-location %bootstrap-guile))
  (with-fluids ((%file-port-name-canonicalization 'absolute))
    (location-file (package-field-location %bootstrap-guile 'version))))

(test-assert "package-transitive-inputs"
  (let* ((a (dummy-package "a"))
         (b (dummy-package "b"
              (propagated-inputs `(("a" ,a)))))
         (c (dummy-package "c"
              (inputs `(("a" ,a)))))
         (d (dummy-package "d"
              (propagated-inputs `(("x" "something.drv")))))
         (e (dummy-package "e"
              (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
    (and (null? (package-transitive-inputs a))
         (equal? `(("a" ,a)) (package-transitive-inputs b))
         (equal? `(("a" ,a)) (package-transitive-inputs c))
         (equal? (package-propagated-inputs d)
                 (package-transitive-inputs d))
         (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
                   ("a" ,a) ("x" "something.drv"))
                 (pk 'x (package-transitive-inputs e))))))

(test-assert "package-transitive-inputs, no duplicates"
  (let* ((a (dummy-package "a"))
         (b (dummy-package "b"
              (inputs `(("a+" ,a)))
              (native-inputs `(("a*" ,a)))
              (propagated-inputs `(("a" ,a)))))
         (c (dummy-package "c"
              (propagated-inputs `(("b" ,b)))))
         (d (dummy-package "d"
              (inputs `(("a" ,a) ("c" ,c)))))
         (e (dummy-package "e"
              (inputs `(("b" ,b) ("c" ,c))))))
    (and (null? (package-transitive-inputs a))
         (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
                 (package-transitive-inputs b))
         (equal? `(("b" ,b) ("a" ,a))
                 (package-transitive-inputs c))
         (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
                 (package-transitive-inputs d))
         (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
                 (package-transitive-inputs e))))) ;ditto

(test-equal "package-transitive-supported-systems"
  '(("x" "y" "z")                                 ;a
    ("x" "y")                                     ;b
    ("y")                                         ;c
    ("y")                                         ;d
    ("y"))                                        ;e
  ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
  ;; doesn't restrict the set of supported systems.
  (let* ((a (dummy-package "a"
              (build-system trivial-build-system)
              (supported-systems '("x" "y" "z"))))
         (b (dummy-package "b"
              (build-system trivial-build-system)
              (supported-systems '("x" "y"))
              (inputs `(("a" ,a)))))
         (c (dummy-package "c"
              (build-system trivial-build-system)
              (supported-systems '("y" "z"))
              (inputs `(("b" ,b)))))
         (d (dummy-package "d"
              (build-system trivial-build-system)
              (supported-systems '("x" "y" "z"))
              (inputs `(("b" ,b) ("c" ,c)))))
         (e (dummy-package "e"
              (build-system trivial-build-system)
              (supported-systems '("x" "y" "z"))
              (inputs `(("d" ,d))))))
    (list (package-transitive-supported-systems a)
          (package-transitive-supported-systems b)
          (package-transitive-supported-systems c)
          (package-transitive-supported-systems d)
          (package-transitive-supported-systems e))))

(test-equal "origin-actual-file-name"
  "foo-1.tar.gz"
  (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
    (origin-actual-file-name o)))

(test-equal "origin-actual-file-name, file-name"
  "foo-1.tar.gz"
  (let ((o (dummy-origin
            (uri "http://www.example.com/tarball")
            (file-name "foo-1.tar.gz"))))
    (origin-actual-file-name o)))

(let* ((o (dummy-origin))
       (u (dummy-origin))
       (i (dummy-origin))
       (a (dummy-package "a"))
       (b (dummy-package "b"
            (inputs `(("a" ,a) ("i" ,i)))))
       (c (package (inherit b) (source o)))
       (d (dummy-package "d"
            (build-system trivial-build-system)
            (source u) (inputs `(("c" ,c))))))
  (test-assert "package-direct-sources, no source"
    (null? (package-direct-sources a)))
  (test-equal "package-direct-sources, #f source"
    (list i)
    (package-direct-sources b))
  (test-equal "package-direct-sources, not input source"
    (list u)
    (package-direct-sources d))
  (test-assert "package-direct-sources"
    (let ((s (package-direct-sources c)))
      (and (= (length (pk 's-sources s)) 2)
           (member o s)
           (member i s))))
  (test-assert "package-transitive-sources"
    (let ((s (package-transitive-sources d)))
      (and (= (length (pk 'd-sources s)) 3)
           (member o s)
           (member i s)
           (member u s)))))

(test-assert "transitive-input-references"
  (let* ((a (dummy-package "a"))
         (b (dummy-package "b"))
         (c (dummy-package "c"
              (inputs `(("a" ,a)))
              (propagated-inputs `(("boo" ,b)))))
         (d (dummy-package "d"
              (inputs `(("c*" ,c)))))
         (keys (map (match-lambda
                      (('assoc-ref 'l key)
                       key))
                    (pk 'refs (transitive-input-references
                               'l (package-inputs d))))))
    (and (= (length keys) 2)
         (member "c*" keys)
         (member "boo" keys))))

(test-equal "package-transitive-supported-systems, implicit inputs"
  %supported-systems

  ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
  ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
  (let ((p (dummy-package "foo"
             (build-system gnu-build-system)
             (supported-systems
              `("does-not-exist" "foobar" ,@%supported-systems)))))
    (package-transitive-supported-systems p)))

(test-assert "supported-package?"
  (let ((p (dummy-package "foo"
             (build-system gnu-build-system)
             (supported-systems '("x86_64-linux" "does-not-exist")))))
    (and (supported-package? p "x86_64-linux")
         (not (supported-package? p "does-not-exist"))
         (not (supported-package? p "i686-linux")))))

(test-skip (if (not %store) 8 0))

(test-assert "package-source-derivation, file"
  (let* ((file    (search-path %load-path "guix.scm"))
         (package (package (inherit (dummy-package "p"))
                    (source file)))
         (source  (package-source-derivation %store
                                             (package-source package))))
    (and (store-path? source)
         (valid-path? %store source)
         (equal? (call-with-input-file source get-bytevector-all)
                 (call-with-input-file file get-bytevector-all)))))

(test-assert "package-source-derivation, store path"
  (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
                                (search-path %load-path "guix.scm")))
         (package (package (inherit (dummy-package "p"))
                    (source file)))
         (source  (package-source-derivation %store
                                             (package-source package))))
    (string=? file source)))

(test-assert "package-source-derivation, indirect store path"
  (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
                                (dirname (search-path %load-path
                                                      "guix/build/utils.scm"))))
         (package (package (inherit (dummy-package "p"))
                    (source (string-append dir "/utils.scm"))))
         (source  (package-source-derivation %store
                                             (package-source package))))
    (and (direct-store-path? source)
         (string-suffix? "utils.scm" source))))

(test-assert "package-source-derivation, local-file"
  (let* ((file    (local-file "../guix/base32.scm"))
         (package (package (inherit (dummy-package "p"))
                    (source file)))
         (source  (package-source-derivation %store
                                             (package-source package))))
    (and (store-path? source)
         (string-suffix? "base32.scm" source)
         (valid-path? %store source)
         (equal? (call-with-input-file source get-bytevector-all)
                 (call-with-input-file
                     (search-path %load-path "guix/base32.scm")
                   get-bytevector-all)))))

(unless (network-reachable?) (test-skip 1))
(test-equal "package-source-derivation, snippet"
  "OK"
  (let* ((source (bootstrap-origin
                  (origin
                    (inherit (bootstrap-guile-origin (%current-system)))
                    (patch-inputs
                     `(("tar" ,%bootstrap-coreutils&co)
                       ("xz" ,%bootstrap-coreutils&co)
                       ("patch" ,%bootstrap-coreutils&co)))
                    (patch-guile %bootstrap-guile)
                    (modules '((guix build utils)))
                    (snippet '(begin
                                ;; We end up in 'bin', because it's the first
                                ;; directory, alphabetically.  Not a very good
                                ;; example but hey.
                                (chmod "." #o777)
                                (symlink "guile" "guile-rocks")
                                (copy-recursively "../share/guile/2.0/scripts"
                                                  "scripts")

                                ;; Make sure '.file_list' can be created.
                                (chmod ".." #o777))))))
         (package (package (inherit (dummy-package "with-snippet"))
                    (source source)
                    (build-system trivial-build-system)
                    (inputs
                     `(("tar" ,(search-bootstrap-binary "tar"
                                                        (%current-system)))
                       ("xz"  ,(search-bootstrap-binary "xz"
                                                        (%current-system)))))
                    (arguments
                     `(#:guile ,%bootstrap-guile
                       #:modules ((guix build utils))
                       #:builder
                       (begin
                         (use-modules (guix build utils))
                         (let ((tar    (assoc-ref %build-inputs "tar"))
                               (xz     (assoc-ref %build-inputs "xz"))
                               (source (assoc-ref %build-inputs "source")))
                           (invoke tar "xvf" source
                                   "--use-compress-program" xz)
                           (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
                                        (file-exists? "bin/scripts/compile.scm"))
                             (error "the snippet apparently failed"))
                           (let ((out (assoc-ref %outputs "out")))
                             (call-with-output-file out
                               (lambda (p)
                                 (display "OK" p))))
                           #t))))))
         (drv    (package-derivation %store package))
         (out    (derivation->output-path drv)))
    (and (build-derivations %store (list (pk 'snippet-drv drv)))
         (call-with-input-file out get-string-all))))

(test-assert "return value"
  (let ((drv (package-derivation %store (dummy-package "p"))))
    (and (derivation? drv)
         (file-exists? (derivation-file-name drv)))))

(test-assert "package-output"
  (let* ((package  (dummy-package "p"))
         (drv      (package-derivation %store package)))
    (and (derivation? drv)
         (string=? (derivation->output-path drv)
                   (package-output %store package "out")))))

(test-assert "patch not found yields a run-time error"
  (guard (c ((condition-has-type? c &message)
             (and (string-contains (condition-message c)
                                   "does-not-exist.patch")
                  (string-contains (condition-message c)
                                   "not found"))))
    (let ((p (package
               (inherit (dummy-package "p"))
               (source (origin
                         (method (const #f))
                         (uri "http://whatever")
                         (patches
                          (list (search-patch "does-not-exist.patch")))
                         (sha256
                          (base32
                           "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
      (package-derivation %store p)
      #f)))

(let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
  (test-equal "&package-input-error"
    (list dummy (current-module))
    (guard (c ((package-input-error? c)
               (list (package-error-package c)
                     (package-error-invalid-input c))))
      (package-derivation %store dummy))))

(test-assert "reference to non-existent output"
  ;; See <http://bugs.gnu.org/19630>.
  (parameterize ((%graft? #f))
    (let* ((dep (dummy-package "dep"))
           (p   (dummy-package "p"
                  (inputs `(("dep" ,dep "non-existent"))))))
      (guard (c ((derivation-missing-output-error? c)
                 (and (string=? (derivation-missing-output c) "non-existent")
                      (equal? (package-derivation %store dep)
                              (derivation-error-derivation c)))))
        (package-derivation %store p)))))

(test-assert "trivial"
  (let* ((p (package (inherit (dummy-package "trivial"))
              (build-system trivial-build-system)
              (source #f)
              (arguments
               `(#:guile ,%bootstrap-guile
                 #:builder
                 (begin
                   (mkdir %output)
                   (call-with-output-file (string-append %output "/test")
                     (lambda (p)
                       (display '(hello guix) p)))
                   #t)))))
         (d (package-derivation %store p)))
    (and (build-derivations %store (list d))
         (let ((p (pk 'drv d (derivation->output-path d))))
           (equal? '(hello guix)
                   (call-with-input-file (string-append p "/test") read))))))

(test-assert "trivial with local file as input"
  (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
         (p (package (inherit (dummy-package "trivial-with-input-file"))
              (build-system trivial-build-system)
              (source #f)
              (arguments
               `(#:guile ,%bootstrap-guile
                 #:builder (begin
                             (copy-file (assoc-ref %build-inputs "input")
                                        %output)
                             #t)))
              (inputs `(("input" ,i)))))
         (d (package-derivation %store p)))
    (and (build-derivations %store (list d))
         (let ((p (pk 'drv d (derivation->output-path d))))
           (equal? (call-with-input-file p get-bytevector-all)
                   (call-with-input-file i get-bytevector-all))))))

(test-assert "trivial with source"
  (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
         (p (package (inherit (dummy-package "trivial-with-source"))
              (build-system trivial-build-system)
              (source i)
              (arguments
               `(#:guile ,%bootstrap-guile
                 #:builder (begin
                             (copy-file (assoc-ref %build-inputs "source")
                                        %output)
                             #t)))))
         (d (package-derivation %store p)))
    (and (build-derivations %store (list d))
         (let ((p (derivation->output-path d)))
           (equal? (call-with-input-file p get-bytevector-all)
                   (call-with-input-file i get-bytevector-all))))))

(test-assert "trivial with system-dependent input"
  (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
              (build-system trivial-build-system)
              (source #f)
              (arguments
               `(#:guile ,%bootstrap-guile
                 #:modules ((guix build utils))
                 #:builder
                 (begin
                   (use-modules (guix build utils))
                   (let ((out  (assoc-ref %outputs "out"))
                         (bash (assoc-ref %build-inputs "bash")))
                     (invoke bash "-c"
                             (format #f "echo hello > ~a" out))))))
              (inputs `(("bash" ,(search-bootstrap-binary "bash"
                                                          (%current-system)))))))
         (d (package-derivation %store p)))
    (and (build-derivations %store (list d))
         (let ((p (pk 'drv d (derivation->output-path d))))
           (eq? 'hello (call-with-input-file p read))))))

(test-assert "trivial with #:allowed-references"
  (let* ((p (package
              (inherit (dummy-package "trivial"))
              (build-system trivial-build-system)
              (arguments
               `(#:guile ,%bootstrap-guile
                 #:allowed-references (,%bootstrap-guile)
                 #:builder
                 (begin
                   (mkdir %output)
                   ;; The reference to itself isn't allowed so building it
                   ;; should fail.
                   (symlink %output (string-append %output "/self"))
                   #t)))))
         (d (package-derivation %store p)))
    (guard (c ((nix-protocol-error? c) #t))
      (build-derivations %store (list d))
      #f)))

(test-assert "search paths"
  (let* ((p (make-prompt-tag "return-search-paths"))
         (s (build-system
             (name 'raw)
             (description "Raw build system with direct store access")
             (lower (lambda* (name #:key source inputs system target
                                   #:allow-other-keys)
                      (bag
                        (name name)
                        (system system) (target target)
                        (build-inputs inputs)
                        (build
                         (lambda* (store name inputs
                                         #:key outputs system search-paths)
                           search-paths)))))))
         (x (list (search-path-specification
                   (variable "GUILE_LOAD_PATH")
                   (files '("share/guile/site/2.0")))
                  (search-path-specification
                   (variable "GUILE_LOAD_COMPILED_PATH")
                   (files '("share/guile/site/2.0")))))
         (a (package (inherit (dummy-package "guile"))
              (build-system s)
              (native-search-paths x)))
         (b (package (inherit (dummy-package "guile-foo"))
              (build-system s)
              (inputs `(("guile" ,a)))))
         (c (package (inherit (dummy-package "guile-bar"))
              (build-system s)
              (inputs `(("guile" ,a)
                        ("guile-foo" ,b))))))
    (let-syntax ((collect (syntax-rules ()
                            ((_ body ...)
                             (call-with-prompt p
                               (lambda ()
                                 body ...)
                               (lambda (k search-paths)
                                 search-paths))))))
      (and (null? (collect (package-derivation %store a)))
           (equal? x (collect (package-derivation %store b)))
           (equal? x (collect (package-derivation %store c)))))))

(test-assert "package-transitive-native-search-paths"
  (let* ((sp (lambda (name)
               (list (search-path-specification
                      (variable name)
                      (files '("foo/bar"))))))
         (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
         (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
         (p2 (dummy-package "p2"
               (native-search-paths (sp "PATH2"))
               (inputs `(("p0" ,p0)))
               (propagated-inputs `(("p1" ,p1)))))
         (p3 (dummy-package "p3"
               (native-search-paths (sp "PATH3"))
               (native-inputs `(("p0" ,p0)))
               (propagated-inputs `(("p2" ,p2))))))
    (lset= string=?
           '("PATH1" "PATH2" "PATH3")
           (map search-path-specification-variable
                (package-transitive-native-search-paths p3)))))

(test-assert "package-cross-derivation"
  (let ((drv (package-cross-derivation %store (dummy-package "p")
                                       "mips64el-linux-gnu")))
    (and (derivation? drv)
         (file-exists? (derivation-file-name drv)))))

(test-assert "package-cross-derivation, trivial-build-system"
  (let ((p (package (inherit (dummy-package "p"))
             (build-system trivial-build-system)
             (arguments '(#:builder (exit 1))))))
    (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
      (derivation? drv))))

(test-assert "package-cross-derivation, no cross builder"
  (let* ((b (build-system (inherit trivial-build-system)
              (lower (const #f))))
         (p (package (inherit (dummy-package "p"))
              (build-system b))))
    (guard (c ((package-cross-build-system-error? c)
               (eq? (package-error-package c) p)))
      (package-cross-derivation %store p "mips64el-linux-gnu")
      #f)))

;; XXX: The next two tests can trigger builds when the distro defines
;; replacements on core packages, so they're disable for lack of a better
;; solution.

;; (test-equal "package-derivation, direct graft"
;;   (package-derivation %store gnu-make #:graft? #f)
;;   (let ((p (package (inherit coreutils)
;;              (replacement gnu-make))))
;;     (package-derivation %store p #:graft? #t)))

;; (test-equal "package-cross-derivation, direct graft"
;;   (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
;;                             #:graft? #f)
;;   (let ((p (package (inherit coreutils)
;;              (replacement gnu-make))))
;;     (package-cross-derivation %store p "mips64el-linux-gnu"
;;                               #:graft? #t)))

(test-assert "package-grafts, indirect grafts"
  (let* ((new   (dummy-package "dep"
                  (arguments '(#:implicit-inputs? #f))))
         (dep   (package (inherit new) (version "0.0")))
         (dep*  (package (inherit dep) (replacement new)))
         (dummy (dummy-package "dummy"
                  (arguments '(#:implicit-inputs? #f))
                  (inputs `(("dep" ,dep*))))))
    (equal? (package-grafts %store dummy)
            (list (graft
                    (origin (package-derivation %store dep))
                    (replacement (package-derivation %store new)))))))

;; XXX: This test would require building the cross toolchain just to see if it
;; needs grafting, which is obviously too expensive, and thus disabled.
;;
;; (test-assert "package-grafts, indirect grafts, cross"
;;   (let* ((new    (dummy-package "dep"
;;                    (arguments '(#:implicit-inputs? #f))))
;;          (dep    (package (inherit new) (version "0.0")))
;;          (dep*   (package (inherit dep) (replacement new)))
;;          (dummy  (dummy-package "dummy"
;;                    (arguments '(#:implicit-inputs? #f))
;;                    (inputs `(("dep" ,dep*)))))
;;          (target "mips64el-linux-gnu"))
;;     ;; XXX: There might be additional grafts, for instance if the distro
;;     ;; defines replacements for core packages like Perl.
;;     (member (graft
;;               (origin (package-cross-derivation %store dep target))
;;               (replacement
;;                (package-cross-derivation %store new target)))
;;             (package-grafts %store dummy #:target target))))

(test-assert "package-grafts, indirect grafts, propagated inputs"
  (let* ((new   (dummy-package "dep"
                  (arguments '(#:implicit-inputs? #f))))
         (dep   (package (inherit new) (version "0.0")))
         (dep*  (package (inherit dep) (replacement new)))
         (prop  (dummy-package "propagated"
                  (propagated-inputs `(("dep" ,dep*)))
                  (arguments '(#:implicit-inputs? #f))))
         (dummy (dummy-package "dummy"
                  (arguments '(#:implicit-inputs? #f))
                  (inputs `(("prop" ,prop))))))
    (equal? (package-grafts %store dummy)
            (list (graft
                    (origin (package-derivation %store dep))
                    (replacement (package-derivation %store new)))))))

(test-assert "package-grafts, same replacement twice"
  (let* ((new  (dummy-package "dep"
                 (version "1")
                 (arguments '(#:implicit-inputs? #f))))
         (dep  (package (inherit new) (version "0") (replacement new)))
         (p1   (dummy-package "intermediate1"
                 (arguments '(#:implicit-inputs? #f))
                 (inputs `(("dep" ,dep)))))
         (p2   (dummy-package "intermediate2"
                 (arguments '(#:implicit-inputs? #f))
                 ;; Here we copy DEP to have an equivalent package that is not
                 ;; 'eq?' to DEP.  This is similar to what happens with
                 ;; 'package-with-explicit-inputs' & co.
                 (inputs `(("dep" ,(package (inherit dep)))))))
         (p3   (dummy-package "final"
                 (arguments '(#:implicit-inputs? #f))
                 (inputs `(("p1" ,p1) ("p2" ,p2))))))
    (equal? (package-grafts %store p3)
            (list (graft
                    (origin (package-derivation %store
                                                (package (inherit dep)
                                                         (replacement #f))))
                    (replacement (package-derivation %store new)))))))

(test-assert "replacement also grafted"
  ;; We build a DAG as below, where dotted arrows represent replacements and
  ;; solid arrows represent dependencies:
  ;;
  ;;  P1  ·············>  P1R
  ;;  |\__________________.
  ;;  v                   v
  ;;  P2  ·············>  P2R
  ;;  |
  ;;  v
  ;;  P3
  ;;
  ;; We want to make sure that:
  ;;   grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
  ;; where:
  ;;   (A,B) is a graft to replace A by B
  ;;   grafted(DRV,G) denoted DRV with graft G applied
  (let* ((p1r (dummy-package "P1"
                (build-system trivial-build-system)
                (arguments
                 `(#:guile ,%bootstrap-guile
                   #:builder (let ((out (assoc-ref %outputs "out")))
                               (mkdir out)
                               (call-with-output-file
                                   (string-append out "/replacement")
                                 (const #t)))))))
         (p1  (package
                (inherit p1r) (name "p1") (replacement p1r)
                (arguments
                 `(#:guile ,%bootstrap-guile
                   #:builder (begin
                               (mkdir (assoc-ref %outputs "out"))
                               #t)))))
         (p2r (dummy-package "P2"
                (build-system trivial-build-system)
                (inputs `(("p1" ,p1)))
                (arguments
                 `(#:guile ,%bootstrap-guile
                   #:builder (let ((out (assoc-ref %outputs "out")))
                               (mkdir out)
                               (chdir out)
                               (symlink (assoc-ref %build-inputs "p1") "p1")
                               (call-with-output-file (string-append out "/replacement")
                                 (const #t)))))))
         (p2  (package
                (inherit p2r) (name "p2") (replacement p2r)
                (arguments
                 `(#:guile ,%bootstrap-guile
                   #:builder (let ((out (assoc-ref %outputs "out")))
                               (mkdir out)
                               (chdir out)
                               (symlink (assoc-ref %build-inputs "p1")
                                        "p1")
                               #t)))))
         (p3  (dummy-package "p3"
                (build-system trivial-build-system)
                (inputs `(("p2" ,p2)))
                (arguments
                 `(#:guile ,%bootstrap-guile
                   #:builder (let ((out (assoc-ref %outputs "out")))
                               (mkdir out)
                               (chdir out)
                               (symlink (assoc-ref %build-inputs "p2")
                                        "p2")
                               #t))))))
    (lset= equal?
           (package-grafts %store p3)
           (list (graft
                   (origin (package-derivation %store p1 #:graft? #f))
                   (replacement (package-derivation %store p1r)))
                 (graft
                   (origin (package-derivation %store p2 #:graft? #f))
                   (replacement
                    (package-derivation %store p2r #:graft? #t)))))))

;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
;;; find out about their run-time dependencies, so this test is no longer
;;; applicable since it would trigger a full rebuild.
;;
;; (test-assert "package-derivation, indirect grafts"
;;   (let* ((new   (dummy-package "dep"
;;                   (arguments '(#:implicit-inputs? #f))))
;;          (dep   (package (inherit new) (version "0.0")))
;;          (dep*  (package (inherit dep) (replacement new)))
;;          (dummy (dummy-package "dummy"
;;                   (arguments '(#:implicit-inputs? #f))
;;                   (inputs `(("dep" ,dep*)))))
;;          (guile (package-derivation %store (canonical-package guile-2.0)
;;                                     #:graft? #f)))
;;     (equal? (package-derivation %store dummy)
;;             (graft-derivation %store
;;                               (package-derivation %store dummy #:graft? #f)
;;                               (package-grafts %store dummy)

;;                               ;; Use the same Guile as 'package-derivation'.
;;                               #:guile guile))))

(test-equal "package->bag"
  `("foo86-hurd" #f (,(package-source gnu-make))
    (,(canonical-package glibc)) (,(canonical-package coreutils)))
  (let ((bag (package->bag gnu-make "foo86-hurd")))
    (list (bag-system bag) (bag-target bag)
          (assoc-ref (bag-build-inputs bag) "source")
          (assoc-ref (bag-build-inputs bag) "libc")
          (assoc-ref (bag-build-inputs bag) "coreutils"))))

(test-equal "package->bag, cross-compilation"
  `(,(%current-system) "foo86-hurd"
    (,(package-source gnu-make))
    (,(canonical-package glibc)) (,(canonical-package coreutils)))
  (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
    (list (bag-system bag) (bag-target bag)
          (assoc-ref (bag-build-inputs bag) "source")
          (assoc-ref (bag-build-inputs bag) "libc")
          (assoc-ref (bag-build-inputs bag) "coreutils"))))

(test-assert "package->bag, propagated inputs"
  (let* ((dep    (dummy-package "dep"))
         (prop   (dummy-package "prop"
                   (propagated-inputs `(("dep" ,dep)))))
         (dummy  (dummy-package "dummy"
                   (inputs `(("prop" ,prop)))))
         (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
    (match (assoc "dep" inputs)
      (("dep" package)
       (eq? package dep)))))

(test-assert "bag->derivation"
  (parameterize ((%graft? #f))
    (let ((bag (package->bag gnu-make))
          (drv (package-derivation %store gnu-make)))
      (parameterize ((%current-system "foox86-hurd")) ;should have no effect
        (equal? drv (bag->derivation %store bag))))))

(test-assert "bag->derivation, cross-compilation"
  (parameterize ((%graft? #f))
    (let* ((target "mips64el-linux-gnu")
           (bag    (package->bag gnu-make (%current-system) target))
           (drv    (package-cross-derivation %store gnu-make target)))
      (parameterize ((%current-system "foox86-hurd") ;should have no effect
                     (%current-target-system "foo64-linux-gnu"))
        (equal? drv (bag->derivation %store bag))))))

(when (or (not (network-reachable?)) (shebang-too-long?))
  (test-skip 1))
(test-assert "GNU Make, bootstrap"
  ;; GNU Make is the first program built during bootstrap; we choose it
  ;; here so that the test doesn't last for too long.
  (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
    (and (package? gnu-make)
         (or (location? (package-location gnu-make))
             (not (package-location gnu-make)))
         (let* ((drv (package-derivation %store gnu-make))
                (out (derivation->output-path drv)))
           (and (build-derivations %store (list drv))
                (file-exists? (string-append out "/bin/make")))))))

(test-equal "package-mapping"
  42
  (let* ((dep       (dummy-package "chbouib"
                      (native-inputs `(("x" ,grep)))))
         (p0        (dummy-package "example"
                      (inputs `(("foo" ,coreutils)
                                ("bar" ,grep)
                                ("baz" ,dep)))))
         (transform (lambda (p)
                      (package (inherit p) (source 42))))
         (rewrite   (package-mapping transform))
         (p1        (rewrite p0)))
    (and (eq? p1 (rewrite p0))
         (eqv? 42 (package-source p1))
         (match (package-inputs p1)
           ((("foo" dep1) ("bar" dep2) ("baz" dep3))
            (and (eq? dep1 (rewrite coreutils))   ;memoization
                 (eq? dep2 (rewrite grep))
                 (eq? dep3 (rewrite dep))
                 (eqv? 42
                       (package-source dep1) (package-source dep2)
                       (package-source dep3))
                 (match (package-native-inputs dep3)
                   ((("x" dep))
                    (and (eq? dep (rewrite grep))
                         (package-source dep))))))))))

(test-assert "package-input-rewriting"
  (let* ((dep     (dummy-package "chbouib"
                    (native-inputs `(("x" ,grep)))))
         (p0      (dummy-package "example"
                    (inputs `(("foo" ,coreutils)
                              ("bar" ,grep)
                              ("baz" ,dep)))))
         (rewrite (package-input-rewriting `((,coreutils . ,sed)
                                             (,grep . ,findutils))
                                           (cut string-append "r-" <>)))
         (p1      (rewrite p0))
         (p2      (rewrite p0)))
    (and (not (eq? p1 p0))
         (eq? p1 p2)                              ;memoization
         (string=? "r-example" (package-name p1))
         (match (package-inputs p1)
           ((("foo" dep1) ("bar" dep2) ("baz" dep3))
            (and (eq? dep1 sed)
                 (eq? dep2 findutils)
                 (string=? (package-name dep3) "r-chbouib")
                 (eq? dep3 (rewrite dep))         ;memoization
                 (match (package-native-inputs dep3)
                   ((("x" dep))
                    (eq? dep findutils)))))))))

(test-equal "package-patched-vulnerabilities"
  '(("CVE-2015-1234")
    ("CVE-2016-1234" "CVE-2018-4567")
    ())
  (let ((p1 (dummy-package "pi"
              (source (dummy-origin
                       (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
        (p2 (dummy-package "pi"
              (source (dummy-origin
                       (patches (list
                                 "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
        (p3 (dummy-package "pi" (source (dummy-origin)))))
    (map package-patched-vulnerabilities
         (list p1 p2 p3))))

(test-eq "fold-packages" hello
  (fold-packages (lambda (p r)
                   (if (string=? (package-name p) "hello")
                       p
                       r))
                 #f))

(test-assert "fold-packages, hidden package"
  ;; There are two public variables providing "guile@2.0" ('guile-final' in
  ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
  ;; should show up.
  (match (fold-packages (lambda (p r)
                          (if (and (string=? (package-name p) "guile")
                                   (string-prefix? "2.0"
                                                   (package-version p)))
                              (cons p r)
                              r))
                        '())
    ((one)
     (eq? one guile-2.0))))

(test-assert "find-packages-by-name"
  (match (find-packages-by-name "hello")
    (((? (cut eq? hello <>))) #t)
    (wrong (pk 'find-packages-by-name wrong #f))))

(test-assert "find-packages-by-name with version"
  (match (find-packages-by-name "hello" (package-version hello))
    (((? (cut eq? hello <>))) #t)
    (wrong (pk 'find-packages-by-name wrong #f))))

(test-assert "--search-paths with pattern"
  ;; Make sure 'guix package --search-paths' correctly reports environment
  ;; variables when file patterns are used (in particular, it must follow
  ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
  ;; libxml2 package specification, which contains such a definition.
  (let* ((p1 (package
               (name "foo") (version "0") (source #f)
               (build-system trivial-build-system)
               (arguments
                `(#:guile ,%bootstrap-guile
                  #:modules ((guix build utils))
                  #:builder (begin
                              (use-modules (guix build utils))
                              (let ((out (assoc-ref %outputs "out")))
                                (mkdir-p (string-append out "/xml/bar/baz"))
                                (call-with-output-file
                                    (string-append out "/xml/bar/baz/catalog.xml")
                                  (lambda (port)
                                    (display "xml? wat?!" port)))
                                #t))))
               (synopsis #f) (description #f)
               (home-page #f) (license #f)))
         (p2 (package
               ;; Provide a fake libxml2 to avoid building the real one.  This
               ;; is OK because 'guix package' gets search path specifications
               ;; from the same-named package found in the distro.
               (name "libxml2") (version "0.0.0") (source #f)
               (build-system trivial-build-system)
               (arguments
                `(#:guile ,%bootstrap-guile
                  #:builder (begin
                              (mkdir (assoc-ref %outputs "out"))
                              #t)))
               (native-search-paths (package-native-search-paths libxml2))
               (synopsis #f) (description #f)
               (home-page #f) (license #f)))
         (prof (run-with-store %store
                 (profile-derivation
                  (manifest (map package->manifest-entry
                                 (list p1 p2)))
                  #:hooks '()
                  #:locales? #f)
                 #:guile-for-build (%guile-for-build))))
    (build-derivations %store (list prof))
    (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
                          (regexp-quote (derivation->output-path prof)))
                  (with-output-to-string
                    (lambda ()
                      (guix-package "-p" (derivation->output-path prof)
                                    "--search-paths"))))))

(test-assert "--search-paths with single-item search path"
  ;; Make sure 'guix package --search-paths' correctly reports environment
  ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
  ;; separator, meaning that the first match wins.
  (let* ((p1 (dummy-package "foo"
               (build-system trivial-build-system)
               (arguments
                `(#:guile ,%bootstrap-guile
                  #:modules ((guix build utils))
                  #:builder (begin
                              (use-modules (guix build utils))
                              (let ((out (assoc-ref %outputs "out")))
                                (mkdir-p (string-append out "/etc/ssl/certs"))
                                (call-with-output-file
                                    (string-append
                                     out "/etc/ssl/certs/ca-certificates.crt")
                                  (const #t))))))))
         (p2 (package (inherit p1) (name "bar")))
         (p3 (dummy-package "git"
               ;; Provide a fake Git to avoid building the real one.
               (build-system trivial-build-system)
               (arguments
                `(#:guile ,%bootstrap-guile
                  #:builder (begin
                              (mkdir (assoc-ref %outputs "out"))
                              #t)))
               (native-search-paths (package-native-search-paths git))))
         (prof1 (run-with-store %store
                  (profile-derivation
                   (packages->manifest (list p1 p3))
                   #:hooks '()
                   #:locales? #f)
                  #:guile-for-build (%guile-for-build)))
         (prof2 (run-with-store %store
                  (profile-derivation
                   (packages->manifest (list p2 p3))
                   #:hooks '()
                   #:locales? #f)
                  #:guile-for-build (%guile-for-build))))
    (build-derivations %store (list prof1 prof2))
    (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
                          (regexp-quote (derivation->output-path prof1)))
                  (with-output-to-string
                    (lambda ()
                      (guix-package "-p" (derivation->output-path prof1)
                                    "-p" (derivation->output-path prof2)
                                    "--search-paths"))))))

(test-equal "specification->package when not found"
  'quit
  (catch 'quit
    (lambda ()
      ;; This should call 'leave', producing an error message.
      (specification->package "this-package-does-not-exist"))
    (lambda (key . args)
      key)))

(test-end "packages")

;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End:


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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-pki)
  #:use-module (guix pki)
  #:use-module (gcrypt pk-crypto)
  #:use-module (gcrypt hash)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-64))

;; Test the (guix pki) module.

(define %public-key
  (call-with-input-file %public-key-file
    (compose string->canonical-sexp get-string-all)))

(define %secret-key
  (call-with-input-file %private-key-file
    (compose string->canonical-sexp get-string-all)))

(define %alternate-secret-key
  (string->canonical-sexp
   "
  (key-data
   (public-key
    (rsa
     (n #00FDBF170366AC43B7D95CF9085565C566FB1F21B17C0A36E68F35ABB500E7851E00B40D7B04C8CD25903371F38E4C298FACEFFC4C97E913B536A0672BAF99D04515AE98A1A56627CD7EB02502FCFBEEA21AF13CC1A853192AD6409B9EFBD9F549BDE32BD890AE01F9A221E81FEE1C407090550647790E0D60775B855E181C2FB5#)
     (e #010001#)))
   (private-key
    (rsa
     (n #00FDBF170366AC43B7D95CF9085565C566FB1F21B17C0A36E68F35ABB500E7851E00B40D7B04C8CD25903371F38E4C298FACEFFC4C97E913B536A0672BAF99D04515AE98A1A56627CD7EB02502FCFBEEA21AF13CC1A853192AD6409B9EFBD9F549BDE32BD890AE01F9A221E81FEE1C407090550647790E0D60775B855E181C2FB5#)
     (e #010001#)
     (d #2790250C2E74C2FD361A99288BBA19B878048F5A0F333F829CC71B3DD64582DB9DF3F4DB1EB0994DD7493225EDA4A1E1492F44D903617FA5643E47BFC7BA157EF48B492AB51229916B02DDBDA0E7DBC7B35A6B8332AB463DC61951CA694551A9760F5A836A375D39E3EA8F2C502A3B5D89CB8777A809B75D603BE7511CEB74E9#)
     (p #00FE15B1751E1C31125B724FF37462F9476239A2AFF4192FAB1550F76928C8D02407F4F5EFC83F7A0AF51BD93399DDC06A4B54DFA60A7079F160A9F618C0148AD9#)
     (q #00FFA8BE7005AAB7401B0926CD9D6AC30BC9BE7D12C8737C9438498A999F56BE9F5EA98B4D7F5364BEB6D550A5AEDDE34C1EC152C9DAF61A97FDE71740C73BAA3D#)
     (u #00FD4050EF4F31B41EC81C28E18D205DFFB3C188F15D8BBA300E30AD8B5C4D3E392EFE10269FC115A538B19F4025973AB09B6650A7FF97DA833FB726F3D8819319#))))"))

(test-begin "pki")

(test-assert "current-acl"
  (not (not (member (canonical-sexp->sexp %public-key)
                    (map canonical-sexp->sexp
                         (acl->public-keys (current-acl)))))))

(test-assert "authorized-key? public-key current-acl"
  (authorized-key? %public-key))

(test-assert "authorized-key? public-key empty-acl"
  (not (authorized-key? %public-key (public-keys->acl '()))))

(test-assert "authorized-key? public-key singleton"
  (authorized-key? %public-key (public-keys->acl (list %public-key))))

(test-assert "signature-case valid-signature"
  (let* ((hash (sha256 #vu8(1 2 3)))
         (data (bytevector->hash-data hash #:key-type (key-type %public-key)))
         (sig  (signature-sexp data %secret-key %public-key)))
   (signature-case (sig hash (public-keys->acl (list %public-key)))
     (valid-signature #t)
     (else #f))))

(test-eq "signature-case invalid-signature" 'i
  (let* ((hash (sha256 #vu8(1 2 3)))
         (data (bytevector->hash-data hash #:key-type (key-type %public-key)))
         (sig  (signature-sexp data %alternate-secret-key %public-key)))
    (signature-case (sig hash (public-keys->acl (list %public-key)))
      (valid-signature 'v)
      (invalid-signature 'i)
      (hash-mismatch 'm)
      (unauthorized-key 'u)
      (corrupt-signature 'c))))

(test-eq "signature-case hash-mismatch" 'm
  (let* ((hash (sha256 #vu8(1 2 3)))
         (data (bytevector->hash-data hash #:key-type (key-type %public-key)))
         (sig  (signature-sexp data %secret-key %public-key)))
    (signature-case (sig (sha256 #vu8())
                         (public-keys->acl (list %public-key)))
      (valid-signature 'v)
      (invalid-signature 'i)
      (hash-mismatch 'm)
      (unauthorized-key 'u)
      (corrupt-signature 'c))))

(test-eq "signature-case unauthorized-key" 'u
  (let* ((hash (sha256 #vu8(1 2 3)))
         (data (bytevector->hash-data hash #:key-type (key-type %public-key)))
         (sig  (signature-sexp data %secret-key %public-key)))
    (signature-case (sig hash (public-keys->acl '()))
      (valid-signature 'v)
      (invalid-signature 'i)
      (hash-mismatch 'm)
      (unauthorized-key 'u)
      (corrupt-signature 'c))))

(test-eq "signature-case corrupt-signature" 'c
  (let* ((hash (sha256 #vu8(1 2 3)))
         (sig  (string->canonical-sexp "(w tf)")))
    (signature-case (sig hash (public-keys->acl (list %public-key)))
      (valid-signature 'v)
      (invalid-signature 'i)
      (hash-mismatch 'm)
      (unauthorized-key 'u)
      (corrupt-signature 'c))))

(test-end)

license: mit


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; 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-print)
  #:use-module (guix import print)
  #:use-module (guix build-system gnu)
  #:use-module (guix download)
  #:use-module (guix packages)
  #:use-module (guix licenses)
  #:use-module (srfi srfi-64))

(test-begin "print")

(define pkg
  (package
    (name "test")
    (version "1.2.3")
    (source (origin
              (method url-fetch)
              (uri (string-append "file:///tmp/test-"
                                  version ".tar.gz"))
              (sha256
               (base32
                "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
    (build-system gnu-build-system)
    (home-page "http://gnu.org")
    (synopsis "Dummy")
    (description "This is a dummy package.")
    (license gpl3+)))

(test-equal "simple package"
  (package->code pkg)
  '(package
     (name "test")
     (version "1.2.3")
     (source (origin
               (method url-fetch)
               (uri (string-append "file:///tmp/test-"
                                   version ".tar.gz"))
               (sha256
                (base32
                 "070pwb7brdcn1mfvplkd56vjc7lbz4iznzkqvfsakvgbv68k71ah"))))
     (build-system gnu-build-system)
     (home-page "http://gnu.org")
     (synopsis "Dummy")
     (description "This is a dummy package.")
     (license gpl3+)))

(test-end "print")


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018 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 monads)
  #:use-module (guix grafts)
  #:use-module (guix packages)
  #:use-module (guix derivations)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages bootstrap)
  #:use-module ((gnu packages base) #:prefix packages:)
  #:use-module ((gnu packages guile) #:prefix packages:)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 popen)
  #:use-module (rnrs io ports)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-11)
  #:use-module (srfi srfi-34)
  #:use-module (srfi srfi-64))

;; Test the (guix profiles) module.

(define %store
  (open-connection-for-tests))

;; Globally disable grafts because they can trigger early builds.
(%graft? #f)

(define-syntax-rule (test-assertm name exp)
  (test-assert name
    (run-with-store %store exp
                    #:guile-for-build (%guile-for-build))))

(define-syntax-rule (test-equalm name value exp)
  (test-equal name
    value
    (run-with-store %store exp
                    #:guile-for-build (%guile-for-build))))

;; Example manifest entries.

(define guile-1.8.8
  (manifest-entry
    (name "guile")
    (version "1.8.8")
    (item "/gnu/store/...")
    (output "out")))

(define guile-2.0.9
  (manifest-entry
    (name "guile")
    (version "2.0.9")
    (item "/gnu/store/...")
    (output "out")))

(define guile-2.0.9:debug
  (manifest-entry (inherit guile-2.0.9)
    (output "debug")))

(define glibc
  (manifest-entry
    (name "glibc")
    (version "2.19")
    (item "/gnu/store/...")
    (output "out")))

(test-begin "profiles")

(test-assert "manifest-installed?"
  (let ((m (manifest (list guile-2.0.9 guile-2.0.9:debug))))
    (and (manifest-installed? m (manifest-pattern (name "guile")))
         (manifest-installed? m (manifest-pattern
                                  (name "guile") (output "debug")))
         (manifest-installed? m (manifest-pattern
                                  (name "guile") (output "out")
                                  (version "2.0.9")))
         (not (manifest-installed?
               m (manifest-pattern (name "guile") (version "1.8.8"))))
         (not (manifest-installed?
               m (manifest-pattern (name "guile") (output "foobar")))))))

(test-assert "manifest-matching-entries"
  (let* ((e (list guile-2.0.9 guile-2.0.9:debug))
         (m (manifest e)))
    (and (null? (manifest-matching-entries m
                                           (list (manifest-pattern
                                                   (name "python")))))
         (equal? e
                 (manifest-matching-entries m
                                            (list (manifest-pattern
                                                    (name "guile")
                                                    (output #f)))))
         (equal? (list guile-2.0.9)
                 (manifest-matching-entries m
                                            (list (manifest-pattern
                                                    (name "guile")
                                                    (version "2.0.9"))))))))

(test-assert "manifest-remove"
  (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
         (m1 (manifest-remove m0
                              (list (manifest-pattern (name "guile")))))
         (m2 (manifest-remove m1
                              (list (manifest-pattern (name "guile"))))) ; same
         (m3 (manifest-remove m2
                              (list (manifest-pattern
                                      (name "guile") (output "debug")))))
         (m4 (manifest-remove m3
                              (list (manifest-pattern (name "guile"))))))
    (match (manifest-entries m2)
      ((($ <manifest-entry> "guile" "2.0.9" "debug"))
       (and (equal? m1 m2)
            (null? (manifest-entries m3))
            (null? (manifest-entries m4)))))))

(test-assert "manifest-add"
  (let* ((m0 (manifest '()))
         (m1 (manifest-add m0 (list guile-1.8.8)))
         (m2 (manifest-add m1 (list guile-2.0.9)))
         (m3 (manifest-add m2 (list guile-2.0.9:debug)))
         (m4 (manifest-add m3 (list guile-2.0.9:debug))))
    (and (match (manifest-entries m1)
           ((($ <manifest-entry> "guile" "1.8.8" "out")) #t)
           (_ #f))
         (match (manifest-entries m2)
           ((($ <manifest-entry> "guile" "2.0.9" "out")) #t)
           (_ #f))
         (equal? m3 m4))))

(test-equal "manifest-add removes duplicates"    ;<https://bugs.gnu.org/30569>
  (list guile-2.0.9)
  (manifest-entries (manifest-add (manifest '())
                                  (list guile-2.0.9 guile-2.0.9))))

(test-assert "manifest-perform-transaction"
  (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
         (t1 (manifest-transaction
              (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))
              (remove (list (manifest-pattern (name "coreutils")))))))
    (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 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-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 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
      ((gnu-make-boot0 -> (@@ (gnu packages commencement) gnu-make-boot0))
       (manifest -> (packages->manifest
                     (list %bootstrap-guile gnu-make-boot0)))
       (guile       (package->derivation %bootstrap-guile))
       (make        (package->derivation gnu-make-boot0))
       (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) python2-matplotlib)))
    (lset= eq?
           (package-transitive-native-search-paths mpl)
           (manifest-entry-search-paths
            (package->manifest-entry mpl)))))

(test-equal "packages->manifest, propagated inputs"
  (map (match-lambda
         ((label package)
          (list (package-name package) (package-version package)
                package)))
       (package-propagated-inputs packages:guile-2.2))
  (map (lambda (entry)
         (list (manifest-entry-name entry)
               (manifest-entry-version entry)
               (manifest-entry-item entry)))
       (manifest-entry-dependencies
        (package->manifest-entry packages:guile-2.2))))

(test-assert "manifest-entry-parent"
  (let ((entry (package->manifest-entry packages:guile-2.2)))
    (match (manifest-entry-dependencies entry)
      ((dependencies ..1)
       (and (every (lambda (parent)
                     (eq? entry (force parent)))
                   (map manifest-entry-parent dependencies))
            (not (force (manifest-entry-parent entry))))))))

(test-assertm "read-manifest"
  (mlet* %store-monad ((manifest -> (packages->manifest
                                     (list (package
                                             (inherit %bootstrap-guile)
                                             (native-search-paths
                                              (package-native-search-paths
                                               packages:guile-2.0))))))
                       (drv (profile-derivation manifest
                                                #:hooks '()
                                                #:locales? #f))
                       (out -> (derivation->output-path drv)))
    (define (entry->sexp entry)
      (list (manifest-entry-name entry)
            (manifest-entry-version entry)
            (manifest-entry-search-paths entry)
            (manifest-entry-dependencies entry)
            (force (manifest-entry-parent entry))))

    (mbegin %store-monad
      (built-derivations (list drv))
      (let ((manifest2 (profile-manifest out)))
        (return (equal? (map entry->sexp (manifest-entries manifest))
                        (map entry->sexp (manifest-entries manifest2))))))))

(test-equal "collision"
  '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
  (guard (c ((profile-collision-error? c)
             (let ((entry1 (profile-collision-error-entry c))
                   (entry2 (profile-collision-error-conflict c)))
               (list (list (manifest-entry-name entry1)
                           (manifest-entry-version entry1))
                     (list (manifest-entry-name entry2)
                           (manifest-entry-version entry2))))))
    (run-with-store %store
      (mlet* %store-monad ((p0 -> (package
                                    (inherit %bootstrap-guile)
                                    (version "42")))
                           (p1 -> (dummy-package "p1"
                                    (propagated-inputs `(("p0" ,p0)))))
                           (manifest -> (packages->manifest
                                         (list %bootstrap-guile p1)))
                           (drv (profile-derivation manifest
                                                    #:hooks '()
                                                    #:locales? #f)))
        (return #f)))))

(test-equal "collision of propagated inputs"
  '(("guile-bootstrap" "2.0") ("guile-bootstrap" "42"))
  (guard (c ((profile-collision-error? c)
             (let ((entry1 (profile-collision-error-entry c))
                   (entry2 (profile-collision-error-conflict c)))
               (list (list (manifest-entry-name entry1)
                           (manifest-entry-version entry1))
                     (list (manifest-entry-name entry2)
                           (manifest-entry-version entry2))))))
    (run-with-store %store
      (mlet* %store-monad ((p0 -> (package
                                    (inherit %bootstrap-guile)
                                    (version "42")))
                           (p1 -> (dummy-package "p1"
                                    (propagated-inputs
                                     `(("guile" ,%bootstrap-guile)))))
                           (p2 -> (dummy-package "p2"
                                    (propagated-inputs
                                     `(("guile" ,p0)))))
                           (manifest -> (packages->manifest (list p1 p2)))
                           (drv (profile-derivation manifest
                                                    #:hooks '()
                                                    #:locales? #f)))
        (return #f)))))

(test-assertm "no collision"
  ;; Here we have an entry that is "lowered" (its 'item' field is a store file
  ;; name) and another entry (its 'item' field is a package) that is
  ;; equivalent.
  (mlet* %store-monad ((p -> (dummy-package "p"
                               (propagated-inputs
                                `(("guile" ,%bootstrap-guile)))))
                       (guile    (package->derivation %bootstrap-guile))
                       (entry -> (manifest-entry
                                   (inherit (package->manifest-entry
                                             %bootstrap-guile))
                                   (item (derivation->output-path guile))))
                       (manifest -> (manifest
                                     (list entry
                                           (package->manifest-entry p))))
                       (drv (profile-derivation manifest)))
    (return (->bool drv))))

(test-assertm "etc/profile"
  ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
  (mlet* %store-monad
      ((guile ->   (package
                     (inherit %bootstrap-guile)
                     (native-search-paths
                      (package-native-search-paths packages:guile-2.0))))
       (entry ->   (package->manifest-entry guile))
       (drv        (profile-derivation (manifest (list entry))
                                       #:hooks '()
                                       #:locales? #f))
       (profile -> (derivation->output-path drv)))
    (mbegin %store-monad
      (built-derivations (list drv))
      (let* ((pipe (open-input-pipe
                    (string-append "unset GUIX_PROFILE; "
                                   ;; 'source' is a Bashism; use '.' (dot).
                                   ". " profile "/etc/profile; "
                                   ;; Don't try to parse set(1) output because
                                   ;; it differs among shells; just use echo.
                                   "echo $PATH")))
             (path (get-string-all pipe)))
        (return
         (and (zero? (close-pipe pipe))
              (string-contains path (string-append profile "/bin"))))))))

(test-assertm "etc/profile when etc/ already exists"
  ;; Here 'union-build' makes the profile's etc/ a symlink to the package's
  ;; etc/ directory, which makes it read-only.  Make sure the profile build
  ;; handles that.
  (mlet* %store-monad
      ((thing ->   (dummy-package "dummy"
                     (build-system trivial-build-system)
                     (arguments
                      `(#:guile ,%bootstrap-guile
                        #:builder
                        (let ((out (assoc-ref %outputs "out")))
                          (mkdir out)
                          (mkdir (string-append out "/etc"))
                          (call-with-output-file (string-append out "/etc/foo")
                            (lambda (port)
                              (display "foo!" port)))
                          #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-end "profiles")

;;; Local Variables:
;;; eval: (put 'dummy-package 'scheme-indent-function 1)
;;; End: