guix/packages.scm

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