guix/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix packages)
  21   #:use-module (guix utils)
  22   #:use-module (guix records)
  23   #:use-module (guix store)
  24   #:use-module (guix monads)
  25   #:use-module (guix gexp)
  26   #:use-module (guix base32)
  27   #:use-module (guix derivations)
  28   #:use-module (guix build-system)
  29   #:use-module (guix search-paths)
  30   #:use-module (guix gexp)
  31   #:use-module (ice-9 match)
  32   #:use-module (ice-9 vlist)
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-9 gnu)
  35   #:use-module (srfi srfi-11)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-34)
  38   #:use-module (srfi srfi-35)
  39   #:re-export (%current-system
  40                %current-target-system
  41                search-path-specification)         ;for convenience
  42   #:export (origin
  43             origin?
  44             origin-uri
  45             origin-method
  46             origin-sha256
  47             origin-file-name
  48             origin-patches
  49             origin-patch-flags
  50             origin-patch-inputs
  51             origin-patch-guile
  52             origin-snippet
  53             origin-modules
  54             origin-imported-modules
  55             base32
  56
  57             package
  58             package?
  59             package-name
  60             package-version
  61             package-full-name
  62             package-source
  63             package-build-system
  64             package-arguments
  65             package-inputs
  66             package-native-inputs
  67             package-propagated-inputs
  68             package-outputs
  69             package-native-search-paths
  70             package-search-paths
  71             package-replacement
  72             package-synopsis
  73             package-description
  74             package-license
  75             package-home-page
  76             package-supported-systems
  77             package-maintainers
  78             package-properties
  79             package-location
  80             package-field-location
  81
  82             package-direct-sources
  83             package-transitive-sources
  84             package-direct-inputs
  85             package-transitive-inputs
  86             package-transitive-target-inputs
  87             package-transitive-native-inputs
  88             package-transitive-propagated-inputs
  89             package-transitive-supported-systems
  90             package-source-derivation
  91             package-derivation
  92             package-cross-derivation
  93             package-output
  94             package-grafts
  95
  96             %supported-systems
  97             %hurd-systems
  98             %hydra-supported-systems
  99             supported-package?
 100
 101             &package-error
 102             package-error?
 103             package-error-package
 104             &package-input-error
 105             package-input-error?
 106             package-error-invalid-input
 107             &package-cross-build-system-error
 108             package-cross-build-system-error?
 109
 110             package->bag
 111             bag->derivation
 112             bag-direct-inputs
 113             bag-transitive-inputs
 114             bag-transitive-host-inputs
 115             bag-transitive-build-inputs
 116             bag-transitive-target-inputs
 117
 118             default-guile
 119             default-guile-derivation
 120             set-guile-for-build
 121             package-file
 122             package->derivation
 123             package->cross-derivation
 124             origin->derivation))
 125
 126 ;;; Commentary:
 127 ;;;
 128 ;;; This module provides a high-level mechanism to define packages in a
 129 ;;; Guix-based distribution.
 130 ;;;
 131 ;;; Code:
 132
 133 ;; The source of a package, such as a tarball URL and fetcher---called
 134 ;; "origin" to avoid name clash with `package-source', `source', etc.
 135 (define-record-type* <origin>
 136   origin make-origin
 137   origin?
 138   (uri       origin-uri)                          ; string
 139   (method    origin-method)                       ; procedure
 140   (sha256    origin-sha256)                       ; bytevector
 141   (file-name origin-file-name (default #f))       ; optional file name
 142
 143   ;; Patches are delayed so that the 'search-patch' calls are made lazily,
 144   ;; which reduces I/O on startup and allows patch-not-found errors to be
 145   ;; gracefully handled at run time.
 146   (patches   origin-patches                       ; list of file names
 147              (default '()) (delayed))
 148
 149   (snippet   origin-snippet (default #f))         ; sexp or #f
 150   (patch-flags  origin-patch-flags                ; list of strings
 151                 (default '("-p1")))
 152
 153   ;; Patching requires Guile, GNU Patch, and a few more.  These two fields are
 154   ;; used to specify these dependencies when needed.
 155   (patch-inputs origin-patch-inputs               ; input list or #f
 156                 (default #f))
 157   (modules      origin-modules                    ; list of module names
 158                 (default '()))
 159   (imported-modules origin-imported-modules       ; list of module names
 160                     (default '()))
 161   (patch-guile origin-patch-guile                 ; package or #f
 162                (default #f)))
 163
 164 (define (print-origin origin port)
 165   "Write a concise representation of ORIGIN to PORT."
 166   (match origin
 167     (($ <origin> uri method sha256 file-name patches)
 168      (simple-format port "#<origin ~s ~a ~s ~a>"
 169                     uri (bytevector->base32-string sha256)
 170                     (force patches)
 171                     (number->string (object-address origin) 16)))))
 172
 173 (set-record-type-printer! <origin> print-origin)
 174
 175 (define-syntax base32
 176   (lambda (s)
 177     "Return the bytevector corresponding to the given Nix-base32
 178 representation."
 179     (syntax-case s ()
 180       ((_ str)
 181        (string? (syntax->datum #'str))
 182        ;; A literal string: do the conversion at expansion time.
 183        (with-syntax ((bv (nix-base32-string->bytevector
 184                           (syntax->datum #'str))))
 185          #''bv))
 186       ((_ str)
 187        #'(nix-base32-string->bytevector str)))))
 188
 189 (define %supported-systems
 190   ;; This is the list of system types that are supported.  By default, we
 191   ;; expect all packages to build successfully here.
 192   '("x86_64-linux" "i686-linux" "armhf-linux" "mips64el-linux"))
 193
 194 (define %hurd-systems
 195   ;; The GNU/Hurd systems for which support is being developed.
 196   '("i585-gnu" "i686-gnu"))
 197
 198 (define %hydra-supported-systems
 199   ;; This is the list of system types for which build slaves are available.
 200   %supported-systems)
 201
 202
 203 ;; A package.
 204 (define-record-type* <package>
 205   package make-package
 206   package?
 207   (name   package-name)                   ; string
 208   (version package-version)               ; string
 209   (source package-source)                 ; <origin> instance
 210   (build-system package-build-system)     ; build system
 211   (arguments package-arguments            ; arguments for the build method
 212              (default '()) (thunked))
 213
 214   (inputs package-inputs                  ; input packages or derivations
 215           (default '()) (thunked))
 216   (propagated-inputs package-propagated-inputs    ; same, but propagated
 217                      (default '()) (thunked))
 218   (native-inputs package-native-inputs    ; native input packages/derivations
 219                  (default '()) (thunked))
 220   (self-native-input? package-self-native-input?  ; whether to use itself as
 221                                                   ; a native input when cross-
 222                       (default #f))               ; compiling
 223
 224   (outputs package-outputs                ; list of strings
 225            (default '("out")))
 226
 227                                                   ; lists of
 228                                                   ; <search-path-specification>,
 229                                                   ; for native and cross
 230                                                   ; inputs
 231   (native-search-paths package-native-search-paths (default '()))
 232   (search-paths package-search-paths (default '()))
 233   (replacement package-replacement                ; package | #f
 234                (default #f) (thunked))
 235
 236   (synopsis package-synopsis)                    ; one-line description
 237   (description package-description)              ; one or two paragraphs
 238   (license package-license)
 239   (home-page package-home-page)
 240   (supported-systems package-supported-systems    ; list of strings
 241                      (default %supported-systems))
 242   (maintainers package-maintainers (default '()))
 243
 244   (properties package-properties (default '()))   ; alist for anything else
 245
 246   (location package-location
 247             (default (and=> (current-source-location)
 248                             source-properties->location))
 249             (innate)))
 250
 251 (set-record-type-printer! <package>
 252                           (lambda (package port)
 253                             (let ((loc    (package-location package))
 254                                   (format simple-format))
 255                               (format port "#<package ~a-~a ~a~a>"
 256                                       (package-name package)
 257                                       (package-version package)
 258                                       (if loc
 259                                           (format #f "~a:~a "
 260                                                   (location-file loc)
 261                                                   (location-line loc))
 262                                           "")
 263                                       (number->string (object-address
 264                                                        package)
 265                                                       16)))))
 266
 267 (define (package-field-location package field)
 268   "Return the source code location of the definition of FIELD for PACKAGE, or
 269 #f if it could not be determined."
 270   (define (goto port line column)
 271     (unless (and (= (port-column port) (- column 1))
 272                  (= (port-line port) (- line 1)))
 273       (unless (eof-object? (read-char port))
 274         (goto port line column))))
 275
 276   (match (package-location package)
 277     (($ <location> file line column)
 278      (catch 'system
 279        (lambda ()
 280          ;; In general we want to keep relative file names for modules.
 281          (with-fluids ((%file-port-name-canonicalization 'relative))
 282            (call-with-input-file (search-path %load-path file)
 283              (lambda (port)
 284                (goto port line column)
 285                (match (read port)
 286                  (('package inits ...)
 287                   (let ((field (assoc field inits)))
 288                     (match field
 289                       ((_ value)
 290                        ;; Put the `or' here, and not in the first argument of
 291                        ;; `and=>', to work around a compiler bug in 2.0.5.
 292                        (or (and=> (source-properties value)
 293                                   source-properties->location)
 294                            (and=> (source-properties field)
 295                                   source-properties->location)))
 296                       (_
 297                        #f))))
 298                  (_
 299                   #f))))))
 300        (lambda _
 301          #f)))
 302     (_ #f)))
 303
 304
 305 ;; Error conditions.
 306
 307 (define-condition-type &package-error &error
 308   package-error?
 309   (package package-error-package))
 310
 311 (define-condition-type &package-input-error &package-error
 312   package-input-error?
 313   (input package-error-invalid-input))
 314
 315 (define-condition-type &package-cross-build-system-error &package-error
 316   package-cross-build-system-error?)
 317
 318
 319 (define (package-full-name package)
 320   "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
 321   (string-append (package-name package) "-" (package-version package)))
 322
 323 (define (%standard-patch-inputs)
 324   (let* ((canonical (module-ref (resolve-interface '(gnu packages base))
 325                                 'canonical-package))
 326          (ref       (lambda (module var)
 327                       (canonical
 328                        (module-ref (resolve-interface module) var)))))
 329     `(("tar"   ,(ref '(gnu packages base) 'tar))
 330       ("xz"    ,(ref '(gnu packages compression) 'xz))
 331       ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
 332       ("gzip"  ,(ref '(gnu packages compression) 'gzip))
 333       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
 334       ("unzip" ,(ref '(gnu packages zip) 'unzip))
 335       ("patch" ,(ref '(gnu packages base) 'patch))
 336       ("locales" ,(ref '(gnu packages base) 'glibc-utf8-locales)))))
 337
 338 (define (default-guile)
 339   "Return the default Guile package used to run the build code of
 340 derivations."
 341   (let ((distro (resolve-interface '(gnu packages commencement))))
 342     (module-ref distro 'guile-final)))
 343
 344 (define* (default-guile-derivation #:optional (system (%current-system)))
 345   "Return the derivation for SYSTEM of the default Guile package used to run
 346 the build code of derivation."
 347   (package->derivation (default-guile) system
 348                        #:graft? #f))
 349
 350 (define* (patch-and-repack source patches
 351                            #:key
 352                            inputs
 353                            (snippet #f)
 354                            (flags '("-p1"))
 355                            (modules '())
 356                            (imported-modules '())
 357                            (guile-for-build (%guile-for-build))
 358                            (system (%current-system)))
 359   "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
 360 repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
 361 it must be an s-expression that will run from within the directory where
 362 SOURCE was unpacked, after all of PATCHES have been applied.  MODULES and
 363 IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
 364   (define source-file-name
 365     ;; SOURCE is usually a derivation, but it could be a store file.
 366     (if (derivation? source)
 367         (derivation->output-path source)
 368         source))
 369
 370   (define lookup-input
 371     ;; The default value of the 'patch-inputs' field, and thus INPUTS is #f,
 372     ;; so deal with that.
 373     (let ((inputs (or inputs (%standard-patch-inputs))))
 374       (lambda (name)
 375         (match (assoc-ref inputs name)
 376           ((package) package)
 377           (#f        #f)))))
 378
 379   (define decompression-type
 380     (cond ((string-suffix? "gz" source-file-name)  "gzip")
 381           ((string-suffix? "bz2" source-file-name) "bzip2")
 382           ((string-suffix? "lz" source-file-name)  "lzip")
 383           ((string-suffix? "zip" source-file-name) "unzip")
 384           (else "xz")))
 385
 386   (define original-file-name
 387     ;; Remove the store prefix plus the slash, hash, and hyphen.
 388     (let* ((sans (string-drop source-file-name
 389                               (+ (string-length (%store-prefix)) 1)))
 390            (dash (string-index sans #\-)))
 391       (string-drop sans (+ 1 dash))))
 392
 393   (define (numeric-extension? file-name)
 394     ;; Return true if FILE-NAME ends with digits.
 395     (and=> (file-extension file-name)
 396            (cut string-every char-set:hex-digit <>)))
 397
 398   (define (tarxz-name file-name)
 399     ;; Return a '.tar.xz' file name based on FILE-NAME.
 400     (let ((base (if (numeric-extension? file-name)
 401                     original-file-name
 402                     (file-sans-extension file-name))))
 403       (string-append base
 404                      (if (equal? (file-extension base) "tar")
 405                          ".xz"
 406                          ".tar.xz"))))
 407
 408   (define instantiate-patch
 409     (match-lambda
 410       ((? string? patch)
 411        (interned-file patch #:recursive? #t))
 412       ((? origin? patch)
 413        (origin->derivation patch system))))
 414
 415   (mlet %store-monad ((tar ->     (lookup-input "tar"))
 416                       (xz ->      (lookup-input "xz"))
 417                       (patch ->   (lookup-input "patch"))
 418                       (locales -> (lookup-input "locales"))
 419                       (decomp ->  (lookup-input decompression-type))
 420                       (patches    (sequence %store-monad
 421                                             (map instantiate-patch patches))))
 422     (define build
 423       #~(begin
 424           (use-modules (ice-9 ftw)
 425                        (srfi srfi-1)
 426                        (guix build utils))
 427
 428           ;; The --sort option was added to GNU tar in version 1.28, released
 429           ;; 2014-07-28.  During bootstrap we must cope with older versions.
 430           (define tar-supports-sort?
 431             (zero? (system* (string-append #+tar "/bin/tar")
 432                             "cf" "/dev/null" "--files-from=/dev/null"
 433                             "--sort=name")))
 434
 435           (define (apply-patch patch)
 436             (format (current-error-port) "applying '~a'...~%" patch)
 437
 438             ;; Use '--force' so that patches that do not apply perfectly are
 439             ;; rejected.
 440             (zero? (system* (string-append #+patch "/bin/patch")
 441                             "--force" #+@flags "--input" patch)))
 442
 443           (define (first-file directory)
 444             ;; Return the name of the first file in DIRECTORY.
 445             (car (scandir directory
 446                           (lambda (name)
 447                             (not (member name '("." "..")))))))
 448
 449           ;; Encoding/decoding errors shouldn't be silent.
 450           (fluid-set! %default-port-conversion-strategy 'error)
 451
 452           (when #+locales
 453             ;; First of all, install a UTF-8 locale so that UTF-8 file names
 454             ;; are correctly interpreted.  During bootstrap, LOCALES is #f.
 455             (setenv "LOCPATH" (string-append #+locales "/lib/locale"))
 456             (setlocale LC_ALL "en_US.UTF-8"))
 457
 458           (setenv "PATH" (string-append #+xz "/bin" ":"
 459                                         #+decomp "/bin"))
 460
 461           ;; SOURCE may be either a directory or a tarball.
 462           (and (if (file-is-directory? #+source)
 463                    (let* ((store     (%store-directory))
 464                           (len       (+ 1 (string-length store)))
 465                           (base      (string-drop #+source len))
 466                           (dash      (string-index base #\-))
 467                           (directory (string-drop base (+ 1 dash))))
 468                      (mkdir directory)
 469                      (copy-recursively #+source directory)
 470                      #t)
 471                    #+(if (string=? decompression-type "unzip")
 472                          #~(zero? (system* "unzip" #+source))
 473                          #~(zero? (system* (string-append #+tar "/bin/tar")
 474                                            "xvf" #+source))))
 475                (let ((directory (first-file ".")))
 476                  (format (current-error-port)
 477                          "source is under '~a'~%" directory)
 478                  (chdir directory)
 479
 480                  (and (every apply-patch '#+patches)
 481                       #+@(if snippet
 482                              #~((let ((module (make-fresh-user-module)))
 483                                   (module-use-interfaces! module
 484                                                           (map resolve-interface
 485                                                                '#+modules))
 486                                   ((@ (system base compile) compile)
 487                                    '#+snippet
 488                                    #:to 'value
 489                                    #:opts %auto-compilation-options
 490                                    #:env module)))
 491                              #~())
 492
 493                       (begin (chdir "..") #t)
 494
 495                       (unless tar-supports-sort?
 496                         (call-with-output-file ".file_list"
 497                           (lambda (port)
 498                             (for-each (lambda (name) (format port "~a~%" name))
 499                                       (find-files directory
 500                                                   #:directories? #t
 501                                                   #:fail-on-error? #t)))))
 502                       (zero? (apply system* (string-append #+tar "/bin/tar")
 503                                     "cvfa" #$output
 504                                     ;; avoid non-determinism in the archive
 505                                     "--mtime=@0"
 506                                     "--owner=root:0"
 507                                     "--group=root:0"
 508                                     (if tar-supports-sort?
 509                                         `("--sort=name"
 510                                           ,directory)
 511                                         '("--no-recursion"
 512                                           "--files-from=.file_list")))))))))
 513
 514     (let ((name    (tarxz-name original-file-name))
 515           (modules (delete-duplicates (cons '(guix build utils) modules))))
 516       (gexp->derivation name build
 517                         #:graft? #f
 518                         #:system system
 519                         #:modules modules
 520                         #:guile-for-build guile-for-build))))
 521
 522 (define (transitive-inputs inputs)
 523   "Return the closure of INPUTS when considering the 'propagated-inputs'
 524 edges.  Omit duplicate inputs, except for those already present in INPUTS
 525 itself.
 526
 527 This is implemented as a breadth-first traversal such that INPUTS is
 528 preserved, and only duplicate propagated inputs are removed."
 529   (define (seen? seen item outputs)
 530     (match (vhash-assq item seen)
 531       ((_ . o) (equal? o outputs))
 532       (_       #f)))
 533
 534   (let loop ((inputs     inputs)
 535              (result     '())
 536              (propagated '())
 537              (first?     #t)
 538              (seen       vlist-null))
 539     (match inputs
 540       (()
 541        (if (null? propagated)
 542            (reverse result)
 543            (loop (reverse (concatenate propagated)) result '() #f seen)))
 544       (((and input (label (? package? package) outputs ...)) rest ...)
 545        (if (and (not first?) (seen? seen package outputs))
 546            (loop rest result propagated first? seen)
 547            (loop rest
 548                  (cons input result)
 549                  (cons (package-propagated-inputs package) propagated)
 550                  first?
 551                  (vhash-consq package outputs seen))))
 552       ((input rest ...)
 553        (loop rest (cons input result) propagated first? seen)))))
 554
 555 (define (package-direct-sources package)
 556   "Return all source origins associated with PACKAGE; including origins in
 557 PACKAGE's inputs."
 558   `(,@(or (and=> (package-source package) list) '())
 559     ,@(filter-map (match-lambda
 560                    ((_ (? origin? orig) _ ...)
 561                     orig)
 562                    (_ #f))
 563                   (package-direct-inputs package))))
 564
 565 (define (package-transitive-sources package)
 566   "Return PACKAGE's direct sources, and their direct sources, recursively."
 567   (delete-duplicates
 568    (concatenate (filter-map (match-lambda
 569                              ((_ (? origin? orig) _ ...)
 570                               (list orig))
 571                              ((_ (? package? p) _ ...)
 572                               (package-direct-sources p))
 573                              (_ #f))
 574                             (bag-transitive-inputs
 575                              (package->bag package))))))
 576
 577 (define (package-direct-inputs package)
 578   "Return all the direct inputs of PACKAGE---i.e, its direct inputs along
 579 with their propagated inputs."
 580   (append (package-native-inputs package)
 581           (package-inputs package)
 582           (package-propagated-inputs package)))
 583
 584 (define (package-transitive-inputs package)
 585   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 586 with their propagated inputs, recursively."
 587   (transitive-inputs (package-direct-inputs package)))
 588
 589 (define (package-transitive-target-inputs package)
 590   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 591 along with their propagated inputs, recursively.  This only includes inputs
 592 for the target system, and not native inputs."
 593   (transitive-inputs (append (package-inputs package)
 594                              (package-propagated-inputs package))))
 595
 596 (define (package-transitive-native-inputs package)
 597   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 598 along with their propagated inputs, recursively.  This only includes inputs
 599 for the host system (\"native inputs\"), and not target inputs."
 600   (transitive-inputs (package-native-inputs package)))
 601
 602 (define (package-transitive-propagated-inputs package)
 603   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 604 recursively."
 605   (transitive-inputs (package-propagated-inputs package)))
 606
 607 (define-syntax define-memoized/v
 608   (lambda (form)
 609     "Define a memoized single-valued unary procedure with docstring.
 610 The procedure argument is compared to cached keys using `eqv?'."
 611     (syntax-case form ()
 612       ((_ (proc arg) docstring body body* ...)
 613        (string? (syntax->datum #'docstring))
 614        #'(define proc
 615            (let ((cache (make-hash-table)))
 616              (define (proc arg)
 617                docstring
 618                (match (hashv-get-handle cache arg)
 619                  ((_ . value)
 620                   value)
 621                  (_
 622                   (let ((result (let () body body* ...)))
 623                     (hashv-set! cache arg result)
 624                     result))))
 625              proc))))))
 626
 627 (define-memoized/v (package-transitive-supported-systems package)
 628   "Return the intersection of the systems supported by PACKAGE and those
 629 supported by its dependencies."
 630   (fold (lambda (input systems)
 631           (match input
 632             ((label (? package? p) . _)
 633              (lset-intersection
 634               string=? systems (package-transitive-supported-systems p)))
 635             (_
 636              systems)))
 637         (package-supported-systems package)
 638         (bag-direct-inputs (package->bag package))))
 639
 640 (define* (supported-package? package #:optional (system (%current-system)))
 641   "Return true if PACKAGE is supported on SYSTEM--i.e., if PACKAGE and all its
 642 dependencies are known to build on SYSTEM."
 643   (member system (package-transitive-supported-systems package)))
 644
 645 (define (bag-direct-inputs bag)
 646   "Same as 'package-direct-inputs', but applied to a bag."
 647   (append (bag-build-inputs bag)
 648           (bag-host-inputs bag)
 649           (bag-target-inputs bag)))
 650
 651 (define (bag-transitive-inputs bag)
 652   "Same as 'package-transitive-inputs', but applied to a bag."
 653   (transitive-inputs (bag-direct-inputs bag)))
 654
 655 (define (bag-transitive-build-inputs bag)
 656   "Same as 'package-transitive-native-inputs', but applied to a bag."
 657   (transitive-inputs (bag-build-inputs bag)))
 658
 659 (define (bag-transitive-host-inputs bag)
 660   "Same as 'package-transitive-target-inputs', but applied to a bag."
 661   (transitive-inputs (bag-host-inputs bag)))
 662
 663 (define (bag-transitive-target-inputs bag)
 664   "Return the \"target inputs\" of BAG, recursively."
 665   (transitive-inputs (bag-target-inputs bag)))
 666
 667 \f
 668 ;;;
 669 ;;; Package derivations.
 670 ;;;
 671
 672 (define %derivation-cache
 673   ;; Package to derivation-path mapping.
 674   (make-weak-key-hash-table 100))
 675
 676 (define (cache package system thunk)
 677   "Memoize the return values of THUNK as the derivation of PACKAGE on
 678 SYSTEM."
 679   ;; FIXME: This memoization should be associated with the open store, because
 680   ;; otherwise it breaks when switching to a different store.
 681   (let ((vals (call-with-values thunk list)))
 682     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 683     ;; same value for all structs (as of Guile 2.0.6), and because pointer
 684     ;; equality is sufficient in practice.
 685     (hashq-set! %derivation-cache package
 686                 `((,system ,@vals)
 687                   ,@(or (hashq-ref %derivation-cache package)
 688                         '())))
 689     (apply values vals)))
 690
 691 (define-syntax-rule (cached package system body ...)
 692   "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 693 Return the cached result when available."
 694   (let ((thunk (lambda () body ...))
 695         (key   system))
 696     (match (hashq-ref %derivation-cache package)
 697       ((alist (... ...))
 698        (match (assoc-ref alist key)
 699          ((vals (... ...))
 700           (apply values vals))
 701          (#f
 702           (cache package key thunk))))
 703       (#f
 704        (cache package key thunk)))))
 705
 706 (define* (expand-input store package input system #:optional cross-system)
 707   "Expand INPUT, an input tuple, such that it contains only references to
 708 derivation paths or store paths.  PACKAGE is only used to provide contextual
 709 information in exceptions."
 710   (define (intern file)
 711     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 712     ;; file permissions are preserved.
 713     (add-to-store store (basename file) #t "sha256" file))
 714
 715   (define derivation
 716     (if cross-system
 717         (cut package-cross-derivation store <> cross-system system
 718              #:graft? #f)
 719         (cut package-derivation store <> system #:graft? #f)))
 720
 721   (match input
 722     (((? string? name) (? package? package))
 723      (list name (derivation package)))
 724     (((? string? name) (? package? package)
 725       (? string? sub-drv))
 726      (list name (derivation package)
 727            sub-drv))
 728     (((? string? name)
 729       (and (? string?) (? derivation-path?) drv))
 730      (list name drv))
 731     (((? string? name)
 732       (and (? string?) (? file-exists? file)))
 733      ;; Add FILE to the store.  When FILE is in the sub-directory of a
 734      ;; store path, it needs to be added anyway, so it can be used as a
 735      ;; source.
 736      (list name (intern file)))
 737     (((? string? name) (? origin? source))
 738      (list name (package-source-derivation store source system)))
 739     (x
 740      (raise (condition (&package-input-error
 741                         (package package)
 742                         (input   x)))))))
 743
 744 (define* (package->bag package #:optional
 745                        (system (%current-system))
 746                        (target (%current-target-system))
 747                        #:key (graft? (%graft?)))
 748   "Compile PACKAGE into a bag for SYSTEM, possibly cross-compiled to TARGET,
 749 and return it."
 750   ;; Bind %CURRENT-SYSTEM and %CURRENT-TARGET-SYSTEM so that thunked field
 751   ;; values can refer to it.
 752   (parameterize ((%current-system system)
 753                  (%current-target-system target))
 754     (match (if graft?
 755                (or (package-replacement package) package)
 756                package)
 757       (($ <package> name version source build-system
 758                     args inputs propagated-inputs native-inputs self-native-input?
 759                     outputs)
 760        (or (make-bag build-system (string-append name "-" version)
 761                      #:system system
 762                      #:target target
 763                      #:source source
 764                      #:inputs (append (inputs)
 765                                       (propagated-inputs))
 766                      #:outputs outputs
 767                      #:native-inputs `(,@(if (and target self-native-input?)
 768                                              `(("self" ,package))
 769                                              '())
 770                                        ,@(native-inputs))
 771                      #:arguments (args))
 772            (raise (if target
 773                       (condition
 774                        (&package-cross-build-system-error
 775                         (package package)))
 776                       (condition
 777                        (&package-error
 778                         (package package))))))))))
 779
 780 (define (input-graft store system)
 781   "Return a procedure that, given an input referring to a package with a
 782 graft, returns a pair with the original derivation and the graft's derivation,
 783 and returns #f for other inputs."
 784   (match-lambda
 785    ((label (? package? package) sub-drv ...)
 786     (let ((replacement (package-replacement package)))
 787       (and replacement
 788            (let ((orig (package-derivation store package system
 789                                            #:graft? #f))
 790                  (new  (package-derivation store replacement system)))
 791              (graft
 792                (origin orig)
 793                (replacement new)
 794                (origin-output (match sub-drv
 795                                 (() "out")
 796                                 ((output) output)))
 797                (replacement-output origin-output))))))
 798    (x
 799     #f)))
 800
 801 (define (input-cross-graft store target system)
 802   "Same as 'input-graft', but for cross-compilation inputs."
 803   (match-lambda
 804    ((label (? package? package) sub-drv ...)
 805     (let ((replacement (package-replacement package)))
 806       (and replacement
 807            (let ((orig (package-cross-derivation store package target system
 808                                                  #:graft? #f))
 809                  (new  (package-cross-derivation store replacement
 810                                                  target system)))
 811              (graft
 812                (origin orig)
 813                (replacement new)
 814                (origin-output (match sub-drv
 815                                 (() "out")
 816                                 ((output) output)))
 817                (replacement-output origin-output))))))
 818    (_
 819     #f)))
 820
 821 (define* (bag-grafts store bag)
 822   "Return the list of grafts applicable to BAG.  Each graft is a <graft>
 823 record."
 824   (let ((target (bag-target bag))
 825         (system (bag-system bag)))
 826     (define native-grafts
 827       (filter-map (input-graft store system)
 828                   (append (bag-transitive-build-inputs bag)
 829                           (bag-transitive-target-inputs bag)
 830                           (if target
 831                               '()
 832                               (bag-transitive-host-inputs bag)))))
 833
 834     (define target-grafts
 835       (if target
 836           (filter-map (input-cross-graft store target system)
 837                       (bag-transitive-host-inputs bag))
 838           '()))
 839
 840     (append native-grafts target-grafts)))
 841
 842 (define* (package-grafts store package
 843                          #:optional (system (%current-system))
 844                          #:key target)
 845   "Return the list of grafts applicable to PACKAGE as built for SYSTEM and
 846 TARGET."
 847   (let* ((package (or (package-replacement package) package))
 848          (bag     (package->bag package system target)))
 849     (bag-grafts store bag)))
 850
 851 (define* (bag->derivation store bag
 852                           #:optional context)
 853   "Return the derivation to build BAG for SYSTEM.  Optionally, CONTEXT can be
 854 a package object describing the context in which the call occurs, for improved
 855 error reporting."
 856   (if (bag-target bag)
 857       (bag->cross-derivation store bag)
 858       (let* ((system     (bag-system bag))
 859              (inputs     (bag-transitive-inputs bag))
 860              (input-drvs (map (cut expand-input store context <> system)
 861                               inputs))
 862              (paths      (delete-duplicates
 863                           (append-map (match-lambda
 864                                        ((_ (? package? p) _ ...)
 865                                         (package-native-search-paths
 866                                          p))
 867                                        (_ '()))
 868                                       inputs))))
 869
 870         (apply (bag-build bag)
 871                store (bag-name bag) input-drvs
 872                #:search-paths paths
 873                #:outputs (bag-outputs bag) #:system system
 874                (bag-arguments bag)))))
 875
 876 (define* (bag->cross-derivation store bag
 877                                 #:optional context)
 878   "Return the derivation to build BAG, which is actually a cross build.
 879 Optionally, CONTEXT can be a package object denoting the context of the call.
 880 This is an internal procedure."
 881   (let* ((system      (bag-system bag))
 882          (target      (bag-target bag))
 883          (host        (bag-transitive-host-inputs bag))
 884          (host-drvs   (map (cut expand-input store context <> system target)
 885                            host))
 886          (target*     (bag-transitive-target-inputs bag))
 887          (target-drvs (map (cut expand-input store context <> system)
 888                            target*))
 889          (build       (bag-transitive-build-inputs bag))
 890          (build-drvs  (map (cut expand-input store context <> system)
 891                            build))
 892          (all         (append build target* host))
 893          (paths       (delete-duplicates
 894                        (append-map (match-lambda
 895                                     ((_ (? package? p) _ ...)
 896                                      (package-search-paths p))
 897                                     (_ '()))
 898                                    all)))
 899          (npaths      (delete-duplicates
 900                        (append-map (match-lambda
 901                                     ((_ (? package? p) _ ...)
 902                                      (package-native-search-paths
 903                                       p))
 904                                     (_ '()))
 905                                    all))))
 906
 907     (apply (bag-build bag)
 908            store (bag-name bag)
 909            #:native-drvs build-drvs
 910            #:target-drvs (append host-drvs target-drvs)
 911            #:search-paths paths
 912            #:native-search-paths npaths
 913            #:outputs (bag-outputs bag)
 914            #:system system #:target target
 915            (bag-arguments bag))))
 916
 917 (define* (package-derivation store package
 918                              #:optional (system (%current-system))
 919                              #:key (graft? (%graft?)))
 920   "Return the <derivation> object of PACKAGE for SYSTEM."
 921
 922   ;; Compute the derivation and cache the result.  Caching is important
 923   ;; because some derivations, such as the implicit inputs of the GNU build
 924   ;; system, will be queried many, many times in a row.
 925   (cached package (cons system graft?)
 926           (let* ((bag (package->bag package system #f #:graft? graft?))
 927                  (drv (bag->derivation store bag package)))
 928             (if graft?
 929                 (match (bag-grafts store bag)
 930                   (()
 931                    drv)
 932                   (grafts
 933                    (let ((guile (package-derivation store (default-guile)
 934                                                     system #:graft? #f)))
 935                      (graft-derivation store (bag-name bag) drv grafts
 936                                        #:system system
 937                                        #:guile guile))))
 938                 drv))))
 939
 940 (define* (package-cross-derivation store package target
 941                                    #:optional (system (%current-system))
 942                                    #:key (graft? (%graft?)))
 943   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 944 system identifying string)."
 945   (cached package (list system target graft?)
 946           (let* ((bag (package->bag package system target #:graft? graft?))
 947                  (drv (bag->derivation store bag package)))
 948             (if graft?
 949                 (match (bag-grafts store bag)
 950                   (()
 951                    drv)
 952                   (grafts
 953                    (graft-derivation store (bag-name bag) drv grafts
 954                                      #:system system
 955                                      #:guile
 956                                      (package-derivation store (default-guile)
 957                                                          system #:graft? #f))))
 958                 drv))))
 959
 960 (define* (package-output store package
 961                          #:optional (output "out") (system (%current-system)))
 962   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
 963 symbolic output name, such as \"out\".  Note that this procedure calls
 964 `package-derivation', which is costly."
 965   (let ((drv (package-derivation store package system)))
 966     (derivation->output-path drv output)))
 967
 968 \f
 969 ;;;
 970 ;;; Monadic interface.
 971 ;;;
 972
 973 (define (set-guile-for-build guile)
 974   "This monadic procedure changes the Guile currently used to run the build
 975 code of derivations to GUILE, a package object."
 976   (lambda (store)
 977     (let ((guile (package-derivation store guile)))
 978       (values (%guile-for-build guile) store))))
 979
 980 (define* (package-file package
 981                        #:optional file
 982                        #:key
 983                        system (output "out") target)
 984   "Return as a monadic value the absolute file name of FILE within the
 985 OUTPUT directory of PACKAGE.  When FILE is omitted, return the name of the
 986 OUTPUT directory of PACKAGE.  When TARGET is true, use it as a
 987 cross-compilation target triplet."
 988   (lambda (store)
 989     (define compute-derivation
 990       (if target
 991           (cut package-cross-derivation <> <> target <>)
 992           package-derivation))
 993
 994     (let* ((system (or system (%current-system)))
 995            (drv    (compute-derivation store package system))
 996            (out    (derivation->output-path drv output)))
 997       (values (if file
 998                   (string-append out "/" file)
 999                   out)
1000               store))))
1001
1002 (define package->derivation
1003   (store-lift package-derivation))
1004
1005 (define package->cross-derivation
1006   (store-lift package-cross-derivation))
1007
1008 (define-gexp-compiler (package-compiler (package package?) system target)
1009   ;; Compile PACKAGE to a derivation for SYSTEM, optionally cross-compiled for
1010   ;; TARGET.  This is used when referring to a package from within a gexp.
1011   (if target
1012       (package->cross-derivation package target system)
1013       (package->derivation package system)))
1014
1015 (define* (origin->derivation source
1016                              #:optional (system (%current-system)))
1017   "When SOURCE is an <origin> object, return its derivation for SYSTEM.  When
1018 SOURCE is a file name, return either the interned file name (if SOURCE is
1019 outside of the store) or SOURCE itself (if SOURCE is already a store item.)"
1020   (match source
1021     (($ <origin> uri method sha256 name (= force ()) #f)
1022      ;; No patches, no snippet: this is a fixed-output derivation.
1023      (method uri 'sha256 sha256 name #:system system))
1024     (($ <origin> uri method sha256 name (= force (patches ...)) snippet
1025         (flags ...) inputs (modules ...) (imported-modules ...)
1026         guile-for-build)
1027      ;; Patches and/or a snippet.
1028      (mlet %store-monad ((source (method uri 'sha256 sha256 name
1029                                          #:system system))
1030                          (guile  (package->derivation (or guile-for-build
1031                                                           (default-guile))
1032                                                       system
1033                                                       #:graft? #f)))
1034        (patch-and-repack source patches
1035                          #:inputs inputs
1036                          #:snippet snippet
1037                          #:flags flags
1038                          #:system system
1039                          #:modules modules
1040                          #:imported-modules modules
1041                          #:guile-for-build guile)))
1042     ((and (? string?) (? direct-store-path?) file)
1043      (with-monad %store-monad
1044        (return file)))
1045     ((? string? file)
1046      (interned-file file (basename file)
1047                     #:recursive? #t))))
1048
1049 (define-gexp-compiler (origin-compiler (origin origin?) system target)
1050   ;; Compile ORIGIN to a derivation for SYSTEM.  This is used when referring
1051   ;; to an origin from within a gexp.
1052   (origin->derivation origin system))
1053
1054 (define package-source-derivation
1055   (store-lower origin->derivation))