gnu/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Mark H Weaver <mhw@netris.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2016, 2017 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
   7 ;;;
   8 ;;; This file is part of GNU Guix.
   9 ;;;
  10 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  11 ;;; under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 3 of the License, or (at
  13 ;;; your option) any later version.
  14 ;;;
  15 ;;; GNU Guix is distributed in the hope that it will be useful, but
  16 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 (define-module (gnu packages)
  24   #:use-module (guix packages)
  25   #:use-module (guix ui)
  26   #:use-module (guix utils)
  27   #:use-module (guix discovery)
  28   #:use-module (guix memoization)
  29   #:use-module ((guix build utils)
  30                 #:select ((package-name->name+version
  31                            . hyphen-separated-name->name+version)))
  32   #:use-module (ice-9 vlist)
  33   #:use-module (ice-9 match)
  34   #:use-module (srfi srfi-1)
  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   #:use-module (srfi srfi-39)
  40   #:export (search-patch
  41             search-patches
  42             search-auxiliary-file
  43             search-bootstrap-binary
  44             %patch-path
  45             %auxiliary-files-path
  46             %bootstrap-binaries-path
  47             %package-module-path
  48
  49             fold-packages
  50
  51             find-packages-by-name
  52             find-best-packages-by-name
  53             find-newest-available-packages
  54
  55             specification->package
  56             specification->package+output))
  57
  58 ;;; Commentary:
  59 ;;;
  60 ;;; General utilities for the software distribution---i.e., the modules under
  61 ;;; (gnu packages ...).
  62 ;;;
  63 ;;; Code:
  64
  65 ;; By default, we store patches, auxiliary files and bootstrap binaries
  66 ;; alongside Guile modules.  This is so that these extra files can be
  67 ;; found without requiring a special setup, such as a specific
  68 ;; installation directory and an extra environment variable.  One
  69 ;; advantage of this setup is that everything just works in an
  70 ;; auto-compilation setting.
  71
  72 (define %bootstrap-binaries-path
  73   (make-parameter
  74    (map (cut string-append <> "/gnu/packages/bootstrap")
  75         %load-path)))
  76
  77 (define %auxiliary-files-path
  78   (make-parameter
  79    (map (cut string-append <> "/gnu/packages/aux-files")
  80         %load-path)))
  81
  82 (define (search-auxiliary-file file-name)
  83   "Search the auxiliary FILE-NAME.  Return #f if not found."
  84   (search-path (%auxiliary-files-path) file-name))
  85
  86 (define (search-patch file-name)
  87   "Search the patch FILE-NAME.  Raise an error if not found."
  88   (or (search-path (%patch-path) file-name)
  89       (raise (condition
  90               (&message (message (format #f (G_ "~a: patch not found")
  91                                          file-name)))))))
  92
  93 (define-syntax-rule (search-patches file-name ...)
  94   "Return the list of absolute file names corresponding to each
  95 FILE-NAME found in %PATCH-PATH."
  96   (list (search-patch file-name) ...))
  97
  98 (define (search-bootstrap-binary file-name system)
  99   "Search the bootstrap binary FILE-NAME for SYSTEM.  Raise an error if not
 100 found."
 101   (or (search-path (%bootstrap-binaries-path)
 102                    (string-append system "/" file-name))
 103       (raise (condition
 104               (&message
 105                (message
 106                 (format #f (G_ "could not find bootstrap binary '~a' \
 107 for system '~a'")
 108                         file-name system)))))))
 109
 110 (define %distro-root-directory
 111   ;; Absolute file name of the module hierarchy.
 112   (dirname (search-path %load-path "guix.scm")))
 113
 114 (define %package-module-path
 115   ;; Search path for package modules.  Each item must be either a directory
 116   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
 117   ;; to narrow the search.
 118   (let* ((not-colon   (char-set-complement (char-set #\:)))
 119          (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
 120                                        not-colon)))
 121     ;; Automatically add items from $GUIX_PACKAGE_PATH to Guile's search path.
 122     (for-each (lambda (directory)
 123                 (set! %load-path (cons directory %load-path))
 124                 (set! %load-compiled-path
 125                       (cons directory %load-compiled-path)))
 126               environment)
 127
 128     (make-parameter
 129      (append environment `((,%distro-root-directory . "gnu/packages"))))))
 130
 131 (define %patch-path
 132   ;; Define it after '%package-module-path' so that '%load-path' contains user
 133   ;; directories, allowing patches in $GUIX_PACKAGE_PATH to be found.
 134   (make-parameter
 135    (map (lambda (directory)
 136           (if (string=? directory %distro-root-directory)
 137               (string-append directory "/gnu/packages/patches")
 138               directory))
 139         %load-path)))
 140
 141 (define (fold-packages proc init)
 142   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 143 the initial value of RESULT.  It is guaranteed to never traverse the
 144 same package twice."
 145   (fold-module-public-variables (lambda (object result)
 146                                   (if (and (package? object)
 147                                            (not (hidden-package? object)))
 148                                       (proc object result)
 149                                       result))
 150                                 init
 151                                 (all-modules (%package-module-path))))
 152
 153 (define find-packages-by-name
 154   (let ((packages (delay
 155                     (fold-packages (lambda (p r)
 156                                      (vhash-cons (package-name p) p r))
 157                                    vlist-null)))
 158         (version>? (lambda (p1 p2)
 159                      (version>? (package-version p1) (package-version p2)))))
 160     (lambda* (name #:optional version)
 161       "Return the list of packages with the given NAME.  If VERSION is not #f,
 162 then only return packages whose version is prefixed by VERSION, sorted in
 163 decreasing version order."
 164       (let ((matching (sort (vhash-fold* cons '() name (force packages))
 165                             version>?)))
 166         (if version
 167             (filter (lambda (package)
 168                       (string-prefix? version (package-version package)))
 169                     matching)
 170             matching)))))
 171
 172 (define find-newest-available-packages
 173   (mlambda ()
 174     "Return a vhash keyed by package names, and with
 175 associated values of the form
 176
 177   (newest-version newest-package ...)
 178
 179 where the preferred package is listed first."
 180
 181     ;; FIXME: Currently, the preferred package is whichever one
 182     ;; was found last by 'fold-packages'.  Find a better solution.
 183     (fold-packages (lambda (p r)
 184                      (let ((name    (package-name p))
 185                            (version (package-version p)))
 186                        (match (vhash-assoc name r)
 187                          ((_ newest-so-far . pkgs)
 188                           (case (version-compare version newest-so-far)
 189                             ((>) (vhash-cons name `(,version ,p) r))
 190                             ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
 191                             ((<) r)))
 192                          (#f (vhash-cons name `(,version ,p) r)))))
 193                    vlist-null)))
 194
 195 (define (find-best-packages-by-name name version)
 196   "If version is #f, return the list of packages named NAME with the highest
 197 version numbers; otherwise, return the list of packages named NAME and at
 198 VERSION."
 199   (if version
 200       (find-packages-by-name name version)
 201       (match (vhash-assoc name (find-newest-available-packages))
 202         ((_ version pkgs ...) pkgs)
 203         (#f '()))))
 204
 205 \f
 206 (define %sigint-prompt
 207   ;; The prompt to jump to upon SIGINT.
 208   (make-prompt-tag "interruptible"))
 209
 210 (define (call-with-sigint-handler thunk handler)
 211   "Call THUNK and return its value.  Upon SIGINT, call HANDLER with the signal
 212 number in the context of the continuation of the call to this function, and
 213 return its return value."
 214   (call-with-prompt %sigint-prompt
 215                     (lambda ()
 216                       (sigaction SIGINT
 217                         (lambda (signum)
 218                           (sigaction SIGINT SIG_DFL)
 219                           (abort-to-prompt %sigint-prompt signum)))
 220                       (dynamic-wind
 221                         (const #t)
 222                         thunk
 223                         (cut sigaction SIGINT SIG_DFL)))
 224                     (lambda (k signum)
 225                       (handler signum))))
 226
 227 \f
 228 ;;;
 229 ;;; Package specification.
 230 ;;;
 231
 232 (define* (%find-package spec name version)
 233   (match (find-best-packages-by-name name version)
 234     ((pkg . pkg*)
 235      (unless (null? pkg*)
 236        (warning (G_ "ambiguous package specification `~a'~%") spec)
 237        (warning (G_ "choosing ~a@~a from ~a~%")
 238                 (package-name pkg) (package-version pkg)
 239                 (location->string (package-location pkg))))
 240      (match (package-superseded pkg)
 241        ((? package? new)
 242         (info (G_ "package '~a' has been superseded by '~a'~%")
 243               (package-name pkg) (package-name new))
 244         new)
 245        (#f
 246         pkg)))
 247     (x
 248      (if version
 249          (leave (G_ "~A: package not found for version ~a~%") name version)
 250          (leave (G_ "~A: unknown package~%") name)))))
 251
 252 (define (specification->package spec)
 253   "Return a package matching SPEC.  SPEC may be a package name, or a package
 254 name followed by an at-sign and a version number.  If the version number is not
 255 present, return the preferred newest version."
 256   (let-values (((name version) (package-name->name+version spec)))
 257     (%find-package spec name version)))
 258
 259 (define* (specification->package+output spec #:optional (output "out"))
 260   "Return the package and output specified by SPEC, or #f and #f; SPEC may
 261 optionally contain a version number and an output name, as in these examples:
 262
 263   guile
 264   guile@2.0.9
 265   guile:debug
 266   guile@2.0.9:debug
 267
 268 If SPEC does not specify a version number, return the preferred newest
 269 version; if SPEC does not specify an output, return OUTPUT."
 270   (let-values (((name version sub-drv)
 271                 (package-specification->name+version+output spec output)))
 272     (match (%find-package spec name version)
 273       (#f
 274        (values #f #f))
 275       (package
 276        (if (member sub-drv (package-outputs package))
 277            (values package sub-drv)
 278            (leave (G_ "package `~a' lacks output `~a'~%")
 279                   (package-full-name package)
 280                   sub-drv))))))