tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (test-packages)
  21   #:use-module (guix tests)
  22   #:use-module (guix store)
  23   #:use-module (guix monads)
  24   #:use-module (guix grafts)
  25   #:use-module ((guix gexp) #:select (local-file local-file-file))
  26   #:use-module ((guix utils)
  27                 ;; Rename the 'location' binding to allow proper syntax
  28                 ;; matching when setting the 'location' field of a package.
  29                 #:renamer (lambda (name)
  30                             (cond ((eq? name 'location) 'make-location)
  31                                   (else name))))
  32   #:use-module ((gcrypt hash) #:prefix gcrypt:)
  33   #:use-module (guix derivations)
  34   #:use-module (guix packages)
  35   #:use-module (guix grafts)
  36   #:use-module (guix search-paths)
  37   #:use-module (guix build-system)
  38   #:use-module (guix build-system trivial)
  39   #:use-module (guix build-system gnu)
  40   #:use-module (guix memoization)
  41   #:use-module (guix profiles)
  42   #:use-module (guix scripts package)
  43   #:use-module (gnu packages)
  44   #:use-module (gnu packages base)
  45   #:use-module (gnu packages guile)
  46   #:use-module (gnu packages bootstrap)
  47   #:use-module (gnu packages version-control)
  48   #:use-module (gnu packages xml)
  49   #:use-module (srfi srfi-1)
  50   #:use-module (srfi srfi-26)
  51   #:use-module (srfi srfi-34)
  52   #:use-module (srfi srfi-35)
  53   #:use-module (srfi srfi-64)
  54   #:use-module (rnrs bytevectors)
  55   #:use-module (rnrs io ports)
  56   #:use-module (ice-9 vlist)
  57   #:use-module (ice-9 regex)
  58   #:use-module (ice-9 match))
  59
  60 ;; Test the high-level packaging layer.
  61
  62 (define %store
  63   (open-connection-for-tests))
  64
  65 ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
  66 ;; can trigger builds early.)
  67 (%graft? #f)
  68
  69 \f
  70 (test-begin "packages")
  71
  72 (test-assert "printer with location"
  73   (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
  74                 (with-output-to-string
  75                   (lambda ()
  76                     (write
  77                      (dummy-package "foo"
  78                        (location (make-location "foo.scm" 42 7))))))))
  79
  80 (test-assert "printer without location"
  81   (string-match "^#<package foo@0 [[:xdigit:]]+>$"
  82                 (with-output-to-string
  83                   (lambda ()
  84                     (write
  85                      (dummy-package "foo" (location #f)))))))
  86
  87 (test-assert "hidden-package"
  88   (and (hidden-package? (hidden-package (dummy-package "foo")))
  89        (not (hidden-package? (dummy-package "foo")))))
  90
  91 (test-assert "package-superseded"
  92   (let* ((new (dummy-package "bar"))
  93          (old (deprecated-package "foo" new)))
  94     (and (eq? (package-superseded old) new)
  95          (mock ((gnu packages) find-best-packages-by-name (const (list old)))
  96                (specification->package "foo")
  97                (and (eq? new (specification->package "foo"))
  98                     (eq? new (specification->package+output "foo")))))))
  99
 100 (test-assert "transaction-upgrade-entry, zero upgrades"
 101   (let* ((old (dummy-package "foo" (version "1")))
 102          (tx  (mock ((gnu packages) find-best-packages-by-name
 103                      (const '()))
 104                     (transaction-upgrade-entry
 105                      #f                           ;no store access needed
 106                      (manifest-entry
 107                        (inherit (package->manifest-entry old))
 108                        (item (string-append (%store-prefix) "/"
 109                                             (make-string 32 #\e) "-foo-1")))
 110                      (manifest-transaction)))))
 111     (manifest-transaction-null? tx)))
 112
 113 (test-assert "transaction-upgrade-entry, zero upgrades, equivalent package"
 114   (let* ((old (dummy-package "foo" (version "1")))
 115          (drv (package-derivation %store old))
 116          (tx  (mock ((gnu packages) find-best-packages-by-name
 117                      (const (list old)))
 118                     (transaction-upgrade-entry
 119                      %store
 120                      (manifest-entry
 121                        (inherit (package->manifest-entry old))
 122                        (item (derivation->output-path drv)))
 123                      (manifest-transaction)))))
 124     (manifest-transaction-null? tx)))
 125
 126 (test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs"
 127   ;; Properly detect equivalent packages even when they have propagated
 128   ;; inputs.  See <https://bugs.gnu.org/35872>.
 129   (let* ((dep (dummy-package "dep" (version "2")))
 130          (old (dummy-package "foo" (version "1")
 131                              (propagated-inputs `(("dep" ,dep)))))
 132          (drv (package-derivation %store old))
 133          (tx  (mock ((gnu packages) find-best-packages-by-name
 134                      (const (list old)))
 135                     (transaction-upgrade-entry
 136                      %store
 137                      (manifest-entry
 138                        (inherit (package->manifest-entry old))
 139                        (item (derivation->output-path drv))
 140                        (dependencies
 141                         (list (manifest-entry
 142                                 (inherit (package->manifest-entry dep))
 143                                 (item (derivation->output-path
 144                                        (package-derivation %store dep)))))))
 145                      (manifest-transaction)))))
 146     (manifest-transaction-null? tx)))
 147
 148 (test-assert "transaction-upgrade-entry, one upgrade"
 149   (let* ((old (dummy-package "foo" (version "1")))
 150          (new (dummy-package "foo" (version "2")))
 151          (tx  (mock ((gnu packages) find-best-packages-by-name
 152                      (const (list new)))
 153                     (transaction-upgrade-entry
 154                      #f                           ;no store access needed
 155                      (manifest-entry
 156                        (inherit (package->manifest-entry old))
 157                        (item (string-append (%store-prefix) "/"
 158                                             (make-string 32 #\e) "-foo-1")))
 159                      (manifest-transaction)))))
 160     (and (match (manifest-transaction-install tx)
 161            ((($ <manifest-entry> "foo" "2" "out" item))
 162             (eq? item new)))
 163          (null? (manifest-transaction-remove tx)))))
 164
 165 (test-assert "transaction-upgrade-entry, superseded package"
 166   (let* ((old (dummy-package "foo" (version "1")))
 167          (new (dummy-package "bar" (version "2")))
 168          (dep (deprecated-package "foo" new))
 169          (tx  (mock ((gnu packages) find-best-packages-by-name
 170                      (const (list dep)))
 171                     (transaction-upgrade-entry
 172                      #f                           ;no store access needed
 173                      (manifest-entry
 174                        (inherit (package->manifest-entry old))
 175                        (item (string-append (%store-prefix) "/"
 176                                             (make-string 32 #\e) "-foo-1")))
 177                      (manifest-transaction)))))
 178     (and (match (manifest-transaction-install tx)
 179            ((($ <manifest-entry> "bar" "2" "out" item))
 180             (eq? item new)))
 181          (match (manifest-transaction-remove tx)
 182            (((? manifest-pattern? pattern))
 183             (and (string=? (manifest-pattern-name pattern) "foo")
 184                  (string=? (manifest-pattern-version pattern) "1")
 185                  (string=? (manifest-pattern-output pattern) "out")))))))
 186
 187 (test-assert "transaction-upgrade-entry, grafts"
 188   ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't
 189   ;; try to build stuff.
 190   (with-build-handler (const 'failed!)
 191     (parameterize ((%graft? #t))
 192       (let* ((old (dummy-package "foo" (version "1")))
 193              (bar (dummy-package "bar" (version "0")
 194                                  (replacement old)))
 195              (new (dummy-package "foo" (version "1")
 196                                  (inputs `(("bar" ,bar)))))
 197              (tx  (mock ((gnu packages) find-best-packages-by-name
 198                          (const (list new)))
 199                         (transaction-upgrade-entry
 200                          %store
 201                          (manifest-entry
 202                            (inherit (package->manifest-entry old))
 203                            (item (string-append (%store-prefix) "/"
 204                                                 (make-string 32 #\e) "-foo-1")))
 205                          (manifest-transaction)))))
 206         (and (match (manifest-transaction-install tx)
 207                ((($ <manifest-entry> "foo" "1" "out" item))
 208                 (eq? item new)))
 209              (null? (manifest-transaction-remove tx)))))))
 210
 211 (test-assert "package-field-location"
 212   (let ()
 213     (define (goto port line column)
 214       (unless (and (= (port-column port) (- column 1))
 215                    (= (port-line port) (- line 1)))
 216         (unless (eof-object? (get-char port))
 217           (goto port line column))))
 218
 219     (define read-at
 220       (match-lambda
 221        (($ <location> file line column)
 222         (call-with-input-file (search-path %load-path file)
 223           (lambda (port)
 224             (goto port line column)
 225             (read port))))))
 226
 227     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
 228     ;; Thus, check against both VALUE and (FIELD VALUE).
 229     (and (member (read-at (package-field-location %bootstrap-guile 'name))
 230                  (let ((name (package-name %bootstrap-guile)))
 231                    (list name `(name ,name))))
 232          (member (read-at (package-field-location %bootstrap-guile 'version))
 233                  (let ((version (package-version %bootstrap-guile)))
 234                    (list version `(version ,version))))
 235          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 236
 237 ;; Make sure we don't change the file name to an absolute file name.
 238 (test-equal "package-field-location, relative file name"
 239   (location-file (package-location %bootstrap-guile))
 240   (with-fluids ((%file-port-name-canonicalization 'absolute))
 241     (location-file (package-field-location %bootstrap-guile 'version))))
 242
 243 (test-assert "package-transitive-inputs"
 244   (let* ((a (dummy-package "a"))
 245          (b (dummy-package "b"
 246               (propagated-inputs `(("a" ,a)))))
 247          (c (dummy-package "c"
 248               (inputs `(("a" ,a)))))
 249          (d (dummy-package "d"
 250               (propagated-inputs `(("x" "something.drv")))))
 251          (e (dummy-package "e"
 252               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
 253     (and (null? (package-transitive-inputs a))
 254          (equal? `(("a" ,a)) (package-transitive-inputs b))
 255          (equal? `(("a" ,a)) (package-transitive-inputs c))
 256          (equal? (package-propagated-inputs d)
 257                  (package-transitive-inputs d))
 258          (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
 259                    ("a" ,a) ("x" "something.drv"))
 260                  (pk 'x (package-transitive-inputs e))))))
 261
 262 (test-assert "package-transitive-inputs, no duplicates"
 263   (let* ((a (dummy-package "a"))
 264          (b (dummy-package "b"
 265               (inputs `(("a+" ,a)))
 266               (native-inputs `(("a*" ,a)))
 267               (propagated-inputs `(("a" ,a)))))
 268          (c (dummy-package "c"
 269               (propagated-inputs `(("b" ,b)))))
 270          (d (dummy-package "d"
 271               (inputs `(("a" ,a) ("c" ,c)))))
 272          (e (dummy-package "e"
 273               (inputs `(("b" ,b) ("c" ,c))))))
 274     (and (null? (package-transitive-inputs a))
 275          (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
 276                  (package-transitive-inputs b))
 277          (equal? `(("b" ,b) ("a" ,a))
 278                  (package-transitive-inputs c))
 279          (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
 280                  (package-transitive-inputs d))
 281          (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
 282                  (package-transitive-inputs e))))) ;ditto
 283
 284 (test-equal "package-transitive-supported-systems"
 285   '(("x" "y" "z")                                 ;a
 286     ("x" "y")                                     ;b
 287     ("y")                                         ;c
 288     ("y")                                         ;d
 289     ("y"))                                        ;e
 290   ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
 291   ;; doesn't restrict the set of supported systems.
 292   (let* ((a (dummy-package "a"
 293               (build-system trivial-build-system)
 294               (supported-systems '("x" "y" "z"))))
 295          (b (dummy-package "b"
 296               (build-system trivial-build-system)
 297               (supported-systems '("x" "y"))
 298               (inputs `(("a" ,a)))))
 299          (c (dummy-package "c"
 300               (build-system trivial-build-system)
 301               (supported-systems '("y" "z"))
 302               (inputs `(("b" ,b)))))
 303          (d (dummy-package "d"
 304               (build-system trivial-build-system)
 305               (supported-systems '("x" "y" "z"))
 306               (inputs `(("b" ,b) ("c" ,c)))))
 307          (e (dummy-package "e"
 308               (build-system trivial-build-system)
 309               (supported-systems '("x" "y" "z"))
 310               (inputs `(("d" ,d))))))
 311     (list (package-transitive-supported-systems a)
 312           (package-transitive-supported-systems b)
 313           (package-transitive-supported-systems c)
 314           (package-transitive-supported-systems d)
 315           (package-transitive-supported-systems e))))
 316
 317 (test-assert "package-closure"
 318   (let-syntax ((dummy-package/no-implicit
 319                 (syntax-rules ()
 320                   ((_ name rest ...)
 321                    (package
 322                      (inherit (dummy-package name rest ...))
 323                      (build-system trivial-build-system))))))
 324     (let* ((a (dummy-package/no-implicit "a"))
 325            (b (dummy-package/no-implicit "b"
 326                 (propagated-inputs `(("a" ,a)))))
 327            (c (dummy-package/no-implicit "c"
 328                 (inputs `(("a" ,a)))))
 329            (d (dummy-package/no-implicit "d"
 330                 (native-inputs `(("b" ,b)))))
 331            (e (dummy-package/no-implicit "e"
 332                 (inputs `(("c" ,c) ("d" ,d))))))
 333       (lset= eq?
 334              (list a b c d e)
 335              (package-closure (list e))
 336              (package-closure (list e d))
 337              (package-closure (list e c b))))))
 338
 339 (test-equal "origin-actual-file-name"
 340   "foo-1.tar.gz"
 341   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 342     (origin-actual-file-name o)))
 343
 344 (test-equal "origin-actual-file-name, file-name"
 345   "foo-1.tar.gz"
 346   (let ((o (dummy-origin
 347             (uri "http://www.example.com/tarball")
 348             (file-name "foo-1.tar.gz"))))
 349     (origin-actual-file-name o)))
 350
 351 (let* ((o (dummy-origin))
 352        (u (dummy-origin))
 353        (i (dummy-origin))
 354        (a (dummy-package "a"))
 355        (b (dummy-package "b"
 356             (inputs `(("a" ,a) ("i" ,i)))))
 357        (c (package (inherit b) (source o)))
 358        (d (dummy-package "d"
 359             (build-system trivial-build-system)
 360             (source u) (inputs `(("c" ,c))))))
 361   (test-assert "package-direct-sources, no source"
 362     (null? (package-direct-sources a)))
 363   (test-equal "package-direct-sources, #f source"
 364     (list i)
 365     (package-direct-sources b))
 366   (test-equal "package-direct-sources, not input source"
 367     (list u)
 368     (package-direct-sources d))
 369   (test-assert "package-direct-sources"
 370     (let ((s (package-direct-sources c)))
 371       (and (= (length (pk 's-sources s)) 2)
 372            (member o s)
 373            (member i s))))
 374   (test-assert "package-transitive-sources"
 375     (let ((s (package-transitive-sources d)))
 376       (and (= (length (pk 'd-sources s)) 3)
 377            (member o s)
 378            (member i s)
 379            (member u s)))))
 380
 381 (test-assert "transitive-input-references"
 382   (let* ((a (dummy-package "a"))
 383          (b (dummy-package "b"))
 384          (c (dummy-package "c"
 385               (inputs `(("a" ,a)))
 386               (propagated-inputs `(("boo" ,b)))))
 387          (d (dummy-package "d"
 388               (inputs `(("c*" ,c)))))
 389          (keys (map (match-lambda
 390                       (('assoc-ref 'l key)
 391                        key))
 392                     (pk 'refs (transitive-input-references
 393                                'l (package-inputs d))))))
 394     (and (= (length keys) 2)
 395          (member "c*" keys)
 396          (member "boo" keys))))
 397
 398 (test-equal "package-transitive-supported-systems, implicit inputs"
 399   %supported-systems
 400
 401   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 402   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 403   (let ((p (dummy-package "foo"
 404                (build-system gnu-build-system)
 405                (supported-systems
 406                 `("does-not-exist" "foobar" ,@%supported-systems)))))
 407     (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
 408       (package-transitive-supported-systems p))))
 409
 410 (test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs"
 411   '("x86_64-linux" "i686-linux")
 412
 413   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 414   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 415   (let ((p (dummy-package "foo"
 416              (build-system gnu-build-system)
 417              (supported-systems
 418               `("does-not-exist" "foobar" ,@%supported-systems)))))
 419     (parameterize ((%current-system "x86_64-linux"))
 420       (package-transitive-supported-systems p))))
 421
 422 (test-assert "supported-package?"
 423   (let* ((d (dummy-package "dep"
 424               (build-system trivial-build-system)
 425               (supported-systems '("x86_64-linux"))))
 426          (p (dummy-package "foo"
 427               (build-system gnu-build-system)
 428               (inputs `(("d" ,d)))
 429               (supported-systems '("x86_64-linux" "armhf-linux")))))
 430     (and (supported-package? p "x86_64-linux")
 431          (not (supported-package? p "i686-linux"))
 432          (not (supported-package? p "armhf-linux")))))
 433
 434 (test-assert "supported-package? vs. system-dependent graph"
 435   ;; The inputs of a package can depend on (%current-system).  Thus,
 436   ;; 'supported-package?' must make sure that it binds (%current-system)
 437   ;; appropriately before traversing the dependency graph.  In the example
 438   ;; below, 'supported-package?' must thus return true for both systems.
 439   (let* ((p0a (dummy-package "foo-arm"
 440                 (build-system trivial-build-system)
 441                 (supported-systems '("armhf-linux"))))
 442          (p0b (dummy-package "foo-x86_64"
 443                 (build-system trivial-build-system)
 444                 (supported-systems '("x86_64-linux"))))
 445          (p   (dummy-package "bar"
 446                 (build-system trivial-build-system)
 447                 (inputs
 448                  (if (string=? (%current-system) "armhf-linux")
 449                      `(("foo" ,p0a))
 450                      `(("foo" ,p0b)))))))
 451     (and (supported-package? p "x86_64-linux")
 452          (supported-package? p "armhf-linux"))))
 453
 454 (test-skip (if (not %store) 8 0))
 455
 456 (test-assert "package-source-derivation, file"
 457   (let* ((file    (search-path %load-path "guix.scm"))
 458          (package (package (inherit (dummy-package "p"))
 459                     (source file)))
 460          (source  (package-source-derivation %store
 461                                              (package-source package))))
 462     (and (store-path? source)
 463          (valid-path? %store source)
 464          (equal? (call-with-input-file source get-bytevector-all)
 465                  (call-with-input-file file get-bytevector-all)))))
 466
 467 (test-assert "package-source-derivation, store path"
 468   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 469                                 (search-path %load-path "guix.scm")))
 470          (package (package (inherit (dummy-package "p"))
 471                     (source file)))
 472          (source  (package-source-derivation %store
 473                                              (package-source package))))
 474     (string=? file source)))
 475
 476 (test-assert "package-source-derivation, indirect store path"
 477   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 478                                 (dirname (search-path %load-path
 479                                                       "guix/build/utils.scm"))))
 480          (package (package (inherit (dummy-package "p"))
 481                     (source (string-append dir "/utils.scm"))))
 482          (source  (package-source-derivation %store
 483                                              (package-source package))))
 484     (and (direct-store-path? source)
 485          (string-suffix? "utils.scm" source))))
 486
 487 (test-assert "package-source-derivation, local-file"
 488   (let* ((file    (local-file "../guix/base32.scm"))
 489          (package (package (inherit (dummy-package "p"))
 490                     (source file)))
 491          (source  (package-source-derivation %store
 492                                              (package-source package))))
 493     (and (store-path? source)
 494          (string-suffix? "base32.scm" source)
 495          (valid-path? %store source)
 496          (equal? (call-with-input-file source get-bytevector-all)
 497                  (call-with-input-file
 498                      (search-path %load-path "guix/base32.scm")
 499                    get-bytevector-all)))))
 500
 501 (test-equal "package-source-derivation, origin, sha512"
 502   "hello"
 503   (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
 504          (builder (add-text-to-store %store "my-fixed-builder.sh"
 505                                      "echo -n hello > $out" '()))
 506          (method  (lambda* (url hash-algo hash #:optional name
 507                                 #:rest rest)
 508                     (and (eq? hash-algo 'sha512)
 509                          (raw-derivation name bash (list builder)
 510                                          #:sources (list builder)
 511                                          #:hash hash
 512                                          #:hash-algo hash-algo))))
 513          (source  (origin
 514                     (method method)
 515                     (uri "unused://")
 516                     (file-name "origin-sha512")
 517                     (hash (content-hash
 518                            (gcrypt:bytevector-hash (string->utf8 "hello")
 519                                                    (gcrypt:lookup-hash-algorithm
 520                                                     'sha512))
 521                            sha512))))
 522          (drv    (package-source-derivation %store source))
 523          (output (derivation->output-path drv)))
 524     (build-derivations %store (list drv))
 525     (call-with-input-file output get-string-all)))
 526
 527 (test-equal "package-source-derivation, origin, sha3-512"
 528   "hello, sha3"
 529   (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
 530          (builder (add-text-to-store %store "my-fixed-builder.sh"
 531                                      "echo -n hello, sha3 > $out" '()))
 532          (method  (lambda* (url hash-algo hash #:optional name
 533                                 #:rest rest)
 534                     (and (eq? hash-algo 'sha3-512)
 535                          (raw-derivation name bash (list builder)
 536                                          #:sources (list builder)
 537                                          #:hash hash
 538                                          #:hash-algo hash-algo))))
 539          (source  (origin
 540                     (method method)
 541                     (uri "unused://")
 542                     (file-name "origin-sha3")
 543                     (hash (content-hash
 544                            (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
 545                                                    (gcrypt:lookup-hash-algorithm
 546                                                     'sha3-512))
 547                            sha3-512))))
 548          (drv    (package-source-derivation %store source))
 549          (output (derivation->output-path drv)))
 550     (build-derivations %store (list drv))
 551     (call-with-input-file output get-string-all)))
 552
 553 (unless (network-reachable?) (test-skip 1))
 554 (test-equal "package-source-derivation, snippet"
 555   "OK"
 556   (let* ((source (bootstrap-origin
 557                   (origin
 558                     (inherit (bootstrap-guile-origin (%current-system)))
 559                     (patch-inputs
 560                      `(("tar" ,%bootstrap-coreutils&co)
 561                        ("xz" ,%bootstrap-coreutils&co)
 562                        ("patch" ,%bootstrap-coreutils&co)))
 563                     (patch-guile %bootstrap-guile)
 564                     (modules '((guix build utils)))
 565                     (snippet '(begin
 566                                 ;; We end up in 'bin', because it's the first
 567                                 ;; directory, alphabetically.  Not a very good
 568                                 ;; example but hey.
 569                                 (chmod "." #o777)
 570                                 (symlink "guile" "guile-rocks")
 571                                 (copy-recursively "../share/guile/2.0/scripts"
 572                                                   "scripts")
 573
 574                                 ;; Make sure '.file_list' can be created.
 575                                 (chmod ".." #o777))))))
 576          (package (package (inherit (dummy-package "with-snippet"))
 577                     (source source)
 578                     (build-system trivial-build-system)
 579                     (inputs
 580                      `(("tar" ,(search-bootstrap-binary "tar"
 581                                                         (%current-system)))
 582                        ("xz"  ,(search-bootstrap-binary "xz"
 583                                                         (%current-system)))))
 584                     (arguments
 585                      `(#:guile ,%bootstrap-guile
 586                        #:modules ((guix build utils))
 587                        #:builder
 588                        (begin
 589                          (use-modules (guix build utils))
 590                          (let ((tar    (assoc-ref %build-inputs "tar"))
 591                                (xz     (assoc-ref %build-inputs "xz"))
 592                                (source (assoc-ref %build-inputs "source")))
 593                            (invoke tar "xvf" source
 594                                    "--use-compress-program" xz)
 595                            (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
 596                                         (file-exists? "bin/scripts/compile.scm"))
 597                              (error "the snippet apparently failed"))
 598                            (let ((out (assoc-ref %outputs "out")))
 599                              (call-with-output-file out
 600                                (lambda (p)
 601                                  (display "OK" p))))
 602                            #t))))))
 603          (drv    (package-derivation %store package))
 604          (out    (derivation->output-path drv)))
 605     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 606          (call-with-input-file out get-string-all))))
 607
 608 (test-assert "return value"
 609   (let ((drv (package-derivation %store (dummy-package "p"))))
 610     (and (derivation? drv)
 611          (file-exists? (derivation-file-name drv)))))
 612
 613 (test-assert "package-output"
 614   (let* ((package  (dummy-package "p"))
 615          (drv      (package-derivation %store package)))
 616     (and (derivation? drv)
 617          (string=? (derivation->output-path drv)
 618                    (package-output %store package "out")))))
 619
 620 (test-assert "patch not found yields a run-time error"
 621   (guard (c ((condition-has-type? c &message)
 622              (and (string-contains (condition-message c)
 623                                    "does-not-exist.patch")
 624                   (string-contains (condition-message c)
 625                                    "not found"))))
 626     (let ((p (package
 627                (inherit (dummy-package "p"))
 628                (source (origin
 629                          (method (const #f))
 630                          (uri "http://whatever")
 631                          (patches
 632                           (list (search-patch "does-not-exist.patch")))
 633                          (sha256
 634                           (base32
 635                            "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
 636       (package-derivation %store p)
 637       #f)))
 638
 639 (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
 640   (test-equal "&package-input-error"
 641     (list dummy (current-module))
 642     (guard (c ((package-input-error? c)
 643                (list (package-error-package c)
 644                      (package-error-invalid-input c))))
 645       (package-derivation %store dummy))))
 646
 647 (test-assert "reference to non-existent output"
 648   ;; See <http://bugs.gnu.org/19630>.
 649   (parameterize ((%graft? #f))
 650     (let* ((dep (dummy-package "dep"))
 651            (p   (dummy-package "p"
 652                   (inputs `(("dep" ,dep "non-existent"))))))
 653       (guard (c ((derivation-missing-output-error? c)
 654                  (and (string=? (derivation-missing-output c) "non-existent")
 655                       (equal? (package-derivation %store dep)
 656                               (derivation-error-derivation c)))))
 657         (package-derivation %store p)))))
 658
 659 (test-assert "trivial"
 660   (let* ((p (package (inherit (dummy-package "trivial"))
 661               (build-system trivial-build-system)
 662               (source #f)
 663               (arguments
 664                `(#:guile ,%bootstrap-guile
 665                  #:builder
 666                  (begin
 667                    (mkdir %output)
 668                    (call-with-output-file (string-append %output "/test")
 669                      (lambda (p)
 670                        (display '(hello guix) p)))
 671                    #t)))))
 672          (d (package-derivation %store p)))
 673     (and (build-derivations %store (list d))
 674          (let ((p (pk 'drv d (derivation->output-path d))))
 675            (equal? '(hello guix)
 676                    (call-with-input-file (string-append p "/test") read))))))
 677
 678 (test-assert "trivial with local file as input"
 679   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 680          (p (package (inherit (dummy-package "trivial-with-input-file"))
 681               (build-system trivial-build-system)
 682               (source #f)
 683               (arguments
 684                `(#:guile ,%bootstrap-guile
 685                  #:builder (begin
 686                              (copy-file (assoc-ref %build-inputs "input")
 687                                         %output)
 688                              #t)))
 689               (inputs `(("input" ,i)))))
 690          (d (package-derivation %store p)))
 691     (and (build-derivations %store (list d))
 692          (let ((p (pk 'drv d (derivation->output-path d))))
 693            (equal? (call-with-input-file p get-bytevector-all)
 694                    (call-with-input-file i get-bytevector-all))))))
 695
 696 (test-assert "trivial with source"
 697   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 698          (p (package (inherit (dummy-package "trivial-with-source"))
 699               (build-system trivial-build-system)
 700               (source i)
 701               (arguments
 702                `(#:guile ,%bootstrap-guile
 703                  #:builder (begin
 704                              (copy-file (assoc-ref %build-inputs "source")
 705                                         %output)
 706                              #t)))))
 707          (d (package-derivation %store p)))
 708     (and (build-derivations %store (list d))
 709          (let ((p (derivation->output-path d)))
 710            (equal? (call-with-input-file p get-bytevector-all)
 711                    (call-with-input-file i get-bytevector-all))))))
 712
 713 (test-assert "trivial with system-dependent input"
 714   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 715               (build-system trivial-build-system)
 716               (source #f)
 717               (arguments
 718                `(#:guile ,%bootstrap-guile
 719                  #:modules ((guix build utils))
 720                  #:builder
 721                  (begin
 722                    (use-modules (guix build utils))
 723                    (let ((out  (assoc-ref %outputs "out"))
 724                          (bash (assoc-ref %build-inputs "bash")))
 725                      (invoke bash "-c"
 726                              (format #f "echo hello > ~a" out))))))
 727               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 728                                                           (%current-system)))))))
 729          (d (package-derivation %store p)))
 730     (and (build-derivations %store (list d))
 731          (let ((p (pk 'drv d (derivation->output-path d))))
 732            (eq? 'hello (call-with-input-file p read))))))
 733
 734 (test-assert "trivial with #:allowed-references"
 735   (let* ((p (package
 736               (inherit (dummy-package "trivial"))
 737               (build-system trivial-build-system)
 738               (arguments
 739                `(#:guile ,%bootstrap-guile
 740                  #:allowed-references (,%bootstrap-guile)
 741                  #:builder
 742                  (begin
 743                    (mkdir %output)
 744                    ;; The reference to itself isn't allowed so building it
 745                    ;; should fail.
 746                    (symlink %output (string-append %output "/self"))
 747                    #t)))))
 748          (d (package-derivation %store p)))
 749     (guard (c ((store-protocol-error? c) #t))
 750       (build-derivations %store (list d))
 751       #f)))
 752
 753 (test-assert "search paths"
 754   (let* ((p (make-prompt-tag "return-search-paths"))
 755          (s (build-system
 756              (name 'raw)
 757              (description "Raw build system with direct store access")
 758              (lower (lambda* (name #:key source inputs system target
 759                                    #:allow-other-keys)
 760                       (bag
 761                         (name name)
 762                         (system system) (target target)
 763                         (build-inputs inputs)
 764                         (build
 765                          (lambda* (store name inputs
 766                                          #:key outputs system search-paths)
 767                            search-paths)))))))
 768          (x (list (search-path-specification
 769                    (variable "GUILE_LOAD_PATH")
 770                    (files '("share/guile/site/2.0")))
 771                   (search-path-specification
 772                    (variable "GUILE_LOAD_COMPILED_PATH")
 773                    (files '("share/guile/site/2.0")))))
 774          (a (package (inherit (dummy-package "guile"))
 775               (build-system s)
 776               (native-search-paths x)))
 777          (b (package (inherit (dummy-package "guile-foo"))
 778               (build-system s)
 779               (inputs `(("guile" ,a)))))
 780          (c (package (inherit (dummy-package "guile-bar"))
 781               (build-system s)
 782               (inputs `(("guile" ,a)
 783                         ("guile-foo" ,b))))))
 784     (let-syntax ((collect (syntax-rules ()
 785                             ((_ body ...)
 786                              (call-with-prompt p
 787                                (lambda ()
 788                                  body ...)
 789                                (lambda (k search-paths)
 790                                  search-paths))))))
 791       (and (null? (collect (package-derivation %store a)))
 792            (equal? x (collect (package-derivation %store b)))
 793            (equal? x (collect (package-derivation %store c)))))))
 794
 795 (test-assert "package-transitive-native-search-paths"
 796   (let* ((sp (lambda (name)
 797                (list (search-path-specification
 798                       (variable name)
 799                       (files '("foo/bar"))))))
 800          (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
 801          (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
 802          (p2 (dummy-package "p2"
 803                (native-search-paths (sp "PATH2"))
 804                (inputs `(("p0" ,p0)))
 805                (propagated-inputs `(("p1" ,p1)))))
 806          (p3 (dummy-package "p3"
 807                (native-search-paths (sp "PATH3"))
 808                (native-inputs `(("p0" ,p0)))
 809                (propagated-inputs `(("p2" ,p2))))))
 810     (lset= string=?
 811            '("PATH1" "PATH2" "PATH3")
 812            (map search-path-specification-variable
 813                 (package-transitive-native-search-paths p3)))))
 814
 815 (test-assert "package-cross-derivation"
 816   (let ((drv (package-cross-derivation %store (dummy-package "p")
 817                                        "mips64el-linux-gnu")))
 818     (and (derivation? drv)
 819          (file-exists? (derivation-file-name drv)))))
 820
 821 (test-assert "package-cross-derivation, trivial-build-system"
 822   (let ((p (package (inherit (dummy-package "p"))
 823              (build-system trivial-build-system)
 824              (arguments '(#:builder (exit 1))))))
 825     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 826       (derivation? drv))))
 827
 828 (test-assert "package-cross-derivation, no cross builder"
 829   (let* ((b (build-system (inherit trivial-build-system)
 830               (lower (const #f))))
 831          (p (package (inherit (dummy-package "p"))
 832               (build-system b))))
 833     (guard (c ((package-cross-build-system-error? c)
 834                (eq? (package-error-package c) p)))
 835       (package-cross-derivation %store p "mips64el-linux-gnu")
 836       #f)))
 837
 838 ;; XXX: The next two tests can trigger builds when the distro defines
 839 ;; replacements on core packages, so they're disable for lack of a better
 840 ;; solution.
 841
 842 ;; (test-equal "package-derivation, direct graft"
 843 ;;   (package-derivation %store gnu-make #:graft? #f)
 844 ;;   (let ((p (package (inherit coreutils)
 845 ;;              (replacement gnu-make))))
 846 ;;     (package-derivation %store p #:graft? #t)))
 847
 848 ;; (test-equal "package-cross-derivation, direct graft"
 849 ;;   (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
 850 ;;                             #:graft? #f)
 851 ;;   (let ((p (package (inherit coreutils)
 852 ;;              (replacement gnu-make))))
 853 ;;     (package-cross-derivation %store p "mips64el-linux-gnu"
 854 ;;                               #:graft? #t)))
 855
 856 (test-assert "package-grafts, indirect grafts"
 857   (let* ((new   (dummy-package "dep"
 858                   (arguments '(#:implicit-inputs? #f))))
 859          (dep   (package (inherit new) (version "0.0")))
 860          (dep*  (package (inherit dep) (replacement new)))
 861          (dummy (dummy-package "dummy"
 862                   (arguments '(#:implicit-inputs? #f))
 863                   (inputs `(("dep" ,dep*))))))
 864     (equal? (package-grafts %store dummy)
 865             (list (graft
 866                     (origin (package-derivation %store dep))
 867                     (replacement (package-derivation %store new)))))))
 868
 869 ;; XXX: This test would require building the cross toolchain just to see if it
 870 ;; needs grafting, which is obviously too expensive, and thus disabled.
 871 ;;
 872 ;; (test-assert "package-grafts, indirect grafts, cross"
 873 ;;   (let* ((new    (dummy-package "dep"
 874 ;;                    (arguments '(#:implicit-inputs? #f))))
 875 ;;          (dep    (package (inherit new) (version "0.0")))
 876 ;;          (dep*   (package (inherit dep) (replacement new)))
 877 ;;          (dummy  (dummy-package "dummy"
 878 ;;                    (arguments '(#:implicit-inputs? #f))
 879 ;;                    (inputs `(("dep" ,dep*)))))
 880 ;;          (target "mips64el-linux-gnu"))
 881 ;;     ;; XXX: There might be additional grafts, for instance if the distro
 882 ;;     ;; defines replacements for core packages like Perl.
 883 ;;     (member (graft
 884 ;;               (origin (package-cross-derivation %store dep target))
 885 ;;               (replacement
 886 ;;                (package-cross-derivation %store new target)))
 887 ;;             (package-grafts %store dummy #:target target))))
 888
 889 (test-assert "package-grafts, indirect grafts, propagated inputs"
 890   (let* ((new   (dummy-package "dep"
 891                   (arguments '(#:implicit-inputs? #f))))
 892          (dep   (package (inherit new) (version "0.0")))
 893          (dep*  (package (inherit dep) (replacement new)))
 894          (prop  (dummy-package "propagated"
 895                   (propagated-inputs `(("dep" ,dep*)))
 896                   (arguments '(#:implicit-inputs? #f))))
 897          (dummy (dummy-package "dummy"
 898                   (arguments '(#:implicit-inputs? #f))
 899                   (inputs `(("prop" ,prop))))))
 900     (equal? (package-grafts %store dummy)
 901             (list (graft
 902                     (origin (package-derivation %store dep))
 903                     (replacement (package-derivation %store new)))))))
 904
 905 (test-assert "package-grafts, same replacement twice"
 906   (let* ((new  (dummy-package "dep"
 907                  (version "1")
 908                  (arguments '(#:implicit-inputs? #f))))
 909          (dep  (package (inherit new) (version "0") (replacement new)))
 910          (p1   (dummy-package "intermediate1"
 911                  (arguments '(#:implicit-inputs? #f))
 912                  (inputs `(("dep" ,dep)))))
 913          (p2   (dummy-package "intermediate2"
 914                  (arguments '(#:implicit-inputs? #f))
 915                  ;; Here we copy DEP to have an equivalent package that is not
 916                  ;; 'eq?' to DEP.  This is similar to what happens with
 917                  ;; 'package-with-explicit-inputs' & co.
 918                  (inputs `(("dep" ,(package (inherit dep)))))))
 919          (p3   (dummy-package "final"
 920                  (arguments '(#:implicit-inputs? #f))
 921                  (inputs `(("p1" ,p1) ("p2" ,p2))))))
 922     (equal? (package-grafts %store p3)
 923             (list (graft
 924                     (origin (package-derivation %store
 925                                                 (package (inherit dep)
 926                                                          (replacement #f))))
 927                     (replacement (package-derivation %store new)))))))
 928
 929 (test-assert "package-grafts, dependency on several outputs"
 930   ;; Make sure we get one graft per output; see <https://bugs.gnu.org/41796>.
 931   (letrec* ((p0  (dummy-package "p0"
 932                    (version "1.0")
 933                    (replacement p0*)
 934                    (arguments '(#:implicit-inputs? #f))
 935                    (outputs '("out" "lib"))))
 936             (p0* (package (inherit p0) (version "1.1")))
 937             (p1  (dummy-package "p1"
 938                    (arguments '(#:implicit-inputs? #f))
 939                    (inputs `(("p0" ,p0)
 940                              ("p0:lib" ,p0 "lib"))))))
 941     (lset= equal? (pk (package-grafts %store p1))
 942            (list (graft
 943                    (origin (package-derivation %store p0))
 944                    (origin-output "out")
 945                    (replacement (package-derivation %store p0*))
 946                    (replacement-output "out"))
 947                  (graft
 948                    (origin (package-derivation %store p0))
 949                    (origin-output "lib")
 950                    (replacement (package-derivation %store p0*))
 951                    (replacement-output "lib"))))))
 952
 953 (test-assert "replacement also grafted"
 954   ;; We build a DAG as below, where dotted arrows represent replacements and
 955   ;; solid arrows represent dependencies:
 956   ;;
 957   ;;  P1  ·············>  P1R
 958   ;;  |\__________________.
 959   ;;  v                   v
 960   ;;  P2  ·············>  P2R
 961   ;;  |
 962   ;;  v
 963   ;;  P3
 964   ;;
 965   ;; We want to make sure that:
 966   ;;   grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
 967   ;; where:
 968   ;;   (A,B) is a graft to replace A by B
 969   ;;   grafted(DRV,G) denoted DRV with graft G applied
 970   (let* ((p1r (dummy-package "P1"
 971                 (build-system trivial-build-system)
 972                 (arguments
 973                  `(#:guile ,%bootstrap-guile
 974                    #:builder (let ((out (assoc-ref %outputs "out")))
 975                                (mkdir out)
 976                                (call-with-output-file
 977                                    (string-append out "/replacement")
 978                                  (const #t)))))))
 979          (p1  (package
 980                 (inherit p1r) (name "p1") (replacement p1r)
 981                 (arguments
 982                  `(#:guile ,%bootstrap-guile
 983                    #:builder (begin
 984                                (mkdir (assoc-ref %outputs "out"))
 985                                #t)))))
 986          (p2r (dummy-package "P2"
 987                 (build-system trivial-build-system)
 988                 (inputs `(("p1" ,p1)))
 989                 (arguments
 990                  `(#:guile ,%bootstrap-guile
 991                    #:builder (let ((out (assoc-ref %outputs "out")))
 992                                (mkdir out)
 993                                (chdir out)
 994                                (symlink (assoc-ref %build-inputs "p1") "p1")
 995                                (call-with-output-file (string-append out "/replacement")
 996                                  (const #t)))))))
 997          (p2  (package
 998                 (inherit p2r) (name "p2") (replacement p2r)
 999                 (arguments
1000                  `(#:guile ,%bootstrap-guile
1001                    #:builder (let ((out (assoc-ref %outputs "out")))
1002                                (mkdir out)
1003                                (chdir out)
1004                                (symlink (assoc-ref %build-inputs "p1")
1005                                         "p1")
1006                                #t)))))
1007          (p3  (dummy-package "p3"
1008                 (build-system trivial-build-system)
1009                 (inputs `(("p2" ,p2)))
1010                 (arguments
1011                  `(#:guile ,%bootstrap-guile
1012                    #:builder (let ((out (assoc-ref %outputs "out")))
1013                                (mkdir out)
1014                                (chdir out)
1015                                (symlink (assoc-ref %build-inputs "p2")
1016                                         "p2")
1017                                #t))))))
1018     (lset= equal?
1019            (package-grafts %store p3)
1020            (list (graft
1021                    (origin (package-derivation %store p1 #:graft? #f))
1022                    (replacement (package-derivation %store p1r)))
1023                  (graft
1024                    (origin (package-derivation %store p2 #:graft? #f))
1025                    (replacement
1026                     (package-derivation %store p2r #:graft? #t)))))))
1027
1028 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
1029 ;;; find out about their run-time dependencies, so this test is no longer
1030 ;;; applicable since it would trigger a full rebuild.
1031 ;;
1032 ;; (test-assert "package-derivation, indirect grafts"
1033 ;;   (let* ((new   (dummy-package "dep"
1034 ;;                   (arguments '(#:implicit-inputs? #f))))
1035 ;;          (dep   (package (inherit new) (version "0.0")))
1036 ;;          (dep*  (package (inherit dep) (replacement new)))
1037 ;;          (dummy (dummy-package "dummy"
1038 ;;                   (arguments '(#:implicit-inputs? #f))
1039 ;;                   (inputs `(("dep" ,dep*)))))
1040 ;;          (guile (package-derivation %store (canonical-package guile-2.0)
1041 ;;                                     #:graft? #f)))
1042 ;;     (equal? (package-derivation %store dummy)
1043 ;;             (graft-derivation %store
1044 ;;                               (package-derivation %store dummy #:graft? #f)
1045 ;;                               (package-grafts %store dummy)
1046
1047 ;;                               ;; Use the same Guile as 'package-derivation'.
1048 ;;                               #:guile guile))))
1049
1050 (test-equal "package->bag"
1051   `("foo86-hurd" #f (,(package-source gnu-make))
1052     (,(canonical-package glibc)) (,(canonical-package coreutils)))
1053   (let ((bag (package->bag gnu-make "foo86-hurd")))
1054     (list (bag-system bag) (bag-target bag)
1055           (assoc-ref (bag-build-inputs bag) "source")
1056           (assoc-ref (bag-build-inputs bag) "libc")
1057           (assoc-ref (bag-build-inputs bag) "coreutils"))))
1058
1059 (test-assert "package->bag, sensitivity to %current-target-system"
1060   ;; https://bugs.gnu.org/41713
1061   (let* ((lower (lambda* (name #:key system target inputs native-inputs
1062                                #:allow-other-keys)
1063                   (and (not target)
1064                        (bag (name name) (system system) (target target)
1065                             (build-inputs native-inputs)
1066                             (host-inputs inputs)
1067                             (build (lambda* (store name inputs
1068                                                    #:key system target
1069                                                    #:allow-other-keys)
1070                                      (build-expression->derivation
1071                                       store "foo" '(mkdir %output))))))))
1072          (bs    (build-system
1073                   (name 'build-system-without-cross-compilation)
1074                   (description "Does not support cross compilation.")
1075                   (lower lower)))
1076          (dep   (dummy-package "dep" (build-system bs)))
1077          (pkg   (dummy-package "example"
1078                   (native-inputs `(("dep" ,dep)))))
1079          (do-not-build (lambda (continue store lst . _) lst)))
1080     (equal? (with-build-handler do-not-build
1081               (parameterize ((%current-target-system "powerpc64le-linux-gnu")
1082                              (%graft? #t))
1083                 (package-cross-derivation %store pkg
1084                                           (%current-target-system)
1085                                           #:graft? #t)))
1086             (with-build-handler do-not-build
1087               (package-cross-derivation %store
1088                                         (package (inherit pkg))
1089                                         "powerpc64le-linux-gnu"
1090                                         #:graft? #t)))))
1091
1092 (test-equal "package->bag, cross-compilation"
1093   `(,(%current-system) "foo86-hurd"
1094     (,(package-source gnu-make))
1095     (,(canonical-package glibc)) (,(canonical-package coreutils)))
1096   (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
1097     (list (bag-system bag) (bag-target bag)
1098           (assoc-ref (bag-build-inputs bag) "source")
1099           (assoc-ref (bag-build-inputs bag) "libc")
1100           (assoc-ref (bag-build-inputs bag) "coreutils"))))
1101
1102 (test-assert "package->bag, propagated inputs"
1103   (let* ((dep    (dummy-package "dep"))
1104          (prop   (dummy-package "prop"
1105                    (propagated-inputs `(("dep" ,dep)))))
1106          (dummy  (dummy-package "dummy"
1107                    (inputs `(("prop" ,prop)))))
1108          (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
1109     (match (assoc "dep" inputs)
1110       (("dep" package)
1111        (eq? package dep)))))
1112
1113 (test-assert "package->bag, sensitivity to %current-target-system"
1114   (let* ((dep (dummy-package "dep"
1115                 (propagated-inputs (if (%current-target-system)
1116                                        `(("libxml2" ,libxml2))
1117                                        '()))))
1118          (pkg (dummy-package "foo"
1119                 (native-inputs `(("dep" ,dep)))))
1120          (bag (package->bag pkg (%current-system) "foo86-hurd")))
1121     (equal? (parameterize ((%current-target-system "foo64-gnu"))
1122               (bag-transitive-inputs bag))
1123             (parameterize ((%current-target-system #f))
1124               (bag-transitive-inputs bag)))))
1125
1126 (test-assert "bag->derivation"
1127   (parameterize ((%graft? #f))
1128     (let ((bag (package->bag gnu-make))
1129           (drv (package-derivation %store gnu-make)))
1130       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
1131         (equal? drv (bag->derivation %store bag))))))
1132
1133 (test-assert "bag->derivation, cross-compilation"
1134   (parameterize ((%graft? #f))
1135     (let* ((target "mips64el-linux-gnu")
1136            (bag    (package->bag gnu-make (%current-system) target))
1137            (drv    (package-cross-derivation %store gnu-make target)))
1138       (parameterize ((%current-system "foox86-hurd") ;should have no effect
1139                      (%current-target-system "foo64-linux-gnu"))
1140         (equal? drv (bag->derivation %store bag))))))
1141
1142 (when (or (not (network-reachable?)) (shebang-too-long?))
1143   (test-skip 1))
1144 (test-assert "GNU Make, bootstrap"
1145   ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the
1146   ;; test doesn't last for too long.
1147   (let ((gnu-make gnu-make-for-tests))
1148     (and (package? gnu-make)
1149          (or (location? (package-location gnu-make))
1150              (not (package-location gnu-make)))
1151          (let* ((drv (package-derivation %store gnu-make))
1152                 (out (derivation->output-path drv)))
1153            (and (build-derivations %store (list drv))
1154                 (file-exists? (string-append out "/bin/make")))))))
1155
1156 (test-equal "package-mapping"
1157   42
1158   (let* ((dep       (dummy-package "chbouib"
1159                       (native-inputs `(("x" ,grep)))))
1160          (p0        (dummy-package "example"
1161                       (inputs `(("foo" ,coreutils)
1162                                 ("bar" ,grep)
1163                                 ("baz" ,dep)))))
1164          (transform (lambda (p)
1165                       (package (inherit p) (source 42))))
1166          (rewrite   (package-mapping transform))
1167          (p1        (rewrite p0)))
1168     (and (eq? p1 (rewrite p0))
1169          (eqv? 42 (package-source p1))
1170          (match (package-inputs p1)
1171            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1172             (and (eq? dep1 (rewrite coreutils))   ;memoization
1173                  (eq? dep2 (rewrite grep))
1174                  (eq? dep3 (rewrite dep))
1175                  (eqv? 42
1176                        (package-source dep1) (package-source dep2)
1177                        (package-source dep3))
1178                  (match (package-native-inputs dep3)
1179                    ((("x" dep))
1180                     (and (eq? dep (rewrite grep))
1181                          (package-source dep))))))))))
1182
1183 (test-assert "package-input-rewriting"
1184   (let* ((dep     (dummy-package "chbouib"
1185                     (native-inputs `(("x" ,grep)))))
1186          (p0      (dummy-package "example"
1187                     (inputs `(("foo" ,coreutils)
1188                               ("bar" ,grep)
1189                               ("baz" ,dep)))))
1190          (rewrite (package-input-rewriting `((,coreutils . ,sed)
1191                                              (,grep . ,findutils))
1192                                            (cut string-append "r-" <>)))
1193          (p1      (rewrite p0))
1194          (p2      (rewrite p0)))
1195     (and (not (eq? p1 p0))
1196          (eq? p1 p2)                              ;memoization
1197          (string=? "r-example" (package-name p1))
1198          (match (package-inputs p1)
1199            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1200             (and (eq? dep1 sed)
1201                  (eq? dep2 findutils)
1202                  (string=? (package-name dep3) "r-chbouib")
1203                  (eq? dep3 (rewrite dep))         ;memoization
1204                  (match (package-native-inputs dep3)
1205                    ((("x" dep))
1206                     (eq? dep findutils)))))))))
1207
1208 (test-assert "package-input-rewriting/spec"
1209   (let* ((dep     (dummy-package "chbouib"
1210                     (native-inputs `(("x" ,grep)))))
1211          (p0      (dummy-package "example"
1212                     (inputs `(("foo" ,coreutils)
1213                               ("bar" ,grep)
1214                               ("baz" ,dep)))))
1215          (rewrite (package-input-rewriting/spec
1216                    `(("coreutils" . ,(const sed))
1217                      ("grep" . ,(const findutils)))))
1218          (p1      (rewrite p0))
1219          (p2      (rewrite p0)))
1220     (and (not (eq? p1 p0))
1221          (eq? p1 p2)                              ;memoization
1222          (string=? "example" (package-name p1))
1223          (match (package-inputs p1)
1224            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1225             (and (string=? (package-full-name dep1)
1226                            (package-full-name sed))
1227                  (string=? (package-full-name dep2)
1228                            (package-full-name findutils))
1229                  (string=? (package-name dep3) "chbouib")
1230                  (eq? dep3 (rewrite dep))         ;memoization
1231                  (match (package-native-inputs dep3)
1232                    ((("x" dep))
1233                     (string=? (package-full-name dep)
1234                               (package-full-name findutils))))))))))
1235
1236 (test-assert "package-input-rewriting/spec, partial match"
1237   (let* ((dep     (dummy-package "chbouib"
1238                     (version "1")
1239                     (native-inputs `(("x" ,grep)))))
1240          (p0      (dummy-package "example"
1241                     (inputs `(("foo" ,coreutils)
1242                               ("bar" ,dep)))))
1243          (rewrite (package-input-rewriting/spec
1244                    `(("chbouib@123" . ,(const sed)) ;not matched
1245                      ("grep" . ,(const findutils)))))
1246          (p1      (rewrite p0)))
1247     (and (not (eq? p1 p0))
1248          (string=? "example" (package-name p1))
1249          (match (package-inputs p1)
1250            ((("foo" dep1) ("bar" dep2))
1251             (and (string=? (package-full-name dep1)
1252                            (package-full-name coreutils))
1253                  (eq? dep2 (rewrite dep))         ;memoization
1254                  (match (package-native-inputs dep2)
1255                    ((("x" dep))
1256                     (string=? (package-full-name dep)
1257                               (package-full-name findutils))))))))))
1258
1259 (test-equal "package-patched-vulnerabilities"
1260   '(("CVE-2015-1234")
1261     ("CVE-2016-1234" "CVE-2018-4567")
1262     ())
1263   (let ((p1 (dummy-package "pi"
1264               (source (dummy-origin
1265                        (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
1266         (p2 (dummy-package "pi"
1267               (source (dummy-origin
1268                        (patches (list
1269                                  "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
1270         (p3 (dummy-package "pi" (source (dummy-origin)))))
1271     (map package-patched-vulnerabilities
1272          (list p1 p2 p3))))
1273
1274 (test-eq "fold-packages" hello
1275   (fold-packages (lambda (p r)
1276                    (if (string=? (package-name p) "hello")
1277                        p
1278                        r))
1279                  #f))
1280
1281 (test-assert "fold-packages, hidden package"
1282   ;; There are two public variables providing "guile@2.0" ('guile-final' in
1283   ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
1284   ;; should show up.
1285   (match (fold-packages (lambda (p r)
1286                           (if (and (string=? (package-name p) "guile")
1287                                    (string-prefix? "2.0"
1288                                                    (package-version p)))
1289                               (cons p r)
1290                               r))
1291                         '())
1292     ((one)
1293      (eq? one guile-2.0))))
1294
1295 (test-assert "fold-available-packages with/without cache"
1296   (let ()
1297     (define no-cache
1298       (fold-available-packages (lambda* (name version result #:rest rest)
1299                                  (cons (cons* name version rest)
1300                                        result))
1301                                '()))
1302
1303     (define from-cache
1304       (call-with-temporary-directory
1305        (lambda (cache)
1306          (generate-package-cache cache)
1307          (mock ((guix describe) current-profile (const cache))
1308                (mock ((gnu packages) cache-is-authoritative? (const #t))
1309                      (fold-available-packages (lambda* (name version result
1310                                                              #:rest rest)
1311                                                 (cons (cons* name version rest)
1312                                                       result))
1313                                               '()))))))
1314
1315     (and (equal? (delete-duplicates from-cache) from-cache)
1316          (lset= equal? no-cache from-cache))))
1317
1318 (test-assert "find-packages-by-name"
1319   (match (find-packages-by-name "hello")
1320     (((? (cut eq? hello <>))) #t)
1321     (wrong (pk 'find-packages-by-name wrong #f))))
1322
1323 (test-assert "find-packages-by-name with version"
1324   (match (find-packages-by-name "hello" (package-version hello))
1325     (((? (cut eq? hello <>))) #t)
1326     (wrong (pk 'find-packages-by-name wrong #f))))
1327
1328 (test-equal "find-packages-by-name with cache"
1329   (find-packages-by-name "guile")
1330   (call-with-temporary-directory
1331    (lambda (cache)
1332      (generate-package-cache cache)
1333      (mock ((guix describe) current-profile (const cache))
1334            (mock ((gnu packages) cache-is-authoritative? (const #t))
1335                  (find-packages-by-name "guile"))))))
1336
1337 (test-equal "find-packages-by-name + version, with cache"
1338   (find-packages-by-name "guile" "2")
1339   (call-with-temporary-directory
1340    (lambda (cache)
1341      (generate-package-cache cache)
1342      (mock ((guix describe) current-profile (const cache))
1343            (mock ((gnu packages) cache-is-authoritative? (const #t))
1344                  (find-packages-by-name "guile" "2"))))))
1345
1346 (test-assert "--search-paths with pattern"
1347   ;; Make sure 'guix package --search-paths' correctly reports environment
1348   ;; variables when file patterns are used (in particular, it must follow
1349   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
1350   ;; libxml2 package specification, which contains such a definition.
1351   (let* ((p1 (package
1352                (name "foo") (version "0") (source #f)
1353                (build-system trivial-build-system)
1354                (arguments
1355                 `(#:guile ,%bootstrap-guile
1356                   #:modules ((guix build utils))
1357                   #:builder (begin
1358                               (use-modules (guix build utils))
1359                               (let ((out (assoc-ref %outputs "out")))
1360                                 (mkdir-p (string-append out "/xml/bar/baz"))
1361                                 (call-with-output-file
1362                                     (string-append out "/xml/bar/baz/catalog.xml")
1363                                   (lambda (port)
1364                                     (display "xml? wat?!" port)))
1365                                 #t))))
1366                (synopsis #f) (description #f)
1367                (home-page #f) (license #f)))
1368          (p2 (package
1369                ;; Provide a fake libxml2 to avoid building the real one.  This
1370                ;; is OK because 'guix package' gets search path specifications
1371                ;; from the same-named package found in the distro.
1372                (name "libxml2") (version "0.0.0") (source #f)
1373                (build-system trivial-build-system)
1374                (arguments
1375                 `(#:guile ,%bootstrap-guile
1376                   #:builder (begin
1377                               (mkdir (assoc-ref %outputs "out"))
1378                               #t)))
1379                (native-search-paths (package-native-search-paths libxml2))
1380                (synopsis #f) (description #f)
1381                (home-page #f) (license #f)))
1382          (prof (run-with-store %store
1383                  (profile-derivation
1384                   (manifest (map package->manifest-entry
1385                                  (list p1 p2)))
1386                   #:hooks '()
1387                   #:locales? #f)
1388                  #:guile-for-build (%guile-for-build))))
1389     (build-derivations %store (list prof))
1390     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1391                           (regexp-quote (derivation->output-path prof)))
1392                   (with-output-to-string
1393                     (lambda ()
1394                       (guix-package "-p" (derivation->output-path prof)
1395                                     "--search-paths"))))))
1396
1397 (test-assert "--search-paths with single-item search path"
1398   ;; Make sure 'guix package --search-paths' correctly reports environment
1399   ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1400   ;; separator, meaning that the first match wins.
1401   (let* ((p1 (dummy-package "foo"
1402                (build-system trivial-build-system)
1403                (arguments
1404                 `(#:guile ,%bootstrap-guile
1405                   #:modules ((guix build utils))
1406                   #:builder (begin
1407                               (use-modules (guix build utils))
1408                               (let ((out (assoc-ref %outputs "out")))
1409                                 (mkdir-p (string-append out "/etc/ssl/certs"))
1410                                 (call-with-output-file
1411                                     (string-append
1412                                      out "/etc/ssl/certs/ca-certificates.crt")
1413                                   (const #t))))))))
1414          (p2 (package (inherit p1) (name "bar")))
1415          (p3 (dummy-package "git"
1416                ;; Provide a fake Git to avoid building the real one.
1417                (build-system trivial-build-system)
1418                (arguments
1419                 `(#:guile ,%bootstrap-guile
1420                   #:builder (begin
1421                               (mkdir (assoc-ref %outputs "out"))
1422                               #t)))
1423                (native-search-paths (package-native-search-paths git))))
1424          (prof1 (run-with-store %store
1425                   (profile-derivation
1426                    (packages->manifest (list p1 p3))
1427                    #:hooks '()
1428                    #:locales? #f)
1429                   #:guile-for-build (%guile-for-build)))
1430          (prof2 (run-with-store %store
1431                   (profile-derivation
1432                    (packages->manifest (list p2 p3))
1433                    #:hooks '()
1434                    #:locales? #f)
1435                   #:guile-for-build (%guile-for-build))))
1436     (build-derivations %store (list prof1 prof2))
1437     (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1438                           (regexp-quote (derivation->output-path prof1)))
1439                   (with-output-to-string
1440                     (lambda ()
1441                       (guix-package "-p" (derivation->output-path prof1)
1442                                     "-p" (derivation->output-path prof2)
1443                                     "--search-paths"))))))
1444
1445 (test-equal "specification->package when not found"
1446   'quit
1447   (catch 'quit
1448     (lambda ()
1449       ;; This should call 'leave', producing an error message.
1450       (specification->package "this-package-does-not-exist"))
1451     (lambda (key . args)
1452       key)))
1453
1454 (test-equal "specification->package+output"
1455   `((,coreutils "out") (,coreutils "debug"))
1456   (list (call-with-values (lambda ()
1457                             (specification->package+output "coreutils"))
1458           list)
1459         (call-with-values (lambda ()
1460                             (specification->package+output "coreutils:debug"))
1461           list)))
1462
1463 (test-equal "specification->package+output invalid output"
1464   'error
1465   (catch 'quit
1466     (lambda ()
1467       (specification->package+output "coreutils:does-not-exist"))
1468     (lambda _
1469       'error)))
1470
1471 (test-equal "specification->package+output no default output"
1472   `(,coreutils #f)
1473   (call-with-values
1474     (lambda ()
1475       (specification->package+output "coreutils" #f))
1476     list))
1477
1478 (test-equal "specification->package+output invalid output, no default"
1479   'error
1480   (catch 'quit
1481     (lambda ()
1482       (specification->package+output "coreutils:does-not-exist" #f))
1483     (lambda _
1484       'error)))
1485
1486 (test-equal "find-package-locations"
1487   (map (lambda (package)
1488          (cons (package-version package)
1489                (package-location package)))
1490        (find-packages-by-name "guile"))
1491   (find-package-locations "guile"))
1492
1493 (test-equal "find-package-locations with cache"
1494   (map (lambda (package)
1495          (cons (package-version package)
1496                (package-location package)))
1497        (find-packages-by-name "guile"))
1498   (call-with-temporary-directory
1499    (lambda (cache)
1500      (generate-package-cache cache)
1501      (mock ((guix describe) current-profile (const cache))
1502            (mock ((gnu packages) cache-is-authoritative? (const #t))
1503                  (find-package-locations "guile"))))))
1504
1505 (test-equal "specification->location"
1506   (package-location (specification->package "guile@2"))
1507   (specification->location "guile@2"))
1508
1509 (test-end "packages")
1510
1511 ;;; Local Variables:
1512 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
1513 ;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1)
1514 ;;; End: