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