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