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   #:use-module ((guix diagnostics)
  28                 ;; Rename the 'location' binding to allow proper syntax
  29                 ;; matching when setting the 'location' field of a package.
  30                 #:renamer (lambda (name)
  31                             (cond ((eq? name 'location) 'make-location)
  32                                   (else name))))
  33   #:use-module ((gcrypt hash) #:prefix gcrypt:)
  34   #:use-module (guix derivations)
  35   #:use-module (guix packages)
  36   #:use-module (guix grafts)
  37   #:use-module (guix search-paths)
  38   #:use-module (guix build-system)
  39   #:use-module (guix build-system trivial)
  40   #:use-module (guix build-system gnu)
  41   #:use-module (guix memoization)
  42   #:use-module (guix profiles)
  43   #:use-module (guix scripts package)
  44   #:use-module (gnu packages)
  45   #:use-module (gnu packages base)
  46   #:use-module (gnu packages guile)
  47   #:use-module (gnu packages bootstrap)
  48   #:use-module (gnu packages version-control)
  49   #:use-module (gnu packages xml)
  50   #:use-module (srfi srfi-1)
  51   #:use-module (srfi srfi-26)
  52   #:use-module (srfi srfi-34)
  53   #:use-module (srfi srfi-35)
  54   #:use-module (srfi srfi-64)
  55   #:use-module (rnrs bytevectors)
  56   #:use-module (rnrs io ports)
  57   #:use-module (ice-9 vlist)
  58   #:use-module (ice-9 regex)
  59   #:use-module (ice-9 match))
  60
  61 ;; Test the high-level packaging layer.
  62
  63 (define %store
  64   (open-connection-for-tests))
  65
  66 ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
  67 ;; can trigger builds early.)
  68 (%graft? #f)
  69
  70 \f
  71 (test-begin "packages")
  72
  73 (test-assert "printer with location"
  74   (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
  75                 (with-output-to-string
  76                   (lambda ()
  77                     (write
  78                      (dummy-package "foo"
  79                        (location (make-location "foo.scm" 42 7))))))))
  80
  81 (test-assert "printer without location"
  82   (string-match "^#<package foo@0 [[:xdigit:]]+>$"
  83                 (with-output-to-string
  84                   (lambda ()
  85                     (write
  86                      (dummy-package "foo" (location #f)))))))
  87
  88 (test-assert "hidden-package"
  89   (and (hidden-package? (hidden-package (dummy-package "foo")))
  90        (not (hidden-package? (dummy-package "foo")))))
  91
  92 (test-assert "package-superseded"
  93   (let* ((new (dummy-package "bar"))
  94          (old (deprecated-package "foo" new)))
  95     (and (eq? (package-superseded old) new)
  96          (mock ((gnu packages) find-best-packages-by-name (const (list old)))
  97                (specification->package "foo")
  98                (and (eq? new (specification->package "foo"))
  99                     (eq? new (specification->package+output "foo")))))))
 100
 101 (test-assert "transaction-upgrade-entry, zero upgrades"
 102   (let* ((old (dummy-package "foo" (version "1")))
 103          (tx  (mock ((gnu packages) find-best-packages-by-name
 104                      (const '()))
 105                     (transaction-upgrade-entry
 106                      #f                           ;no store access needed
 107                      (manifest-entry
 108                        (inherit (package->manifest-entry old))
 109                        (item (string-append (%store-prefix) "/"
 110                                             (make-string 32 #\e) "-foo-1")))
 111                      (manifest-transaction)))))
 112     (manifest-transaction-null? tx)))
 113
 114 (test-assert "transaction-upgrade-entry, zero upgrades, equivalent package"
 115   (let* ((old (dummy-package "foo" (version "1")))
 116          (drv (package-derivation %store old))
 117          (tx  (mock ((gnu packages) find-best-packages-by-name
 118                      (const (list old)))
 119                     (transaction-upgrade-entry
 120                      %store
 121                      (manifest-entry
 122                        (inherit (package->manifest-entry old))
 123                        (item (derivation->output-path drv)))
 124                      (manifest-transaction)))))
 125     (manifest-transaction-null? tx)))
 126
 127 (test-assert "transaction-upgrade-entry, zero upgrades, propagated inputs"
 128   ;; Properly detect equivalent packages even when they have propagated
 129   ;; inputs.  See <https://bugs.gnu.org/35872>.
 130   (let* ((dep (dummy-package "dep" (version "2")))
 131          (old (dummy-package "foo" (version "1")
 132                              (propagated-inputs `(("dep" ,dep)))))
 133          (drv (package-derivation %store old))
 134          (tx  (mock ((gnu packages) find-best-packages-by-name
 135                      (const (list old)))
 136                     (transaction-upgrade-entry
 137                      %store
 138                      (manifest-entry
 139                        (inherit (package->manifest-entry old))
 140                        (item (derivation->output-path drv))
 141                        (dependencies
 142                         (list (manifest-entry
 143                                 (inherit (package->manifest-entry dep))
 144                                 (item (derivation->output-path
 145                                        (package-derivation %store dep)))))))
 146                      (manifest-transaction)))))
 147     (manifest-transaction-null? tx)))
 148
 149 (test-assert "transaction-upgrade-entry, one upgrade"
 150   (let* ((old (dummy-package "foo" (version "1")))
 151          (new (dummy-package "foo" (version "2")))
 152          (tx  (mock ((gnu packages) find-best-packages-by-name
 153                      (const (list new)))
 154                     (transaction-upgrade-entry
 155                      #f                           ;no store access needed
 156                      (manifest-entry
 157                        (inherit (package->manifest-entry old))
 158                        (item (string-append (%store-prefix) "/"
 159                                             (make-string 32 #\e) "-foo-1")))
 160                      (manifest-transaction)))))
 161     (and (match (manifest-transaction-install tx)
 162            ((($ <manifest-entry> "foo" "2" "out" item))
 163             (eq? item new)))
 164          (null? (manifest-transaction-remove tx)))))
 165
 166 (test-assert "transaction-upgrade-entry, superseded package"
 167   (let* ((old (dummy-package "foo" (version "1")))
 168          (new (dummy-package "bar" (version "2")))
 169          (dep (deprecated-package "foo" new))
 170          (tx  (mock ((gnu packages) find-best-packages-by-name
 171                      (const (list dep)))
 172                     (transaction-upgrade-entry
 173                      #f                           ;no store access needed
 174                      (manifest-entry
 175                        (inherit (package->manifest-entry old))
 176                        (item (string-append (%store-prefix) "/"
 177                                             (make-string 32 #\e) "-foo-1")))
 178                      (manifest-transaction)))))
 179     (and (match (manifest-transaction-install tx)
 180            ((($ <manifest-entry> "bar" "2" "out" item))
 181             (eq? item new)))
 182          (match (manifest-transaction-remove tx)
 183            (((? manifest-pattern? pattern))
 184             (and (string=? (manifest-pattern-name pattern) "foo")
 185                  (string=? (manifest-pattern-version pattern) "1")
 186                  (string=? (manifest-pattern-output pattern) "out")))))))
 187
 188 (test-assert "transaction-upgrade-entry, grafts"
 189   ;; Ensure that, when grafts are enabled, 'transaction-upgrade-entry' doesn't
 190   ;; try to build stuff.
 191   (with-build-handler (const 'failed!)
 192     (parameterize ((%graft? #t))
 193       (let* ((old (dummy-package "foo" (version "1")))
 194              (bar (dummy-package "bar" (version "0")
 195                                  (replacement old)))
 196              (new (dummy-package "foo" (version "1")
 197                                  (inputs `(("bar" ,bar)))))
 198              (tx  (mock ((gnu packages) find-best-packages-by-name
 199                          (const (list new)))
 200                         (transaction-upgrade-entry
 201                          %store
 202                          (manifest-entry
 203                            (inherit (package->manifest-entry old))
 204                            (item (string-append (%store-prefix) "/"
 205                                                 (make-string 32 #\e) "-foo-1")))
 206                          (manifest-transaction)))))
 207         (and (match (manifest-transaction-install tx)
 208                ((($ <manifest-entry> "foo" "1" "out" item))
 209                 (eq? item new)))
 210              (null? (manifest-transaction-remove tx)))))))
 211
 212 (test-assert "package-field-location"
 213   (let ()
 214     (define (goto port line column)
 215       (unless (and (= (port-column port) (- column 1))
 216                    (= (port-line port) (- line 1)))
 217         (unless (eof-object? (get-char port))
 218           (goto port line column))))
 219
 220     (define read-at
 221       (match-lambda
 222        (($ <location> file line column)
 223         (call-with-input-file (search-path %load-path file)
 224           (lambda (port)
 225             (goto port line column)
 226             (read port))))))
 227
 228     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
 229     ;; Thus, check against both VALUE and (FIELD VALUE).
 230     (and (member (read-at (package-field-location %bootstrap-guile 'name))
 231                  (let ((name (package-name %bootstrap-guile)))
 232                    (list name `(name ,name))))
 233          (member (read-at (package-field-location %bootstrap-guile 'version))
 234                  (let ((version (package-version %bootstrap-guile)))
 235                    (list version `(version ,version))))
 236          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 237
 238 ;; Make sure we don't change the file name to an absolute file name.
 239 (test-equal "package-field-location, relative file name"
 240   (location-file (package-location %bootstrap-guile))
 241   (with-fluids ((%file-port-name-canonicalization 'absolute))
 242     (location-file (package-field-location %bootstrap-guile 'version))))
 243
 244 (test-assert "package-transitive-inputs"
 245   (let* ((a (dummy-package "a"))
 246          (b (dummy-package "b"
 247               (propagated-inputs `(("a" ,a)))))
 248          (c (dummy-package "c"
 249               (inputs `(("a" ,a)))))
 250          (d (dummy-package "d"
 251               (propagated-inputs `(("x" "something.drv")))))
 252          (e (dummy-package "e"
 253               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
 254     (and (null? (package-transitive-inputs a))
 255          (equal? `(("a" ,a)) (package-transitive-inputs b))
 256          (equal? `(("a" ,a)) (package-transitive-inputs c))
 257          (equal? (package-propagated-inputs d)
 258                  (package-transitive-inputs d))
 259          (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
 260                    ("a" ,a) ("x" "something.drv"))
 261                  (pk 'x (package-transitive-inputs e))))))
 262
 263 (test-assert "package-transitive-inputs, no duplicates"
 264   (let* ((a (dummy-package "a"))
 265          (b (dummy-package "b"
 266               (inputs `(("a+" ,a)))
 267               (native-inputs `(("a*" ,a)))
 268               (propagated-inputs `(("a" ,a)))))
 269          (c (dummy-package "c"
 270               (propagated-inputs `(("b" ,b)))))
 271          (d (dummy-package "d"
 272               (inputs `(("a" ,a) ("c" ,c)))))
 273          (e (dummy-package "e"
 274               (inputs `(("b" ,b) ("c" ,c))))))
 275     (and (null? (package-transitive-inputs a))
 276          (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
 277                  (package-transitive-inputs b))
 278          (equal? `(("b" ,b) ("a" ,a))
 279                  (package-transitive-inputs c))
 280          (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
 281                  (package-transitive-inputs d))
 282          (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
 283                  (package-transitive-inputs e))))) ;ditto
 284
 285 (test-equal "package-transitive-supported-systems"
 286   '(("x" "y" "z")                                 ;a
 287     ("x" "y")                                     ;b
 288     ("y")                                         ;c
 289     ("y")                                         ;d
 290     ("y"))                                        ;e
 291   ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
 292   ;; doesn't restrict the set of supported systems.
 293   (let* ((a (dummy-package "a"
 294               (build-system trivial-build-system)
 295               (supported-systems '("x" "y" "z"))))
 296          (b (dummy-package "b"
 297               (build-system trivial-build-system)
 298               (supported-systems '("x" "y"))
 299               (inputs `(("a" ,a)))))
 300          (c (dummy-package "c"
 301               (build-system trivial-build-system)
 302               (supported-systems '("y" "z"))
 303               (inputs `(("b" ,b)))))
 304          (d (dummy-package "d"
 305               (build-system trivial-build-system)
 306               (supported-systems '("x" "y" "z"))
 307               (inputs `(("b" ,b) ("c" ,c)))))
 308          (e (dummy-package "e"
 309               (build-system trivial-build-system)
 310               (supported-systems '("x" "y" "z"))
 311               (inputs `(("d" ,d))))))
 312     (list (package-transitive-supported-systems a)
 313           (package-transitive-supported-systems b)
 314           (package-transitive-supported-systems c)
 315           (package-transitive-supported-systems d)
 316           (package-transitive-supported-systems e))))
 317
 318 (test-assert "package-closure"
 319   (let-syntax ((dummy-package/no-implicit
 320                 (syntax-rules ()
 321                   ((_ name rest ...)
 322                    (package
 323                      (inherit (dummy-package name rest ...))
 324                      (build-system trivial-build-system))))))
 325     (let* ((a (dummy-package/no-implicit "a"))
 326            (b (dummy-package/no-implicit "b"
 327                 (propagated-inputs `(("a" ,a)))))
 328            (c (dummy-package/no-implicit "c"
 329                 (inputs `(("a" ,a)))))
 330            (d (dummy-package/no-implicit "d"
 331                 (native-inputs `(("b" ,b)))))
 332            (e (dummy-package/no-implicit "e"
 333                 (inputs `(("c" ,c) ("d" ,d))))))
 334       (lset= eq?
 335              (list a b c d e)
 336              (package-closure (list e))
 337              (package-closure (list e d))
 338              (package-closure (list e c b))))))
 339
 340 (test-equal "origin-actual-file-name"
 341   "foo-1.tar.gz"
 342   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 343     (origin-actual-file-name o)))
 344
 345 (test-equal "origin-actual-file-name, file-name"
 346   "foo-1.tar.gz"
 347   (let ((o (dummy-origin
 348             (uri "http://www.example.com/tarball")
 349             (file-name "foo-1.tar.gz"))))
 350     (origin-actual-file-name o)))
 351
 352 (let* ((o (dummy-origin))
 353        (u (dummy-origin))
 354        (i (dummy-origin))
 355        (a (dummy-package "a"))
 356        (b (dummy-package "b"
 357             (inputs `(("a" ,a) ("i" ,i)))))
 358        (c (package (inherit b) (source o)))
 359        (d (dummy-package "d"
 360             (build-system trivial-build-system)
 361             (source u) (inputs `(("c" ,c))))))
 362   (test-assert "package-direct-sources, no source"
 363     (null? (package-direct-sources a)))
 364   (test-equal "package-direct-sources, #f source"
 365     (list i)
 366     (package-direct-sources b))
 367   (test-equal "package-direct-sources, not input source"
 368     (list u)
 369     (package-direct-sources d))
 370   (test-assert "package-direct-sources"
 371     (let ((s (package-direct-sources c)))
 372       (and (= (length (pk 's-sources s)) 2)
 373            (member o s)
 374            (member i s))))
 375   (test-assert "package-transitive-sources"
 376     (let ((s (package-transitive-sources d)))
 377       (and (= (length (pk 'd-sources s)) 3)
 378            (member o s)
 379            (member i s)
 380            (member u s)))))
 381
 382 (test-assert "transitive-input-references"
 383   (let* ((a (dummy-package "a"))
 384          (b (dummy-package "b"))
 385          (c (dummy-package "c"
 386               (inputs `(("a" ,a)))
 387               (propagated-inputs `(("boo" ,b)))))
 388          (d (dummy-package "d"
 389               (inputs `(("c*" ,c)))))
 390          (keys (map (match-lambda
 391                       (('assoc-ref 'l key)
 392                        key))
 393                     (pk 'refs (transitive-input-references
 394                                'l (package-inputs d))))))
 395     (and (= (length keys) 2)
 396          (member "c*" keys)
 397          (member "boo" keys))))
 398
 399 (test-equal "package-transitive-supported-systems, implicit inputs"
 400   %supported-systems
 401
 402   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 403   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 404   (let ((p (dummy-package "foo"
 405                (build-system gnu-build-system)
 406                (supported-systems
 407                 `("does-not-exist" "foobar" ,@%supported-systems)))))
 408     (parameterize ((%current-system "armhf-linux")) ; a traditionally-bootstrapped architecture
 409       (package-transitive-supported-systems p))))
 410
 411 (test-equal "package-transitive-supported-systems: reduced binary seed, implicit inputs"
 412   '("x86_64-linux" "i686-linux")
 413
 414   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 415   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 416   (let ((p (dummy-package "foo"
 417              (build-system gnu-build-system)
 418              (supported-systems
 419               `("does-not-exist" "foobar" ,@%supported-systems)))))
 420     (parameterize ((%current-system "x86_64-linux"))
 421       (package-transitive-supported-systems p))))
 422
 423 (test-assert "supported-package?"
 424   (let* ((d (dummy-package "dep"
 425               (build-system trivial-build-system)
 426               (supported-systems '("x86_64-linux"))))
 427          (p (dummy-package "foo"
 428               (build-system gnu-build-system)
 429               (inputs `(("d" ,d)))
 430               (supported-systems '("x86_64-linux" "armhf-linux")))))
 431     (and (supported-package? p "x86_64-linux")
 432          (not (supported-package? p "i686-linux"))
 433          (not (supported-package? p "armhf-linux")))))
 434
 435 (test-assert "supported-package? vs. system-dependent graph"
 436   ;; The inputs of a package can depend on (%current-system).  Thus,
 437   ;; 'supported-package?' must make sure that it binds (%current-system)
 438   ;; appropriately before traversing the dependency graph.  In the example
 439   ;; below, 'supported-package?' must thus return true for both systems.
 440   (let* ((p0a (dummy-package "foo-arm"
 441                 (build-system trivial-build-system)
 442                 (supported-systems '("armhf-linux"))))
 443          (p0b (dummy-package "foo-x86_64"
 444                 (build-system trivial-build-system)
 445                 (supported-systems '("x86_64-linux"))))
 446          (p   (dummy-package "bar"
 447                 (build-system trivial-build-system)
 448                 (inputs
 449                  (if (string=? (%current-system) "armhf-linux")
 450                      `(("foo" ,p0a))
 451                      `(("foo" ,p0b)))))))
 452     (and (supported-package? p "x86_64-linux")
 453          (supported-package? p "armhf-linux"))))
 454
 455 (test-skip (if (not %store) 8 0))
 456
 457 (test-assert "package-source-derivation, file"
 458   (let* ((file    (search-path %load-path "guix.scm"))
 459          (package (package (inherit (dummy-package "p"))
 460                     (source file)))
 461          (source  (package-source-derivation %store
 462                                              (package-source package))))
 463     (and (store-path? source)
 464          (valid-path? %store source)
 465          (equal? (call-with-input-file source get-bytevector-all)
 466                  (call-with-input-file file get-bytevector-all)))))
 467
 468 (test-assert "package-source-derivation, store path"
 469   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 470                                 (search-path %load-path "guix.scm")))
 471          (package (package (inherit (dummy-package "p"))
 472                     (source file)))
 473          (source  (package-source-derivation %store
 474                                              (package-source package))))
 475     (string=? file source)))
 476
 477 (test-assert "package-source-derivation, indirect store path"
 478   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 479                                 (dirname (search-path %load-path
 480                                                       "guix/build/utils.scm"))))
 481          (package (package (inherit (dummy-package "p"))
 482                     (source (string-append dir "/utils.scm"))))
 483          (source  (package-source-derivation %store
 484                                              (package-source package))))
 485     (and (direct-store-path? source)
 486          (string-suffix? "utils.scm" source))))
 487
 488 (test-assert "package-source-derivation, local-file"
 489   (let* ((file    (local-file "../guix/base32.scm"))
 490          (package (package (inherit (dummy-package "p"))
 491                     (source file)))
 492          (source  (package-source-derivation %store
 493                                              (package-source package))))
 494     (and (store-path? source)
 495          (string-suffix? "base32.scm" source)
 496          (valid-path? %store source)
 497          (equal? (call-with-input-file source get-bytevector-all)
 498                  (call-with-input-file
 499                      (search-path %load-path "guix/base32.scm")
 500                    get-bytevector-all)))))
 501
 502 (test-equal "package-source-derivation, origin, sha512"
 503   "hello"
 504   (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
 505          (builder (add-text-to-store %store "my-fixed-builder.sh"
 506                                      "echo -n hello > $out" '()))
 507          (method  (lambda* (url hash-algo hash #:optional name
 508                                 #:rest rest)
 509                     (and (eq? hash-algo 'sha512)
 510                          (raw-derivation name bash (list builder)
 511                                          #:sources (list builder)
 512                                          #:hash hash
 513                                          #:hash-algo hash-algo))))
 514          (source  (origin
 515                     (method method)
 516                     (uri "unused://")
 517                     (file-name "origin-sha512")
 518                     (hash (content-hash
 519                            (gcrypt:bytevector-hash (string->utf8 "hello")
 520                                                    (gcrypt:lookup-hash-algorithm
 521                                                     'sha512))
 522                            sha512))))
 523          (drv    (package-source-derivation %store source))
 524          (output (derivation->output-path drv)))
 525     (build-derivations %store (list drv))
 526     (call-with-input-file output get-string-all)))
 527
 528 (test-equal "package-source-derivation, origin, sha3-512"
 529   "hello, sha3"
 530   (let* ((bash    (search-bootstrap-binary "bash" (%current-system)))
 531          (builder (add-text-to-store %store "my-fixed-builder.sh"
 532                                      "echo -n hello, sha3 > $out" '()))
 533          (method  (lambda* (url hash-algo hash #:optional name
 534                                 #:rest rest)
 535                     (and (eq? hash-algo 'sha3-512)
 536                          (raw-derivation name bash (list builder)
 537                                          #:sources (list builder)
 538                                          #:hash hash
 539                                          #:hash-algo hash-algo))))
 540          (source  (origin
 541                     (method method)
 542                     (uri "unused://")
 543                     (file-name "origin-sha3")
 544                     (hash (content-hash
 545                            (gcrypt:bytevector-hash (string->utf8 "hello, sha3")
 546                                                    (gcrypt:lookup-hash-algorithm
 547                                                     'sha3-512))
 548                            sha3-512))))
 549          (drv    (package-source-derivation %store source))
 550          (output (derivation->output-path drv)))
 551     (build-derivations %store (list drv))
 552     (call-with-input-file output get-string-all)))
 553
 554 (unless (network-reachable?) (test-skip 1))
 555 (test-equal "package-source-derivation, snippet"
 556   "OK"
 557   (let* ((source (bootstrap-origin
 558                   (origin
 559                     (inherit (bootstrap-guile-origin (%current-system)))
 560                     (patch-inputs
 561                      `(("tar" ,%bootstrap-coreutils&co)
 562                        ("xz" ,%bootstrap-coreutils&co)
 563                        ("patch" ,%bootstrap-coreutils&co)))
 564                     (patch-guile %bootstrap-guile)
 565                     (modules '((guix build utils)))
 566                     (snippet '(begin
 567                                 ;; We end up in 'bin', because it's the first
 568                                 ;; directory, alphabetically.  Not a very good
 569                                 ;; example but hey.
 570                                 (chmod "." #o777)
 571                                 (symlink "guile" "guile-rocks")
 572                                 (copy-recursively "../share/guile/2.0/scripts"
 573                                                   "scripts")
 574
 575                                 ;; Make sure '.file_list' can be created.
 576                                 (chmod ".." #o777))))))
 577          (package (package (inherit (dummy-package "with-snippet"))
 578                     (source source)
 579                     (build-system trivial-build-system)
 580                     (inputs
 581                      `(("tar" ,(search-bootstrap-binary "tar"
 582                                                         (%current-system)))
 583                        ("xz"  ,(search-bootstrap-binary "xz"
 584                                                         (%current-system)))))
 585                     (arguments
 586                      `(#:guile ,%bootstrap-guile
 587                        #:modules ((guix build utils))
 588                        #:builder
 589                        (begin
 590                          (use-modules (guix build utils))
 591                          (let ((tar    (assoc-ref %build-inputs "tar"))
 592                                (xz     (assoc-ref %build-inputs "xz"))
 593                                (source (assoc-ref %build-inputs "source")))
 594                            (invoke tar "xvf" source
 595                                    "--use-compress-program" xz)
 596                            (unless (and (string=? "guile" (readlink "bin/guile-rocks"))
 597                                         (file-exists? "bin/scripts/compile.scm"))
 598                              (error "the snippet apparently failed"))
 599                            (let ((out (assoc-ref %outputs "out")))
 600                              (call-with-output-file out
 601                                (lambda (p)
 602                                  (display "OK" p))))
 603                            #t))))))
 604          (drv    (package-derivation %store package))
 605          (out    (derivation->output-path drv)))
 606     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 607          (call-with-input-file out get-string-all))))
 608
 609 (test-assert "return value"
 610   (let ((drv (package-derivation %store (dummy-package "p"))))
 611     (and (derivation? drv)
 612          (file-exists? (derivation-file-name drv)))))
 613
 614 (test-assert "package-output"
 615   (let* ((package  (dummy-package "p"))
 616          (drv      (package-derivation %store package)))
 617     (and (derivation? drv)
 618          (string=? (derivation->output-path drv)
 619                    (package-output %store package "out")))))
 620
 621 (test-equal "patch not found yields a run-time error"
 622   '("~a: patch not found\n" "does-not-exist.patch")
 623   (guard (c ((formatted-message? c)
 624              (cons (formatted-message-string c)
 625                    (formatted-message-arguments c))))
 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-system"
1114   (let* ((dep (dummy-package "dep"
1115                 (propagated-inputs (if (string=? (%current-system)
1116                                                  "i586-gnu")
1117                                        `(("libxml2" ,libxml2))
1118                                        '()))))
1119          (pkg (dummy-package "foo"
1120                 (native-inputs `(("dep" ,dep)))))
1121          (bag (package->bag pkg (%current-system) "i586-gnu")))
1122     (equal? (parameterize ((%current-system "x86_64-linux"))
1123               (bag-transitive-inputs bag))
1124             (parameterize ((%current-system "i586-gnu"))
1125               (bag-transitive-inputs bag)))))
1126
1127 (test-assert "package->bag, sensitivity to %current-target-system"
1128   (let* ((dep (dummy-package "dep"
1129                 (propagated-inputs (if (%current-target-system)
1130                                        `(("libxml2" ,libxml2))
1131                                        '()))))
1132          (pkg (dummy-package "foo"
1133                 (native-inputs `(("dep" ,dep)))))
1134          (bag (package->bag pkg (%current-system) "foo86-hurd")))
1135     (equal? (parameterize ((%current-target-system "foo64-gnu"))
1136               (bag-transitive-inputs bag))
1137             (parameterize ((%current-target-system #f))
1138               (bag-transitive-inputs bag)))))
1139
1140 (test-assert "bag->derivation"
1141   (parameterize ((%graft? #f))
1142     (let ((bag (package->bag gnu-make))
1143           (drv (package-derivation %store gnu-make)))
1144       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
1145         (equal? drv (bag->derivation %store bag))))))
1146
1147 (test-assert "bag->derivation, cross-compilation"
1148   (parameterize ((%graft? #f))
1149     (let* ((target "mips64el-linux-gnu")
1150            (bag    (package->bag gnu-make (%current-system) target))
1151            (drv    (package-cross-derivation %store gnu-make target)))
1152       (parameterize ((%current-system "foox86-hurd") ;should have no effect
1153                      (%current-target-system "foo64-linux-gnu"))
1154         (equal? drv (bag->derivation %store bag))))))
1155
1156 (when (or (not (network-reachable?)) (shebang-too-long?))
1157   (test-skip 1))
1158 (test-assert "GNU Make, bootstrap"
1159   ;; GNU-MAKE-FOR-TESTS can be built cheaply; we choose it here so that the
1160   ;; test doesn't last for too long.
1161   (let ((gnu-make gnu-make-for-tests))
1162     (and (package? gnu-make)
1163          (or (location? (package-location gnu-make))
1164              (not (package-location gnu-make)))
1165          (let* ((drv (package-derivation %store gnu-make))
1166                 (out (derivation->output-path drv)))
1167            (and (build-derivations %store (list drv))
1168                 (file-exists? (string-append out "/bin/make")))))))
1169
1170 (test-equal "package-mapping"
1171   42
1172   (let* ((dep       (dummy-package "chbouib"
1173                       (native-inputs `(("x" ,grep)))))
1174          (p0        (dummy-package "example"
1175                       (inputs `(("foo" ,coreutils)
1176                                 ("bar" ,grep)
1177                                 ("baz" ,dep)))))
1178          (transform (lambda (p)
1179                       (package (inherit p) (source 42))))
1180          (rewrite   (package-mapping transform))
1181          (p1        (rewrite p0)))
1182     (and (eq? p1 (rewrite p0))
1183          (eqv? 42 (package-source p1))
1184          (match (package-inputs p1)
1185            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1186             (and (eq? dep1 (rewrite coreutils))   ;memoization
1187                  (eq? dep2 (rewrite grep))
1188                  (eq? dep3 (rewrite dep))
1189                  (eqv? 42
1190                        (package-source dep1) (package-source dep2)
1191                        (package-source dep3))
1192                  (match (package-native-inputs dep3)
1193                    ((("x" dep))
1194                     (and (eq? dep (rewrite grep))
1195                          (package-source dep))))))))))
1196
1197 (test-assert "package-input-rewriting"
1198   (let* ((dep     (dummy-package "chbouib"
1199                     (native-inputs `(("x" ,grep)))))
1200          (p0      (dummy-package "example"
1201                     (inputs `(("foo" ,coreutils)
1202                               ("bar" ,grep)
1203                               ("baz" ,dep)))))
1204          (rewrite (package-input-rewriting `((,coreutils . ,sed)
1205                                              (,grep . ,findutils))
1206                                            (cut string-append "r-" <>)))
1207          (p1      (rewrite p0))
1208          (p2      (rewrite p0)))
1209     (and (not (eq? p1 p0))
1210          (eq? p1 p2)                              ;memoization
1211          (string=? "r-example" (package-name p1))
1212          (match (package-inputs p1)
1213            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1214             (and (eq? dep1 sed)
1215                  (eq? dep2 findutils)
1216                  (string=? (package-name dep3) "r-chbouib")
1217                  (eq? dep3 (rewrite dep))         ;memoization
1218                  (match (package-native-inputs dep3)
1219                    ((("x" dep))
1220                     (eq? dep findutils)))))))))
1221
1222 (test-assert "package-input-rewriting/spec"
1223   (let* ((dep     (dummy-package "chbouib"
1224                     (native-inputs `(("x" ,grep)))))
1225          (p0      (dummy-package "example"
1226                     (inputs `(("foo" ,coreutils)
1227                               ("bar" ,grep)
1228                               ("baz" ,dep)))))
1229          (rewrite (package-input-rewriting/spec
1230                    `(("coreutils" . ,(const sed))
1231                      ("grep" . ,(const findutils)))))
1232          (p1      (rewrite p0))
1233          (p2      (rewrite p0)))
1234     (and (not (eq? p1 p0))
1235          (eq? p1 p2)                              ;memoization
1236          (string=? "example" (package-name p1))
1237          (match (package-inputs p1)
1238            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
1239             (and (string=? (package-full-name dep1)
1240                            (package-full-name sed))
1241                  (string=? (package-full-name dep2)
1242                            (package-full-name findutils))
1243                  (string=? (package-name dep3) "chbouib")
1244                  (eq? dep3 (rewrite dep))         ;memoization
1245                  (match (package-native-inputs dep3)
1246                    ((("x" dep))
1247                     (string=? (package-full-name dep)
1248                               (package-full-name findutils))))))))))
1249
1250 (test-assert "package-input-rewriting/spec, partial match"
1251   (let* ((dep     (dummy-package "chbouib"
1252                     (version "1")
1253                     (native-inputs `(("x" ,grep)))))
1254          (p0      (dummy-package "example"
1255                     (inputs `(("foo" ,coreutils)
1256                               ("bar" ,dep)))))
1257          (rewrite (package-input-rewriting/spec
1258                    `(("chbouib@123" . ,(const sed)) ;not matched
1259                      ("grep" . ,(const findutils)))))
1260          (p1      (rewrite p0)))
1261     (and (not (eq? p1 p0))
1262          (string=? "example" (package-name p1))
1263          (match (package-inputs p1)
1264            ((("foo" dep1) ("bar" dep2))
1265             (and (string=? (package-full-name dep1)
1266                            (package-full-name coreutils))
1267                  (eq? dep2 (rewrite dep))         ;memoization
1268                  (match (package-native-inputs dep2)
1269                    ((("x" dep))
1270                     (string=? (package-full-name dep)
1271                               (package-full-name findutils))))))))))
1272
1273 (test-equal "package-patched-vulnerabilities"
1274   '(("CVE-2015-1234")
1275     ("CVE-2016-1234" "CVE-2018-4567")
1276     ())
1277   (let ((p1 (dummy-package "pi"
1278               (source (dummy-origin
1279                        (patches (list "/a/b/pi-CVE-2015-1234.patch"))))))
1280         (p2 (dummy-package "pi"
1281               (source (dummy-origin
1282                        (patches (list
1283                                  "/a/b/pi-CVE-2016-1234-CVE-2018-4567.patch"))))))
1284         (p3 (dummy-package "pi" (source (dummy-origin)))))
1285     (map package-patched-vulnerabilities
1286          (list p1 p2 p3))))
1287
1288 (test-eq "fold-packages" hello
1289   (fold-packages (lambda (p r)
1290                    (if (string=? (package-name p) "hello")
1291                        p
1292                        r))
1293                  #f))
1294
1295 (test-assert "fold-packages, hidden package"
1296   ;; There are two public variables providing "guile@2.0" ('guile-final' in
1297   ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
1298   ;; should show up.
1299   (match (fold-packages (lambda (p r)
1300                           (if (and (string=? (package-name p) "guile")
1301                                    (string-prefix? "2.0"
1302                                                    (package-version p)))
1303                               (cons p r)
1304                               r))
1305                         '())
1306     ((one)
1307      (eq? one guile-2.0))))
1308
1309 (test-assert "fold-available-packages with/without cache"
1310   (let ()
1311     (define no-cache
1312       (fold-available-packages (lambda* (name version result #:rest rest)
1313                                  (cons (cons* name version rest)
1314                                        result))
1315                                '()))
1316
1317     (define from-cache
1318       (call-with-temporary-directory
1319        (lambda (cache)
1320          (generate-package-cache cache)
1321          (mock ((guix describe) current-profile (const cache))
1322                (mock ((gnu packages) cache-is-authoritative? (const #t))
1323                      (fold-available-packages (lambda* (name version result
1324                                                              #:rest rest)
1325                                                 (cons (cons* name version rest)
1326                                                       result))
1327                                               '()))))))
1328
1329     (define (find-duplicates l)
1330       (match l
1331         (() '())
1332         ((head . tail)
1333          (if (member head tail)
1334              (cons head (find-duplicates tail))
1335              (find-duplicates tail)))))
1336
1337     (pk (find-duplicates from-cache))
1338     (and (equal? (delete-duplicates from-cache) from-cache)
1339          (lset= equal? no-cache from-cache))))
1340
1341 (test-assert "find-packages-by-name"
1342   (match (find-packages-by-name "hello")
1343     (((? (cut eq? hello <>))) #t)
1344     (wrong (pk 'find-packages-by-name wrong #f))))
1345
1346 (test-assert "find-packages-by-name with version"
1347   (match (find-packages-by-name "hello" (package-version hello))
1348     (((? (cut eq? hello <>))) #t)
1349     (wrong (pk 'find-packages-by-name wrong #f))))
1350
1351 (test-equal "find-packages-by-name with cache"
1352   (find-packages-by-name "guile")
1353   (call-with-temporary-directory
1354    (lambda (cache)
1355      (generate-package-cache cache)
1356      (mock ((guix describe) current-profile (const cache))
1357            (mock ((gnu packages) cache-is-authoritative? (const #t))
1358                  (find-packages-by-name "guile"))))))
1359
1360 (test-equal "find-packages-by-name + version, with cache"
1361   (find-packages-by-name "guile" "2")
1362   (call-with-temporary-directory
1363    (lambda (cache)
1364      (generate-package-cache cache)
1365      (mock ((guix describe) current-profile (const cache))
1366            (mock ((gnu packages) cache-is-authoritative? (const #t))
1367                  (find-packages-by-name "guile" "2"))))))
1368
1369 (test-assert "--search-paths with pattern"
1370   ;; Make sure 'guix package --search-paths' correctly reports environment
1371   ;; variables when file patterns are used (in particular, it must follow
1372   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
1373   ;; libxml2 package specification, which contains such a definition.
1374   (let* ((p1 (package
1375                (name "foo") (version "0") (source #f)
1376                (build-system trivial-build-system)
1377                (arguments
1378                 `(#:guile ,%bootstrap-guile
1379                   #:modules ((guix build utils))
1380                   #:builder (begin
1381                               (use-modules (guix build utils))
1382                               (let ((out (assoc-ref %outputs "out")))
1383                                 (mkdir-p (string-append out "/xml/bar/baz"))
1384                                 (call-with-output-file
1385                                     (string-append out "/xml/bar/baz/catalog.xml")
1386                                   (lambda (port)
1387                                     (display "xml? wat?!" port)))
1388                                 #t))))
1389                (synopsis #f) (description #f)
1390                (home-page #f) (license #f)))
1391          (p2 (package
1392                ;; Provide a fake libxml2 to avoid building the real one.  This
1393                ;; is OK because 'guix package' gets search path specifications
1394                ;; from the same-named package found in the distro.
1395                (name "libxml2") (version "0.0.0") (source #f)
1396                (build-system trivial-build-system)
1397                (arguments
1398                 `(#:guile ,%bootstrap-guile
1399                   #:builder (begin
1400                               (mkdir (assoc-ref %outputs "out"))
1401                               #t)))
1402                (native-search-paths (package-native-search-paths libxml2))
1403                (synopsis #f) (description #f)
1404                (home-page #f) (license #f)))
1405          (prof (run-with-store %store
1406                  (profile-derivation
1407                   (manifest (map package->manifest-entry
1408                                  (list p1 p2)))
1409                   #:hooks '()
1410                   #:locales? #f)
1411                  #:guile-for-build (%guile-for-build))))
1412     (build-derivations %store (list prof))
1413     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1414                           (regexp-quote (derivation->output-path prof)))
1415                   (with-output-to-string
1416                     (lambda ()
1417                       (guix-package "-p" (derivation->output-path prof)
1418                                     "--search-paths"))))))
1419
1420 (test-assert "--search-paths with single-item search path"
1421   ;; Make sure 'guix package --search-paths' correctly reports environment
1422   ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1423   ;; separator, meaning that the first match wins.
1424   (let* ((p1 (dummy-package "foo"
1425                (build-system trivial-build-system)
1426                (arguments
1427                 `(#:guile ,%bootstrap-guile
1428                   #:modules ((guix build utils))
1429                   #:builder (begin
1430                               (use-modules (guix build utils))
1431                               (let ((out (assoc-ref %outputs "out")))
1432                                 (mkdir-p (string-append out "/etc/ssl/certs"))
1433                                 (call-with-output-file
1434                                     (string-append
1435                                      out "/etc/ssl/certs/ca-certificates.crt")
1436                                   (const #t))))))))
1437          (p2 (package (inherit p1) (name "bar")))
1438          (p3 (dummy-package "git"
1439                ;; Provide a fake Git to avoid building the real one.
1440                (build-system trivial-build-system)
1441                (arguments
1442                 `(#:guile ,%bootstrap-guile
1443                   #:builder (begin
1444                               (mkdir (assoc-ref %outputs "out"))
1445                               #t)))
1446                (native-search-paths (package-native-search-paths git))))
1447          (prof1 (run-with-store %store
1448                   (profile-derivation
1449                    (packages->manifest (list p1 p3))
1450                    #:hooks '()
1451                    #:locales? #f)
1452                   #:guile-for-build (%guile-for-build)))
1453          (prof2 (run-with-store %store
1454                   (profile-derivation
1455                    (packages->manifest (list p2 p3))
1456                    #:hooks '()
1457                    #:locales? #f)
1458                   #:guile-for-build (%guile-for-build))))
1459     (build-derivations %store (list prof1 prof2))
1460     (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1461                           (regexp-quote (derivation->output-path prof1)))
1462                   (with-output-to-string
1463                     (lambda ()
1464                       (guix-package "-p" (derivation->output-path prof1)
1465                                     "-p" (derivation->output-path prof2)
1466                                     "--search-paths"))))))
1467
1468 (test-equal "specification->package when not found"
1469   'quit
1470   (catch 'quit
1471     (lambda ()
1472       ;; This should call 'leave', producing an error message.
1473       (specification->package "this-package-does-not-exist"))
1474     (lambda (key . args)
1475       key)))
1476
1477 (test-equal "specification->package+output"
1478   `((,coreutils "out") (,coreutils "debug"))
1479   (list (call-with-values (lambda ()
1480                             (specification->package+output "coreutils"))
1481           list)
1482         (call-with-values (lambda ()
1483                             (specification->package+output "coreutils:debug"))
1484           list)))
1485
1486 (test-equal "specification->package+output invalid output"
1487   'error
1488   (catch 'quit
1489     (lambda ()
1490       (specification->package+output "coreutils:does-not-exist"))
1491     (lambda _
1492       'error)))
1493
1494 (test-equal "specification->package+output no default output"
1495   `(,coreutils #f)
1496   (call-with-values
1497     (lambda ()
1498       (specification->package+output "coreutils" #f))
1499     list))
1500
1501 (test-equal "specification->package+output invalid output, no default"
1502   'error
1503   (catch 'quit
1504     (lambda ()
1505       (specification->package+output "coreutils:does-not-exist" #f))
1506     (lambda _
1507       'error)))
1508
1509 (test-equal "find-package-locations"
1510   (map (lambda (package)
1511          (cons (package-version package)
1512                (package-location package)))
1513        (find-packages-by-name "guile"))
1514   (find-package-locations "guile"))
1515
1516 (test-equal "find-package-locations with cache"
1517   (map (lambda (package)
1518          (cons (package-version package)
1519                (package-location package)))
1520        (find-packages-by-name "guile"))
1521   (call-with-temporary-directory
1522    (lambda (cache)
1523      (generate-package-cache cache)
1524      (mock ((guix describe) current-profile (const cache))
1525            (mock ((gnu packages) cache-is-authoritative? (const #t))
1526                  (find-package-locations "guile"))))))
1527
1528 (test-equal "specification->location"
1529   (package-location (specification->package "guile@2"))
1530   (specification->location "guile@2"))
1531
1532 (test-end "packages")
1533
1534 ;;; Local Variables:
1535 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
1536 ;;; eval: (put 'dummy-package/no-implicit 'scheme-indent-function 1)
1537 ;;; End: