gnu/packages.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (gnu packages)
  22   #:use-module (guix packages)
  23   #:use-module (guix ui)
  24   #:use-module (guix utils)
  25   #:use-module ((guix ftp-client) #:select (ftp-open))
  26   #:use-module (guix gnu-maintenance)
  27   #:use-module (guix upstream)
  28   #:use-module (ice-9 ftw)
  29   #:use-module (ice-9 vlist)
  30   #:use-module (ice-9 match)
  31   #:use-module (srfi srfi-1)
  32   #:use-module (srfi srfi-11)
  33   #:use-module (srfi srfi-26)
  34   #:use-module (srfi srfi-34)
  35   #:use-module (srfi srfi-35)
  36   #:use-module (srfi srfi-39)
  37   #:export (search-patch
  38             search-bootstrap-binary
  39             %patch-path
  40             %bootstrap-binaries-path
  41             %package-module-path
  42
  43             fold-packages
  44
  45             find-packages-by-name
  46             find-best-packages-by-name
  47             find-newest-available-packages
  48
  49             package-direct-dependents
  50             package-transitive-dependents
  51             package-covering-dependents
  52
  53             check-package-freshness
  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 and bootstrap binaries alongside Guile
  66 ;; modules.  This is so that these extra files can be found without
  67 ;; requiring a special setup, such as a specific installation directory
  68 ;; and an extra environment variable.  One advantage of this setup is
  69 ;; that everything just works in an auto-compilation setting.
  70
  71 (define %bootstrap-binaries-path
  72   (make-parameter
  73    (map (cut string-append <> "/gnu/packages/bootstrap")
  74         %load-path)))
  75
  76 (define (search-patch file-name)
  77   "Search the patch FILE-NAME.  Raise an error if not found."
  78   (or (search-path (%patch-path) file-name)
  79       (raise (condition
  80               (&message (message (format #f (_ "~a: patch not found")
  81                                          file-name)))))))
  82
  83 (define (search-bootstrap-binary file-name system)
  84   "Search the bootstrap binary FILE-NAME for SYSTEM.  Raise an error if not
  85 found."
  86   (or (search-path (%bootstrap-binaries-path)
  87                    (string-append system "/" file-name))
  88       (raise (condition
  89               (&message
  90                (message
  91                 (format #f (_ "could not find bootstrap binary '~a' \
  92 for system '~a'")
  93                         file-name system)))))))
  94
  95 (define %distro-root-directory
  96   ;; Absolute file name of the module hierarchy.
  97   (dirname (search-path %load-path "guix.scm")))
  98
  99 (define %package-module-path
 100   ;; Search path for package modules.  Each item must be either a directory
 101   ;; name or a pair whose car is a directory and whose cdr is a sub-directory
 102   ;; to narrow the search.
 103   (let* ((not-colon   (char-set-complement (char-set #\:)))
 104          (environment (string-tokenize (or (getenv "GUIX_PACKAGE_PATH") "")
 105                                        not-colon)))
 106     ;; Automatically add items from $GUIX_PACKAGE_PATH to Guile's search path.
 107     (for-each (lambda (directory)
 108                 (set! %load-path (cons directory %load-path))
 109                 (set! %load-compiled-path
 110                       (cons directory %load-compiled-path)))
 111               environment)
 112
 113     (make-parameter
 114      (append environment `((,%distro-root-directory . "gnu/packages"))))))
 115
 116 (define %patch-path
 117   ;; Define it after '%package-module-path' so that '%load-path' contains user
 118   ;; directories, allowing patches in $GUIX_PACKAGE_PATH to be found.
 119   (make-parameter
 120    (map (lambda (directory)
 121           (if (string=? directory %distro-root-directory)
 122               (string-append directory "/gnu/packages/patches")
 123               directory))
 124         %load-path)))
 125
 126 (define* (scheme-files directory)
 127   "Return the list of Scheme files found under DIRECTORY, recursively.  The
 128 returned list is sorted in alphabetical order."
 129
 130   ;; Sort entries so that 'fold-packages' works in a deterministic fashion
 131   ;; regardless of details of the underlying file system.
 132   (sort (file-system-fold (const #t)                   ; enter?
 133                           (lambda (path stat result)   ; leaf
 134                             (if (string-suffix? ".scm" path)
 135                                 (cons path result)
 136                                 result))
 137                           (lambda (path stat result)   ; down
 138                             result)
 139                           (lambda (path stat result)   ; up
 140                             result)
 141                           (const #f)                   ; skip
 142                           (lambda (path stat errno result)
 143                             (warning (_ "cannot access `~a': ~a~%")
 144                                      path (strerror errno))
 145                             result)
 146                           '()
 147                           directory
 148                           stat)
 149         string<?))
 150
 151 (define file-name->module-name
 152   (let ((not-slash (char-set-complement (char-set #\/))))
 153     (lambda (file)
 154       "Return the module name (a list of symbols) corresponding to FILE."
 155       (map string->symbol
 156            (string-tokenize (string-drop-right file 4) not-slash)))))
 157
 158 (define* (package-modules directory #:optional sub-directory)
 159   "Return the list of modules that provide packages for the distribution.
 160 Optionally, narrow the search to SUB-DIRECTORY."
 161   (define prefix-len
 162     (string-length directory))
 163
 164   (filter-map (lambda (file)
 165                 (let* ((file   (substring file prefix-len))
 166                        (module (file-name->module-name file)))
 167                   (catch #t
 168                     (lambda ()
 169                       (resolve-interface module))
 170                     (lambda args
 171                       ;; Report the error, but keep going.
 172                       (warn-about-load-error module args)
 173                       #f))))
 174               (scheme-files (if sub-directory
 175                                 (string-append directory "/" sub-directory)
 176                                 directory))))
 177
 178 (define* (all-package-modules #:optional (path (%package-module-path)))
 179   "Return the list of package modules found in PATH, a list of directories to
 180 search."
 181   (fold-right (lambda (spec result)
 182                 (match spec
 183                   ((? string? directory)
 184                    (append (package-modules directory) result))
 185                   ((directory . sub-directory)
 186                    (append (package-modules directory sub-directory)
 187                            result))))
 188               '()
 189               path))
 190
 191 (define (fold-packages proc init)
 192   "Call (PROC PACKAGE RESULT) for each available package, using INIT as
 193 the initial value of RESULT.  It is guaranteed to never traverse the
 194 same package twice."
 195   (identity   ; discard second return value
 196    (fold2 (lambda (module result seen)
 197             (fold2 (lambda (var result seen)
 198                      (if (and (package? var)
 199                               (not (vhash-assq var seen)))
 200                          (values (proc var result)
 201                                  (vhash-consq var #t seen))
 202                          (values result seen)))
 203                    result
 204                    seen
 205                    (module-map (lambda (sym var)
 206                                  (false-if-exception (variable-ref var)))
 207                                module)))
 208           init
 209           vlist-null
 210           (all-package-modules))))
 211
 212 (define find-packages-by-name
 213   (let ((packages (delay
 214                     (fold-packages (lambda (p r)
 215                                      (vhash-cons (package-name p) p r))
 216                                    vlist-null)))
 217         (version>? (lambda (p1 p2)
 218                      (version>? (package-version p1) (package-version p2)))))
 219     (lambda* (name #:optional version)
 220       "Return the list of packages with the given NAME.  If VERSION is not #f,
 221 then only return packages whose version is prefixed by VERSION, sorted in
 222 decreasing version order."
 223       (let ((matching (sort (vhash-fold* cons '() name (force packages))
 224                             version>?)))
 225         (if version
 226             (filter (lambda (package)
 227                       (string-prefix? version (package-version package)))
 228                     matching)
 229             matching)))))
 230
 231 (define find-newest-available-packages
 232   (memoize
 233    (lambda ()
 234      "Return a vhash keyed by package names, and with
 235 associated values of the form
 236
 237   (newest-version newest-package ...)
 238
 239 where the preferred package is listed first."
 240
 241      ;; FIXME: Currently, the preferred package is whichever one
 242      ;; was found last by 'fold-packages'.  Find a better solution.
 243      (fold-packages (lambda (p r)
 244                       (let ((name    (package-name p))
 245                             (version (package-version p)))
 246                         (match (vhash-assoc name r)
 247                           ((_ newest-so-far . pkgs)
 248                            (case (version-compare version newest-so-far)
 249                              ((>) (vhash-cons name `(,version ,p) r))
 250                              ((=) (vhash-cons name `(,version ,p ,@pkgs) r))
 251                              ((<) r)))
 252                           (#f (vhash-cons name `(,version ,p) r)))))
 253                     vlist-null))))
 254
 255 (define (find-best-packages-by-name name version)
 256   "If version is #f, return the list of packages named NAME with the highest
 257 version numbers; otherwise, return the list of packages named NAME and at
 258 VERSION."
 259   (if version
 260       (find-packages-by-name name version)
 261       (match (vhash-assoc name (find-newest-available-packages))
 262         ((_ version pkgs ...) pkgs)
 263         (#f '()))))
 264
 265 \f
 266 (define* (vhash-refq vhash key #:optional (dflt #f))
 267   "Look up KEY in the vhash VHASH, and return the value (if any) associated
 268 with it.  If KEY is not found, return DFLT (or `#f' if no DFLT argument is
 269 supplied).  Uses `eq?' for equality testing."
 270   (or (and=> (vhash-assq key vhash) cdr)
 271       dflt))
 272
 273 (define package-dependencies
 274   (memoize
 275    (lambda ()
 276      "Return a vhash keyed by package, and with associated values that are a
 277 list of packages that depend on that package."
 278      (fold-packages
 279       (lambda (package dag)
 280         (fold
 281          (lambda (in d)
 282            ;; Insert a graph edge from each of package's inputs to package.
 283            (vhash-consq in
 284                         (cons package (vhash-refq d in '()))
 285                         (vhash-delq in d)))
 286          dag
 287          (match (package-direct-inputs package)
 288            (((labels packages . _) ...)
 289             packages) )))
 290       vlist-null))))
 291
 292 (define (package-direct-dependents packages)
 293   "Return a list of packages from the distribution that directly depend on the
 294 packages in PACKAGES."
 295   (delete-duplicates
 296    (concatenate
 297     (map (lambda (p)
 298            (vhash-refq (package-dependencies) p '()))
 299          packages))))
 300
 301 (define (package-transitive-dependents packages)
 302   "Return the transitive dependent packages of the distribution packages in
 303 PACKAGES---i.e. the dependents of those packages, plus their dependents,
 304 recursively."
 305   (let ((dependency-dag (package-dependencies)))
 306     (fold-tree
 307      cons '()
 308      (lambda (node) (vhash-refq dependency-dag node))
 309      ;; Start with the dependents to avoid including PACKAGES in the result.
 310      (package-direct-dependents packages))))
 311
 312 (define (package-covering-dependents packages)
 313   "Return a minimal list of packages from the distribution whose dependencies
 314 include all of PACKAGES and all packages that depend on PACKAGES."
 315   (let ((dependency-dag (package-dependencies)))
 316     (fold-tree-leaves
 317      cons '()
 318      (lambda (node) (vhash-refq dependency-dag node))
 319      ;; Start with the dependents to avoid including PACKAGES in the result.
 320      (package-direct-dependents packages))))
 321
 322 \f
 323 (define %sigint-prompt
 324   ;; The prompt to jump to upon SIGINT.
 325   (make-prompt-tag "interruptible"))
 326
 327 (define (call-with-sigint-handler thunk handler)
 328   "Call THUNK and return its value.  Upon SIGINT, call HANDLER with the signal
 329 number in the context of the continuation of the call to this function, and
 330 return its return value."
 331   (call-with-prompt %sigint-prompt
 332                     (lambda ()
 333                       (sigaction SIGINT
 334                         (lambda (signum)
 335                           (sigaction SIGINT SIG_DFL)
 336                           (abort-to-prompt %sigint-prompt signum)))
 337                       (dynamic-wind
 338                         (const #t)
 339                         thunk
 340                         (cut sigaction SIGINT SIG_DFL)))
 341                     (lambda (k signum)
 342                       (handler signum))))
 343
 344 (define-syntax-rule (waiting exp fmt rest ...)
 345   "Display the given message while EXP is being evaluated."
 346   (let* ((message (format #f fmt rest ...))
 347          (blank   (make-string (string-length message) #\space)))
 348     (display message (current-error-port))
 349     (force-output (current-error-port))
 350     (call-with-sigint-handler
 351      (lambda ()
 352        (dynamic-wind
 353          (const #f)
 354          (lambda () exp)
 355          (lambda ()
 356            ;; Clear the line.
 357            (display #\cr (current-error-port))
 358            (display blank (current-error-port))
 359            (display #\cr (current-error-port))
 360            (force-output (current-error-port)))))
 361      (lambda (signum)
 362        (format (current-error-port) "  interrupted by signal ~a~%" SIGINT)
 363        #f))))
 364
 365 (define ftp-open*
 366   ;; Memoizing version of `ftp-open'.  The goal is to avoid initiating a new
 367   ;; FTP connection for each package, esp. since most of them are to the same
 368   ;; server.  This has a noticeable impact when doing "guix upgrade -u".
 369   (memoize ftp-open))
 370
 371 (define (check-package-freshness package)
 372   "Check whether PACKAGE has a newer version available upstream, and report
 373 it."
 374   ;; TODO: Automatically inject the upstream version when desired.
 375
 376   (catch #t
 377     (lambda ()
 378       (when (false-if-exception (gnu-package? package))
 379         (let ((name      (package-name package))
 380               (full-name (package-full-name package)))
 381           ;; XXX: This could work with non-GNU packages as well.  However,
 382           ;; GNU's FTP-based updater would be too slow if it weren't memoized,
 383           ;; and the generic interface in (guix upstream) doesn't support
 384           ;; that.
 385           (match (waiting (latest-release name
 386                                           #:ftp-open ftp-open*
 387                                           #:ftp-close (const #f))
 388                           (_ "looking for the latest release of GNU ~a...") name)
 389             ((? upstream-source? source)
 390              (let ((latest-version
 391                     (string-append (upstream-source-package source) "-"
 392                                    (upstream-source-version source))))
 393               (when (version>? latest-version full-name)
 394                 (format (current-error-port)
 395                         (_ "~a: note: using ~a \
 396 but ~a is available upstream~%")
 397                         (location->string (package-location package))
 398                         full-name latest-version))))
 399             (_ #t)))))
 400     (lambda (key . args)
 401       ;; Silently ignore networking errors rather than preventing
 402       ;; installation.
 403       (case key
 404         ((getaddrinfo-error ftp-error) #f)
 405         (else (apply throw key args))))))
 406
 407 (define (specification->package spec)
 408   "Return a package matching SPEC.  SPEC may be a package name, or a package
 409 name followed by a hyphen and a version number.  If the version number is not
 410 present, return the preferred newest version."
 411   (let-values (((name version)
 412                 (package-name->name+version spec)))
 413     (match (find-best-packages-by-name name version)
 414       ((p)                                      ; one match
 415        p)
 416       ((p x ...)                                ; several matches
 417        (warning (_ "ambiguous package specification `~a'~%") spec)
 418        (warning (_ "choosing ~a from ~a~%")
 419                 (package-full-name p)
 420                 (location->string (package-location p)))
 421        p)
 422       (_                                        ; no matches
 423        (if version
 424            (leave (_ "~A: package not found for version ~a~%")
 425                   name version)
 426            (leave (_ "~A: unknown package~%") name))))))
 427
 428 (define* (specification->package+output spec #:optional (output "out"))
 429   "Return the package and output specified by SPEC, or #f and #f; SPEC may
 430 optionally contain a version number and an output name, as in these examples:
 431
 432   guile
 433   guile-2.0.9
 434   guile:debug
 435   guile-2.0.9:debug
 436
 437 If SPEC does not specify a version number, return the preferred newest
 438 version; if SPEC does not specify an output, return OUTPUT."
 439   (define (ensure-output p sub-drv)
 440     (if (member sub-drv (package-outputs p))
 441         sub-drv
 442         (leave (_ "package `~a' lacks output `~a'~%")
 443                (package-full-name p)
 444                sub-drv)))
 445
 446   (let-values (((name version sub-drv)
 447                 (package-specification->name+version+output spec output)))
 448     (match (find-best-packages-by-name name version)
 449       ((p)
 450        (values p (ensure-output p sub-drv)))
 451       ((p p* ...)
 452        (warning (_ "ambiguous package specification `~a'~%")
 453                 spec)
 454        (warning (_ "choosing ~a from ~a~%")
 455                 (package-full-name p)
 456                 (location->string (package-location p)))
 457        (values p (ensure-output p sub-drv)))
 458       (()
 459        (leave (_ "~a: package not found~%") spec)))))