guix/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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   (replacement package-replacement                ; package | #f
 273                (default #f) (thunked))
 274
 275   (synopsis package-synopsis)                    ; one-line description
 276   (description package-description)              ; one or two paragraphs
 277   (license package-license)
 278   (home-page package-home-page)
 279   (supported-systems package-supported-systems    ; list of strings
 280                      (default %supported-systems))
 281   (maintainers package-maintainers (default '()))
 282
 283   (properties package-properties (default '()))   ; alist for anything else
 284
 285   (location package-location
 286             (default (and=> (current-source-location)
 287                             source-properties->location))
 288             (innate)))
 289
 290 (set-record-type-printer! <package>
 291                           (lambda (package port)
 292                             (let ((loc    (package-location package))
 293                                   (format simple-format))
 294                               (format port "#<package ~a@~a ~a~a>"
 295                                       (package-name package)
 296                                       (package-version package)
 297                                       (if loc
 298                                           (format #f "~a:~a "
 299                                                   (location-file loc)
 300                                                   (location-line loc))
 301                                           "")
 302                                       (number->string (object-address
 303                                                        package)
 304                                                       16)))))
 305
 306 (define (package-upstream-name package)
 307   "Return the upstream name of PACKAGE, which could be different from the name
 308 it has in Guix."
 309   (or (assq-ref (package-properties package) 'upstream-name)
 310       (package-name package)))
 311
 312 (define (hidden-package p)
 313   "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
 314 user interfaces, ignores."
 315   (package
 316     (inherit p)
 317     (properties `((hidden? . #t)
 318                   ,@(package-properties p)))))
 319
 320 (define (hidden-package? p)
 321   "Return true if P is \"hidden\"--i.e., must not be visible to user
 322 interfaces."
 323   (assoc-ref (package-properties p) 'hidden?))
 324
 325 (define (package-superseded p)
 326   "Return the package the supersedes P, or #f if P is still current."
 327   (assoc-ref (package-properties p) 'superseded))
 328
 329 (define (deprecated-package old-name p)
 330   "Return a package called OLD-NAME and marked as superseded by P, a package
 331 object."
 332   (package
 333     (inherit p)
 334     (name old-name)
 335     (properties `((superseded . ,p)))))
 336
 337 (define (package-field-location package field)
 338   "Return the source code location of the definition of FIELD for PACKAGE, or
 339 #f if it could not be determined."
 340   (define (goto port line column)
 341     (unless (and (= (port-column port) (- column 1))
 342                  (= (port-line port) (- line 1)))
 343       (unless (eof-object? (read-char port))
 344         (goto port line column))))
 345
 346   (match (package-location package)
 347     (($ <location> file line column)
 348      (catch 'system
 349        (lambda ()
 350          ;; In general we want to keep relative file names for modules.
 351          (with-fluids ((%file-port-name-canonicalization 'relative))
 352            (call-with-input-file (search-path %load-path file)
 353              (lambda (port)
 354                (goto port line column)
 355                (match (read port)
 356                  (('package inits ...)
 357                   (let ((field (assoc field inits)))
 358                     (match field
 359                       ((_ value)
 360                        ;; Put the `or' here, and not in the first argument of
 361                        ;; `and=>', to work around a compiler bug in 2.0.5.
 362                        (or (and=> (source-properties value)
 363                                   source-properties->location)
 364                            (and=> (source-properties field)
 365                                   source-properties->location)))
 366                       (_
 367                        #f))))
 368                  (_
 369                   #f))))))
 370        (lambda _
 371          #f)))
 372     (_ #f)))
 373
 374
 375 ;; Error conditions.
 376
 377 (define-condition-type &package-error &error
 378   package-error?
 379   (package package-error-package))
 380
 381 (define-condition-type &package-input-error &package-error
 382   package-input-error?
 383   (input package-error-invalid-input))
 384
 385 (define-condition-type &package-cross-build-system-error &package-error
 386   package-cross-build-system-error?)
 387
 388
 389 (define (package-full-name package)
 390   "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
 391   (string-append (package-name package) "-" (package-version package)))
 392
 393 (define (%standard-patch-inputs)
 394   (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
 395                                 'canonical-package))
 396          (ref       (lambda (module var)
 397                       (canonical
 398                        (module-ref (resolve-interface module) var)))))
 399     `(("tar"   ,(ref '(gnu packages base) 'tar))
 400       ("xz"    ,(ref '(gnu packages compression) 'xz))
 401       ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
 402       ("gzip"  ,(ref '(gnu packages compression) 'gzip))
 403       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
 404       ("unzip" ,(ref '(gnu packages zip) 'unzip))
 405       ("patch" ,(ref '(gnu packages base) 'patch))
 406       ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
 407
 408 (define (default-guile)
 409   "Return the default Guile package used to run the build code of
 410 derivations."
 411   (let ((distro (resolve-interface '(gnu packages commencement))))
 412     (module-ref distro 'guile-final)))
 413
 414 (define* (default-guile-derivation #:optional (system (%current-system)))
 415   "Return the derivation for SYSTEM of the default Guile package used to run
 416 the build code of derivation."
 417   (package->derivation (default-guile) system
 418                        #:graft? #f))
 419
 420 (define* (patch-and-repack source patches
 421                            #:key
 422                            inputs
 423                            (snippet #f)
 424                            (flags '("-p1"))
 425                            (modules '())
 426                            (guile-for-build (%guile-for-build))
 427                            (system (%current-system)))
 428   "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
 429 repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
 430 it must be an s-expression that will run from within the directory where
 431 SOURCE was unpacked, after all of PATCHES have been applied.  MODULES
 432 specifies modules in scope when evaluating SNIPPET."
 433   (define source-file-name
 434     ;; SOURCE is usually a derivation, but it could be a store file.
 435     (if (derivation? source)
 436         (derivation->output-path source)
 437         source))
 438
 439   (define lookup-input
 440     ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
 441     ;; so deal with that.
 442     (let ((inputs (or inputs (%standard-patch-inputs))))
 443       (lambda (name)
 444         (match (assoc-ref inputs name)
 445           ((package) package)
 446           (#f        #f)))))
 447
 448   (define decompression-type
 449     (cond ((string-suffix? "gz" source-file-name)  "gzip")
 450           ((string-suffix? "Z" source-file-name)  "gzip")
 451           ((string-suffix? "bz2" source-file-name) "bzip2")
 452           ((string-suffix? "lz" source-file-name)  "lzip")
 453           ((string-suffix? "zip" source-file-name) "unzip")
 454           (else "xz")))
 455
 456   (define original-file-name
 457     ;; Remove the store prefix plus the slash, hash, and hyphen.
 458     (let* ((sans (string-drop source-file-name
 459                               (+ (string-length (%store-prefix)) 1)))
 460            (dash (string-index sans #\-)))
 461       (string-drop sans (+ 1 dash))))
 462
 463   (define (numeric-extension? file-name)
 464     ;; Return true if FILE-NAME ends with digits.
 465     (and=> (file-extension file-name)
 466            (cut string-every char-set:hex-digit <>)))
 467
 468   (define (tarxz-name file-name)
 469     ;; Return a '.tar.xz' file name based on FILE-NAME.
 470     (let ((base (if (numeric-extension? file-name)
 471                     original-file-name
 472                     (file-sans-extension file-name))))
 473       (string-append base
 474                      (if (equal? (file-extension base) "tar")
 475                          ".xz"
 476                          ".tar.xz"))))
 477
 478   (define instantiate-patch
 479     (match-lambda
 480       ((? string? patch)
 481        (interned-file patch #:recursive? #t))
 482       ((? origin? patch)
 483        (origin->derivation patch system))))
 484
 485   (mlet %store-monad ((tar ->     (lookup-input "tar"))
 486                       (xz ->      (lookup-input "xz"))
 487                       (patch ->   (lookup-input "patch"))
 488                       (locales -> (lookup-input "locales"))
 489                       (decomp ->  (lookup-input decompression-type))
 490                       (patches    (sequence %store-monad
 491                                             (map instantiate-patch patches))))
 492     (define build
 493       (with-imported-modules '((guix build utils))
 494         #~(begin
 495             (use-modules (ice-9 ftw)
 496                          (srfi srfi-1)
 497                          (guix build utils))
 498
 499             ;; The --sort option was added to GNU tar in version 1.28, released
 500             ;; 2014-07-28.  During bootstrap we must cope with older versions.
 501             (define tar-supports-sort?
 502               (zero? (system* (string-append #+tar "/bin/tar")
 503                               "cf" "/dev/null" "--files-from=/dev/null"
 504                               "--sort=name")))
 505
 506             (define (apply-patch patch)
 507               (format (current-error-port) "applying '~a'...~%" patch)
 508
 509               ;; Use '--force' so that patches that do not apply perfectly are
 510               ;; rejected.  Use '--no-backup-if-mismatch' to prevent making
 511               ;; "*.orig" file if a patch is applied with offset.
 512               (zero? (system* (string-append #+patch "/bin/patch")
 513                               "--force" "--no-backup-if-mismatch"
 514                               #+@flags "--input" patch)))
 515
 516             (define (first-file directory)
 517               ;; Return the name of the first file in DIRECTORY.
 518               (car (scandir directory
 519                             (lambda (name)
 520                               (not (member name '("." "..")))))))
 521
 522             ;; Encoding/decoding errors shouldn't be silent.
 523             (fluid-set! %default-port-conversion-strategy 'error)
 524
 525             (when #+locales
 526               ;; First of all, install a UTF-8 locale so that UTF-8 file names
 527               ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
 528               (setenv "LOCPATH"
 529                       (string-append #+locales "/lib/locale/"
 530                                      #+(and locales
 531                                             (package-version locales))))
 532               (setlocale LC_ALL "en_US.utf8"))
 533
 534             (setenv "PATH" (string-append #+xz "/bin" ":"
 535                                           #+decomp "/bin"))
 536
 537             ;; SOURCE may be either a directory or a tarball.
 538             (and (if (file-is-directory? #+source)
 539                      (let* ((store     (%store-directory))
 540                             (len       (+ 1 (string-length store)))
 541                             (base      (string-drop #+source len))
 542                             (dash      (string-index base #\-))
 543                             (directory (string-drop base (+ 1 dash))))
 544                        (mkdir directory)
 545                        (copy-recursively #+source directory)
 546                        #t)
 547                      #+(if (string=? decompression-type "unzip")
 548                            #~(zero? (system* "unzip" #+source))
 549                            #~(zero? (system* (string-append #+tar "/bin/tar")
 550                                              "xvf" #+source))))
 551                  (let ((directory (first-file ".")))
 552                    (format (current-error-port)
 553                            "source is under '~a'~%" directory)
 554                    (chdir directory)
 555
 556                    (and (every apply-patch '#+patches)
 557                         #+@(if snippet
 558                                #~((let ((module (make-fresh-user-module)))
 559                                     (module-use-interfaces!
 560                                      module
 561                                      (map resolve-interface '#+modules))
 562                                     ((@ (system base compile) compile)
 563                                      '#+snippet
 564                                      #:to 'value
 565                                      #:opts %auto-compilation-options
 566                                      #:env module)))
 567                                #~())
 568
 569                         (begin (chdir "..") #t)
 570
 571                         (unless tar-supports-sort?
 572                           (call-with-output-file ".file_list"
 573                             (lambda (port)
 574                               (for-each (lambda (name)
 575                                           (format port "~a~%" name))
 576                                         (find-files directory
 577                                                     #:directories? #t
 578                                                     #:fail-on-error? #t)))))
 579                         (zero? (apply system*
 580                                       (string-append #+tar "/bin/tar")
 581                                       "cvf" #$output
 582                                       ;; The bootstrap xz does not support
 583                                       ;; threaded compression (introduced in
 584                                       ;; 5.2.0), but it ignores the extra flag.
 585                                       (string-append "--use-compress-program="
 586                                                      #+xz "/bin/xz --threads=0")
 587                                       ;; avoid non-determinism in the archive
 588                                       "--mtime=@0"
 589                                       "--owner=root:0"
 590                                       "--group=root:0"
 591                                       (if tar-supports-sort?
 592                                           `("--sort=name"
 593                                             ,directory)
 594                                           '("--no-recursion"
 595                                             "--files-from=.file_list"))))))))))
 596
 597     (let ((name (tarxz-name original-file-name)))
 598       (gexp->derivation name build
 599                         #:graft? #f
 600                         #:system system
 601                         #:guile-for-build guile-for-build))))
 602
 603 (define (transitive-inputs inputs)
 604   "Return the closure of INPUTS when considering the 'propagated-inputs'
 605 edges.  Omit duplicate inputs, except for those already present in INPUTS
 606 itself.
 607
 608 This is implemented as a breadth-first traversal such that INPUTS is
 609 preserved, and only duplicate propagated inputs are removed."
 610   (define (seen? seen item outputs)
 611     (match (vhash-assq item seen)
 612       ((_ . o) (equal? o outputs))
 613       (_       #f)))
 614
 615   (let loop ((inputs     inputs)
 616              (result     '())
 617              (propagated '())
 618              (first?     #t)
 619              (seen       vlist-null))
 620     (match inputs
 621       (()
 622        (if (null? propagated)
 623            (reverse result)
 624            (loop (reverse (concatenate propagated)) result '() #f seen)))
 625       (((and input (label (? package? package) outputs ...)) rest ...)
 626        (if (and (not first?) (seen? seen package outputs))
 627            (loop rest result propagated first? seen)
 628            (loop rest
 629                  (cons input result)
 630                  (cons (package-propagated-inputs package) propagated)
 631                  first?
 632                  (vhash-consq package outputs seen))))
 633       ((input rest ...)
 634        (loop rest (cons input result) propagated first? seen)))))
 635
 636 (define (package-direct-sources package)
 637   "Return all source origins associated with PACKAGE; including origins in
 638 PACKAGE's inputs."
 639   `(,@(or (and=> (package-source package) list) '())
 640     ,@(filter-map (match-lambda
 641                    ((_ (? origin? orig) _ ...)
 642                     orig)
 643                    (_ #f))
 644                   (package-direct-inputs package))))
 645
 646 (define (package-transitive-sources package)
 647   "Return PACKAGE's direct sources, and their direct sources, recursively."
 648   (delete-duplicates
 649    (concatenate (filter-map (match-lambda
 650                              ((_ (? origin? orig) _ ...)
 651                               (list orig))
 652                              ((_ (? package? p) _ ...)
 653                               (package-direct-sources p))
 654                              (_ #f))
 655                             (bag-transitive-inputs
 656                              (package->bag package))))))
 657
 658 (define (package-direct-inputs package)
 659   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 660 with their propagated inputs."
 661   (append (package-native-inputs package)
 662           (package-inputs package)
 663           (package-propagated-inputs package)))
 664
 665 (define (package-transitive-inputs package)
 666   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 667 with their propagated inputs, recursively."
 668   (transitive-inputs (package-direct-inputs package)))
 669
 670 (define (package-transitive-target-inputs package)
 671   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 672 along with their propagated inputs, recursively.  This only includes inputs
 673 for the target system, and not native inputs."
 674   (transitive-inputs (append (package-inputs package)
 675                              (package-propagated-inputs package))))
 676
 677 (define (package-transitive-native-inputs package)
 678   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 679 along with their propagated inputs, recursively.  This only includes inputs
 680 for the host system (\"native inputs\"), and not target inputs."
 681   (transitive-inputs (package-native-inputs package)))
 682
 683 (define (package-transitive-propagated-inputs package)
 684   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 685 recursively."
 686   (transitive-inputs (package-propagated-inputs package)))
 687
 688 (define (package-transitive-native-search-paths package)
 689   "Return the list of search paths for PACKAGE and its propagated inputs,
 690 recursively."
 691   (append (package-native-search-paths package)
 692           (append-map (match-lambda
 693                         ((label (? package? p) _ ...)
 694                          (package-native-search-paths p))
 695                         (_
 696                          '()))
 697                       (package-transitive-propagated-inputs package))))
 698
 699 (define (transitive-input-references alist inputs)
 700   "Return a list of (assoc-ref ALIST <label>) for each (<label> <package> . _)
 701 in INPUTS and their transitive propagated inputs."
 702   (define label
 703     (match-lambda
 704       ((label . _)
 705        label)))
 706
 707   (map (lambda (input)
 708          `(assoc-ref ,alist ,(label input)))
 709        (transitive-inputs inputs)))
 710
 711 (define package-transitive-supported-systems
 712   (mlambdaq (package)
 713     "Return the intersection of the systems supported by PACKAGE and those
 714 supported by its dependencies."
 715     (fold (lambda (input systems)
 716             (match input
 717               ((label (? package? p) . _)
 718                (lset-intersection
 719                 string=? systems (package-transitive-supported-systems p)))
 720               (_
 721                systems)))
 722           (package-supported-systems package)
 723           (bag-direct-inputs (package->bag package)))))
 724
 725 (define* (supported-package? package #:optional (system (%current-system)))
 726   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
 727 dependencies are known to build on SYSTEM."
 728   (member system (package-transitive-supported-systems package)))
 729
 730 (define (bag-direct-inputs bag)
 731   "Same as 'package-direct-inputs', but applied to a bag."
 732   (append (bag-build-inputs bag)
 733           (bag-host-inputs bag)
 734           (bag-target-inputs bag)))
 735
 736 (define (bag-transitive-inputs bag)
 737   "Same as 'package-transitive-inputs', but applied to a bag."
 738   (transitive-inputs (bag-direct-inputs bag)))
 739
 740 (define (bag-transitive-build-inputs bag)
 741   "Same as 'package-transitive-native-inputs', but applied to a bag."
 742   (transitive-inputs (bag-build-inputs bag)))
 743
 744 (define (bag-transitive-host-inputs bag)
 745   "Same as 'package-transitive-target-inputs', but applied to a bag."
 746   (transitive-inputs (bag-host-inputs bag)))
 747
 748 (define (bag-transitive-target-inputs bag)
 749   "Return the \"target inputs\" of BAG, recursively."
 750   (transitive-inputs (bag-target-inputs bag)))
 751
 752 (define* (package-mapping proc #:optional (cut? (const #f)))
 753   "Return a procedure that, given a package, applies PROC to all the packages
 754 depended on and returns the resulting package.  The procedure stops recursion
 755 when CUT? returns true for a given package."
 756   (define (rewrite input)
 757     (match input
 758       ((label (? package? package) outputs ...)
 759        (let ((proc (if (cut? package) proc replace)))
 760          (cons* label (proc package) outputs)))
 761       (_
 762        input)))
 763
 764   (define replace
 765     (mlambdaq (p)
 766       ;; Return a variant of P with PROC applied to P and its explicit
 767       ;; dependencies, recursively.  Memoize the transformations.  Failing to
 768       ;; do that, we would build a huge object graph with lots of duplicates,
 769       ;; which in turns prevents us from benefiting from memoization in
 770       ;; 'package-derivation'.
 771       (let ((p (proc p)))
 772         (package
 773           (inherit p)
 774           (location (package-location p))
 775           (inputs (map rewrite (package-inputs p)))
 776           (native-inputs (map rewrite (package-native-inputs p)))
 777           (propagated-inputs (map rewrite (package-propagated-inputs p)))))))
 778
 779   replace)
 780
 781 (define* (package-input-rewriting replacements
 782                                   #:optional (rewrite-name identity))
 783   "Return a procedure that, when passed a package, replaces its direct and
 784 indirect dependencies (but not its implicit inputs) according to REPLACEMENTS.
 785 REPLACEMENTS is a list of package pairs; the first element of each pair is the
 786 package to replace, and the second one is the replacement.
 787
 788 Optionally, REWRITE-NAME is a one-argument procedure that takes the name of a
 789 package and returns its new name after rewrite."
 790   (define (rewrite p)
 791     (match (assq-ref replacements p)
 792       (#f  (package
 793              (inherit p)
 794              (name (rewrite-name (package-name p)))))
 795       (new new)))
 796
 797   (package-mapping rewrite (cut assq <> replacements)))
 798
 799 (define-syntax-rule (package/inherit p overrides ...)
 800   "Like (package (inherit P) OVERRIDES ...), except that the same
 801 transformation is done to the package replacement, if any.  P must be a bare
 802 identifier, and will be bound to either P or its replacement when evaluating
 803 OVERRIDES."
 804   (let loop ((p p))
 805     (package (inherit p)
 806       overrides ...
 807       (replacement (and=> (package-replacement p) loop)))))
 808
 809 \f
 810 ;;;
 811 ;;; Package derivations.
 812 ;;;
 813
 814 (define %derivation-cache
 815   ;; Package to derivation-path mapping.
 816   (make-weak-key-hash-table 100))
 817
 818 (define (cache! cache package system thunk)
 819   "Memoize in CACHE the return values of THUNK as the derivation of PACKAGE on
 820 SYSTEM."
 821   ;; FIXME: This memoization should be associated with the open store, because
 822   ;; otherwise it breaks when switching to a different store.
 823   (let ((vals (call-with-values thunk list)))
 824     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 825     ;; same value for all structs (as of Guile 2.0.6), and because pointer
 826     ;; equality is sufficient in practice.
 827     (hashq-set! cache package
 828                 `((,system ,@vals)
 829                   ,@(or (hashq-ref cache package) '())))
 830     (apply values vals)))
 831
 832 (define-syntax cached
 833   (syntax-rules (=>)
 834     "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 835 Return the cached result when available."
 836     ((_ (=> cache) package system body ...)
 837      (let ((thunk (lambda () body ...))
 838            (key   system))
 839        (match (hashq-ref cache package)
 840          ((alist (... ...))
 841           (match (assoc-ref alist key)
 842             ((vals (... ...))
 843              (apply values vals))
 844             (#f
 845              (cache! cache package key thunk))))
 846          (#f
 847           (cache! cache package key thunk)))))
 848     ((_ package system body ...)
 849      (cached (=> %derivation-cache) package system body ...))))
 850
 851 (define* (expand-input store package input system #:optional cross-system)
 852   "Expand INPUT, an input tuple, such that it contains only references to
 853 derivation paths or store paths.  PACKAGE is only used to provide contextual
 854 information in exceptions."
 855   (define (intern file)
 856     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 857     ;; file permissions are preserved.
 858     (add-to-store store (basename file) #t "sha256" file))
 859
 860   (define derivation
 861     (if cross-system
 862         (cut package-cross-derivation store <> cross-system system
 863              #:graft? #f)
 864         (cut package-derivation store <> system #:graft? #f)))
 865
 866   (match input
 867     (((? string? name) (? package? package))
 868      (list name (derivation package)))
 869     (((? string? name) (? package? package)
 870       (? string? sub-drv))
 871      (list name (derivation package)
 872            sub-drv))
 873     (((? string? name)
 874       (and (? string?) (? derivation-path?) drv))
 875      (list name drv))
 876     (((? string? name)
 877       (and (? string?) (? file-exists? file)))
 878      ;; Add FILE to the store.  When FILE is in the sub-directory of a
 879      ;; store path, it needs to be added anyway, so it can be used as a
 880      ;; source.
 881      (list name (intern file)))
 882     (((? string? name) (? struct? source))
 883      ;; 'package-source-derivation' calls 'lower-object', which can throw
 884      ;; '&gexp-input-error'.  However '&gexp-input-error' lacks source
 885      ;; location info, so we catch and rethrow here (XXX: not optimal
 886      ;; performance-wise).
 887      (guard (c ((gexp-input-error? c)
 888                 (raise (condition
 889                         (&package-input-error
 890                          (package package)
 891                          (input   (gexp-error-invalid-input c)))))))
 892        (list name (package-source-derivation store source system))))
 893     (x
 894      (raise (condition (&package-input-error
 895                         (package package)
 896                         (input   x)))))))
 897
 898 (define %bag-cache
 899   ;; 'eq?' cache mapping packages to system+target+graft?-dependent bags.
 900   ;; It significantly speeds things up when doing repeated calls to
 901   ;; 'package->bag' as is the case when building a profile.
 902   (make-weak-key-hash-table 200))
 903
 904 (define* (package->bag package #:optional
 905                        (system (%current-system))
 906                        (target (%current-target-system))
 907                        #:key (graft? (%graft?)))
 908   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
 909 and return it."
 910   (cached (=> %bag-cache)
 911           package (list system target graft?)
 912           ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked
 913           ;; field values can refer to it.
 914           (parameterize ((%current-system system)
 915                          (%current-target-system target))
 916             (match (if graft?
 917                        (or (package-replacement package) package)
 918                        package)
 919               (($ <package> name version source build-system
 920                             args inputs propagated-inputs native-inputs
 921                             self-native-input? outputs)
 922                (or (make-bag build-system (string-append name "-" version)
 923                              #:system system
 924                              #:target target
 925                              #:source source
 926                              #:inputs (append (inputs)
 927                                               (propagated-inputs))
 928                              #:outputs outputs
 929                              #:native-inputs `(,@(if (and target
 930                                                           self-native-input?)
 931                                                      `(("self" ,package))
 932                                                      '())
 933                                                ,@(native-inputs))
 934                              #:arguments (args))
 935                    (raise (if target
 936                               (condition
 937                                (&package-cross-build-system-error
 938                                 (package package)))
 939                               (condition
 940                                (&package-error
 941                                 (package package)))))))))))
 942
 943 (define %graft-cache
 944   ;; 'eq?' cache mapping package objects to a graft corresponding to their
 945   ;; replacement package.
 946   (make-weak-key-hash-table 200))
 947
 948 (define (input-graft store system)
 949   "Return a procedure that, given a package with a graft, returns a graft, and
 950 #f otherwise."
 951   (match-lambda
 952     ((? package? package)
 953      (let ((replacement (package-replacement package)))
 954        (and replacement
 955             (cached (=> %graft-cache) package system
 956                     (let ((orig (package-derivation store package system
 957                                                     #:graft? #f))
 958                           (new  (package-derivation store replacement system
 959                                                     #:graft? #t)))
 960                       (graft
 961                         (origin orig)
 962                         (replacement new)))))))
 963     (x
 964      #f)))
 965
 966 (define (input-cross-graft store target system)
 967   "Same as 'input-graft', but for cross-compilation inputs."
 968   (match-lambda
 969     ((? package? package)
 970     (let ((replacement (package-replacement package)))
 971       (and replacement
 972            (let ((orig (package-cross-derivation store package target system
 973                                                  #:graft? #f))
 974                  (new  (package-cross-derivation store replacement
 975                                                  target system
 976                                                  #:graft? #t)))
 977              (graft
 978                (origin orig)
 979                (replacement new))))))
 980    (_
 981     #f)))
 982
 983 (define* (fold-bag-dependencies proc seed bag
 984                                 #:key (native? #t))
 985   "Fold PROC over the packages BAG depends on.  Each package is visited only
 986 once, in depth-first order.  If NATIVE? is true, restrict to native
 987 dependencies; otherwise, restrict to target dependencies."
 988   (define nodes
 989     (match (if native?
 990                (append (bag-build-inputs bag)
 991                        (bag-target-inputs bag)
 992                        (if (bag-target bag)
 993                            '()
 994                            (bag-host-inputs bag)))
 995                (bag-host-inputs bag))
 996       (((labels things _ ...) ...)
 997        things)))
 998
 999   (let loop ((nodes nodes)
1000              (result seed)
1001              (visited (setq)))
1002     (match nodes
1003       (()
1004        result)
1005       (((? package? head) . tail)
1006        (if (set-contains? visited head)
1007            (loop tail result visited)
1008            (let ((inputs (bag-direct-inputs (package->bag head))))
1009              (loop (match inputs
1010                      (((labels things _ ...) ...)
1011                       (append things tail)))
1012                    (proc head result)
1013                    (set-insert head visited)))))
1014       ((head . tail)
1015        (loop tail result visited)))))
1016
1017 (define* (bag-grafts store bag)
1018   "Return the list of grafts potentially applicable to BAG.  Potentially
1019 applicable grafts are collected by looking at direct or indirect dependencies
1020 of BAG that have a 'replacement'.  Whether a graft is actually applicable
1021 depends on whether the outputs of BAG depend on the items the grafts refer
1022 to (see 'graft-derivation'.)"
1023   (define system (bag-system bag))
1024   (define target (bag-target bag))
1025
1026   (define native-grafts
1027     (let ((->graft (input-graft store system)))
1028       (fold-bag-dependencies (lambda (package grafts)
1029                                (match (->graft package)
1030                                  (#f    grafts)
1031                                  (graft (cons graft grafts))))
1032                              '()
1033                              bag)))
1034
1035   (define target-grafts
1036     (if target
1037         (let ((->graft (input-cross-graft store target system)))
1038           (fold-bag-dependencies (lambda (package grafts)
1039                                    (match (->graft package)
1040                                      (#f    grafts)
1041                                      (graft (cons graft grafts))))
1042                                  '()
1043                                  bag
1044                                  #:native? #f))
1045         '()))
1046
1047   ;; We can end up with several identical grafts if we stumble upon packages
1048   ;; that are not 'eq?' but map to the same derivation (this can happen when
1049   ;; using things like 'package-with-explicit-inputs'.)  Hence the
1050   ;; 'delete-duplicates' call.
1051   (delete-duplicates
1052    (append native-grafts target-grafts)))
1053
1054 (define* (package-grafts store package
1055                          #:optional (system (%current-system))
1056                          #:key target)
1057   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
1058 TARGET."
1059   (let* ((package (or (package-replacement package) package))
1060          (bag     (package->bag package system target)))
1061     (bag-grafts store bag)))
1062
1063 (define* (bag->derivation store bag
1064                           #:optional context)
1065   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
1066 a package object describing the context in which the call occurs, for improved
1067 error reporting."
1068   (if (bag-target bag)
1069       (bag->cross-derivation store bag)
1070       (let* ((system     (bag-system bag))
1071              (inputs     (bag-transitive-inputs bag))
1072              (input-drvs (map (cut expand-input store context <> system)
1073                               inputs))
1074              (paths      (delete-duplicates
1075                           (append-map (match-lambda
1076                                        ((_ (? package? p) _ ...)
1077                                         (package-native-search-paths
1078                                          p))
1079                                        (_ '()))
1080                                       inputs))))
1081
1082         (apply (bag-build bag)
1083                store (bag-name bag) input-drvs
1084                #:search-paths paths
1085                #:outputs (bag-outputs bag) #:system system
1086                (bag-arguments bag)))))
1087
1088 (define* (bag->cross-derivation store bag
1089                                 #:optional context)
1090   "Return the derivation to build BAG, which is actually a cross build.
1091 Optionally, CONTEXT can be a package object denoting the context of the call.
1092 This is an internal procedure."
1093   (let* ((system      (bag-system bag))
1094          (target      (bag-target bag))
1095          (host        (bag-transitive-host-inputs bag))
1096          (host-drvs   (map (cut expand-input store context <> system target)
1097                            host))
1098          (target*     (bag-transitive-target-inputs bag))
1099          (target-drvs (map (cut expand-input store context <> system)
1100                            target*))
1101          (build       (bag-transitive-build-inputs bag))
1102          (build-drvs  (map (cut expand-input store context <> system)
1103                            build))
1104          (all         (append build target* host))
1105          (paths       (delete-duplicates
1106                        (append-map (match-lambda
1107                                     ((_ (? package? p) _ ...)
1108                                      (package-search-paths p))
1109                                     (_ '()))
1110                                    all)))
1111          (npaths      (delete-duplicates
1112                        (append-map (match-lambda
1113                                     ((_ (? package? p) _ ...)
1114                                      (package-native-search-paths
1115                                       p))
1116                                     (_ '()))
1117                                    all))))
1118
1119     (apply (bag-build bag)
1120            store (bag-name bag)
1121            #:native-drvs build-drvs
1122            #:target-drvs (append host-drvs target-drvs)
1123            #:search-paths paths
1124            #:native-search-paths npaths
1125            #:outputs (bag-outputs bag)
1126            #:system system #:target target
1127            (bag-arguments bag))))
1128
1129 (define* (package-derivation store package
1130                              #:optional (system (%current-system))
1131                              #:key (graft? (%graft?)))
1132   "Return the <derivation> object of PACKAGE for SYSTEM."
1133
1134   ;; Compute the derivation and cache the result.  Caching is important
1135   ;; because some derivations, such as the implicit inputs of the GNU build
1136   ;; system, will be queried many, many times in a row.
1137   (cached package (cons system graft?)
1138           (let* ((bag (package->bag package system #f #:graft? graft?))
1139                  (drv (bag->derivation store bag package)))
1140             (if graft?
1141                 (match (bag-grafts store bag)
1142                   (()
1143                    drv)
1144                   (grafts
1145                    (let ((guile (package-derivation store (default-guile)
1146                                                     system #:graft? #f)))
1147                      ;; TODO: As an optimization, we can simply graft the tip
1148                      ;; of the derivation graph since 'graft-derivation'
1149                      ;; recurses anyway.
1150                      (graft-derivation store drv grafts
1151                                        #:system system
1152                                        #:guile guile))))
1153                 drv))))
1154
1155 (define* (package-cross-derivation store package target
1156                                    #:optional (system (%current-system))
1157                                    #:key (graft? (%graft?)))
1158   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
1159 system identifying string)."
1160   (cached package (list system target graft?)
1161           (let* ((bag (package->bag package system target #:graft? graft?))
1162                  (drv (bag->derivation store bag package)))
1163             (if graft?
1164                 (match (bag-grafts store bag)
1165                   (()
1166                    drv)
1167                   (grafts
1168                    (graft-derivation store drv grafts
1169                                      #:system system
1170                                      #:guile
1171                                      (package-derivation store (default-guile)
1172                                                          system #:graft? #f))))
1173                 drv))))
1174
1175 (define* (package-output store package
1176                          #:optional (output "out") (system (%current-system)))
1177   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
1178 symbolic output name, such as \"out\".  Note that this procedure calls
1179 `package-derivation', which is costly."
1180   (let ((drv (package-derivation store package system)))
1181     (derivation->output-path drv output)))
1182
1183 \f
1184 ;;;
1185 ;;; Monadic interface.
1186 ;;;
1187
1188 (define (set-guile-for-build guile)
1189   "This monadic procedure changes the Guile currently used to run the build
1190 code of derivations to GUILE, a package object."
1191   (lambda (store)
1192     (let ((guile (package-derivation store guile)))
1193       (values (%guile-for-build guile) store))))
1194
1195 (define* (package-file package
1196                        #:optional file
1197                        #:key
1198                        system (output "out") target)
1199   "Return as a monadic value the absolute file name of FILE within the
1200 OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
1201 OUTPUT directory of PACKAGE.  When TARGET is true, use it as a
1202 cross-compilation target triplet."
1203   (lambda (store)
1204     (define compute-derivation
1205       (if target
1206           (cut package-cross-derivation <> <> target <>)
1207           package-derivation))
1208
1209     (let* ((system (or system (%current-system)))
1210            (drv    (compute-derivation store package system))
1211            (out    (derivation->output-path drv output)))
1212       (values (if file
1213                   (string-append out "/" file)
1214                   out)
1215               store))))
1216
1217 (define package->derivation
1218   (store-lift package-derivation))
1219
1220 (define package->cross-derivation
1221   (store-lift package-cross-derivation))
1222
1223 (define-gexp-compiler (package-compiler (package <package>) system target)
1224   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1225   ;; TARGET.  This is used when referring to a package from within a gexp.
1226   (if target
1227       (package->cross-derivation package target system)
1228       (package->derivation package system)))
1229
1230 (define* (origin->derivation origin
1231                              #:optional (system (%current-system)))
1232   "Return the derivation corresponding to ORIGIN."
1233   (match origin
1234     (($ <origin> uri method sha256 name (= force ()) #f)
1235      ;; No patches, no snippet: this is a fixed-output derivation.
1236      (method uri 'sha256 sha256 name #:system system))
1237     (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1238         (flags ...) inputs (modules ...) guile-for-build)
1239      ;; Patches and/or a snippet.
1240      (mlet %store-monad ((source (method uri 'sha256 sha256 name
1241                                          #:system system))
1242                          (guile  (package->derivation (or guile-for-build
1243                                                           (default-guile))
1244                                                       system
1245                                                       #:graft? #f)))
1246        (patch-and-repack source patches
1247                          #:inputs inputs
1248                          #:snippet snippet
1249                          #:flags flags
1250                          #:system system
1251                          #:modules modules
1252                          #:guile-for-build guile)))))
1253
1254 (define-gexp-compiler (origin-compiler (origin <origin>) system target)
1255   ;; Compile ORIGIN to a derivation for SYSTEM.  This is used when referring
1256   ;; to an origin from within a gexp.
1257   (origin->derivation origin system))
1258
1259 (define package-source-derivation                 ;somewhat deprecated
1260   (let ((lower (store-lower lower-object)))
1261     (lambda* (store source #:optional (system (%current-system)))
1262       "Return the derivation or file corresponding to SOURCE, which can be an
1263 a file name or any object handled by 'lower-object', such as an <origin>.
1264 When SOURCE is a file name, return either the interned file name (if SOURCE is
1265 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1266       (match source
1267         ((and (? string?) (? direct-store-path?) file)
1268          file)
1269         ((? string? file)
1270          (add-to-store store (basename file) #t "sha256" file))
1271         (_
1272          (lower store source system))))))