guix/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix packages)
  20   #:use-module (guix utils)
  21   #:use-module (guix records)
  22   #:use-module (guix store)
  23   #:use-module (guix base32)
  24   #:use-module (guix derivations)
  25   #:use-module (guix build-system)
  26   #:use-module (ice-9 match)
  27   #:use-module (srfi srfi-1)
  28   #:use-module (srfi srfi-9 gnu)
  29   #:use-module (srfi srfi-26)
  30   #:use-module (srfi srfi-34)
  31   #:use-module (srfi srfi-35)
  32   #:re-export (%current-system
  33                %current-target-system)
  34   #:export (origin
  35             origin?
  36             origin-uri
  37             origin-method
  38             origin-sha256
  39             origin-file-name
  40             origin-patches
  41             origin-patch-flags
  42             origin-patch-inputs
  43             origin-patch-guile
  44             origin-snippet
  45             origin-modules
  46             origin-imported-modules
  47             base32
  48
  49             <search-path-specification>
  50             search-path-specification
  51             search-path-specification?
  52             search-path-specification->sexp
  53
  54             package
  55             package?
  56             package-name
  57             package-version
  58             package-full-name
  59             package-source
  60             package-build-system
  61             package-arguments
  62             package-inputs
  63             package-native-inputs
  64             package-propagated-inputs
  65             package-outputs
  66             package-native-search-paths
  67             package-search-paths
  68             package-synopsis
  69             package-description
  70             package-license
  71             package-home-page
  72             package-platforms
  73             package-maintainers
  74             package-properties
  75             package-location
  76             package-field-location
  77
  78             package-transitive-inputs
  79             package-transitive-target-inputs
  80             package-transitive-native-inputs
  81             package-transitive-propagated-inputs
  82             package-source-derivation
  83             package-derivation
  84             package-cross-derivation
  85             package-output
  86
  87             &package-error
  88             package-error?
  89             package-error-package
  90             &package-input-error
  91             package-input-error?
  92             package-error-invalid-input
  93             &package-cross-build-system-error
  94             package-cross-build-system-error?))
  95
  96 ;;; Commentary:
  97 ;;;
  98 ;;; This module provides a high-level mechanism to define packages in a
  99 ;;; Guix-based distribution.
 100 ;;;
 101 ;;; Code:
 102
 103 ;; The source of a package, such as a tarball URL and fetcher---called
 104 ;; "origin" to avoid name clash with `package-source', `source', etc.
 105 (define-record-type* <origin>
 106   origin make-origin
 107   origin?
 108   (uri       origin-uri)                          ; string
 109   (method    origin-method)                       ; symbol
 110   (sha256    origin-sha256)                       ; bytevector
 111   (file-name origin-file-name (default #f))       ; optional file name
 112   (patches   origin-patches (default '()))        ; list of file names
 113   (snippet   origin-snippet (default #f))         ; sexp or #f
 114   (patch-flags  origin-patch-flags                ; list of strings
 115                 (default '("-p1")))
 116
 117   ;; Patching requires Guile, GNU Patch, and a few more.  These two fields are
 118   ;; used to specify these dependencies when needed.
 119   (patch-inputs origin-patch-inputs               ; input list or #f
 120                 (default #f))
 121   (modules      origin-modules                    ; list of module names
 122                 (default '()))
 123   (imported-modules origin-imported-modules       ; list of module names
 124                     (default '()))
 125   (patch-guile origin-patch-guile                 ; package or #f
 126                (default #f)))
 127
 128 (define-syntax base32
 129   (lambda (s)
 130     "Return the bytevector corresponding to the given Nix-base32
 131 representation."
 132     (syntax-case s ()
 133       ((_ str)
 134        (string? (syntax->datum #'str))
 135        ;; A literal string: do the conversion at expansion time.
 136        (with-syntax ((bv (nix-base32-string->bytevector
 137                           (syntax->datum #'str))))
 138          #''bv))
 139       ((_ str)
 140        #'(nix-base32-string->bytevector str)))))
 141
 142 ;; The specification of a search path.
 143 (define-record-type* <search-path-specification>
 144   search-path-specification make-search-path-specification
 145   search-path-specification?
 146   (variable     search-path-specification-variable)
 147   (directories  search-path-specification-directories)
 148   (separator    search-path-specification-separator (default ":")))
 149
 150 (define (search-path-specification->sexp spec)
 151   "Return an sexp representing SPEC, a <search-path-specification>.  The sexp
 152 corresponds to the arguments expected by `set-path-environment-variable'."
 153   (match spec
 154     (($ <search-path-specification> variable directories separator)
 155      `(,variable ,directories ,separator))))
 156
 157 ;; A package.
 158 (define-record-type* <package>
 159   package make-package
 160   package?
 161   (name   package-name)                   ; string
 162   (version package-version)               ; string
 163   (source package-source)                 ; <origin> instance
 164   (build-system package-build-system)     ; build system
 165   (arguments package-arguments            ; arguments for the build method
 166              (default '()) (thunked))
 167
 168   (inputs package-inputs                  ; input packages or derivations
 169           (default '()) (thunked))
 170   (propagated-inputs package-propagated-inputs    ; same, but propagated
 171                      (default '()) (thunked))
 172   (native-inputs package-native-inputs    ; native input packages/derivations
 173                  (default '()) (thunked))
 174   (self-native-input? package-self-native-input?  ; whether to use itself as
 175                                                   ; a native input when cross-
 176                       (default #f))               ; compiling
 177
 178   (outputs package-outputs                ; list of strings
 179            (default '("out")))
 180
 181                                                   ; lists of
 182                                                   ; <search-path-specification>,
 183                                                   ; for native and cross
 184                                                   ; inputs
 185   (native-search-paths package-native-search-paths (default '()))
 186   (search-paths package-search-paths (default '()))
 187
 188   (synopsis package-synopsis)                    ; one-line description
 189   (description package-description)              ; one or two paragraphs
 190   (license package-license)
 191   (home-page package-home-page)
 192   (platforms package-platforms (default '()))
 193   (maintainers package-maintainers (default '()))
 194
 195   (properties package-properties (default '()))   ; alist for anything else
 196
 197   (location package-location
 198             (default (and=> (current-source-location)
 199                             source-properties->location))))
 200
 201 (set-record-type-printer! <package>
 202                           (lambda (package port)
 203                             (let ((loc    (package-location package))
 204                                   (format simple-format))
 205                               (format port "#<package ~a-~a ~a:~a ~a>"
 206                                       (package-name package)
 207                                       (package-version package)
 208                                       (location-file loc)
 209                                       (location-line loc)
 210                                       (number->string (object-address
 211                                                        package)
 212                                                       16)))))
 213
 214 (define (package-field-location package field)
 215   "Return the source code location of the definition of FIELD for PACKAGE, or
 216 #f if it could not be determined."
 217   (define (goto port line column)
 218     (unless (and (= (port-column port) (- column 1))
 219                  (= (port-line port) (- line 1)))
 220       (unless (eof-object? (read-char port))
 221         (goto port line column))))
 222
 223   (match (package-location package)
 224     (($ <location> file line column)
 225      (catch 'system
 226        (lambda ()
 227          (call-with-input-file (search-path %load-path file)
 228            (lambda (port)
 229              (goto port line column)
 230              (match (read port)
 231                (('package inits ...)
 232                 (let ((field (assoc field inits)))
 233                   (match field
 234                     ((_ value)
 235                      ;; Put the `or' here, and not in the first argument of
 236                      ;; `and=>', to work around a compiler bug in 2.0.5.
 237                      (or (and=> (source-properties value)
 238                                 source-properties->location)
 239                          (and=> (source-properties field)
 240                                 source-properties->location)))
 241                     (_
 242                      #f))))
 243                (_
 244                 #f)))))
 245        (lambda _
 246          #f)))
 247     (_ #f)))
 248
 249
 250 ;; Error conditions.
 251
 252 (define-condition-type &package-error &error
 253   package-error?
 254   (package package-error-package))
 255
 256 (define-condition-type &package-input-error &package-error
 257   package-input-error?
 258   (input package-error-invalid-input))
 259
 260 (define-condition-type &package-cross-build-system-error &package-error
 261   package-cross-build-system-error?)
 262
 263
 264 (define (package-full-name package)
 265   "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
 266   (string-append (package-name package) "-" (package-version package)))
 267
 268 (define (%standard-patch-inputs)
 269   (let ((ref (lambda (module var)
 270                (module-ref (resolve-interface module) var))))
 271     `(("tar"   ,(ref '(gnu packages base) 'tar))
 272       ("xz"    ,(ref '(gnu packages compression) 'xz))
 273       ("bzip2" ,(ref '(gnu packages compression) 'bzip2))
 274       ("gzip"  ,(ref '(gnu packages compression) 'gzip))
 275       ("lzip"  ,(ref '(gnu packages compression) 'lzip))
 276       ("patch" ,(ref '(gnu packages base) 'patch)))))
 277
 278 (define (default-guile)
 279   "Return the default Guile package for SYSTEM."
 280   (let ((distro (resolve-interface '(gnu packages base))))
 281     (module-ref distro 'guile-final)))
 282
 283 (define* (patch-and-repack store source patches
 284                            #:key
 285                            (inputs '())
 286                            (snippet #f)
 287                            (flags '("-p1"))
 288                            (modules '())
 289                            (imported-modules '())
 290                            (guile-for-build (%guile-for-build))
 291                            (system (%current-system)))
 292   "Unpack SOURCE (a derivation or store path), apply all of PATCHES, and
 293 repack the tarball using the tools listed in INPUTS.  When SNIPPET is true,
 294 it must be an s-expression that will run from within the directory where
 295 SOURCE was unpacked, after all of PATCHES have been applied.  MODULES and
 296 IMPORTED-MODULES specify modules to use/import for use by SNIPPET."
 297   (define source-file-name
 298     ;; SOURCE is usually a derivation, but it could be a store file.
 299     (if (derivation? source)
 300         (derivation->output-path source)
 301         source))
 302
 303   (define decompression-type
 304     (cond ((string-suffix? "gz" source-file-name)  "gzip")
 305           ((string-suffix? "bz2" source-file-name) "bzip2")
 306           ((string-suffix? "lz" source-file-name)  "lzip")
 307           (else "xz")))
 308
 309   (define original-file-name
 310     ;; Remove the store prefix plus the slash, hash, and hyphen.
 311     (let* ((sans (string-drop source-file-name
 312                               (+ (string-length (%store-prefix)) 1)))
 313            (dash (string-index sans #\-)))
 314       (string-drop sans (+ 1 dash))))
 315
 316   (define patch-inputs
 317     (map (lambda (number patch)
 318            (list (string-append "patch" (number->string number))
 319                  (add-to-store store (basename patch) #t
 320                                "sha256" patch)))
 321          (iota (length patches))
 322
 323          patches))
 324
 325   (define builder
 326     `(begin
 327        (use-modules (ice-9 ftw)
 328                     (srfi srfi-1))
 329
 330        (let ((out     (assoc-ref %outputs "out"))
 331              (xz      (assoc-ref %build-inputs "xz"))
 332              (decomp  (assoc-ref %build-inputs ,decompression-type))
 333              (source  (assoc-ref %build-inputs "source"))
 334              (tar     (string-append (assoc-ref %build-inputs "tar")
 335                                      "/bin/tar"))
 336              (patch   (string-append (assoc-ref %build-inputs "patch")
 337                                      "/bin/patch")))
 338          (define (apply-patch input)
 339            (let ((patch* (assoc-ref %build-inputs input)))
 340              (format (current-error-port) "applying '~a'...~%" patch*)
 341              (zero? (system* patch "--batch" ,@flags "--input" patch*))))
 342
 343          (setenv "PATH" (string-append xz "/bin" ":"
 344                                        decomp "/bin"))
 345          (and (zero? (system* tar "xvf" source))
 346               (let ((directory (car (scandir "."
 347                                              (lambda (name)
 348                                                (not
 349                                                 (member name
 350                                                         '("." ".."))))))))
 351                 (format (current-error-port)
 352                         "source is under '~a'~%" directory)
 353                 (chdir directory)
 354
 355                 (and (every apply-patch ',(map car patch-inputs))
 356
 357                      ,@(if snippet
 358                            `((let ((module (make-fresh-user-module)))
 359                                (module-use-interfaces! module
 360                                                        (map resolve-interface
 361                                                             ',modules))
 362                                (module-define! module '%build-inputs
 363                                                %build-inputs)
 364                                (module-define! module '%outputs %outputs)
 365                                ((@ (system base compile) compile)
 366                                 ',snippet
 367                                 #:to 'value
 368                                 #:opts %auto-compilation-options
 369                                 #:env module)))
 370                            '())
 371
 372                      (begin (chdir "..") #t)
 373                      (zero? (system* tar "cvfa" out directory))))))))
 374
 375
 376   (let ((name   (string-append (file-sans-extension original-file-name)
 377                                ".xz"))
 378         (inputs (filter-map (match-lambda
 379                              ((name (? package? p))
 380                               (and (member name (cons decompression-type
 381                                                       '("tar" "xz" "patch")))
 382                                    (list name
 383                                          (package-derivation store p
 384                                                              system)))))
 385                             (or inputs (%standard-patch-inputs)))))
 386
 387    (build-expression->derivation store name system builder
 388                                  `(("source" ,source)
 389                                    ,@inputs
 390                                    ,@patch-inputs)
 391                                  #:modules imported-modules
 392                                  #:guile-for-build guile-for-build)))
 393
 394 (define* (package-source-derivation store source
 395                                     #:optional (system (%current-system)))
 396   "Return the derivation path for SOURCE, a package source, for SYSTEM."
 397   (match source
 398     (($ <origin> uri method sha256 name () #f)
 399      ;; No patches, no snippet: this is a fixed-output derivation.
 400      (method store uri 'sha256 sha256 name
 401              #:system system))
 402     (($ <origin> uri method sha256 name (patches ...) snippet
 403         (flags ...) inputs (modules ...) (imported-modules ...)
 404         guile-for-build)
 405      ;; Patches and/or a snippet.
 406      (let ((source (method store uri 'sha256 sha256 name
 407                            #:system system))
 408            (guile  (match (or guile-for-build (%guile-for-build)
 409                               (default-guile))
 410                      ((? package? p)
 411                       (package-derivation store p system))
 412                      ((? derivation? drv)
 413                       drv))))
 414        (patch-and-repack store source patches
 415                          #:inputs inputs
 416                          #:snippet snippet
 417                          #:flags flags
 418                          #:system system
 419                          #:modules modules
 420                          #:imported-modules modules
 421                          #:guile-for-build guile)))
 422     ((and (? string?) (? store-path?) file)
 423      file)
 424     ((? string? file)
 425      (add-to-store store (basename file) #t "sha256" file))))
 426
 427 (define (transitive-inputs inputs)
 428   (let loop ((inputs  inputs)
 429              (result '()))
 430     (match inputs
 431       (()
 432        (delete-duplicates (reverse result)))      ; XXX: efficiency
 433       (((and i (name (? package? p) sub ...)) rest ...)
 434        (let ((t (map (match-lambda
 435                       ((dep-name derivation ...)
 436                        (cons (string-append name "/" dep-name)
 437                              derivation)))
 438                      (package-propagated-inputs p))))
 439          (loop (append t rest)
 440                (append t (cons i result)))))
 441       ((input rest ...)
 442        (loop rest (cons input result))))))
 443
 444 (define (package-transitive-inputs package)
 445   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 446 with their propagated inputs, recursively."
 447   (transitive-inputs (append (package-native-inputs package)
 448                              (package-inputs package)
 449                              (package-propagated-inputs package))))
 450
 451 (define (package-transitive-target-inputs package)
 452   "Return the transitive target inputs of PACKAGE---i.e., its direct inputs
 453 along with their propagated inputs, recursively.  This only includes inputs
 454 for the target system, and not native inputs."
 455   (transitive-inputs (append (package-inputs package)
 456                              (package-propagated-inputs package))))
 457
 458 (define (package-transitive-native-inputs package)
 459   "Return the transitive native inputs of PACKAGE---i.e., its direct inputs
 460 along with their propagated inputs, recursively.  This only includes inputs
 461 for the host system (\"native inputs\"), and not target inputs."
 462   (transitive-inputs (package-native-inputs package)))
 463
 464 (define (package-transitive-propagated-inputs package)
 465   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 466 recursively."
 467   (transitive-inputs (package-propagated-inputs package)))
 468
 469 \f
 470 ;;;
 471 ;;; Package derivations.
 472 ;;;
 473
 474 (define %derivation-cache
 475   ;; Package to derivation-path mapping.
 476   (make-weak-key-hash-table 100))
 477
 478 (define (cache package system thunk)
 479   "Memoize the return values of THUNK as the derivation of PACKAGE on
 480 SYSTEM."
 481   (let ((vals (call-with-values thunk list)))
 482     ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 483     ;; same value for all structs (as of Guile 2.0.6), and because pointer
 484     ;; equality is sufficient in practice.
 485     (hashq-set! %derivation-cache package `((,system ,@vals)))
 486     (apply values vals)))
 487
 488 (define-syntax-rule (cached package system body ...)
 489   "Memoize the result of BODY for the arguments PACKAGE and SYSTEM.
 490 Return the cached result when available."
 491   (let ((thunk (lambda () body ...)))
 492     (match (hashq-ref %derivation-cache package)
 493       ((alist (... ...))
 494        (match (assoc-ref alist system)
 495          ((vals (... ...))
 496           (apply values vals))
 497          (#f
 498           (cache package system thunk))))
 499       (#f
 500        (cache package system thunk)))))
 501
 502 (define* (expand-input store package input system #:optional cross-system)
 503   "Expand INPUT, an input tuple, such that it contains only references to
 504 derivation paths or store paths.  PACKAGE is only used to provide contextual
 505 information in exceptions."
 506   (define (intern file)
 507     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 508     ;; file permissions are preserved.
 509     (add-to-store store (basename file) #t "sha256" file))
 510
 511   (define derivation
 512     (if cross-system
 513         (cut package-cross-derivation store <> cross-system system)
 514         (cut package-derivation store <> system)))
 515
 516   (match input
 517     (((? string? name) (? package? package))
 518      (list name (derivation package)))
 519     (((? string? name) (? package? package)
 520       (? string? sub-drv))
 521      (list name (derivation package)
 522            sub-drv))
 523     (((? string? name)
 524       (and (? string?) (? derivation-path?) drv))
 525      (list name drv))
 526     (((? string? name)
 527       (and (? string?) (? file-exists? file)))
 528      ;; Add FILE to the store.  When FILE is in the sub-directory of a
 529      ;; store path, it needs to be added anyway, so it can be used as a
 530      ;; source.
 531      (list name (intern file)))
 532     (((? string? name) (? origin? source))
 533      (list name (package-source-derivation store source system)))
 534     (x
 535      (raise (condition (&package-input-error
 536                         (package package)
 537                         (input   x)))))))
 538
 539 (define* (package-derivation store package
 540                              #:optional (system (%current-system)))
 541   "Return the <derivation> object of PACKAGE for SYSTEM."
 542
 543   ;; Compute the derivation and cache the result.  Caching is important
 544   ;; because some derivations, such as the implicit inputs of the GNU build
 545   ;; system, will be queried many, many times in a row.
 546   (cached package system
 547
 548           ;; Bind %CURRENT-SYSTEM so that thunked field values can refer
 549           ;; to it.
 550           (parameterize ((%current-system system)
 551                          (%current-target-system #f))
 552             (match package
 553               (($ <package> name version source (= build-system-builder builder)
 554                   args inputs propagated-inputs native-inputs self-native-input?
 555                   outputs)
 556                (let* ((inputs     (package-transitive-inputs package))
 557                       (input-drvs (map (cut expand-input
 558                                             store package <> system)
 559                                        inputs))
 560                       (paths      (delete-duplicates
 561                                    (append-map (match-lambda
 562                                                 ((_ (? package? p) _ ...)
 563                                                  (package-native-search-paths
 564                                                   p))
 565                                                 (_ '()))
 566                                                inputs))))
 567
 568                  (apply builder
 569                         store (package-full-name package)
 570                         (and source
 571                              (package-source-derivation store source system))
 572                         input-drvs
 573                         #:search-paths paths
 574                         #:outputs outputs #:system system
 575                         (args))))))))
 576
 577 (define* (package-cross-derivation store package target
 578                                    #:optional (system (%current-system)))
 579   "Cross-build PACKAGE for TARGET (a GNU triplet) from host SYSTEM (a Guix
 580 system identifying string)."
 581   (cached package (cons system target)
 582
 583           ;; Bind %CURRENT-SYSTEM so that thunked field values can refer
 584           ;; to it.
 585           (parameterize ((%current-system system)
 586                          (%current-target-system target))
 587             (match package
 588               (($ <package> name version source
 589                   (= build-system-cross-builder builder)
 590                   args inputs propagated-inputs native-inputs self-native-input?
 591                   outputs)
 592                (unless builder
 593                  (raise (condition
 594                          (&package-cross-build-system-error
 595                           (package package)))))
 596
 597                (let* ((inputs     (package-transitive-target-inputs package))
 598                       (input-drvs (map (cut expand-input
 599                                             store package <>
 600                                             system target)
 601                                        inputs))
 602                       (host       (append (if self-native-input?
 603                                               `(("self" ,package))
 604                                               '())
 605                                           (package-transitive-native-inputs package)))
 606                       (host-drvs  (map (cut expand-input
 607                                             store package <> system)
 608                                        host))
 609                       (all        (append host inputs))
 610                       (paths      (delete-duplicates
 611                                    (append-map (match-lambda
 612                                                 ((_ (? package? p) _ ...)
 613                                                  (package-search-paths p))
 614                                                 (_ '()))
 615                                                all)))
 616                       (npaths     (delete-duplicates
 617                                    (append-map (match-lambda
 618                                                 ((_ (? package? p) _ ...)
 619                                                  (package-native-search-paths
 620                                                   p))
 621                                                 (_ '()))
 622                                                all))))
 623
 624                  (apply builder
 625                         store (package-full-name package) target
 626                         (and source
 627                              (package-source-derivation store source system))
 628                         input-drvs host-drvs
 629                         #:search-paths paths
 630                         #:native-search-paths npaths
 631                         #:outputs outputs #:system system
 632                         (args))))))))
 633
 634 (define* (package-output store package
 635                          #:optional (output "out") (system (%current-system)))
 636   "Return the output path of PACKAGE's OUTPUT for SYSTEM---where OUTPUT is the
 637 symbolic output name, such as \"out\".  Note that this procedure calls
 638 `package-derivation', which is costly."
 639   (let ((drv (package-derivation store package system)))
 640     (derivation->output-path drv output)))