tests/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (test-packages)
  20   #:use-module (guix tests)
  21   #:use-module (guix store)
  22   #:use-module (guix monads)
  23   #:use-module (guix grafts)
  24   #:use-module ((guix gexp) #:select (local-file local-file-file))
  25   #:use-module ((guix utils)
  26                 ;; Rename the 'location' binding to allow proper syntax
  27                 ;; matching when setting the 'location' field of a package.
  28                 #:renamer (lambda (name)
  29                             (cond ((eq? name 'location) 'make-location)
  30                                   (else name))))
  31   #:use-module (guix hash)
  32   #:use-module (guix derivations)
  33   #:use-module (guix packages)
  34   #:use-module (guix grafts)
  35   #:use-module (guix search-paths)
  36   #:use-module (guix build-system)
  37   #:use-module (guix build-system trivial)
  38   #:use-module (guix build-system gnu)
  39   #:use-module (guix profiles)
  40   #:use-module (guix scripts package)
  41   #:use-module (gnu packages)
  42   #:use-module (gnu packages base)
  43   #:use-module (gnu packages guile)
  44   #:use-module (gnu packages bootstrap)
  45   #:use-module (gnu packages version-control)
  46   #:use-module (gnu packages xml)
  47   #:use-module (srfi srfi-1)
  48   #:use-module (srfi srfi-26)
  49   #:use-module (srfi srfi-34)
  50   #:use-module (srfi srfi-35)
  51   #:use-module (srfi srfi-64)
  52   #:use-module (rnrs io ports)
  53   #:use-module (ice-9 vlist)
  54   #:use-module (ice-9 regex)
  55   #:use-module (ice-9 match))
  56
  57 ;; Test the high-level packaging layer.
  58
  59 (define %store
  60   (open-connection-for-tests))
  61
  62 ;; Globally disable grafting to avoid rebuilding the world ('graft-derivation'
  63 ;; can trigger builds early.)
  64 (%graft? #f)
  65
  66 \f
  67 (test-begin "packages")
  68
  69 (test-assert "printer with location"
  70   (string-match "^#<package foo@0 foo.scm:42 [[:xdigit:]]+>$"
  71                 (with-output-to-string
  72                   (lambda ()
  73                     (write
  74                      (dummy-package "foo"
  75                        (location (make-location "foo.scm" 42 7))))))))
  76
  77 (test-assert "printer without location"
  78   (string-match "^#<package foo@0 [[:xdigit:]]+>$"
  79                 (with-output-to-string
  80                   (lambda ()
  81                     (write
  82                      (dummy-package "foo" (location #f)))))))
  83
  84 (test-assert "hidden-package"
  85   (and (hidden-package? (hidden-package (dummy-package "foo")))
  86        (not (hidden-package? (dummy-package "foo")))))
  87
  88 (test-assert "package-superseded"
  89   (let* ((new (dummy-package "bar"))
  90          (old (deprecated-package "foo" new)))
  91     (and (eq? (package-superseded old) new)
  92          (mock ((gnu packages) find-best-packages-by-name (const (list old)))
  93                (specification->package "foo")
  94                (and (eq? new (specification->package "foo"))
  95                     (eq? new (specification->package+output "foo")))))))
  96
  97 (test-assert "transaction-upgrade-entry, zero upgrades"
  98   (let* ((old (dummy-package "foo" (version "1")))
  99          (tx  (mock ((gnu packages) find-newest-available-packages
 100                      (const vlist-null))
 101                     ((@@ (guix scripts package) transaction-upgrade-entry)
 102                      (manifest-entry
 103                        (inherit (package->manifest-entry old))
 104                        (item (string-append (%store-prefix) "/"
 105                                             (make-string 32 #\e) "-foo-1")))
 106                      (manifest-transaction)))))
 107     (manifest-transaction-null? tx)))
 108
 109 (test-assert "transaction-upgrade-entry, one upgrade"
 110   (let* ((old (dummy-package "foo" (version "1")))
 111          (new (dummy-package "foo" (version "2")))
 112          (tx  (mock ((gnu packages) find-newest-available-packages
 113                      (const (vhash-cons "foo" (list "2" new) vlist-null)))
 114                     ((@@ (guix scripts package) transaction-upgrade-entry)
 115                      (manifest-entry
 116                        (inherit (package->manifest-entry old))
 117                        (item (string-append (%store-prefix) "/"
 118                                             (make-string 32 #\e) "-foo-1")))
 119                      (manifest-transaction)))))
 120     (and (match (manifest-transaction-install tx)
 121            ((($ <manifest-entry> "foo" "2" "out" item))
 122             (eq? item new)))
 123          (null? (manifest-transaction-remove tx)))))
 124
 125 (test-assert "transaction-upgrade-entry, superseded package"
 126   (let* ((old (dummy-package "foo" (version "1")))
 127          (new (dummy-package "bar" (version "2")))
 128          (dep (deprecated-package "foo" new))
 129          (tx  (mock ((gnu packages) find-newest-available-packages
 130                      (const (vhash-cons "foo" (list "2" dep) vlist-null)))
 131                     ((@@ (guix scripts package) transaction-upgrade-entry)
 132                      (manifest-entry
 133                        (inherit (package->manifest-entry old))
 134                        (item (string-append (%store-prefix) "/"
 135                                             (make-string 32 #\e) "-foo-1")))
 136                      (manifest-transaction)))))
 137     (and (match (manifest-transaction-install tx)
 138            ((($ <manifest-entry> "bar" "2" "out" item))
 139             (eq? item new)))
 140          (match (manifest-transaction-remove tx)
 141            (((? manifest-pattern? pattern))
 142             (and (string=? (manifest-pattern-name pattern) "foo")
 143                  (string=? (manifest-pattern-version pattern) "1")
 144                  (string=? (manifest-pattern-output pattern) "out")))))))
 145
 146 (test-assert "package-field-location"
 147   (let ()
 148     (define (goto port line column)
 149       (unless (and (= (port-column port) (- column 1))
 150                    (= (port-line port) (- line 1)))
 151         (unless (eof-object? (get-char port))
 152           (goto port line column))))
 153
 154     (define read-at
 155       (match-lambda
 156        (($ <location> file line column)
 157         (call-with-input-file (search-path %load-path file)
 158           (lambda (port)
 159             (goto port line column)
 160             (read port))))))
 161
 162     ;; Until Guile 2.0.6 included, source properties were added only to pairs.
 163     ;; Thus, check against both VALUE and (FIELD VALUE).
 164     (and (member (read-at (package-field-location %bootstrap-guile 'name))
 165                  (let ((name (package-name %bootstrap-guile)))
 166                    (list name `(name ,name))))
 167          (member (read-at (package-field-location %bootstrap-guile 'version))
 168                  (let ((version (package-version %bootstrap-guile)))
 169                    (list version `(version ,version))))
 170          (not (package-field-location %bootstrap-guile 'does-not-exist)))))
 171
 172 ;; Make sure we don't change the file name to an absolute file name.
 173 (test-equal "package-field-location, relative file name"
 174   (location-file (package-location %bootstrap-guile))
 175   (with-fluids ((%file-port-name-canonicalization 'absolute))
 176     (location-file (package-field-location %bootstrap-guile 'version))))
 177
 178 (test-assert "package-transitive-inputs"
 179   (let* ((a (dummy-package "a"))
 180          (b (dummy-package "b"
 181               (propagated-inputs `(("a" ,a)))))
 182          (c (dummy-package "c"
 183               (inputs `(("a" ,a)))))
 184          (d (dummy-package "d"
 185               (propagated-inputs `(("x" "something.drv")))))
 186          (e (dummy-package "e"
 187               (inputs `(("b" ,b) ("c" ,c) ("d" ,d))))))
 188     (and (null? (package-transitive-inputs a))
 189          (equal? `(("a" ,a)) (package-transitive-inputs b))
 190          (equal? `(("a" ,a)) (package-transitive-inputs c))
 191          (equal? (package-propagated-inputs d)
 192                  (package-transitive-inputs d))
 193          (equal? `(("b" ,b) ("c" ,c) ("d" ,d)
 194                    ("a" ,a) ("x" "something.drv"))
 195                  (pk 'x (package-transitive-inputs e))))))
 196
 197 (test-assert "package-transitive-inputs, no duplicates"
 198   (let* ((a (dummy-package "a"))
 199          (b (dummy-package "b"
 200               (inputs `(("a+" ,a)))
 201               (native-inputs `(("a*" ,a)))
 202               (propagated-inputs `(("a" ,a)))))
 203          (c (dummy-package "c"
 204               (propagated-inputs `(("b" ,b)))))
 205          (d (dummy-package "d"
 206               (inputs `(("a" ,a) ("c" ,c)))))
 207          (e (dummy-package "e"
 208               (inputs `(("b" ,b) ("c" ,c))))))
 209     (and (null? (package-transitive-inputs a))
 210          (equal? `(("a*" ,a) ("a+" ,a) ("a" ,a))   ;here duplicates are kept
 211                  (package-transitive-inputs b))
 212          (equal? `(("b" ,b) ("a" ,a))
 213                  (package-transitive-inputs c))
 214          (equal? `(("a" ,a) ("c" ,c) ("b" ,b))     ;duplicate A removed
 215                  (package-transitive-inputs d))
 216          (equal? `(("b" ,b) ("c" ,c) ("a" ,a))
 217                  (package-transitive-inputs e))))) ;ditto
 218
 219 (test-equal "package-transitive-supported-systems"
 220   '(("x" "y" "z")                                 ;a
 221     ("x" "y")                                     ;b
 222     ("y")                                         ;c
 223     ("y")                                         ;d
 224     ("y"))                                        ;e
 225   ;; Use TRIVIAL-BUILD-SYSTEM because it doesn't add implicit inputs and thus
 226   ;; doesn't restrict the set of supported systems.
 227   (let* ((a (dummy-package "a"
 228               (build-system trivial-build-system)
 229               (supported-systems '("x" "y" "z"))))
 230          (b (dummy-package "b"
 231               (build-system trivial-build-system)
 232               (supported-systems '("x" "y"))
 233               (inputs `(("a" ,a)))))
 234          (c (dummy-package "c"
 235               (build-system trivial-build-system)
 236               (supported-systems '("y" "z"))
 237               (inputs `(("b" ,b)))))
 238          (d (dummy-package "d"
 239               (build-system trivial-build-system)
 240               (supported-systems '("x" "y" "z"))
 241               (inputs `(("b" ,b) ("c" ,c)))))
 242          (e (dummy-package "e"
 243               (build-system trivial-build-system)
 244               (supported-systems '("x" "y" "z"))
 245               (inputs `(("d" ,d))))))
 246     (list (package-transitive-supported-systems a)
 247           (package-transitive-supported-systems b)
 248           (package-transitive-supported-systems c)
 249           (package-transitive-supported-systems d)
 250           (package-transitive-supported-systems e))))
 251
 252 (test-equal "origin-actual-file-name"
 253   "foo-1.tar.gz"
 254   (let ((o (dummy-origin (uri "http://www.example.com/foo-1.tar.gz"))))
 255     (origin-actual-file-name o)))
 256
 257 (test-equal "origin-actual-file-name, file-name"
 258   "foo-1.tar.gz"
 259   (let ((o (dummy-origin
 260             (uri "http://www.example.com/tarball")
 261             (file-name "foo-1.tar.gz"))))
 262     (origin-actual-file-name o)))
 263
 264 (let* ((o (dummy-origin))
 265        (u (dummy-origin))
 266        (i (dummy-origin))
 267        (a (dummy-package "a"))
 268        (b (dummy-package "b"
 269             (inputs `(("a" ,a) ("i" ,i)))))
 270        (c (package (inherit b) (source o)))
 271        (d (dummy-package "d"
 272             (build-system trivial-build-system)
 273             (source u) (inputs `(("c" ,c))))))
 274   (test-assert "package-direct-sources, no source"
 275     (null? (package-direct-sources a)))
 276   (test-equal "package-direct-sources, #f source"
 277     (list i)
 278     (package-direct-sources b))
 279   (test-equal "package-direct-sources, not input source"
 280     (list u)
 281     (package-direct-sources d))
 282   (test-assert "package-direct-sources"
 283     (let ((s (package-direct-sources c)))
 284       (and (= (length (pk 's-sources s)) 2)
 285            (member o s)
 286            (member i s))))
 287   (test-assert "package-transitive-sources"
 288     (let ((s (package-transitive-sources d)))
 289       (and (= (length (pk 'd-sources s)) 3)
 290            (member o s)
 291            (member i s)
 292            (member u s)))))
 293
 294 (test-assert "transitive-input-references"
 295   (let* ((a (dummy-package "a"))
 296          (b (dummy-package "b"))
 297          (c (dummy-package "c"
 298               (inputs `(("a" ,a)))
 299               (propagated-inputs `(("boo" ,b)))))
 300          (d (dummy-package "d"
 301               (inputs `(("c*" ,c)))))
 302          (keys (map (match-lambda
 303                       (('assoc-ref 'l key)
 304                        key))
 305                     (pk 'refs (transitive-input-references
 306                                'l (package-inputs d))))))
 307     (and (= (length keys) 2)
 308          (member "c*" keys)
 309          (member "boo" keys))))
 310
 311 (test-equal "package-transitive-supported-systems, implicit inputs"
 312   %supported-systems
 313
 314   ;; Here GNU-BUILD-SYSTEM adds implicit inputs that build only on
 315   ;; %SUPPORTED-SYSTEMS.  Thus the others must be ignored.
 316   (let ((p (dummy-package "foo"
 317              (build-system gnu-build-system)
 318              (supported-systems
 319               `("does-not-exist" "foobar" ,@%supported-systems)))))
 320     (package-transitive-supported-systems p)))
 321
 322 (test-assert "supported-package?"
 323   (let ((p (dummy-package "foo"
 324              (build-system gnu-build-system)
 325              (supported-systems '("x86_64-linux" "does-not-exist")))))
 326     (and (supported-package? p "x86_64-linux")
 327          (not (supported-package? p "does-not-exist"))
 328          (not (supported-package? p "i686-linux")))))
 329
 330 (test-skip (if (not %store) 8 0))
 331
 332 (test-assert "package-source-derivation, file"
 333   (let* ((file    (search-path %load-path "guix.scm"))
 334          (package (package (inherit (dummy-package "p"))
 335                     (source file)))
 336          (source  (package-source-derivation %store
 337                                              (package-source package))))
 338     (and (store-path? source)
 339          (valid-path? %store source)
 340          (equal? (call-with-input-file source get-bytevector-all)
 341                  (call-with-input-file file get-bytevector-all)))))
 342
 343 (test-assert "package-source-derivation, store path"
 344   (let* ((file    (add-to-store %store "guix.scm" #t "sha256"
 345                                 (search-path %load-path "guix.scm")))
 346          (package (package (inherit (dummy-package "p"))
 347                     (source file)))
 348          (source  (package-source-derivation %store
 349                                              (package-source package))))
 350     (string=? file source)))
 351
 352 (test-assert "package-source-derivation, indirect store path"
 353   (let* ((dir     (add-to-store %store "guix-build" #t "sha256"
 354                                 (dirname (search-path %load-path
 355                                                       "guix/build/utils.scm"))))
 356          (package (package (inherit (dummy-package "p"))
 357                     (source (string-append dir "/utils.scm"))))
 358          (source  (package-source-derivation %store
 359                                              (package-source package))))
 360     (and (direct-store-path? source)
 361          (string-suffix? "utils.scm" source))))
 362
 363 (test-assert "package-source-derivation, local-file"
 364   (let* ((file    (local-file "../guix/base32.scm"))
 365          (package (package (inherit (dummy-package "p"))
 366                     (source file)))
 367          (source  (package-source-derivation %store
 368                                              (package-source package))))
 369     (and (store-path? source)
 370          (string-suffix? "base32.scm" source)
 371          (valid-path? %store source)
 372          (equal? (call-with-input-file source get-bytevector-all)
 373                  (call-with-input-file
 374                      (search-path %load-path "guix/base32.scm")
 375                    get-bytevector-all)))))
 376
 377 (unless (network-reachable?) (test-skip 1))
 378 (test-equal "package-source-derivation, snippet"
 379   "OK"
 380   (let* ((file   (search-bootstrap-binary (match (%current-system)
 381                                             ("armhf-linux"
 382                                              "guile-2.0.11.tar.xz")
 383                                             ("aarch64-linux"
 384                                              "guile-2.0.14.tar.xz")
 385                                             (_
 386                                              "guile-2.0.9.tar.xz"))
 387                                           (%current-system)))
 388          (sha256 (call-with-input-file file port-sha256))
 389          (fetch  (lambda* (url hash-algo hash
 390                            #:optional name #:key system)
 391                    (pk 'fetch url hash-algo hash name system)
 392                    (interned-file url)))
 393          (source (bootstrap-origin
 394                   (origin
 395                     (method fetch)
 396                     (uri file)
 397                     (sha256 sha256)
 398                     (patch-inputs
 399                      `(("tar" ,%bootstrap-coreutils&co)
 400                        ("xz" ,%bootstrap-coreutils&co)
 401                        ("patch" ,%bootstrap-coreutils&co)))
 402                     (patch-guile %bootstrap-guile)
 403                     (modules '((guix build utils)))
 404                     (snippet '(begin
 405                                 ;; We end up in 'bin', because it's the first
 406                                 ;; directory, alphabetically.  Not a very good
 407                                 ;; example but hey.
 408                                 (chmod "." #o777)
 409                                 (symlink "guile" "guile-rocks")
 410                                 (copy-recursively "../share/guile/2.0/scripts"
 411                                                   "scripts")
 412
 413                                 ;; Make sure '.file_list' can be created.
 414                                 (chmod ".." #o777))))))
 415          (package (package (inherit (dummy-package "with-snippet"))
 416                     (source source)
 417                     (build-system trivial-build-system)
 418                     (inputs
 419                      `(("tar" ,(search-bootstrap-binary "tar"
 420                                                         (%current-system)))
 421                        ("xz"  ,(search-bootstrap-binary "xz"
 422                                                         (%current-system)))))
 423                     (arguments
 424                      `(#:guile ,%bootstrap-guile
 425                        #:builder
 426                        (let ((tar    (assoc-ref %build-inputs "tar"))
 427                              (xz     (assoc-ref %build-inputs "xz"))
 428                              (source (assoc-ref %build-inputs "source")))
 429                          (and (zero? (system* tar "xvf" source
 430                                               "--use-compress-program" xz))
 431                               (string=? "guile" (readlink "bin/guile-rocks"))
 432                               (file-exists? "bin/scripts/compile.scm")
 433                               (let ((out (assoc-ref %outputs "out")))
 434                                 (call-with-output-file out
 435                                   (lambda (p)
 436                                     (display "OK" p))))))))))
 437          (drv    (package-derivation %store package))
 438          (out    (derivation->output-path drv)))
 439     (and (build-derivations %store (list (pk 'snippet-drv drv)))
 440          (call-with-input-file out get-string-all))))
 441
 442 (test-assert "return value"
 443   (let ((drv (package-derivation %store (dummy-package "p"))))
 444     (and (derivation? drv)
 445          (file-exists? (derivation-file-name drv)))))
 446
 447 (test-assert "package-output"
 448   (let* ((package  (dummy-package "p"))
 449          (drv      (package-derivation %store package)))
 450     (and (derivation? drv)
 451          (string=? (derivation->output-path drv)
 452                    (package-output %store package "out")))))
 453
 454 (test-assert "patch not found yields a run-time error"
 455   (guard (c ((condition-has-type? c &message)
 456              (and (string-contains (condition-message c)
 457                                    "does-not-exist.patch")
 458                   (string-contains (condition-message c)
 459                                    "not found"))))
 460     (let ((p (package
 461                (inherit (dummy-package "p"))
 462                (source (origin
 463                          (method (const #f))
 464                          (uri "http://whatever")
 465                          (patches
 466                           (list (search-patch "does-not-exist.patch")))
 467                          (sha256
 468                           (base32
 469                            "0amn0bbwqvsvvsh6drfwz20ydc2czk374lzw5kksbh6bf78k4ks4")))))))
 470       (package-derivation %store p)
 471       #f)))
 472
 473 (let ((dummy (dummy-package "foo" (inputs `(("x" ,(current-module)))))))
 474   (test-equal "&package-input-error"
 475     (list dummy (current-module))
 476     (guard (c ((package-input-error? c)
 477                (list (package-error-package c)
 478                      (package-error-invalid-input c))))
 479       (package-derivation %store dummy))))
 480
 481 (test-assert "reference to non-existent output"
 482   ;; See <http://bugs.gnu.org/19630>.
 483   (parameterize ((%graft? #f))
 484     (let* ((dep (dummy-package "dep"))
 485            (p   (dummy-package "p"
 486                   (inputs `(("dep" ,dep "non-existent"))))))
 487       (guard (c ((derivation-missing-output-error? c)
 488                  (and (string=? (derivation-missing-output c) "non-existent")
 489                       (equal? (package-derivation %store dep)
 490                               (derivation-error-derivation c)))))
 491         (package-derivation %store p)))))
 492
 493 (test-assert "trivial"
 494   (let* ((p (package (inherit (dummy-package "trivial"))
 495               (build-system trivial-build-system)
 496               (source #f)
 497               (arguments
 498                `(#:guile ,%bootstrap-guile
 499                  #:builder
 500                  (begin
 501                    (mkdir %output)
 502                    (call-with-output-file (string-append %output "/test")
 503                      (lambda (p)
 504                        (display '(hello guix) p))))))))
 505          (d (package-derivation %store p)))
 506     (and (build-derivations %store (list d))
 507          (let ((p (pk 'drv d (derivation->output-path d))))
 508            (equal? '(hello guix)
 509                    (call-with-input-file (string-append p "/test") read))))))
 510
 511 (test-assert "trivial with local file as input"
 512   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 513          (p (package (inherit (dummy-package "trivial-with-input-file"))
 514               (build-system trivial-build-system)
 515               (source #f)
 516               (arguments
 517                `(#:guile ,%bootstrap-guile
 518                  #:builder (copy-file (assoc-ref %build-inputs "input")
 519                                       %output)))
 520               (inputs `(("input" ,i)))))
 521          (d (package-derivation %store p)))
 522     (and (build-derivations %store (list d))
 523          (let ((p (pk 'drv d (derivation->output-path d))))
 524            (equal? (call-with-input-file p get-bytevector-all)
 525                    (call-with-input-file i get-bytevector-all))))))
 526
 527 (test-assert "trivial with source"
 528   (let* ((i (search-path %load-path "ice-9/boot-9.scm"))
 529          (p (package (inherit (dummy-package "trivial-with-source"))
 530               (build-system trivial-build-system)
 531               (source i)
 532               (arguments
 533                `(#:guile ,%bootstrap-guile
 534                  #:builder (copy-file (assoc-ref %build-inputs "source")
 535                                       %output)))))
 536          (d (package-derivation %store p)))
 537     (and (build-derivations %store (list d))
 538          (let ((p (derivation->output-path d)))
 539            (equal? (call-with-input-file p get-bytevector-all)
 540                    (call-with-input-file i get-bytevector-all))))))
 541
 542 (test-assert "trivial with system-dependent input"
 543   (let* ((p (package (inherit (dummy-package "trivial-system-dependent-input"))
 544               (build-system trivial-build-system)
 545               (source #f)
 546               (arguments
 547                `(#:guile ,%bootstrap-guile
 548                  #:builder
 549                  (let ((out  (assoc-ref %outputs "out"))
 550                        (bash (assoc-ref %build-inputs "bash")))
 551                    (zero? (system* bash "-c"
 552                                    (format #f "echo hello > ~a" out))))))
 553               (inputs `(("bash" ,(search-bootstrap-binary "bash"
 554                                                           (%current-system)))))))
 555          (d (package-derivation %store p)))
 556     (and (build-derivations %store (list d))
 557          (let ((p (pk 'drv d (derivation->output-path d))))
 558            (eq? 'hello (call-with-input-file p read))))))
 559
 560 (test-assert "search paths"
 561   (let* ((p (make-prompt-tag "return-search-paths"))
 562          (s (build-system
 563              (name 'raw)
 564              (description "Raw build system with direct store access")
 565              (lower (lambda* (name #:key source inputs system target
 566                                    #:allow-other-keys)
 567                       (bag
 568                         (name name)
 569                         (system system) (target target)
 570                         (build-inputs inputs)
 571                         (build
 572                          (lambda* (store name inputs
 573                                          #:key outputs system search-paths)
 574                            search-paths)))))))
 575          (x (list (search-path-specification
 576                    (variable "GUILE_LOAD_PATH")
 577                    (files '("share/guile/site/2.0")))
 578                   (search-path-specification
 579                    (variable "GUILE_LOAD_COMPILED_PATH")
 580                    (files '("share/guile/site/2.0")))))
 581          (a (package (inherit (dummy-package "guile"))
 582               (build-system s)
 583               (native-search-paths x)))
 584          (b (package (inherit (dummy-package "guile-foo"))
 585               (build-system s)
 586               (inputs `(("guile" ,a)))))
 587          (c (package (inherit (dummy-package "guile-bar"))
 588               (build-system s)
 589               (inputs `(("guile" ,a)
 590                         ("guile-foo" ,b))))))
 591     (let-syntax ((collect (syntax-rules ()
 592                             ((_ body ...)
 593                              (call-with-prompt p
 594                                (lambda ()
 595                                  body ...)
 596                                (lambda (k search-paths)
 597                                  search-paths))))))
 598       (and (null? (collect (package-derivation %store a)))
 599            (equal? x (collect (package-derivation %store b)))
 600            (equal? x (collect (package-derivation %store c)))))))
 601
 602 (test-assert "package-transitive-native-search-paths"
 603   (let* ((sp (lambda (name)
 604                (list (search-path-specification
 605                       (variable name)
 606                       (files '("foo/bar"))))))
 607          (p0 (dummy-package "p0" (native-search-paths (sp "PATH0"))))
 608          (p1 (dummy-package "p1" (native-search-paths (sp "PATH1"))))
 609          (p2 (dummy-package "p2"
 610                (native-search-paths (sp "PATH2"))
 611                (inputs `(("p0" ,p0)))
 612                (propagated-inputs `(("p1" ,p1)))))
 613          (p3 (dummy-package "p3"
 614                (native-search-paths (sp "PATH3"))
 615                (native-inputs `(("p0" ,p0)))
 616                (propagated-inputs `(("p2" ,p2))))))
 617     (lset= string=?
 618            '("PATH1" "PATH2" "PATH3")
 619            (map search-path-specification-variable
 620                 (package-transitive-native-search-paths p3)))))
 621
 622 (test-assert "package-cross-derivation"
 623   (let ((drv (package-cross-derivation %store (dummy-package "p")
 624                                        "mips64el-linux-gnu")))
 625     (and (derivation? drv)
 626          (file-exists? (derivation-file-name drv)))))
 627
 628 (test-assert "package-cross-derivation, trivial-build-system"
 629   (let ((p (package (inherit (dummy-package "p"))
 630              (build-system trivial-build-system)
 631              (arguments '(#:builder (exit 1))))))
 632     (let ((drv (package-cross-derivation %store p "mips64el-linux-gnu")))
 633       (derivation? drv))))
 634
 635 (test-assert "package-cross-derivation, no cross builder"
 636   (let* ((b (build-system (inherit trivial-build-system)
 637               (lower (const #f))))
 638          (p (package (inherit (dummy-package "p"))
 639               (build-system b))))
 640     (guard (c ((package-cross-build-system-error? c)
 641                (eq? (package-error-package c) p)))
 642       (package-cross-derivation %store p "mips64el-linux-gnu")
 643       #f)))
 644
 645 ;; XXX: The next two tests can trigger builds when the distro defines
 646 ;; replacements on core packages, so they're disable for lack of a better
 647 ;; solution.
 648
 649 ;; (test-equal "package-derivation, direct graft"
 650 ;;   (package-derivation %store gnu-make #:graft? #f)
 651 ;;   (let ((p (package (inherit coreutils)
 652 ;;              (replacement gnu-make))))
 653 ;;     (package-derivation %store p #:graft? #t)))
 654
 655 ;; (test-equal "package-cross-derivation, direct graft"
 656 ;;   (package-cross-derivation %store gnu-make "mips64el-linux-gnu"
 657 ;;                             #:graft? #f)
 658 ;;   (let ((p (package (inherit coreutils)
 659 ;;              (replacement gnu-make))))
 660 ;;     (package-cross-derivation %store p "mips64el-linux-gnu"
 661 ;;                               #:graft? #t)))
 662
 663 (test-assert "package-grafts, indirect grafts"
 664   (let* ((new   (dummy-package "dep"
 665                   (arguments '(#:implicit-inputs? #f))))
 666          (dep   (package (inherit new) (version "0.0")))
 667          (dep*  (package (inherit dep) (replacement new)))
 668          (dummy (dummy-package "dummy"
 669                   (arguments '(#:implicit-inputs? #f))
 670                   (inputs `(("dep" ,dep*))))))
 671     (equal? (package-grafts %store dummy)
 672             (list (graft
 673                     (origin (package-derivation %store dep))
 674                     (replacement (package-derivation %store new)))))))
 675
 676 ;; XXX: This test would require building the cross toolchain just to see if it
 677 ;; needs grafting, which is obviously too expensive, and thus disabled.
 678 ;;
 679 ;; (test-assert "package-grafts, indirect grafts, cross"
 680 ;;   (let* ((new    (dummy-package "dep"
 681 ;;                    (arguments '(#:implicit-inputs? #f))))
 682 ;;          (dep    (package (inherit new) (version "0.0")))
 683 ;;          (dep*   (package (inherit dep) (replacement new)))
 684 ;;          (dummy  (dummy-package "dummy"
 685 ;;                    (arguments '(#:implicit-inputs? #f))
 686 ;;                    (inputs `(("dep" ,dep*)))))
 687 ;;          (target "mips64el-linux-gnu"))
 688 ;;     ;; XXX: There might be additional grafts, for instance if the distro
 689 ;;     ;; defines replacements for core packages like Perl.
 690 ;;     (member (graft
 691 ;;               (origin (package-cross-derivation %store dep target))
 692 ;;               (replacement
 693 ;;                (package-cross-derivation %store new target)))
 694 ;;             (package-grafts %store dummy #:target target))))
 695
 696 (test-assert "package-grafts, indirect grafts, propagated inputs"
 697   (let* ((new   (dummy-package "dep"
 698                   (arguments '(#:implicit-inputs? #f))))
 699          (dep   (package (inherit new) (version "0.0")))
 700          (dep*  (package (inherit dep) (replacement new)))
 701          (prop  (dummy-package "propagated"
 702                   (propagated-inputs `(("dep" ,dep*)))
 703                   (arguments '(#:implicit-inputs? #f))))
 704          (dummy (dummy-package "dummy"
 705                   (arguments '(#:implicit-inputs? #f))
 706                   (inputs `(("prop" ,prop))))))
 707     (equal? (package-grafts %store dummy)
 708             (list (graft
 709                     (origin (package-derivation %store dep))
 710                     (replacement (package-derivation %store new)))))))
 711
 712 (test-assert "package-grafts, same replacement twice"
 713   (let* ((new  (dummy-package "dep"
 714                  (version "1")
 715                  (arguments '(#:implicit-inputs? #f))))
 716          (dep  (package (inherit new) (version "0") (replacement new)))
 717          (p1   (dummy-package "intermediate1"
 718                  (arguments '(#:implicit-inputs? #f))
 719                  (inputs `(("dep" ,dep)))))
 720          (p2   (dummy-package "intermediate2"
 721                  (arguments '(#:implicit-inputs? #f))
 722                  ;; Here we copy DEP to have an equivalent package that is not
 723                  ;; 'eq?' to DEP.  This is similar to what happens with
 724                  ;; 'package-with-explicit-inputs' & co.
 725                  (inputs `(("dep" ,(package (inherit dep)))))))
 726          (p3   (dummy-package "final"
 727                  (arguments '(#:implicit-inputs? #f))
 728                  (inputs `(("p1" ,p1) ("p2" ,p2))))))
 729     (equal? (package-grafts %store p3)
 730             (list (graft
 731                     (origin (package-derivation %store
 732                                                 (package (inherit dep)
 733                                                          (replacement #f))))
 734                     (replacement (package-derivation %store new)))))))
 735
 736 (test-assert "replacement also grafted"
 737   ;; We build a DAG as below, where dotted arrows represent replacements and
 738   ;; solid arrows represent dependencies:
 739   ;;
 740   ;;  P1  ·············>  P1R
 741   ;;  |\__________________.
 742   ;;  v                   v
 743   ;;  P2  ·············>  P2R
 744   ;;  |
 745   ;;  v
 746   ;;  P3
 747   ;;
 748   ;; We want to make sure that:
 749   ;;   grafts(P3) = (P1,P1R) + (P2, grafted(P2R, (P1,P1R)))
 750   ;; where:
 751   ;;   (A,B) is a graft to replace A by B
 752   ;;   grafted(DRV,G) denoted DRV with graft G applied
 753   (let* ((p1r (dummy-package "P1"
 754                 (build-system trivial-build-system)
 755                 (arguments
 756                  `(#:guile ,%bootstrap-guile
 757                    #:builder (let ((out (assoc-ref %outputs "out")))
 758                                (mkdir out)
 759                                (call-with-output-file
 760                                    (string-append out "/replacement")
 761                                  (const #t)))))))
 762          (p1  (package
 763                 (inherit p1r) (name "p1") (replacement p1r)
 764                 (arguments
 765                  `(#:guile ,%bootstrap-guile
 766                    #:builder (mkdir (assoc-ref %outputs "out"))))))
 767          (p2r (dummy-package "P2"
 768                 (build-system trivial-build-system)
 769                 (inputs `(("p1" ,p1)))
 770                 (arguments
 771                  `(#:guile ,%bootstrap-guile
 772                    #:builder (let ((out (assoc-ref %outputs "out")))
 773                                (mkdir out)
 774                                (chdir out)
 775                                (symlink (assoc-ref %build-inputs "p1") "p1")
 776                                (call-with-output-file (string-append out "/replacement")
 777                                  (const #t)))))))
 778          (p2  (package
 779                 (inherit p2r) (name "p2") (replacement p2r)
 780                 (arguments
 781                  `(#:guile ,%bootstrap-guile
 782                    #:builder (let ((out (assoc-ref %outputs "out")))
 783                                (mkdir out)
 784                                (chdir out)
 785                                (symlink (assoc-ref %build-inputs "p1")
 786                                         "p1"))))))
 787          (p3  (dummy-package "p3"
 788                 (build-system trivial-build-system)
 789                 (inputs `(("p2" ,p2)))
 790                 (arguments
 791                  `(#:guile ,%bootstrap-guile
 792                    #:builder (let ((out (assoc-ref %outputs "out")))
 793                                (mkdir out)
 794                                (chdir out)
 795                                (symlink (assoc-ref %build-inputs "p2")
 796                                         "p2")))))))
 797     (lset= equal?
 798            (package-grafts %store p3)
 799            (list (graft
 800                    (origin (package-derivation %store p1 #:graft? #f))
 801                    (replacement (package-derivation %store p1r)))
 802                  (graft
 803                    (origin (package-derivation %store p2 #:graft? #f))
 804                    (replacement
 805                     (package-derivation %store p2r #:graft? #t)))))))
 806
 807 ;;; XXX: Nowadays 'graft-derivation' needs to build derivations beforehand to
 808 ;;; find out about their run-time dependencies, so this test is no longer
 809 ;;; applicable since it would trigger a full rebuild.
 810 ;;
 811 ;; (test-assert "package-derivation, indirect grafts"
 812 ;;   (let* ((new   (dummy-package "dep"
 813 ;;                   (arguments '(#:implicit-inputs? #f))))
 814 ;;          (dep   (package (inherit new) (version "0.0")))
 815 ;;          (dep*  (package (inherit dep) (replacement new)))
 816 ;;          (dummy (dummy-package "dummy"
 817 ;;                   (arguments '(#:implicit-inputs? #f))
 818 ;;                   (inputs `(("dep" ,dep*)))))
 819 ;;          (guile (package-derivation %store (canonical-package guile-2.0)
 820 ;;                                     #:graft? #f)))
 821 ;;     (equal? (package-derivation %store dummy)
 822 ;;             (graft-derivation %store
 823 ;;                               (package-derivation %store dummy #:graft? #f)
 824 ;;                               (package-grafts %store dummy)
 825
 826 ;;                               ;; Use the same Guile as 'package-derivation'.
 827 ;;                               #:guile guile))))
 828
 829 (test-equal "package->bag"
 830   `("foo86-hurd" #f (,(package-source gnu-make))
 831     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 832   (let ((bag (package->bag gnu-make "foo86-hurd")))
 833     (list (bag-system bag) (bag-target bag)
 834           (assoc-ref (bag-build-inputs bag) "source")
 835           (assoc-ref (bag-build-inputs bag) "libc")
 836           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 837
 838 (test-equal "package->bag, cross-compilation"
 839   `(,(%current-system) "foo86-hurd"
 840     (,(package-source gnu-make))
 841     (,(canonical-package glibc)) (,(canonical-package coreutils)))
 842   (let ((bag (package->bag gnu-make (%current-system) "foo86-hurd")))
 843     (list (bag-system bag) (bag-target bag)
 844           (assoc-ref (bag-build-inputs bag) "source")
 845           (assoc-ref (bag-build-inputs bag) "libc")
 846           (assoc-ref (bag-build-inputs bag) "coreutils"))))
 847
 848 (test-assert "package->bag, propagated inputs"
 849   (let* ((dep    (dummy-package "dep"))
 850          (prop   (dummy-package "prop"
 851                    (propagated-inputs `(("dep" ,dep)))))
 852          (dummy  (dummy-package "dummy"
 853                    (inputs `(("prop" ,prop)))))
 854          (inputs (bag-transitive-inputs (package->bag dummy #:graft? #f))))
 855     (match (assoc "dep" inputs)
 856       (("dep" package)
 857        (eq? package dep)))))
 858
 859 (test-assert "bag->derivation"
 860   (parameterize ((%graft? #f))
 861     (let ((bag (package->bag gnu-make))
 862           (drv (package-derivation %store gnu-make)))
 863       (parameterize ((%current-system "foox86-hurd")) ;should have no effect
 864         (equal? drv (bag->derivation %store bag))))))
 865
 866 (test-assert "bag->derivation, cross-compilation"
 867   (parameterize ((%graft? #f))
 868     (let* ((target "mips64el-linux-gnu")
 869            (bag    (package->bag gnu-make (%current-system) target))
 870            (drv    (package-cross-derivation %store gnu-make target)))
 871       (parameterize ((%current-system "foox86-hurd") ;should have no effect
 872                      (%current-target-system "foo64-linux-gnu"))
 873         (equal? drv (bag->derivation %store bag))))))
 874
 875 (when (or (not (network-reachable?)) (shebang-too-long?))
 876   (test-skip 1))
 877 (test-assert "GNU Make, bootstrap"
 878   ;; GNU Make is the first program built during bootstrap; we choose it
 879   ;; here so that the test doesn't last for too long.
 880   (let ((gnu-make (@@ (gnu packages commencement) gnu-make-boot0)))
 881     (and (package? gnu-make)
 882          (or (location? (package-location gnu-make))
 883              (not (package-location gnu-make)))
 884          (let* ((drv (package-derivation %store gnu-make))
 885                 (out (derivation->output-path drv)))
 886            (and (build-derivations %store (list drv))
 887                 (file-exists? (string-append out "/bin/make")))))))
 888
 889 (test-equal "package-mapping"
 890   42
 891   (let* ((dep       (dummy-package "chbouib"
 892                       (native-inputs `(("x" ,grep)))))
 893          (p0        (dummy-package "example"
 894                       (inputs `(("foo" ,coreutils)
 895                                 ("bar" ,grep)
 896                                 ("baz" ,dep)))))
 897          (transform (lambda (p)
 898                       (package (inherit p) (source 42))))
 899          (rewrite   (package-mapping transform))
 900          (p1        (rewrite p0)))
 901     (and (eq? p1 (rewrite p0))
 902          (eqv? 42 (package-source p1))
 903          (match (package-inputs p1)
 904            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 905             (and (eq? dep1 (rewrite coreutils))   ;memoization
 906                  (eq? dep2 (rewrite grep))
 907                  (eq? dep3 (rewrite dep))
 908                  (eqv? 42
 909                        (package-source dep1) (package-source dep2)
 910                        (package-source dep3))
 911                  (match (package-native-inputs dep3)
 912                    ((("x" dep))
 913                     (and (eq? dep (rewrite grep))
 914                          (package-source dep))))))))))
 915
 916 (test-assert "package-input-rewriting"
 917   (let* ((dep     (dummy-package "chbouib"
 918                     (native-inputs `(("x" ,grep)))))
 919          (p0      (dummy-package "example"
 920                     (inputs `(("foo" ,coreutils)
 921                               ("bar" ,grep)
 922                               ("baz" ,dep)))))
 923          (rewrite (package-input-rewriting `((,coreutils . ,sed)
 924                                              (,grep . ,findutils))
 925                                            (cut string-append "r-" <>)))
 926          (p1      (rewrite p0))
 927          (p2      (rewrite p0)))
 928     (and (not (eq? p1 p0))
 929          (eq? p1 p2)                              ;memoization
 930          (string=? "r-example" (package-name p1))
 931          (match (package-inputs p1)
 932            ((("foo" dep1) ("bar" dep2) ("baz" dep3))
 933             (and (eq? dep1 sed)
 934                  (eq? dep2 findutils)
 935                  (string=? (package-name dep3) "r-chbouib")
 936                  (eq? dep3 (rewrite dep))         ;memoization
 937                  (match (package-native-inputs dep3)
 938                    ((("x" dep))
 939                     (eq? dep findutils)))))))))
 940
 941 (test-eq "fold-packages" hello
 942   (fold-packages (lambda (p r)
 943                    (if (string=? (package-name p) "hello")
 944                        p
 945                        r))
 946                  #f))
 947
 948 (test-assert "fold-packages, hidden package"
 949   ;; There are two public variables providing "guile@2.0" ('guile-final' in
 950   ;; commencement.scm and 'guile-2.0' in guile.scm), but only the latter
 951   ;; should show up.
 952   (match (fold-packages (lambda (p r)
 953                           (if (and (string=? (package-name p) "guile")
 954                                    (string-prefix? "2.0"
 955                                                    (package-version p)))
 956                               (cons p r)
 957                               r))
 958                         '())
 959     ((one)
 960      (eq? one guile-2.0))))
 961
 962 (test-assert "find-packages-by-name"
 963   (match (find-packages-by-name "hello")
 964     (((? (cut eq? hello <>))) #t)
 965     (wrong (pk 'find-packages-by-name wrong #f))))
 966
 967 (test-assert "find-packages-by-name with version"
 968   (match (find-packages-by-name "hello" (package-version hello))
 969     (((? (cut eq? hello <>))) #t)
 970     (wrong (pk 'find-packages-by-name wrong #f))))
 971
 972 (test-assert "--search-paths with pattern"
 973   ;; Make sure 'guix package --search-paths' correctly reports environment
 974   ;; variables when file patterns are used (in particular, it must follow
 975   ;; symlinks when looking for 'catalog.xml'.)  To do that, we rely on the
 976   ;; libxml2 package specification, which contains such a definition.
 977   (let* ((p1 (package
 978                (name "foo") (version "0") (source #f)
 979                (build-system trivial-build-system)
 980                (arguments
 981                 `(#:guile ,%bootstrap-guile
 982                   #:modules ((guix build utils))
 983                   #:builder (begin
 984                               (use-modules (guix build utils))
 985                               (let ((out (assoc-ref %outputs "out")))
 986                                 (mkdir-p (string-append out "/xml/bar/baz"))
 987                                 (call-with-output-file
 988                                     (string-append out "/xml/bar/baz/catalog.xml")
 989                                   (lambda (port)
 990                                     (display "xml? wat?!" port)))))))
 991                (synopsis #f) (description #f)
 992                (home-page #f) (license #f)))
 993          (p2 (package
 994                ;; Provide a fake libxml2 to avoid building the real one.  This
 995                ;; is OK because 'guix package' gets search path specifications
 996                ;; from the same-named package found in the distro.
 997                (name "libxml2") (version "0.0.0") (source #f)
 998                (build-system trivial-build-system)
 999                (arguments
1000                 `(#:guile ,%bootstrap-guile
1001                   #:builder (mkdir (assoc-ref %outputs "out"))))
1002                (native-search-paths (package-native-search-paths libxml2))
1003                (synopsis #f) (description #f)
1004                (home-page #f) (license #f)))
1005          (prof (run-with-store %store
1006                  (profile-derivation
1007                   (manifest (map package->manifest-entry
1008                                  (list p1 p2)))
1009                   #:hooks '()
1010                   #:locales? #f)
1011                  #:guile-for-build (%guile-for-build))))
1012     (build-derivations %store (list prof))
1013     (string-match (format #f "^export XML_CATALOG_FILES=\"~a/xml/+bar/baz/catalog\\.xml\"\n"
1014                           (regexp-quote (derivation->output-path prof)))
1015                   (with-output-to-string
1016                     (lambda ()
1017                       (guix-package "-p" (derivation->output-path prof)
1018                                     "--search-paths"))))))
1019
1020 (test-assert "--search-paths with single-item search path"
1021   ;; Make sure 'guix package --search-paths' correctly reports environment
1022   ;; variables for things like 'GIT_SSL_CAINFO' that have #f as their
1023   ;; separator, meaning that the first match wins.
1024   (let* ((p1 (dummy-package "foo"
1025                (build-system trivial-build-system)
1026                (arguments
1027                 `(#:guile ,%bootstrap-guile
1028                   #:modules ((guix build utils))
1029                   #:builder (begin
1030                               (use-modules (guix build utils))
1031                               (let ((out (assoc-ref %outputs "out")))
1032                                 (mkdir-p (string-append out "/etc/ssl/certs"))
1033                                 (call-with-output-file
1034                                     (string-append
1035                                      out "/etc/ssl/certs/ca-certificates.crt")
1036                                   (const #t))))))))
1037          (p2 (package (inherit p1) (name "bar")))
1038          (p3 (dummy-package "git"
1039                ;; Provide a fake Git to avoid building the real one.
1040                (build-system trivial-build-system)
1041                (arguments
1042                 `(#:guile ,%bootstrap-guile
1043                   #:builder (mkdir (assoc-ref %outputs "out"))))
1044                (native-search-paths (package-native-search-paths git))))
1045          (prof1 (run-with-store %store
1046                   (profile-derivation
1047                    (packages->manifest (list p1 p3))
1048                    #:hooks '()
1049                    #:locales? #f)
1050                   #:guile-for-build (%guile-for-build)))
1051          (prof2 (run-with-store %store
1052                   (profile-derivation
1053                    (packages->manifest (list p2 p3))
1054                    #:hooks '()
1055                    #:locales? #f)
1056                   #:guile-for-build (%guile-for-build))))
1057     (build-derivations %store (list prof1 prof2))
1058     (string-match (format #f "^export GIT_SSL_CAINFO=\"~a/etc/ssl/certs/ca-certificates.crt"
1059                           (regexp-quote (derivation->output-path prof1)))
1060                   (with-output-to-string
1061                     (lambda ()
1062                       (guix-package "-p" (derivation->output-path prof1)
1063                                     "-p" (derivation->output-path prof2)
1064                                     "--search-paths"))))))
1065
1066 (test-equal "specification->package when not found"
1067   'quit
1068   (catch 'quit
1069     (lambda ()
1070       ;; This should call 'leave', producing an error message.
1071       (specification->package "this-package-does-not-exist"))
1072     (lambda (key . args)
1073       key)))
1074
1075 (test-end "packages")
1076
1077 ;;; Local Variables:
1078 ;;; eval: (put 'dummy-package 'scheme-indent-function 1)
1079 ;;; End: