guix/packages.scm

   1 ;;; Guix --- Nix package management from Guile.         -*- coding: utf-8 -*-
   2 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of Guix.
   5 ;;;
   6 ;;; 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 ;;; 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 Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix packages)
  20   #:use-module (guix utils)
  21   #:use-module (guix store)
  22   #:use-module (guix build-system)
  23   #:use-module (ice-9 match)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-9 gnu)
  26   #:use-module (srfi srfi-34)
  27   #:use-module (srfi srfi-35)
  28   #:export (origin
  29             origin?
  30             origin-uri
  31             origin-method
  32             origin-sha256
  33             origin-file-name
  34             base32
  35
  36             package
  37             package?
  38             package-name
  39             package-version
  40             package-full-name
  41             package-source
  42             package-build-system
  43             package-arguments
  44             package-inputs
  45             package-native-inputs
  46             package-propagated-inputs
  47             package-outputs
  48             package-search-paths
  49             package-synopsis
  50             package-description
  51             package-license
  52             package-platforms
  53             package-maintainers
  54             package-properties
  55             package-location
  56
  57             package-transitive-inputs
  58             package-transitive-propagated-inputs
  59             package-source-derivation
  60             package-derivation
  61             package-cross-derivation
  62
  63             &package-error
  64             package-error?
  65             package-error-package
  66             &package-input-error
  67             package-input-error?
  68             package-error-invalid-input))
  69
  70 ;;; Commentary:
  71 ;;;
  72 ;;; This module provides a high-level mechanism to define packages in a
  73 ;;; Guix-based distribution.
  74 ;;;
  75 ;;; Code:
  76
  77 ;; The source of a package, such as a tarball URL and fetcher---called
  78 ;; "origin" to avoid name clash with `package-source', `source', etc.
  79 (define-record-type* <origin>
  80   origin make-origin
  81   origin?
  82   (uri       origin-uri)                          ; string
  83   (method    origin-method)                       ; symbol
  84   (sha256    origin-sha256)                       ; bytevector
  85   (file-name origin-file-name (default #f)))      ; optional file name
  86
  87 (define-syntax base32
  88   (lambda (s)
  89     "Return the bytevector corresponding to the given Nix-base32
  90 representation."
  91     (syntax-case s ()
  92       ((_ str)
  93        (string? (syntax->datum #'str))
  94        (with-syntax ((bv (nix-base32-string->bytevector
  95                           (syntax->datum #'str))))
  96          #''bv)))))
  97
  98 ;; A package.
  99
 100 (define-record-type* <package>
 101   package make-package
 102   package?
 103   (name   package-name)                   ; string
 104   (version package-version)               ; string
 105   (source package-source)                 ; <origin> instance
 106   (build-system package-build-system)     ; build system
 107   (arguments package-arguments            ; arguments for the build method
 108              (default '()))
 109
 110   (inputs package-inputs                  ; input packages or derivations
 111           (default '()))
 112   (propagated-inputs package-propagated-inputs    ; same, but propagated
 113                      (default '()))
 114   (native-inputs package-native-inputs    ; native input packages/derivations
 115                  (default '()))
 116   (self-native-input? package-self-native-input?  ; whether to use itself as
 117                                                   ; a native input when cross-
 118                       (default #f))               ; compiling
 119
 120   (outputs package-outputs                ; list of strings
 121            (default '("out")))
 122   (search-paths package-search-paths      ; list of (ENV-VAR (DIRS ...))
 123                 (default '()))            ; tuples; see
 124                                           ; `set-path-environment-variable'
 125                                           ; (aka. "setup-hook")
 126
 127   (synopsis package-synopsis)                    ; one-line description
 128   (description package-description)              ; one or two paragraphs
 129   (license package-license (default '()))
 130   (home-page package-home-page)
 131   (platforms package-platforms (default '()))
 132   (maintainers package-maintainers (default '()))
 133
 134   (properties package-properties (default '()))   ; alist for anything else
 135
 136   (location package-location
 137             (default (and=> (current-source-location)
 138                             source-properties->location))))
 139
 140 (set-record-type-printer! <package>
 141                           (lambda (package port)
 142                             (let ((loc    (package-location package))
 143                                   (format simple-format))
 144                               (format port "#<package ~a-~a ~a:~a ~a>"
 145                                       (package-name package)
 146                                       (package-version package)
 147                                       (location-file loc)
 148                                       (location-line loc)
 149                                       (number->string (object-address
 150                                                        package)
 151                                                       16)))))
 152
 153
 154 ;; Error conditions.
 155
 156 (define-condition-type &package-error &error
 157   package-error?
 158   (package package-error-package))
 159
 160 (define-condition-type &package-input-error &package-error
 161   package-input-error?
 162   (input package-error-invalid-input))
 163
 164
 165 (define (package-full-name package)
 166   "Return the full name of PACKAGE--i.e., `NAME-VERSION'."
 167   (string-append (package-name package) "-" (package-version package)))
 168
 169 (define* (package-source-derivation store source
 170                                     #:optional (system (%current-system)))
 171   "Return the derivation path for SOURCE, a package source, for SYSTEM."
 172   (match source
 173     (($ <origin> uri method sha256 name)
 174      (method store uri 'sha256 sha256 name
 175              #:system system))))
 176
 177 (define (transitive-inputs inputs)
 178   (let loop ((inputs  inputs)
 179              (result '()))
 180     (match inputs
 181       (()
 182        (delete-duplicates (reverse result)))      ; XXX: efficiency
 183       (((and i (name (? package? p) sub ...)) rest ...)
 184        (let ((t (map (match-lambda
 185                       ((dep-name derivation ...)
 186                        (cons (string-append name "/" dep-name)
 187                              derivation)))
 188                      (package-propagated-inputs p))))
 189          (loop (append t rest)
 190                (append t (cons i result)))))
 191       ((input rest ...)
 192        (loop rest (cons input result))))))
 193
 194 (define (package-transitive-inputs package)
 195   "Return the transitive inputs of PACKAGE---i.e., its direct inputs along
 196 with their propagated inputs, recursively."
 197   (transitive-inputs (append (package-native-inputs package)
 198                              (package-inputs package)
 199                              (package-propagated-inputs package))))
 200
 201 (define (package-transitive-propagated-inputs package)
 202   "Return the propagated inputs of PACKAGE, and their propagated inputs,
 203 recursively."
 204   (transitive-inputs (package-propagated-inputs package)))
 205
 206 \f
 207 ;;;
 208 ;;; Package derivations.
 209 ;;;
 210
 211 (define %derivation-cache
 212   ;; Package to derivation-path mapping.
 213   (make-weak-key-hash-table 100))
 214
 215 (define (cache package system drv)
 216   "Memoize DRV as the derivation of PACKAGE on SYSTEM."
 217
 218   ;; Use `hashq-set!' instead of `hash-set!' because `hash' returns the
 219   ;; same value for all structs (as of Guile 2.0.6), and because pointer
 220   ;; equality is sufficient in practice.
 221   (hashq-set! %derivation-cache package `((,system . ,drv)))
 222   drv)
 223
 224 (define (cached-derivation package system)
 225   "Return the cached derivation path of PACKAGE for SYSTEM, or #f."
 226   (match (hashq-ref %derivation-cache package)
 227     ((alist ...)
 228      (assoc-ref alist system))
 229     (#f #f)))
 230
 231 (define* (package-derivation store package
 232                              #:optional (system (%current-system)))
 233   "Return the derivation of PACKAGE for SYSTEM."
 234   (define (intern file)
 235     ;; Add FILE to the store.  Set the `recursive?' bit to #t, so that
 236     ;; file permissions are preserved.
 237     (add-to-store store (basename file)
 238                   #t #t "sha256" file))
 239
 240   (define expand-input
 241     ;; Expand the given input tuple such that it contains only
 242     ;; references to derivation paths or store paths.
 243     (match-lambda
 244      (((? string? name) (? package? package))
 245       (list name (package-derivation store package system)))
 246      (((? string? name) (? package? package)
 247        (? string? sub-drv))
 248       (list name (package-derivation store package system)
 249             sub-drv))
 250      (((? string? name)
 251        (and (? string?) (? derivation-path?) drv))
 252       (list name drv))
 253      (((? string? name)
 254        (and (? string?) (? file-exists? file)))
 255       ;; Add FILE to the store.  When FILE is in the sub-directory of a
 256       ;; store path, it needs to be added anyway, so it can be used as a
 257       ;; source.
 258       (list name (intern file)))
 259      (((? string? name) (? origin? source))
 260       (list name (package-source-derivation store source system)))
 261      ((and i ((? string? name) (? procedure? proc) sub-drv ...))
 262       ;; This form allows PROC to make a SYSTEM-dependent choice.
 263
 264       ;; XXX: Currently PROC must return a .drv, a store path, a local
 265       ;; file name, or an <origin>.  If it were allowed to return a
 266       ;; package, then `transitive-inputs' and co. would need to be
 267       ;; adjusted.
 268       (let ((input (proc system)))
 269         (if (or (string? input) (origin? input))
 270             (expand-input (cons* name input sub-drv))
 271             (raise (condition (&package-input-error
 272                                (package package)
 273                                (input   i)))))))
 274      (x
 275       (raise (condition (&package-input-error
 276                          (package package)
 277                          (input   x)))))))
 278
 279   (or (cached-derivation package system)
 280
 281       ;; Compute the derivation and cache the result.  Caching is
 282       ;; important because some derivations, such as the implicit inputs
 283       ;; of the GNU build system, will be queried many, many times in a
 284       ;; row.
 285       (cache
 286        package system
 287        (match package
 288          (($ <package> name version source (= build-system-builder builder)
 289              args inputs propagated-inputs native-inputs self-native-input?
 290              outputs)
 291           ;; TODO: For `search-paths', add a builder prologue that calls
 292           ;; `set-path-environment-variable'.
 293           (let ((inputs (map expand-input
 294                              (package-transitive-inputs package))))
 295
 296             (apply builder
 297                    store (package-full-name package)
 298                    (and source
 299                         (package-source-derivation store source system))
 300                    inputs
 301                    #:outputs outputs #:system system
 302                    (if (procedure? args)
 303                        (args system)
 304                        args))))))))
 305
 306 (define* (package-cross-derivation store package)
 307   ;; TODO
 308   #f)