guix/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 © 2014, 2015, 2017, 2018 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2017, 2019, 2020 Efraim Flashner <efraim@flashner.co.il>
   7 ;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
   8 ;;;
   9 ;;; This file is part of GNU Guix.
  10 ;;;
  11 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  12 ;;; under the terms of the GNU General Public License as published by
  13 ;;; the Free Software Foundation; either version 3 of the License, or (at
  14 ;;; your option) any later version.
  15 ;;;
  16 ;;; GNU Guix is distributed in the hope that it will be useful, but
  17 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;;; GNU General Public License for more details.
  20 ;;;
  21 ;;; You should have received a copy of the GNU General Public License
  22 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 (define-module (guix packages)
  25   #:use-module (guix utils)
  26   #:use-module (guix records)
  27   #:use-module (guix store)
  28   #:use-module (guix monads)
  29   #:use-module (guix gexp)
  30   #:use-module (guix base32)
  31   #:autoload   (guix base64) (base64-decode)
  32   #:use-module (guix grafts)
  33   #:use-module (guix derivations)
  34   #:use-module (guix memoization)
  35   #:use-module (guix build-system)
  36   #:use-module (guix search-paths)
  37   #:use-module (guix sets)
  38   #:use-module (guix deprecation)
  39   #:use-module (guix i18n)
  40   #:use-module (ice-9 match)
  41   #:use-module (ice-9 vlist)
  42   #:use-module (ice-9 regex)
  43   #:use-module (srfi srfi-1)
  44   #:use-module (srfi srfi-9 gnu)
  45   #:use-module (srfi srfi-11)
  46   #:use-module (srfi srfi-26)
  47   #:use-module (srfi srfi-34)
  48   #:use-module (srfi srfi-35)
  49   #:use-module (rnrs bytevectors)
  50   #:use-module (web uri)
  51   #:re-export (%current-system
  52                %current-target-system
  53                search-path-specification)         ;for convenience
  54   #:export (content-hash
  55             content-hash?
  56             content-hash-algorithm
  57             content-hash-value
  58
  59             origin
  60             origin?
  61             this-origin
  62             origin-uri
  63             origin-method
  64             origin-hash
  65             origin-sha256                         ;deprecated
  66             origin-file-name
  67             origin-actual-file-name
  68             origin-patches
  69             origin-patch-flags
  70             origin-patch-inputs
  71             origin-patch-guile
  72             origin-snippet
  73             origin-modules
  74             base32
  75             base64
  76
  77             package
  78             package?
  79             this-package
  80             package-name
  81             package-upstream-name
  82             package-version
  83             package-full-name
  84             package-source
  85             package-build-system
  86             package-arguments
  87             package-inputs
  88             package-native-inputs
  89             package-propagated-inputs
  90             package-outputs
  91             package-native-search-paths
  92             package-search-paths
  93             package-replacement
  94             package-synopsis
  95             package-description
  96             package-license
  97             package-home-page
  98             package-supported-systems
  99             package-properties
 100             package-location
 101             hidden-package
 102             hidden-package?
 103             package-superseded
 104             deprecated-package
 105             package-field-location
 106
 107             package-direct-sources
 108             package-transitive-sources
 109             package-direct-inputs
 110             package-transitive-inputs
 111             package-transitive-target-inputs
 112             package-transitive-native-inputs
 113             package-transitive-propagated-inputs
 114             package-transitive-native-search-paths
 115             package-transitive-supported-systems
 116             package-mapping
 117             package-input-rewriting
 118             package-input-rewriting/spec
 119             package-source-derivation
 120             package-derivation
 121             package-cross-derivation
 122             package-output
 123             package-grafts
 124             package-patched-vulnerabilities
 125             package-with-patches
 126             package-with-extra-patches
 127             package-with-c-toolchain
 128             package/inherit
 129
 130             transitive-input-references
 131
 132             %supported-systems
 133             %hurd-systems
 134             %hydra-supported-systems
 135             supported-package?
 136
 137             &package-error
 138             package-error?
 139             package-error-package
 140             &package-input-error
 141             package-input-error?
 142             package-error-invalid-input
 143             &package-cross-build-system-error
 144             package-cross-build-system-error?
 145
 146             package->bag
 147             bag->derivation
 148             bag-direct-inputs
 149             bag-transitive-inputs
 150             bag-transitive-host-inputs
 151             bag-transitive-build-inputs
 152             bag-transitive-target-inputs
 153             package-closure
 154
 155             default-guile
 156             default-guile-derivation
 157             set-guile-for-build
 158             package-file
 159             package->derivation
 160             package->cross-derivation
 161             origin->derivation))
 162
 163 ;;; Commentary:
 164 ;;;
 165 ;;; This module provides a high-level mechanism to define packages in a
 166 ;;; Guix-based distribution.
 167 ;;;
 168 ;;; Code:
 169
 170 ;; Crytographic content hash.
 171 (define-immutable-record-type <content-hash>
 172   (%content-hash algorithm value)
 173   content-hash?
 174   (algorithm content-hash-algorithm)              ;symbol
 175   (value     content-hash-value))                 ;bytevector
 176
 177 (define-syntax-rule (define-content-hash-constructor name
 178                       (algorithm size) ...)
 179   "Define NAME as a <content-hash> constructor that ensures that (1) its
 180 second argument is among the listed ALGORITHM, and (2), when possible, that
 181 its first argument has the right size for the chosen algorithm."
 182   (define-syntax name
 183     (lambda (s)
 184       (syntax-case s (algorithm ...)
 185         ((_ bv algorithm)
 186          (let ((bv* (syntax->datum #'bv)))
 187            (when (and (bytevector? bv*)
 188                       (not (= size (bytevector-length bv*))))
 189              (syntax-violation 'content-hash "invalid content hash length" s))
 190            #'(%content-hash 'algorithm bv)))
 191         ...))))
 192
 193 (define-content-hash-constructor build-content-hash
 194   (sha256 32)
 195   (sha512 64)
 196   (sha3-256 32)
 197   (sha3-512 64)
 198   (blake2s-256 64))
 199
 200 (define-syntax content-hash
 201   (lambda (s)
 202     "Return a content hash with the given parameters.  The default hash
 203 algorithm is sha256.  If the first argument is a literal string, it is decoded
 204 as base32.  Otherwise, it must be a bytevector."
 205     ;; What we'd really want here is something like C++ 'constexpr'.
 206     (syntax-case s ()
 207       ((_ str)
 208        (string? (syntax->datum #'str))
 209        #'(content-hash str sha256))
 210       ((_ str algorithm)
 211        (string? (syntax->datum #'str))
 212        (with-syntax ((bv (base32 (syntax->datum #'str))))
 213          #'(content-hash bv algorithm)))
 214       ((_ (id str) algorithm)
 215        (and (string? (syntax->datum #'str))
 216             (free-identifier=? #'id #'base32))
 217        (with-syntax ((bv (nix-base32-string->bytevector (syntax->datum #'str))))
 218          #'(content-hash bv algorithm)))
 219       ((_ (id str) algorithm)
 220        (and (string? (syntax->datum #'str))
 221             (free-identifier=? #'id #'base64))
 222        (with-syntax ((bv (base64-decode (syntax->datum #'str))))
 223          #'(content-hash bv algorithm)))
 224       ((_ bv)
 225        #'(content-hash bv sha256))
 226       ((_ bv hash)
 227        #'(build-content-hash bv hash)))))
 228
 229 (define (print-content-hash hash port)
 230   (format port "#<content-hash ~a:~a>"
 231           (content-hash-algorithm hash)
 232           (and=> (content-hash-value hash)
 233                  bytevector->nix-base32-string)))
 234
 235 (set-record-type-printer! <content-hash> print-content-hash)
 236
 237 \f
 238 ;; The source of a package, such as a tarball URL and fetcher---called
 239 ;; "origin" to avoid name clash with `package-source', `source', etc.
 240 (define-record-type* <origin>
 241   %origin make-origin
 242   origin?
 243   this-origin
 244   (uri       origin-uri)                          ; string
 245   (method    origin-method)                       ; procedure
 246   (hash      origin-hash)                         ; <content-hash>
 247   (file-name origin-file-name (default #f))       ; optional file name
 248
 249   ;; Patches are delayed so that the 'search-patch' calls are made lazily,
 250   ;; which reduces I/O on startup and allows patch-not-found errors to be
 251   ;; gracefully handled at run time.
 252   (patches   origin-patches                       ; list of file names
 253              (default '()) (delayed))
 254
 255   (snippet   origin-snippet (default #f))         ; sexp or #f
 256   (patch-flags  origin-patch-flags                ; list of strings
 257                 (default '("-p1")))
 258
 259   ;; Patching requires Guile, GNU Patch, and a few more.  These two fields are
 260   ;; used to specify these dependencies when needed.
 261   (patch-inputs origin-patch-inputs               ; input list or #f
 262                 (default #f))
 263   (modules      origin-modules                    ; list of module names
 264                 (default '()))
 265
 266   (patch-guile origin-patch-guile                 ; package or #f
 267                (default #f)))
 268
 269 (define-syntax origin-compatibility-helper
 270   (syntax-rules (sha256)
 271     ((_ () (fields ...))
 272      (%origin fields ...))
 273     ((_ ((sha256 exp) rest ...) (others ...))
 274      (%origin others ...
 275               (hash (content-hash exp sha256))
 276               rest ...))
 277     ((_ (field rest ...) (others ...))
 278      (origin-compatibility-helper (rest ...)
 279                                   (others ... field)))))
 280
 281 (define-syntax-rule (origin fields ...)
 282   "Build an <origin> record, automatically converting 'sha256' field
 283 specifications to 'hash'."
 284   (origin-compatibility-helper (fields ...) ()))
 285
 286 (define-deprecated (origin-sha256 origin)
 287   origin-hash
 288   (let ((hash (origin-hash origin)))
 289     (unless (eq? (content-hash-algorithm hash) 'sha256)
 290       (raise (condition (&message
 291                          (message (G_ "no SHA256 hash for origin"))))))
 292     (content-hash-value hash)))
 293
 294 (define (print-origin origin port)
 295   "Write a concise representation of ORIGIN to PORT."
 296   (match origin
 297     (($ <origin> uri method hash file-name patches)
 298      (simple-format port "#<origin ~s ~a ~s ~a>"
 299                     uri hash
 300                     (force patches)
 301                     (number->string (object-address origin) 16)))))
 302
 303 (set-record-type-printer! <origin> print-origin)
 304
 305 (define-syntax-rule (define-compile-time-decoder name string->bytevector)
 306   "Define NAME as a macro that runs STRING->BYTEVECTOR at macro expansion time
 307 if possible."
 308   (define-syntax name
 309     (lambda (s)
 310       "Return the bytevector corresponding to the given textual
 311 representation."
 312       (syntax-case s ()
 313         ((_ str)
 314          (string? (syntax->datum #'str))
 315          ;; A literal string: do the conversion at expansion time.
 316          (with-syntax ((bv (string->bytevector (syntax->datum #'str))))
 317            #''bv))
 318         ((_ str)
 319          #'(string->bytevector str))))))
 320
 321 (define-compile-time-decoder base32 nix-base32-string->bytevector)
 322 (define-compile-time-decoder base64 base64-decode)
 323
 324 (define (origin-actual-file-name origin)
 325   "Return the file name of ORIGIN, either its 'file-name' field or the file
 326 name of its URI."
 327   (define (uri->file-name uri)
 328     ;; Return the 'base name' of URI or URI itself, where URI is a string.
 329     (let ((path (and=> (string->uri uri) uri-path)))
 330       (if path
 331           (basename path)
 332           uri)))
 333
 334   (or (origin-file-name origin)
 335       (match (origin-uri origin)
 336         ((head . tail)
 337          (uri->file-name head))
 338         ((? string? uri)
 339          (uri->file-name uri))
 340         (else
 341          ;; git, svn, cvs, etc. reference
 342          #f))))
 343
 344 \f
 345 (define %supported-systems
 346   ;; This is the list of system types that are supported.  By default, we
 347   ;; expect all packages to build successfully here.
 348   '("x86_64-linux" "i686-linux" "armhf-linux" "aarch64-linux" "mips64el-linux" "i586-gnu"))
 349
 350 (define %hurd-systems
 351   ;; The GNU/Hurd systems for which support is being developed.
 352   '("i586-gnu" "i686-gnu"))
 353
 354 (define %hydra-supported-systems
 355   ;; This is the list of system types for which build machines are available.
 356   ;;
 357   ;; XXX: MIPS is unavailable in CI:
 358   ;; <https://lists.gnu.org/archive/html/guix-devel/2017-03/msg00790.html>.
 359   (fold delete %supported-systems '("mips64el-linux")))
 360
 361
 362 ;; A package.
 363 (define-record-type* <package>
 364   package make-package
 365   package?
 366   this-package
 367   (name   package-name)                   ; string
 368   (version package-version)               ; string
 369   (source package-source)                 ; <origin> instance
 370   (build-system package-build-system)     ; build system
 371   (arguments package-arguments            ; arguments for the build method
 372              (default '()) (thunked))
 373
 374   (inputs package-inputs                  ; input packages or derivations
 375           (default '()) (thunked))
 376   (propagated-inputs package-propagated-inputs    ; same, but propagated
 377                      (default '()) (thunked))
 378   (native-inputs package-native-inputs    ; native input packages/derivations
 379                  (default '()) (thunked))
 380
 381   (outputs package-outputs                ; list of strings
 382            (default '("out")))
 383
 384                                                   ; lists of
 385                                                   ; <search-path-specification>,
 386                                                   ; for native and cross
 387                                                   ; inputs
 388   (native-search-paths package-native-search-paths (default '()))
 389   (search-paths package-search-paths (default '()))
 390
 391   ;; The 'replacement' field is marked as "innate" because it never makes
 392   ;; sense to inherit a replacement as is.  See the 'package/inherit' macro.
 393   (replacement package-replacement                ; package | #f
 394                (default #f) (thunked) (innate))
 395
 396   (synopsis package-synopsis)                    ; one-line description
 397   (description package-description)              ; one or two paragraphs
 398   (license package-license)
 399   (home-page package-home-page)
 400   (supported-systems package-supported-systems    ; list of strings
 401                      (default %supported-systems))
 402
 403   (properties package-properties (default '()))   ; alist for anything else
 404
 405   (location package-location
 406             (default (and=> (current-source-location)
 407                             source-properties->location))
 408             (innate)))
 409
 410 (set-record-type-printer! <package>
 411                           (lambda (package port)
 412                             (let ((loc    (package-location package))
 413                                   (format simple-format))
 414                               (format port "#<package ~a@~a ~a~a>"
 415                                       (package-name package)
 416                                       (package-version package)
 417                                       (if loc
 418                                           (format #f "~a:~a "
 419                                                   (location-file loc)
 420                                                   (location-line loc))
 421                                           "")
 422                                       (number->string (object-address
 423                                                        package)
 424                                                       16)))))
 425
 426 (define-syntax-rule (package/inherit p overrides ...)
 427   "Like (package (inherit P) OVERRIDES ...), except that the same
 428 transformation is done to the package replacement, if any.  P must be a bare
 429 identifier, and will be bound to either P or its replacement when evaluating
 430 OVERRIDES."
 431   (let loop ((p p))
 432     (package (inherit p)
 433       overrides ...
 434       (replacement (and=> (package-replacement p) loop)))))
 435
 436 (define (package-upstream-name package)
 437   "Return the upstream name of PACKAGE, which could be different from the name
 438 it has in Guix."
 439   (or (assq-ref (package-properties package) 'upstream-name)
 440       (package-name package)))
 441
 442 (define (hidden-package p)
 443   "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
 444 user interfaces, ignores."
 445   (package
 446     (inherit p)
 447     (properties `((hidden? . #t)
 448                   ,@(package-properties p)))))
 449
 450 (define (hidden-package? p)
 451   "Return true if P is \"hidden\"--i.e., must not be visible to user
 452 interfaces."
 453   (assoc-ref (package-properties p) 'hidden?))
 454
 455 (define (package-superseded p)
 456   "Return the package the supersedes P, or #f if P is still current."
 457   (assoc-ref (package-properties p) 'superseded))
 458
 459 (define (deprecated-package old-name p)
 460   "Return a package called OLD-NAME and marked as superseded by P, a package
 461 object."
 462   (package
 463     (inherit p)
 464     (name old-name)
 465     (properties `((superseded . ,p)))))
 466
 467 (define (package-field-location package field)
 468   "Return the source code location of the definition of FIELD for PACKAGE, or
 469 #f if it could not be determined."
 470   (define (goto port line column)
 471     (unless (and (= (port-column port) (- column 1))
 472                  (= (port-line port) (- line 1)))
 473       (unless (eof-object? (read-char port))
 474         (goto port line column))))
 475
 476   (match (package-location package)
 477     (($ <location> file line column)
 478      (catch 'system-error
 479        (lambda ()
 480          ;; In general we want to keep relative file names for modules.
 481          (call-with-input-file (search-path %load-path file)
 482            (lambda (port)
 483              (goto port line column)
 484              (match (read port)
 485                (('package inits ...)
 486                 (let ((field (assoc field inits)))
 487                   (match field
 488                     ((_ value)
 489                      (let ((loc (and=> (source-properties value)
 490                                        source-properties->location)))
 491                        (and loc
 492                             ;; Preserve the original file name, which may be a
 493                             ;; relative file name.
 494                             (set-field loc (location-file) file))))
 495                     (_
 496                      #f))))
 497                (_
 498                 #f)))))
 499        (lambda _
 500          #f)))
 501     (_ #f)))
 502
 503
 504 ;; Error conditions.
 505
 506 (define-condition-type &package-error &error
 507   package-error?
 508   (package package-error-package))
 509
 510 (define-condition-type &package-input-error &package-error
 511   package-input-error?
 512   (input package-error-invalid-input))
 513
 514 (define-condition-type &package-cross-build-system-error &package-error
 515   package-cross-build-system-error?)
 516
 517 (define* (package-full-name package #:optional (delimiter "@"))
 518   "Return the full name of PACKAGE--i.e., `NAME@VERSION'.  By specifying
 519 DELIMITER (a string), you can customize what will appear between the name and
 520 the version.  By default, DELIMITER is \"@\"."
 521   (string-append (package-name package) delimiter (package-version package)))
 522
 523 (define (patch-file-name patch)
 524   "Return the basename of PATCH's file name, or #f if the file name could not
 525 be determined."
 526   (match patch
 527     ((? string?)
 528      (basename patch))
 529     ((? origin?)
 530      (and=> (origin-actual-file-name patch) basename))))
 531
 532 (define %vulnerability-regexp
 533   ;; Regexp matching a CVE identifier in patch file names.
 534   (make-regexp "CVE-[0-9]{4}-[0-9]+"))
 535
 536 (define (package-patched-vulnerabilities package)
 537   "Return the list of patched vulnerabilities of PACKAGE as a list of CVE
 538 identifiers.  The result is inferred from the file names of patches."
 539   (define (patch-vulnerabilities patch)
 540     (map (cut match:substring <> 0)
 541          (list-matches %vulnerability-regexp patch)))
 542
 543   (let ((patches (filter-map patch-file-name
 544                              (or (and=> (package-source package)
 545                                         origin-patches)
 546                                  '()))))
 547     (append-map patch-vulnerabilities patches)))
 548
 549 (define (%standard-patch-inputs)
 550   (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
 551                                 'canonical-package))
 552          (ref       (lambda (module var)
 553                       (canonical
 554                        (module-ref (resolve-interface module) var)))))
 555     `(("tar"   ,(ref '(gnu packages base) 'tar))
 556       ("xz"    ,(ref '(gnu packages compression) 'xz))
 557       ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
 558       ("gzip"  ,(ref '(gnu packages compression) 'gzip))
 559       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
 560       ("unzip" ,(ref '(gnu packages compression) 'unzip))
 561       ("patch" ,(ref '(gnu packages base) 'patch))
 562       ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
 563
 564 (define (default-guile)
 565   "Return the default Guile package used to run the build code of
 566 derivations."
 567   (let ((distro (resolve-interface '(gnu packages commencement))))
 568     (module-ref distro 'guile-final)))
 569
 570 (define (guile-for-grafts)
 571   "Return the Guile package used to build grafting derivations."
 572   ;; Guile 2.2 would not work due to <https://bugs.gnu.org/28211> when
 573   ;; grafting packages.
 574   (let ((distro (resolve-interface '(gnu packages guile))))
 575     (module-ref distro 'guile-2.0)))
 576
 577 (define* (default-guile-derivation #:optional (system (%current-system)))
 578   "Return the derivation for SYSTEM of the default Guile package used to run
 579 the build code of derivation."
 580   (package->derivation (default-guile) system
 581                        #:graft? #f))
 582
 583 (define* (patch-and-repack source patches
 584                            #:key
 585                            inputs
 586                            (snippet #f)
 587                            (flags '("-p1"))
 588                            (modules '())
 589                            (guile-for-build (%guile-for-build))
 590                            (system (%current-system)))
 591   "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
 592 repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
 593 it must be an s-expression that will run from within the directory where
 594 SOURCE was unpacked, after all of PATCHES have been applied.  MODULES
 595 specifies modules in scope when evaluating SNIPPET."
 596   (define source-file-name
 597     ;; SOURCE is usually a derivation, but it could be a store file.
 598     (if (derivation? source)
 599         (derivation->output-path source)
 600         source))
 601
 602   (define lookup-input
 603     ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
 604     ;; so deal with that.
 605     (let ((inputs (or inputs (%standard-patch-inputs))))
 606       (lambda (name)
 607         (match (assoc-ref inputs name)
 608           ((package) package)
 609           (#f        #f)))))
 610
 611   (define decompression-type
 612     (cond ((string-suffix? "gz" source-file-name)  "gzip")
 613           ((string-suffix? "Z" source-file-name)  "gzip")
 614           ((string-suffix? "bz2" source-file-name) "bzip2")
 615           ((string-suffix? "lz" source-file-name)  "lzip")
 616           ((string-suffix? "zip" source-file-name) "unzip")
 617           (else "xz")))
 618
 619   (define original-file-name
 620     ;; Remove the store prefix plus the slash, hash, and hyphen.
 621     (let* ((sans (string-drop source-file-name
 622                               (+ (string-length (%store-prefix)) 1)))
 623            (dash (string-index sans #\-)))
 624       (string-drop sans (+ 1 dash))))
 625
 626   (define (numeric-extension? file-name)
 627     ;; Return true if FILE-NAME ends with digits.
 628     (and=> (file-extension file-name)
 629            (cut string-every char-set:hex-digit <>)))
 630
 631   (define (checkout? directory)
 632     ;; Return true if DIRECTORY is a checkout (git, svn, etc).
 633     (string-suffix? "-checkout" directory))
 634
 635   (define (tarxz-name file-name)
 636     ;; Return a '.tar.xz' file name based on FILE-NAME.
 637     (let ((base (cond ((numeric-extension? file-name)
 638                        original-file-name)
 639                       ((checkout? file-name)
 640                        (string-drop-right file-name 9))
 641                       (else (file-sans-extension file-name)))))
 642       (string-append base
 643                      (if (equal? (file-extension base) "tar")
 644                          ".xz"
 645                          ".tar.xz"))))
 646
 647   (define instantiate-patch
 648     (match-lambda
 649       ((? string? patch)                          ;deprecated
 650        (interned-file patch #:recursive? #t))
 651       ((? struct? patch)                          ;origin, local-file, etc.
 652        (lower-object patch system))))
 653
 654   (mlet %store-monad ((tar ->     (lookup-input "tar"))
 655                       (xz ->      (lookup-input "xz"))
 656                       (patch ->   (lookup-input "patch"))
 657                       (locales -> (lookup-input "locales"))
 658                       (decomp ->  (lookup-input decompression-type))
 659                       (patches    (sequence %store-monad
 660                                             (map instantiate-patch patches))))
 661     (define build
 662       (with-imported-modules '((guix build utils))
 663         #~(begin
 664             (use-modules (ice-9 ftw)
 665                          (srfi srfi-1)
 666                          (guix build utils))
 667
 668             ;; The --sort option was added to GNU tar in version 1.28, released
 669             ;; 2014-07-28.  During bootstrap we must cope with older versions.
 670             (define tar-supports-sort?
 671               (zero? (system* (string-append #+tar "/bin/tar")
 672                               "cf" "/dev/null" "--files-from=/dev/null"
 673                               "--sort=name")))
 674
 675             (define (apply-patch patch)
 676               (format (current-error-port) "applying '~a'...~%" patch)
 677
 678               ;; Use '--force' so that patches that do not apply perfectly are
 679               ;; rejected.  Use '--no-backup-if-mismatch' to prevent making
 680               ;; "*.orig" file if a patch is applied with offset.
 681               (invoke (string-append #+patch "/bin/patch")
 682                       "--force" "--no-backup-if-mismatch"
 683                       #+@flags "--input" patch))
 684
 685             (define (first-file directory)
 686               ;; Return the name of the first file in DIRECTORY.
 687               (car (scandir directory
 688                             (lambda (name)
 689                               (not (member name '("." "..")))))))
 690
 691             ;; Encoding/decoding errors shouldn't be silent.
 692             (fluid-set! %default-port-conversion-strategy 'error)
 693
 694             (when #+locales
 695               ;; First of all, install a UTF-8 locale so that UTF-8 file names
 696               ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
 697               (setenv "LOCPATH"
 698                       (string-append #+locales "/lib/locale/"
 699                                      #+(and locales
 700                                             (version-major+minor
 701                                              (package-version locales)))))
 702               (setlocale LC_ALL "en_US.utf8"))
 703
 704             (setenv "PATH" (string-append #+xz "/bin" ":"
 705                                           #+decomp "/bin"))
 706
 707             ;; SOURCE may be either a directory or a tarball.
 708             (if (file-is-directory? #+source)
 709                 (let* ((store     (%store-directory))
 710                        (len       (+ 1 (string-length store)))
 711                        (base      (string-drop #+source len))
 712                        (dash      (string-index base #\-))
 713                        (directory (string-drop base (+ 1 dash))))
 714                   (mkdir directory)
 715                   (copy-recursively #+source directory))
 716                 #+(if (string=? decompression-type "unzip")
 717                       #~(invoke "unzip" #+source)
 718                       #~(invoke (string-append #+tar "/bin/tar")
 719                                 "xvf" #+source)))
 720
 721             (let ((directory (first-file ".")))
 722               (format (current-error-port)
 723                       "source is under '~a'~%" directory)
 724               (chdir directory)
 725
 726               (for-each apply-patch '#+patches)
 727
 728               (let ((result #+(if snippet
 729                                   #~(let ((module (make-fresh-user-module)))
 730                                       (module-use-interfaces!
 731                                        module
 732                                        (map resolve-interface '#+modules))
 733                                       ((@ (system base compile) compile)
 734                                        '#+snippet
 735                                        #:to 'value
 736                                        #:opts %auto-compilation-options
 737                                        #:env module))
 738                                   #~#t)))
 739                 ;; Issue a warning unless the result is #t.
 740                 (unless (eqv? result #t)
 741                   (format (current-error-port) "\
 742 ## WARNING: the snippet returned `~s'.  Return values other than #t
 743 ## are deprecated.  Please migrate this package so that its snippet
 744 ## reports errors by raising an exception, and otherwise returns #t.~%"
 745                           result))
 746                 (unless result
 747                   (error "snippet returned false")))
 748
 749               (chdir "..")
 750
 751               (unless tar-supports-sort?
 752                 (call-with-output-file ".file_list"
 753                   (lambda (port)
 754                     (for-each (lambda (name)
 755                                 (format port "~a~%" name))
 756                               (find-files directory
 757                                           #:directories? #t
 758                                           #:fail-on-error? #t)))))
 759               (apply invoke
 760                      (string-append #+tar "/bin/tar")
 761                      "cvfa" #$output
 762                      ;; Avoid non-determinism in the archive.  Set the mtime
 763                      ;; to 1 as is the case in the store (software like gzip
 764                      ;; behaves differently when it stumbles upon mtime = 0).
 765                      "--mtime=@1"
 766                      "--owner=root:0"
 767                      "--group=root:0"
 768                      (if tar-supports-sort?
 769                          `("--sort=name"
 770                            ,directory)
 771                          '("--no-recursion"
 772                            "--files-from=.file_list")))))))
 773
 774     (let ((name (tarxz-name original-file-name)))
 775       (gexp->derivation name build
 776                         #:graft? #f
 777                         #:system system
 778                         #:guile-for-build guile-for-build
 779                         #:properties `((type . origin)
 780                                        (patches . ,(length patches)))))))
 781
 782 (define (package-with-patches original patches)
 783   "Return package ORIGINAL with PATCHES applied."
 784   (package (inherit original)
 785            (source (origin (inherit (package-source original))
 786                            (patches patches)))))
 787
 788 (define (package-with-extra-patches original patches)
 789   "Return package ORIGINAL with all PATCHES appended to its list of patches."
 790   (package-with-patches original
 791                         (append (origin-patches (package-source original))
 792                                 patches)))
 793
 794 (define (package-with-c-toolchain package toolchain)
 795   "Return a variant of PACKAGE that uses TOOLCHAIN instead of the default GNU
 796 C/C++ toolchain.  TOOLCHAIN must be a list of inputs (label/package tuples)
 797 providing equivalent functionality, such as the 'gcc-toolchain' package."
 798   (let ((bs (package-build-system package)))
 799     (package/inherit package
 800       (build-system (build-system-with-c-toolchain bs toolchain)))))
 801
 802 (define (transitive-inputs inputs)
 803   "Return the closure of INPUTS when considering the 'propagated-inputs'
 804 edges.  Omit duplicate inputs, except for those already present in INPUTS
 805 itself.
 806
 807 This is implemented as a breadth-first traversal such that INPUTS is
 808 preserved, and only duplicate propagated inputs are removed."
 809   (define (seen? seen item outputs)
 810     ;; FIXME: We're using pointer identity here, which is extremely sensitive
 811     ;; to memoization in package-producing procedures; see
 812     ;; <https://bugs.gnu.org/30155>.
 813     (match (vhash-assq item seen)
 814       ((_ . o) (equal? o outputs))
 815       (_       #f)))
 816
 817   (let loop ((inputs     inputs)
 818              (result     '())
 819              (propagated '())
 820              (first?     #t)
 821              (seen       vlist-null))
 822     (match inputs
 823       (()
 824        (if (null? propagated)
 825            (reverse result)
 826            (loop (reverse (concatenate propagated)) result '() #f seen)))
 827       (((and input (label (? package? package) outputs ...)) rest ...)
 828        (if (and (not first?) (seen? seen package outputs))
 829            (loop rest result propagated first? seen)
 830            (loop rest
 831                  (cons input result)
 832                  (cons (package-propagated-inputs package) propagated)
 833                  first?
 834                  (vhash-consq package outputs seen))))
 835       ((input rest ...)
 836        (loop rest (cons input result) propagated first? seen)))))
 837
 838 (define (package-direct-sources package)
 839   "Return all source origins associated with PACKAGE; including origins in
 840 PACKAGE's inputs."
 841   `(,@(or (and=> (package-source package) list) '())
 842     ,@(filter-map (match-lambda
 843                    ((_ (? origin? orig) _ ...)
 844                     orig)
 845                    (_ #f))
 846                   (package-direct-inputs package))))
 847
 848 (define (package-transitive-sources package)
 849   "Return PACKAGE's direct sources, and their direct sources, recursively."
 850   (delete-duplicates
 851    (concatenate (filter-map (match-lambda
 852                              ((_ (? origin? orig) _ ...)
 853                               (list orig))
 854                              ((_ (? package? p) _ ...)
 855                               (package-direct-sources p))
 856                              (_ #f))
 857                             (bag-transitive-inputs
 858                              (package->bag package))))))
 859
 860 (define (package-direct-inputs package)
 861   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 862 with their propagated inputs."
 863   (append (package-native-inputs package)
 864           (package-inputs package)
 865           (package-propagated-inputs package)))
 866
 867 (define (package-transitive-inputs package)
 868   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 869 with their propagated inputs, recursively."
 870   (transitive-inputs (package-direct-inputs package)))
 871
 872 (define (package-transitive-target-inputs package)
 873   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 874 along with their propagated inputs, recursively.  This only includes inputs
 875 for the target system, and not native inputs."
 876   (transitive-inputs (append (package-inputs package)
 877                              (package-propagated-inputs package))))
 878
 879 (define (package-transitive-native-inputs package)
 880   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 881 along with their propagated inputs, recursively.  This only includes inputs
 882 for the host system (\"native inputs\"), and not target inputs."
 883   (transitive-inputs (package-native-inputs package)))
 884
 885 (define (package-transitive-propagated-inputs package)
 886   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 887 recursively."
 888   (transitive-inputs (package-propagated-inputs package)))
 889
 890 (define (package-transitive-native-search-paths package)
 891   "Return the list of search paths for PACKAGE and its propagated inputs,
 892 recursively."
 893   (append (package-native-search-paths package)
 894           (append-map (match-lambda
 895                         ((label (? package? p) _ ...)
 896                          (package-native-search-paths p))
 897                         (_
 898                          '()))
 899                       (package-transitive-propagated-inputs package))))
 900
 901 (define (transitive-input-references alist inputs)
 902   "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
 903 in INPUTS and their transitive propagated inputs."
 904   (define label
 905     (match-lambda
 906       ((label . _)
 907        label)))
 908
 909   (map (lambda (input)
 910          `(assoc-ref ,alist ,(label input)))
 911        (transitive-inputs inputs)))
 912
 913 (define package-transitive-supported-systems
 914   (let ()
 915     (define supported-systems
 916       (mlambda (package system)
 917         (parameterize ((%current-system system))
 918           (fold (lambda (input systems)
 919                   (match input
 920                     ((label (? package? package) . _)
 921                      (lset-intersection string=? systems
 922                                         (supported-systems package system)))
 923                     (_
 924                      systems)))
 925                 (package-supported-systems package)
 926                 (bag-direct-inputs (package->bag package))))))
 927
 928     (lambda* (package #:optional (system (%current-system)))
 929       "Return the intersection of the systems supported by PACKAGE and those
 930 supported by its dependencies."
 931       (supported-systems package system))))
 932
 933 (define* (supported-package? package #:optional (system (%current-system)))
 934   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
 935 dependencies are known to build on SYSTEM."
 936   (member system (package-transitive-supported-systems package system)))
 937
 938 (define (bag-direct-inputs bag)
 939   "Same as 'package-direct-inputs', but applied to a bag."
 940   (append (bag-build-inputs bag)
 941           (bag-host-inputs bag)
 942           (bag-target-inputs bag)))
 943
 944 (define (bag-transitive-inputs bag)
 945   "Same as 'package-transitive-inputs', but applied to a bag."
 946   (parameterize ((%current-target-system #f)
 947                  (%current-system (bag-system bag)))
 948     (transitive-inputs (bag-direct-inputs bag))))
 949
 950 (define (bag-transitive-build-inputs bag)
 951   "Same as 'package-transitive-native-inputs', but applied to a bag."
 952   (parameterize ((%current-target-system #f)
 953                  (%current-system (bag-system bag)))
 954     (transitive-inputs (bag-build-inputs bag))))
 955
 956 (define (bag-transitive-host-inputs bag)
 957   "Same as 'package-transitive-target-inputs', but applied to a bag."
 958   (parameterize ((%current-target-system (bag-target bag))
 959                  (%current-system (bag-system bag)))
 960     (transitive-inputs (bag-host-inputs bag))))
 961
 962 (define (bag-transitive-target-inputs bag)
 963   "Return the \"target inputs\" of BAG, recursively."
 964   (parameterize ((%current-target-system (bag-target bag))
 965                  (%current-system (bag-system bag)))
 966     (transitive-inputs (bag-target-inputs bag))))
 967
 968 (define* (package-closure packages #:key (system (%current-system)))
 969   "Return the closure of PACKAGES on SYSTEM--i.e., PACKAGES and the list of
 970 packages they depend on, recursively."
 971   (let loop ((packages packages)
 972              (visited  vlist-null)
 973              (closure  (list->setq packages)))
 974     (match packages
 975       (()
 976        (set->list closure))
 977       ((package . rest)
 978        (if (vhash-assq package visited)
 979            (loop rest visited closure)
 980            (let* ((bag          (package->bag package system))
 981                   (dependencies (filter-map (match-lambda
 982                                               ((label (? package? package) . _)
 983                                                package)
 984                                               (_ #f))
 985                                             (bag-direct-inputs bag))))
 986              (loop (append dependencies rest)
 987                    (vhash-consq package #t visited)
 988                    (fold set-insert closure dependencies))))))))
 989
 990 (define (build-system-with-package-mapping bs rewrite)
 991   "Return a variant of BS, a build system, that rewrites a bag's inputs by
 992 passing them through REWRITE, a procedure that takes an input tuplet and
 993 returns a \"rewritten\" input tuplet."
 994   (define lower
 995     (build-system-lower bs))
 996
 997   (define (lower* . args)
 998     (let ((lowered (apply lower args)))
 999       (bag
1000         (inherit lowered)
1001         (build-inputs (map rewrite (bag-build-inputs lowered)))
1002         (host-inputs (map rewrite (bag-host-inputs lowered)))
1003         (target-inputs (map rewrite (bag-target-inputs lowered))))))
1004
1005   (build-system
1006     (inherit bs)
1007     (lower lower*)))
1008
1009 (define* (package-mapping proc #:optional (cut? (const #f))
1010                           #:key deep?)
1011   "Return a procedure that, given a package, applies PROC to all the packages
1012 depended on and returns the resulting package.  The procedure stops recursion
1013 when CUT? returns true for a given package.  When DEEP? is true, PROC is
1014 applied to implicit inputs as well."
1015   (define (rewrite input)
1016     (match input
1017       ((label (? package? package) outputs ...)
1018        (cons* label (replace package) outputs))
1019       (_
1020        input)))
1021
1022   (define mapping-property
1023     ;; Property indicating whether the package has already been processed.
1024     (gensym " package-mapping-done"))
1025
1026   (define replace
1027     (mlambdaq (p)
1028       ;; If P is the result of a previous call, return it.
1029       (cond ((assq-ref (package-properties p) mapping-property)
1030              p)
1031
1032             ((cut? p)
1033              ;; Since P's propagated inputs are really inputs of its dependents,
1034              ;; rewrite them as well, unless we're doing a "shallow" rewrite.
1035              (let ((p (proc p)))
1036                (if (or (not deep?)
1037                        (null? (package-propagated-inputs p)))
1038                    p
1039                    (package
1040                      (inherit p)
1041                      (location (package-location p))
1042                      (replacement (package-replacement p))
1043                      (propagated-inputs (map rewrite (package-propagated-inputs p)))
1044                      (properties `((,mapping-property . #t)
1045                                    ,@(package-properties p)))))))
1046
1047             (else
1048              ;; Return a variant of P with PROC applied to P and its explicit
1049              ;; dependencies, recursively.  Memoize the transformations.  Failing
1050              ;; to do that, we would build a huge object graph with lots of
1051              ;; duplicates, which in turns prevents us from benefiting from
1052              ;; memoization in 'package-derivation'.
1053              (let ((p (proc p)))
1054                (package
1055                  (inherit p)
1056                  (location (package-location p))
1057                  (build-system (if deep?
1058                                    (build-system-with-package-mapping
1059                                     (package-build-system p) rewrite)
1060                                    (package-build-system p)))
1061                  (inputs (map rewrite (package-inputs p)))
1062                  (native-inputs (map rewrite (package-native-inputs p)))
1063                  (propagated-inputs (map rewrite (package-propagated-inputs p)))
1064                  (replacement (and=> (package-replacement p) replace))
1065                  (properties `((,mapping-property . #t)
1066                                ,@(package-properties p)))))))))
1067
1068   replace)
1069
1070 (define* (package-input-rewriting replacements
1071                                   #:optional (rewrite-name identity)
1072                                   #:key (deep? #t))
1073   "Return a procedure that, when passed a package, replaces its direct and
1074 indirect dependencies, including implicit inputs when DEEP? is true, according
1075 to REPLACEMENTS.  REPLACEMENTS is a list of package pairs; the first element
1076 of each pair is the package to replace, and the second one is the replacement.
1077
1078 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
1079 package and returns its new name after rewrite."
1080   (define replacement-property
1081     ;; Property to tag right-hand sides in REPLACEMENTS.
1082     (gensym " package-replacement"))
1083
1084   (define (rewrite p)
1085     (if (assq-ref (package-properties p) replacement-property)
1086         p
1087         (match (assq-ref replacements p)
1088           (#f  (package/inherit p
1089                  (name (rewrite-name (package-name p)))))
1090           (new (if deep?
1091                    (package/inherit new
1092                      (properties `((,replacement-property . #t)
1093                                    ,@(package-properties new))))
1094                    new)))))
1095
1096   (define (cut? p)
1097     (or (assq-ref (package-properties p) replacement-property)
1098         (assq-ref replacements p)))
1099
1100   (package-mapping rewrite cut?
1101                    #:deep? deep?))
1102
1103 (define* (package-input-rewriting/spec replacements #:key (deep? #t))
1104   "Return a procedure that, given a package, applies the given REPLACEMENTS to
1105 all the package graph, including implicit inputs unless DEEP? is false.
1106 REPLACEMENTS is a list of spec/procedures pair; each spec is a package
1107 specification such as \"gcc\" or \"guile@2\", and each procedure takes a
1108 matching package and returns a replacement for that package."
1109   (define table
1110     (fold (lambda (replacement table)
1111             (match replacement
1112               ((spec . proc)
1113                (let-values (((name version)
1114                              (package-name->name+version spec)))
1115                  (vhash-cons name (list version proc) table)))))
1116           vlist-null
1117           replacements))
1118
1119   (define (find-replacement package)
1120     (vhash-fold* (lambda (item proc)
1121                    (or proc
1122                        (match item
1123                          ((#f proc)
1124                           proc)
1125                          ((version proc)
1126                           (and (version-prefix? version
1127                                                 (package-version package))
1128                                proc)))))
1129                  #f
1130                  (package-name package)
1131                  table))
1132
1133   (define replacement-property
1134     (gensym " package-replacement"))
1135
1136   (define (rewrite p)
1137     (if (assq-ref (package-properties p) replacement-property)
1138         p
1139         (match (find-replacement p)
1140           (#f p)
1141           (proc
1142            (let ((new (proc p)))
1143              ;; Mark NEW as already processed.
1144              (package/inherit new
1145                (properties `((,replacement-property . #t)
1146                              ,@(package-properties new)))))))))
1147
1148   (define (cut? p)
1149     (or (assq-ref (package-properties p) replacement-property)
1150         (find-replacement p)))
1151
1152   (package-mapping rewrite cut?
1153                    #:deep? deep?))
1154
1155 \f
1156 ;;;
1157 ;;; Package derivations.
1158 ;;;
1159
1160 (define %derivation-cache
1161   ;; Package to derivation-path mapping.
1162   (make-weak-key-hash-table 100))
1163
1164 (define (cache! cache package system thunk)
1165   "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
1166 SYSTEM."
1167   ;; FIXME: This memoization should be associated with the open store, because
1168   ;; otherwise it breaks when switching to a different store.
1169   (let ((result (thunk)))
1170     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
1171     ;; same value for all structs (as of Guile 2.0.6), and because pointer
1172     ;; equality is sufficient in practice.
1173     (hashq-set! cache package
1174                 `((,system . ,result)
1175                   ,@(or (hashq-ref cache package) '())))
1176     result))
1177
1178 (define-syntax cached
1179   (syntax-rules (=>)
1180     "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
1181 Return the cached result when available."
1182     ((_ (=> cache) package system body ...)
1183      (let ((thunk (lambda () body ...))
1184            (key   system))
1185        (match (hashq-ref cache package)
1186          ((alist (... ...))
1187           (match (assoc-ref alist key)
1188             (#f (cache! cache package key thunk))
1189             (value value)))
1190          (#f
1191           (cache! cache package key thunk)))))
1192     ((_ package system body ...)
1193      (cached (=> %derivation-cache) package system body ...))))
1194
1195 (define* (expand-input store package input system #:optional cross-system)
1196   "Expand INPUT, an input tuple, such that it contains only references to
1197 derivation paths or store paths.  PACKAGE is only used to provide contextual
1198 information in exceptions."
1199   (define (intern file)
1200     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
1201     ;; file permissions are preserved.
1202     (add-to-store store (basename file) #t "sha256" file))
1203
1204   (define derivation
1205     (if cross-system
1206         (cut package-cross-derivation store <> cross-system system
1207              #:graft? #f)
1208         (cut package-derivation store <> system #:graft? #f)))
1209
1210   (match input
1211     (((? string? name) (? package? package))
1212      (list name (derivation package)))
1213     (((? string? name) (? package? package)
1214       (? string? sub-drv))
1215      (list name (derivation package)
1216            sub-drv))
1217     (((? string? name)
1218       (and (? string?) (? derivation-path?) drv))
1219      (list name drv))
1220     (((? string? name)
1221       (and (? string?) (? file-exists? file)))
1222      ;; Add FILE to the store.  When FILE is in the sub-directory of a
1223      ;; store path, it needs to be added anyway, so it can be used as a
1224      ;; source.
1225      (list name (intern file)))
1226     (((? string? name) (? struct? source))
1227      ;; 'package-source-derivation' calls 'lower-object', which can throw
1228      ;; '&gexp-input-error'.  However '&gexp-input-error' lacks source
1229      ;; location info, so we catch and rethrow here (XXX: not optimal
1230      ;; performance-wise).
1231      (guard (c ((gexp-input-error? c)
1232                 (raise (condition
1233                         (&package-input-error
1234                          (package package)
1235                          (input   (gexp-error-invalid-input c)))))))
1236        (list name (package-source-derivation store source system))))
1237     (x
1238      (raise (condition (&package-input-error
1239                         (package package)
1240                         (input   x)))))))
1241
1242 (define %bag-cache
1243   ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
1244   ;; It significantly speeds things up when doing repeated calls to
1245   ;; 'package->bag' as is the case when building a profile.
1246   (make-weak-key-hash-table 200))
1247
1248 (define* (package->bag package #:optional
1249                        (system (%current-system))
1250                        (target (%current-target-system))
1251                        #:key (graft? (%graft?)))
1252   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
1253 and return it."
1254   (let ((package (or (and graft? (package-replacement package))
1255                      package)))
1256     (cached (=> %bag-cache)
1257             package (list system target)
1258             ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
1259             ;; field values can refer to it.
1260             (parameterize ((%current-system system)
1261                            (%current-target-system target))
1262               (match package
1263                 ((and self
1264                       ($ <package> name version source build-system
1265                                    args inputs propagated-inputs native-inputs
1266                                    outputs))
1267                  ;; Even though we prefer to use "@" to separate the package
1268                  ;; name from the package version in various user-facing parts
1269                  ;; of Guix, checkStoreName (in nix/libstore/store-api.cc)
1270                  ;; prohibits the use of "@", so use "-" instead.
1271                  (or (make-bag build-system (string-append name "-" version)
1272                                #:system system
1273                                #:target target
1274                                #:source source
1275                                #:inputs (append (inputs self)
1276                                                 (propagated-inputs self))
1277                                #:outputs outputs
1278                                #:native-inputs (native-inputs self)
1279                                #:arguments (args self))
1280                      (raise (if target
1281                                 (condition
1282                                  (&package-cross-build-system-error
1283                                   (package package)))
1284                                 (condition
1285                                  (&package-error
1286                                   (package package))))))))))))
1287
1288 (define %graft-cache
1289   ;; 'eq?' cache mapping package objects to a graft corresponding to their
1290   ;; replacement package.
1291   (make-weak-key-hash-table 200))
1292
1293 (define (input-graft store system)
1294   "Return a procedure that, given a package with a replacement and an output name,
1295 returns a graft, and #f otherwise."
1296   (match-lambda*
1297     (((? package? package) output)
1298      (let ((replacement (package-replacement package)))
1299        (and replacement
1300             (cached (=> %graft-cache) package (cons output system)
1301                     (let ((orig (package-derivation store package system
1302                                                     #:graft? #f))
1303                           (new  (package-derivation store replacement system
1304                                                     #:graft? #t)))
1305                       (graft
1306                         (origin orig)
1307                         (origin-output output)
1308                         (replacement new)
1309                         (replacement-output output)))))))))
1310
1311 (define (input-cross-graft store target system)
1312   "Same as 'input-graft', but for cross-compilation inputs."
1313   (match-lambda*
1314     (((? package? package) output)
1315      (let ((replacement (package-replacement package)))
1316        (and replacement
1317             (let ((orig (package-cross-derivation store package target system
1318                                                   #:graft? #f))
1319                   (new  (package-cross-derivation store replacement
1320                                                   target system
1321                                                   #:graft? #t)))
1322               (graft
1323                 (origin orig)
1324                 (origin-output output)
1325                 (replacement new)
1326                 (replacement-output output))))))))
1327
1328 (define* (fold-bag-dependencies proc seed bag
1329                                 #:key (native? #t))
1330   "Fold PROC over the packages BAG depends on.  Each package is visited only
1331 once, in depth-first order.  If NATIVE? is true, restrict to native
1332 dependencies; otherwise, restrict to target dependencies."
1333   (define bag-direct-inputs*
1334     (if native?
1335         (lambda (bag)
1336           (append (bag-build-inputs bag)
1337                   (bag-target-inputs bag)
1338                   (if (bag-target bag)
1339                       '()
1340                       (bag-host-inputs bag))))
1341         bag-host-inputs))
1342
1343   (let loop ((inputs (bag-direct-inputs* bag))
1344              (result seed)
1345              (visited vlist-null))
1346     (match inputs
1347       (()
1348        result)
1349       (((label (? package? head) . rest) . tail)
1350        (let ((output  (match rest (() "out") ((output) output)))
1351              (outputs (vhash-foldq* cons '() head visited)))
1352          (if (member output outputs)
1353              (loop tail result visited)
1354              (let ((inputs (bag-direct-inputs* (package->bag head))))
1355                (loop (append inputs tail)
1356                      (proc head output result)
1357                      (vhash-consq head output visited))))))
1358       ((head . tail)
1359        (loop tail result visited)))))
1360
1361 (define* (bag-grafts store bag)
1362   "Return the list of grafts potentially applicable to BAG.  Potentially
1363 applicable grafts are collected by looking at direct or indirect dependencies
1364 of BAG that have a 'replacement'.  Whether a graft is actually applicable
1365 depends on whether the outputs of BAG depend on the items the grafts refer
1366 to (see 'graft-derivation'.)"
1367   (define system (bag-system bag))
1368   (define target (bag-target bag))
1369
1370   (define native-grafts
1371     (let ((->graft (input-graft store system)))
1372       (parameterize ((%current-system system)
1373                      (%current-target-system #f))
1374         (fold-bag-dependencies (lambda (package output grafts)
1375                                  (match (->graft package output)
1376                                    (#f    grafts)
1377                                    (graft (cons graft grafts))))
1378                                '()
1379                                bag))))
1380
1381   (define target-grafts
1382     (if target
1383         (let ((->graft (input-cross-graft store target system)))
1384           (parameterize ((%current-system system)
1385                          (%current-target-system target))
1386             (fold-bag-dependencies (lambda (package output grafts)
1387                                      (match (->graft package output)
1388                                        (#f    grafts)
1389                                        (graft (cons graft grafts))))
1390                                    '()
1391                                    bag
1392                                    #:native? #f)))
1393         '()))
1394
1395   ;; We can end up with several identical grafts if we stumble upon packages
1396   ;; that are not 'eq?' but map to the same derivation (this can happen when
1397   ;; using things like 'package-with-explicit-inputs'.)  Hence the
1398   ;; 'delete-duplicates' call.
1399   (delete-duplicates
1400    (append native-grafts target-grafts)))
1401
1402 (define* (package-grafts store package
1403                          #:optional (system (%current-system))
1404                          #:key target)
1405   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1406 TARGET."
1407   (let* ((package (or (package-replacement package) package))
1408          (bag     (package->bag package system target)))
1409     (bag-grafts store bag)))
1410
1411 (define* (bag->derivation store bag
1412                           #:optional context)
1413   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
1414 a package object describing the context in which the call occurs, for improved
1415 error reporting."
1416   (if (bag-target bag)
1417       (bag->cross-derivation store bag)
1418       (let* ((system     (bag-system bag))
1419              (inputs     (bag-transitive-inputs bag))
1420              (input-drvs (map (cut expand-input store context <> system)
1421                               inputs))
1422              (paths      (delete-duplicates
1423                           (append-map (match-lambda
1424                                        ((_ (? package? p) _ ...)
1425                                         (package-native-search-paths
1426                                          p))
1427                                        (_ '()))
1428                                       inputs))))
1429
1430         (apply (bag-build bag)
1431                store (bag-name bag) input-drvs
1432                #:search-paths paths
1433                #:outputs (bag-outputs bag) #:system system
1434                (bag-arguments bag)))))
1435
1436 (define* (bag->cross-derivation store bag
1437                                 #:optional context)
1438   "Return the derivation to build BAG, which is actually a cross build.
1439 Optionally, CONTEXT can be a package object denoting the context of the call.
1440 This is an internal procedure."
1441   (let* ((system      (bag-system bag))
1442          (target      (bag-target bag))
1443          (host        (bag-transitive-host-inputs bag))
1444          (host-drvs   (map (cut expand-input store context <> system target)
1445                            host))
1446          (target*     (bag-transitive-target-inputs bag))
1447          (target-drvs (map (cut expand-input store context <> system)
1448                            target*))
1449          (build       (bag-transitive-build-inputs bag))
1450          (build-drvs  (map (cut expand-input store context <> system)
1451                            build))
1452          (all         (append build target* host))
1453          (paths       (delete-duplicates
1454                        (append-map (match-lambda
1455                                     ((_ (? package? p) _ ...)
1456                                      (package-search-paths p))
1457                                     (_ '()))
1458                                    all)))
1459          (npaths      (delete-duplicates
1460                        (append-map (match-lambda
1461                                     ((_ (? package? p) _ ...)
1462                                      (package-native-search-paths
1463                                       p))
1464                                     (_ '()))
1465                                    all))))
1466
1467     (apply (bag-build bag)
1468            store (bag-name bag)
1469            #:native-drvs build-drvs
1470            #:target-drvs (append host-drvs target-drvs)
1471            #:search-paths paths
1472            #:native-search-paths npaths
1473            #:outputs (bag-outputs bag)
1474            #:system system #:target target
1475            (bag-arguments bag))))
1476
1477 (define* (package-derivation store package
1478                              #:optional (system (%current-system))
1479                              #:key (graft? (%graft?)))
1480   "Return the <derivation> object of PACKAGE for SYSTEM."
1481
1482   ;; Compute the derivation and cache the result.  Caching is important
1483   ;; because some derivations, such as the implicit inputs of the GNU build
1484   ;; system, will be queried many, many times in a row.
1485   (cached package (cons system graft?)
1486           (let* ((bag (package->bag package system #f #:graft? graft?))
1487                  (drv (bag->derivation store bag package)))
1488             (if graft?
1489                 (match (bag-grafts store bag)
1490                   (()
1491                    drv)
1492                   (grafts
1493                    (let ((guile (package-derivation store (guile-for-grafts)
1494                                                     system #:graft? #f)))
1495                      ;; TODO: As an optimization, we can simply graft the tip
1496                      ;; of the derivation graph since 'graft-derivation'
1497                      ;; recurses anyway.
1498                      (graft-derivation store drv grafts
1499                                        #:system system
1500                                        #:guile guile))))
1501                 drv))))
1502
1503 (define* (package-cross-derivation store package target
1504                                    #:optional (system (%current-system))
1505                                    #:key (graft? (%graft?)))
1506   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1507 system identifying string)."
1508   (cached package (list system target graft?)
1509           (let* ((bag (package->bag package system target #:graft? graft?))
1510                  (drv (bag->derivation store bag package)))
1511             (if graft?
1512                 (match (bag-grafts store bag)
1513                   (()
1514                    drv)
1515                   (grafts
1516                    (graft-derivation store drv grafts
1517                                      #:system system
1518                                      #:guile
1519                                      (package-derivation store (guile-for-grafts)
1520                                                          system #:graft? #f))))
1521                 drv))))
1522
1523 (define* (package-output store package
1524                          #:optional (output "out") (system (%current-system)))
1525   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1526 symbolic output name, such as \"out\".  Note that this procedure calls
1527 `package-derivation', which is costly."
1528   (let ((drv (package-derivation store package system)))
1529     (derivation->output-path drv output)))
1530
1531 \f
1532 ;;;
1533 ;;; Monadic interface.
1534 ;;;
1535
1536 (define (set-guile-for-build guile)
1537   "This monadic procedure changes the Guile currently used to run the build
1538 code of derivations to GUILE, a package object."
1539   (lambda (store)
1540     (let ((guile (package-derivation store guile)))
1541       (values (%guile-for-build guile) store))))
1542
1543 (define* (package-file package
1544                        #:optional file
1545                        #:key
1546                        system (output "out") target)
1547   "Return as a monadic value the absolute file name of FILE within the
1548 OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
1549 OUTPUT directory of PACKAGE.  When TARGET is true, use it as a
1550 cross-compilation target triplet.
1551
1552 Note that this procedure does _not_ build PACKAGE.  Thus, the result might or
1553 might not designate an existing file.  We recommend not using this procedure
1554 unless you know what you are doing."
1555   (lambda (store)
1556     (define compute-derivation
1557       (if target
1558           (cut package-cross-derivation <> <> target <>)
1559           package-derivation))
1560
1561     (let* ((system (or system (%current-system)))
1562            (drv    (compute-derivation store package system))
1563            (out    (derivation->output-path drv output)))
1564       (values (if file
1565                   (string-append out "/" file)
1566                   out)
1567               store))))
1568
1569 (define package->derivation
1570   (store-lift package-derivation))
1571
1572 (define package->cross-derivation
1573   (store-lift package-cross-derivation))
1574
1575 (define-gexp-compiler (package-compiler (package <package>) system target)
1576   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1577   ;; TARGET.  This is used when referring to a package from within a gexp.
1578   (if target
1579       (package->cross-derivation package target system)
1580       (package->derivation package system)))
1581
1582 (define* (origin->derivation origin
1583                              #:optional (system (%current-system)))
1584   "Return the derivation corresponding to ORIGIN."
1585   (match origin
1586     (($ <origin> uri method hash name (= force ()) #f)
1587      ;; No patches, no snippet: this is a fixed-output derivation.
1588      (method uri
1589              (content-hash-algorithm hash)
1590              (content-hash-value hash)
1591              name #:system system))
1592     (($ <origin> uri method hash name (= force (patches ...)) snippet
1593         (flags ...) inputs (modules ...) guile-for-build)
1594      ;; Patches and/or a snippet.
1595      (mlet %store-monad ((source (method uri
1596                                          (content-hash-algorithm hash)
1597                                          (content-hash-value hash)
1598                                          name #:system system))
1599                          (guile  (package->derivation (or guile-for-build
1600                                                           (default-guile))
1601                                                       system
1602                                                       #:graft? #f)))
1603        (patch-and-repack source patches
1604                          #:inputs inputs
1605                          #:snippet snippet
1606                          #:flags flags
1607                          #:system system
1608                          #:modules modules
1609                          #:guile-for-build guile)))))
1610
1611 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
1612   ;; Compile ORIGIN to a derivation for SYSTEM.  This is used when referring
1613   ;; to an origin from within a gexp.
1614   (origin->derivation origin system))
1615
1616 (define package-source-derivation                 ;somewhat deprecated
1617   (let ((lower (store-lower lower-object)))
1618     (lambda* (store source #:optional (system (%current-system)))
1619       "Return the derivation or file corresponding to SOURCE, which can be an
1620 a file name or any object handled by 'lower-object', such as an <origin>.
1621 When SOURCE is a file name, return either the interned file name (if SOURCE is
1622 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1623       (match source
1624         ((and (? string?) (? direct-store-path?) file)
1625          file)
1626         ((? string? file)
1627          (add-to-store store (basename file) #t "sha256" file))
1628         (_
1629          (lower store source system))))))