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