guix/packages.scm

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