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