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