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