gnu/packages.scm

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