guix/scripts/refresh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;; Copyright © 2014 Eric Bavier <bavier@member.fsf.org>
   5 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
   6 ;;; Copyright © 2016 Ben Woodcroft <donttrustben@gmail.com>
   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 (guix scripts refresh)
  24   #:use-module (guix ui)
  25   #:use-module (guix hash)
  26   #:use-module (guix scripts)
  27   #:use-module (guix store)
  28   #:use-module (guix utils)
  29   #:use-module (guix packages)
  30   #:use-module (guix upstream)
  31   #:use-module (guix graph)
  32   #:use-module (guix scripts graph)
  33   #:use-module (guix monads)
  34   #:use-module ((guix gnu-maintenance)
  35                 #:select (%gnu-updater
  36                           %gnome-updater
  37                           %kde-updater
  38                           %xorg-updater
  39                           %kernel.org-updater))
  40   #:use-module (guix import elpa)
  41   #:use-module (guix import cran)
  42   #:use-module (guix import hackage)
  43   #:use-module (guix gnupg)
  44   #:use-module (gnu packages)
  45   #:use-module ((gnu packages commencement) #:select (%final-inputs))
  46   #:use-module (ice-9 match)
  47   #:use-module (ice-9 regex)
  48   #:use-module (ice-9 vlist)
  49   #:use-module (ice-9 format)
  50   #:use-module (srfi srfi-1)
  51   #:use-module (srfi srfi-11)
  52   #:use-module (srfi srfi-26)
  53   #:use-module (srfi srfi-37)
  54   #:use-module (ice-9 binary-ports)
  55   #:export (guix-refresh
  56             %updaters))
  57
  58 \f
  59 ;;;
  60 ;;; Command-line options.
  61 ;;;
  62
  63 (define %default-options
  64   ;; Alist of default option values.
  65   '())
  66
  67 (define %options
  68   ;; Specification of the command-line options.
  69   (list (option '(#\u "update") #f #f
  70                 (lambda (opt name arg result)
  71                   (alist-cons 'update? #t result)))
  72         (option '(#\s "select") #t #f
  73                 (lambda (opt name arg result)
  74                   (match arg
  75                     ((or "core" "non-core")
  76                      (alist-cons 'select (string->symbol arg)
  77                                  result))
  78                     (x
  79                      (leave (G_ "~a: invalid selection; expected `core' or `non-core'~%")
  80                             arg)))))
  81         (option '(#\t "type") #t #f
  82                 (lambda (opt name arg result)
  83                   (let* ((not-comma (char-set-complement (char-set #\,)))
  84                          (names (map string->symbol
  85                                      (string-tokenize arg not-comma))))
  86                     (alist-cons 'updaters names result))))
  87         (option '(#\L "list-updaters") #f #f
  88                 (lambda args
  89                   (list-updaters-and-exit)))
  90         (option '(#\e "expression") #t #f
  91                 (lambda (opt name arg result)
  92                   (alist-cons 'expression arg result)))
  93         (option '(#\l "list-dependent") #f #f
  94                 (lambda (opt name arg result)
  95                   (alist-cons 'list-dependent? #t result)))
  96
  97         (option '("key-server") #t #f
  98                 (lambda (opt name arg result)
  99                   (alist-cons 'key-server arg result)))
 100         (option '("gpg") #t #f
 101                 (lambda (opt name arg result)
 102                   (alist-cons 'gpg-command arg result)))
 103         (option '("key-download") #t #f
 104                 (lambda (opt name arg result)
 105                   (match arg
 106                     ((or "interactive" "always" "never")
 107                      (alist-cons 'key-download (string->symbol arg)
 108                                  result))
 109                     (x
 110                      (leave (G_ "unsupported policy: ~a~%")
 111                             arg)))))
 112
 113         (option '(#\h "help") #f #f
 114                 (lambda args
 115                   (show-help)
 116                   (exit 0)))
 117         (option '(#\V "version") #f #f
 118                 (lambda args
 119                   (show-version-and-exit "guix refresh")))))
 120
 121 (define (show-help)
 122   (display (G_ "Usage: guix refresh [OPTION]... [PACKAGE]...
 123 Update package definitions to match the latest upstream version.
 124
 125 When PACKAGE... is given, update only the specified packages.  Otherwise
 126 update all the packages of the distribution, or the subset thereof
 127 specified with `--select'.\n"))
 128   (display (G_ "
 129   -e, --expression=EXPR  consider the package EXPR evaluates to"))
 130   (display (G_ "
 131   -u, --update           update source files in place"))
 132   (display (G_ "
 133   -s, --select=SUBSET    select all the packages in SUBSET, one of
 134                          `core' or `non-core'"))
 135   (display (G_ "
 136   -t, --type=UPDATER,... restrict to updates from the specified updaters
 137                          (e.g., 'gnu')"))
 138   (display (G_ "
 139   -L, --list-updaters    list available updaters and exit"))
 140   (display (G_ "
 141   -l, --list-dependent   list top-level dependent packages that would need to
 142                          be rebuilt as a result of upgrading PACKAGE..."))
 143   (newline)
 144   (display (G_ "
 145       --key-server=HOST  use HOST as the OpenPGP key server"))
 146   (display (G_ "
 147       --gpg=COMMAND      use COMMAND as the GnuPG 2.x command"))
 148   (display (G_ "
 149       --key-download=POLICY
 150                          handle missing OpenPGP keys according to POLICY:
 151                          'always', 'never', and 'interactive', which is also
 152                          used when 'key-download' is not specified"))
 153   (newline)
 154   (display (G_ "
 155   -h, --help             display this help and exit"))
 156   (display (G_ "
 157   -V, --version          display version information and exit"))
 158   (newline)
 159   (show-bug-report-information))
 160
 161 \f
 162 ;;;
 163 ;;; Updates.
 164 ;;;
 165
 166 (define-syntax maybe-updater
 167   ;; Helper macro for 'list-updaters'.
 168   (syntax-rules (=>)
 169     ((_ ((module => updater) rest ...) result)
 170      (maybe-updater (rest ...)
 171                     (let ((iface (false-if-exception
 172                                   (resolve-interface 'module)))
 173                           (tail  result))
 174                       (if iface
 175                           (cons (module-ref iface 'updater) tail)
 176                           tail))))
 177     ((_ (updater rest ...) result)
 178      (maybe-updater (rest ...)
 179                     (cons updater result)))
 180     ((_ () result)
 181      (reverse result))))
 182
 183 (define-syntax-rule (list-updaters updaters ...)
 184   "Expand to '(list UPDATERS ...)' but only the subset of UPDATERS that are
 185 either unconditional, or have their requirement met.
 186
 187 A conditional updater has this form:
 188
 189   ((SOME MODULE) => UPDATER)
 190
 191 meaning that UPDATER is added to the list if and only if (SOME MODULE) could
 192 be resolved at run time.
 193
 194 This is a way to discard at macro expansion time updaters that depend on
 195 unavailable optional dependencies such as Guile-JSON."
 196   (maybe-updater (updaters ...) '()))
 197
 198 (define %updaters
 199   ;; List of "updaters" used by default.  They are consulted in this order.
 200   (list-updaters %gnu-updater
 201                  %gnome-updater
 202                  %kde-updater
 203                  %xorg-updater
 204                  %kernel.org-updater
 205                  %elpa-updater
 206                  %cran-updater
 207                  %bioconductor-updater
 208                  ((guix import stackage) => %stackage-updater)
 209                  %hackage-updater
 210                  ((guix import cpan) => %cpan-updater)
 211                  ((guix import pypi) => %pypi-updater)
 212                  ((guix import gem) => %gem-updater)
 213                  ((guix import github) => %github-updater)
 214                  ((guix import crate) => %crate-updater)))
 215
 216 (define (lookup-updater-by-name name)
 217   "Return the updater called NAME."
 218   (or (find (lambda (updater)
 219               (eq? name (upstream-updater-name updater)))
 220             %updaters)
 221       (leave (G_ "~a: no such updater~%") name)))
 222
 223 (define (list-updaters-and-exit)
 224   "Display available updaters and exit."
 225   (format #t (G_ "Available updaters:~%"))
 226   (newline)
 227
 228   (let* ((packages (fold-packages cons '()))
 229          (total    (length packages)))
 230     (define covered
 231       (fold (lambda (updater covered)
 232               (let ((matches (count (upstream-updater-predicate updater)
 233                                     packages)))
 234                 ;; TRANSLATORS: The parenthetical expression here is rendered
 235                 ;; like "(42% coverage)" and denotes the fraction of packages
 236                 ;; covered by the given updater.
 237                 (format #t (G_ "  - ~a: ~a (~2,1f% coverage)~%")
 238                         (upstream-updater-name updater)
 239                         (G_ (upstream-updater-description updater))
 240                         (* 100. (/ matches total)))
 241                 (+ covered matches)))
 242             0
 243             %updaters))
 244
 245     (newline)
 246     (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%")
 247             (* 100. (/ covered total))))
 248   (exit 0))
 249
 250 (define (warn-no-updater package)
 251   (format (current-error-port)
 252           (G_ "~a: warning: no updater for ~a~%")
 253           (location->string (package-location package))
 254           (package-name package)))
 255
 256 (define* (update-package store package updaters
 257                          #:key (key-download 'interactive) warn?)
 258   "Update the source file that defines PACKAGE with the new version.
 259 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 260 values: 'interactive' (default), 'always', and 'never'.  When WARN? is true,
 261 warn about packages that have no matching updater."
 262   (if (lookup-updater package updaters)
 263       (let-values (((version tarball)
 264                     (package-update store package updaters
 265                                     #:key-download key-download))
 266                    ((loc)
 267                     (or (package-field-location package 'version)
 268                         (package-location package))))
 269         (when version
 270           (if (and=> tarball file-exists?)
 271               (begin
 272                 (format (current-error-port)
 273                         (G_ "~a: ~a: updating from version ~a to version ~a...~%")
 274                         (location->string loc)
 275                         (package-name package)
 276                         (package-version package) version)
 277                 (let ((hash (call-with-input-file tarball
 278                               port-sha256)))
 279                   (update-package-source package version hash)))
 280               (warning (G_ "~a: version ~a could not be \
 281 downloaded and authenticated; not updating~%")
 282                        (package-name package) version))))
 283       (when warn?
 284         (warn-no-updater package))))
 285
 286 (define* (check-for-package-update package updaters #:key warn?)
 287   "Check whether an update is available for PACKAGE and print a message.  When
 288 WARN? is true and no updater exists for PACKAGE, print a warning."
 289   (match (package-latest-release package updaters)
 290     ((? upstream-source? source)
 291      (when (version>? (upstream-source-version source)
 292                       (package-version package))
 293        (let ((loc (or (package-field-location package 'version)
 294                       (package-location package))))
 295          (format (current-error-port)
 296                  (G_ "~a: ~a would be upgraded from ~a to ~a~%")
 297                  (location->string loc)
 298                  (package-name package) (package-version package)
 299                  (upstream-source-version source)))))
 300     (#f
 301      (when warn?
 302        (warn-no-updater package)))))
 303
 304
 305 \f
 306 ;;;
 307 ;;; Dependents.
 308 ;;;
 309
 310 (define (all-packages)
 311   "Return the list of all the distro's packages."
 312   (fold-packages cons '()))
 313
 314 (define (list-dependents packages)
 315   "List all the things that would need to be rebuilt if PACKAGES are changed."
 316   ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE
 317   ;; because it includes implicit dependencies.
 318   (define (full-name package)
 319     (string-append (package-name package) "@"
 320                    (package-version package)))
 321
 322   (mlet %store-monad ((edges (node-back-edges %bag-node-type
 323                                               (all-packages))))
 324     (let* ((dependents (node-transitive-edges packages edges))
 325            (covering   (filter (lambda (node)
 326                                  (null? (edges node)))
 327                                dependents)))
 328       (match dependents
 329         (()
 330          (format (current-output-port)
 331                  (N_ "No dependents other than itself: ~{~a~}~%"
 332                      "No dependents other than themselves: ~{~a~^ ~}~%"
 333                      (length packages))
 334                  (map full-name packages)))
 335
 336         ((x)
 337          (format (current-output-port)
 338                  (G_ "A single dependent package: ~a~%")
 339                  (full-name x)))
 340         (lst
 341          (format (current-output-port)
 342                  (N_ "Building the following package would ensure ~d \
 343 dependent packages are rebuilt: ~*~{~a~^ ~}~%"
 344                      "Building the following ~d packages would ensure ~d \
 345 dependent packages are rebuilt: ~{~a~^ ~}~%"
 346                      (length covering))
 347                  (length covering) (length dependents)
 348                  (map full-name covering))))
 349       (return #t))))
 350
 351 \f
 352 ;;;
 353 ;;; Entry point.
 354 ;;;
 355
 356 (define (guix-refresh . args)
 357   (define (parse-options)
 358     ;; Return the alist of option values.
 359     (args-fold* args %options
 360                 (lambda (opt name arg result)
 361                   (leave (G_ "~A: unrecognized option~%") name))
 362                 (lambda (arg result)
 363                   (alist-cons 'argument arg result))
 364                 %default-options))
 365
 366   (define (options->updaters opts)
 367     ;; Return the list of updaters to use.
 368     (match (filter-map (match-lambda
 369                          (('updaters . names)
 370                           (map lookup-updater-by-name names))
 371                          (_ #f))
 372                        opts)
 373       (()
 374        ;; Use the default updaters.
 375        %updaters)
 376       (lists
 377        (concatenate lists))))
 378
 379   (define (keep-newest package lst)
 380     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
 381     ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
 382     (let ((name (package-name package)))
 383       (match (find (lambda (p)
 384                      (string=? (package-name p) name))
 385                    lst)
 386         ((? package? other)
 387          (if (version>? (package-version other) (package-version package))
 388              lst
 389              (cons package (delq other lst))))
 390         (_
 391          (cons package lst)))))
 392
 393   (define core-package?
 394     (let* ((input->package (match-lambda
 395                              ((name (? package? package) _ ...) package)
 396                              (_ #f)))
 397            (final-inputs   (map input->package %final-inputs))
 398            (core           (append final-inputs
 399                                    (append-map (compose (cut filter-map input->package <>)
 400                                                         package-transitive-inputs)
 401                                                final-inputs)))
 402            (names          (delete-duplicates (map package-name core))))
 403       (lambda (package)
 404         "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
 405 update would trigger a complete rebuild."
 406         ;; Compare by name because packages in base.scm basically inherit
 407         ;; other packages.  So, even if those packages are not core packages
 408         ;; themselves, updating them would also update those who inherit from
 409         ;; them.
 410         ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
 411         (member (package-name package) names))))
 412
 413   (let* ((opts            (parse-options))
 414          (update?         (assoc-ref opts 'update?))
 415          (updaters        (options->updaters opts))
 416          (list-dependent? (assoc-ref opts 'list-dependent?))
 417          (key-download    (assoc-ref opts 'key-download))
 418
 419          ;; Warn about missing updaters when a package is explicitly given on
 420          ;; the command line.
 421          (warn?           (or (assoc-ref opts 'argument)
 422                               (assoc-ref opts 'expression)))
 423
 424          (packages
 425           (match (filter-map (match-lambda
 426                                (('argument . spec)
 427                                 ;; Take either the specified version or the
 428                                 ;; latest one.
 429                                 (specification->package spec))
 430                                (('expression . exp)
 431                                 (read/eval-package-expression exp))
 432                                (_ #f))
 433                              opts)
 434             (()                                   ; default to all packages
 435              (let ((select? (match (assoc-ref opts 'select)
 436                               ('core core-package?)
 437                               ('non-core (negate core-package?))
 438                               (_ (const #t)))))
 439                (fold-packages (lambda (package result)
 440                                 (if (select? package)
 441                                     (keep-newest package result)
 442                                     result))
 443                               '())))
 444             (some                                 ; user-specified packages
 445              some))))
 446     (with-error-handling
 447       (with-store store
 448         (run-with-store store
 449           (cond
 450            (list-dependent?
 451             (list-dependents packages))
 452            (update?
 453             (parameterize ((%openpgp-key-server
 454                             (or (assoc-ref opts 'key-server)
 455                                 (%openpgp-key-server)))
 456                            (%gpg-command
 457                             (or (assoc-ref opts 'gpg-command)
 458                                 (%gpg-command))))
 459               (for-each
 460                (cut update-package store <> updaters
 461                     #:key-download key-download
 462                     #:warn? warn?)
 463                packages)
 464               (with-monad %store-monad
 465                 (return #t))))
 466            (else
 467             (for-each (cut check-for-package-update <> updaters
 468                            #:warn? warn?)
 469                       packages)
 470             (with-monad %store-monad
 471               (return #t)))))))))