guix/packages.scm

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