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