guix/scripts/refresh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019 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 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
   8 ;;; Copyright © 2018 Efraim Flashner <efraim@flashner.co.il>
   9 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
  10 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
  11 ;;;
  12 ;;; This file is part of GNU Guix.
  13 ;;;
  14 ;;; GNU Guix is free software; you can redistribute it and/or modify it
  15 ;;; under the terms of the GNU General Public License as published by
  16 ;;; the Free Software Foundation; either version 3 of the License, or (at
  17 ;;; your option) any later version.
  18 ;;;
  19 ;;; GNU Guix is distributed in the hope that it will be useful, but
  20 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;;; GNU General Public License for more details.
  23 ;;;
  24 ;;; You should have received a copy of the GNU General Public License
  25 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  26
  27 (define-module (guix scripts refresh)
  28   #:use-module (guix ui)
  29   #:use-module (gcrypt hash)
  30   #:use-module (guix scripts)
  31   #:use-module ((guix scripts build) #:select (%standard-build-options))
  32   #:use-module (guix store)
  33   #:use-module (guix utils)
  34   #:use-module (guix packages)
  35   #:use-module (guix profiles)
  36   #:use-module (guix upstream)
  37   #:use-module (guix graph)
  38   #:use-module (guix scripts graph)
  39   #:use-module (guix monads)
  40   #:use-module (guix gnupg)
  41   #:use-module (gnu packages)
  42   #:use-module ((gnu packages commencement) #:select (%final-inputs))
  43   #:use-module (ice-9 match)
  44   #:use-module (ice-9 regex)
  45   #:use-module (ice-9 vlist)
  46   #:use-module (ice-9 format)
  47   #:use-module (srfi srfi-1)
  48   #:use-module (srfi srfi-11)
  49   #:use-module (srfi srfi-26)
  50   #:use-module (srfi srfi-37)
  51   #:use-module (ice-9 binary-ports)
  52   #:export (guix-refresh))
  53
  54 \f
  55 ;;;
  56 ;;; Command-line options.
  57 ;;;
  58
  59 (define %default-options
  60   ;; Alist of default option values.
  61   '())
  62
  63 (define %options
  64   ;; Specification of the command-line options.
  65   (list (option '(#\u "update") #f #f
  66                 (lambda (opt name arg result)
  67                   (alist-cons 'update? #t result)))
  68         (option '(#\s "select") #t #f
  69                 (lambda (opt name arg result)
  70                   (match arg
  71                     ((or "core" "non-core")
  72                      (alist-cons 'select (string->symbol arg)
  73                                  result))
  74                     (x
  75                      (leave (G_ "~a: invalid selection; expected `core' or `non-core'~%")
  76                             arg)))))
  77         (option '(#\t "type") #t #f
  78                 (lambda (opt name arg result)
  79                   (let* ((not-comma (char-set-complement (char-set #\,)))
  80                          (names (map string->symbol
  81                                      (string-tokenize arg not-comma))))
  82                     (alist-cons 'updaters names result))))
  83         (option '(#\L "list-updaters") #f #f
  84                 (lambda args
  85                   (list-updaters-and-exit)))
  86         (option '(#\m "manifest") #t #f
  87                 (lambda (opt name arg result)
  88                   (alist-cons 'manifest arg result)))
  89         (option '(#\e "expression") #t #f
  90                 (lambda (opt name arg result)
  91                   (alist-cons 'expression arg result)))
  92         (option '(#\l "list-dependent") #f #f
  93                 (lambda (opt name arg result)
  94                   (alist-cons 'list-dependent? #t result)))
  95         (option '(#\r "recursive") #f #f
  96                 (lambda (opt name arg result)
  97                   (alist-cons 'recursive? #t result)))
  98         (option '("list-transitive") #f #f
  99                 (lambda (opt name arg result)
 100                   (alist-cons 'list-transitive? #t result)))
 101
 102         (option '("keyring") #t #f
 103                 (lambda (opt name arg result)
 104                   (alist-cons 'keyring arg result)))
 105         (option '("key-server") #t #f
 106                 (lambda (opt name arg result)
 107                   (alist-cons 'key-server arg result)))
 108         (option '("gpg") #t #f
 109                 (lambda (opt name arg result)
 110                   (alist-cons 'gpg-command arg result)))
 111         (option '("key-download") #t #f
 112                 (lambda (opt name arg result)
 113                   (match arg
 114                     ((or "interactive" "always" "never")
 115                      (alist-cons 'key-download (string->symbol arg)
 116                                  result))
 117                     (x
 118                      (leave (G_ "unsupported policy: ~a~%")
 119                             arg)))))
 120
 121         ;; The short option -L is already used by --list-updaters, therefore
 122         ;; it needs to be removed from %standard-build-options.
 123         (let ((%load-path-option (find (lambda (option)
 124                                          (member "load-path"
 125                                                  (option-names option)))
 126                                        %standard-build-options)))
 127           (option
 128            (filter (lambda (name) (not (equal? #\L name)))
 129                    (option-names %load-path-option))
 130            (option-required-arg? %load-path-option)
 131            (option-optional-arg? %load-path-option)
 132            (option-processor     %load-path-option)))
 133
 134         (option '(#\h "help") #f #f
 135                 (lambda args
 136                   (show-help)
 137                   (exit 0)))
 138         (option '(#\V "version") #f #f
 139                 (lambda args
 140                   (show-version-and-exit "guix refresh")))))
 141
 142 (define (show-help)
 143   (display (G_ "Usage: guix refresh [OPTION]... [PACKAGE]...
 144 Update package definitions to match the latest upstream version.
 145
 146 When PACKAGE... is given, update only the specified packages.  Otherwise
 147 update all the packages of the distribution, or the subset thereof
 148 specified with `--select'.\n"))
 149   (display (G_ "
 150   -e, --expression=EXPR  consider the package EXPR evaluates to"))
 151   (display (G_ "
 152   -u, --update           update source files in place"))
 153   (display (G_ "
 154   -s, --select=SUBSET    select all the packages in SUBSET, one of
 155                          `core' or `non-core'"))
 156   (display (G_ "
 157   -m, --manifest=FILE    select all the packages from the manifest in FILE"))
 158   (display (G_ "
 159   -t, --type=UPDATER,... restrict to updates from the specified updaters
 160                          (e.g., 'gnu')"))
 161   (display (G_ "
 162   -L, --list-updaters    list available updaters and exit"))
 163   (display (G_ "
 164   -l, --list-dependent   list top-level dependent packages that would need to
 165                          be rebuilt as a result of upgrading PACKAGE..."))
 166   (display (G_ "
 167   -r, --recursive        check the PACKAGE and its inputs for upgrades"))
 168   (display (G_ "
 169       --list-transitive  list all the packages that PACKAGE depends on"))
 170   (newline)
 171   (display (G_ "
 172       --keyring=FILE     use FILE as the keyring of upstream OpenPGP keys"))
 173   (display (G_ "
 174       --key-server=HOST  use HOST as the OpenPGP key server"))
 175   (display (G_ "
 176       --gpg=COMMAND      use COMMAND as the GnuPG 2.x command"))
 177   (display (G_ "
 178       --key-download=POLICY
 179                          handle missing OpenPGP keys according to POLICY:
 180                          'always', 'never', and 'interactive', which is also
 181                          used when 'key-download' is not specified"))
 182   (newline)
 183   (display (G_ "
 184       --load-path=DIR    prepend DIR to the package module search path"))
 185   (newline)
 186   (display (G_ "
 187   -h, --help             display this help and exit"))
 188   (display (G_ "
 189   -V, --version          display version information and exit"))
 190   (newline)
 191   (show-bug-report-information))
 192
 193 (define (options->packages opts)
 194   "Return the list of packages requested by OPTS, honoring options like
 195 '--recursive'."
 196   (define core-package?
 197     (let* ((input->package (match-lambda
 198                              ((name (? package? package) _ ...) package)
 199                              (_ #f)))
 200            (final-inputs   (map input->package %final-inputs))
 201            (core           (append final-inputs
 202                                    (append-map (compose (cut filter-map input->package <>)
 203                                                         package-transitive-inputs)
 204                                                final-inputs)))
 205            (names          (delete-duplicates (map package-name core))))
 206       (lambda (package)
 207         "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
 208 update would trigger a complete rebuild."
 209         ;; Compare by name because packages in base.scm basically inherit
 210         ;; other packages.  So, even if those packages are not core packages
 211         ;; themselves, updating them would also update those who inherit from
 212         ;; them.
 213         ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
 214         (member (package-name package) names))))
 215
 216   (define (keep-newest package lst)
 217     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
 218     ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
 219     (let ((name (package-name package)))
 220       (match (find (lambda (p)
 221                      (string=? (package-name p) name))
 222                    lst)
 223         ((? package? other)
 224          (if (version>? (package-version other) (package-version package))
 225              lst
 226              (cons package (delq other lst))))
 227         (_
 228          (cons package lst)))))
 229
 230   (define args-packages
 231     ;; Packages explicitly passed as command-line arguments.
 232     (match (filter-map (match-lambda
 233                          (('argument . spec)
 234                           ;; Take either the specified version or the
 235                           ;; latest one.
 236                           (specification->package spec))
 237                          (('expression . exp)
 238                           (read/eval-package-expression exp))
 239                          (_ #f))
 240                        opts)
 241       (()                                         ;default to all packages
 242        (let ((select? (match (assoc-ref opts 'select)
 243                         ('core core-package?)
 244                         ('non-core (negate core-package?))
 245                         (_ (const #t)))))
 246          (fold-packages (lambda (package result)
 247                           (if (select? package)
 248                               (keep-newest package result)
 249                               result))
 250                         '())))
 251       (some                                       ;user-specified packages
 252        some)))
 253
 254   (define packages
 255     (match (assoc-ref opts 'manifest)
 256       (#f args-packages)
 257       ((? string? file) (packages-from-manifest file))))
 258
 259   (if (assoc-ref opts 'recursive?)
 260       (mlet %store-monad ((edges (node-edges %bag-node-type
 261                                              (all-packages))))
 262         (return (node-transitive-edges packages edges)))
 263       (with-monad %store-monad
 264         (return packages))))
 265
 266 \f
 267 ;;;
 268 ;;; Updates.
 269 ;;;
 270
 271 (define (lookup-updater-by-name name)
 272   "Return the updater called NAME."
 273   (or (find (lambda (updater)
 274               (eq? name (upstream-updater-name updater)))
 275             (force %updaters))
 276       (leave (G_ "~a: no such updater~%") name)))
 277
 278 (define (list-updaters-and-exit)
 279   "Display available updaters and exit."
 280   (format #t (G_ "Available updaters:~%"))
 281   (newline)
 282
 283   (let* ((packages (fold-packages cons '()))
 284          (total    (length packages)))
 285     (define uncovered
 286       (fold (lambda (updater uncovered)
 287               (let ((matches (filter (upstream-updater-predicate updater)
 288                                      packages)))
 289                 ;; TRANSLATORS: The parenthetical expression here is rendered
 290                 ;; like "(42% coverage)" and denotes the fraction of packages
 291                 ;; covered by the given updater.
 292                 (format #t (G_ "  - ~a: ~a (~2,1f% coverage)~%")
 293                         (upstream-updater-name updater)
 294                         (G_ (upstream-updater-description updater))
 295                         (* 100. (/ (length matches) total)))
 296                 (lset-difference eq? uncovered matches)))
 297             packages
 298             (force %updaters)))
 299
 300     (newline)
 301     (format #t (G_ "~2,1f% of the packages are covered by these updaters.~%")
 302             (* 100. (/ (- total (length uncovered)) total))))
 303   (exit 0))
 304
 305 (define (warn-no-updater package)
 306   (warning (package-location package)
 307            (G_ "no updater for ~a~%")
 308            (package-name package)))
 309
 310 (define* (update-package store package updaters
 311                          #:key (key-download 'interactive) warn?)
 312   "Update the source file that defines PACKAGE with the new version.
 313 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 314 values: 'interactive' (default), 'always', and 'never'.  When WARN? is true,
 315 warn about packages that have no matching updater."
 316   (if (lookup-updater package updaters)
 317       (let-values (((version tarball source)
 318                     (package-update store package updaters
 319                                     #:key-download key-download))
 320                    ((loc)
 321                     (or (package-field-location package 'version)
 322                         (package-location package))))
 323         (when version
 324           (if (and=> tarball file-exists?)
 325               (begin
 326                 (info loc
 327                       (G_ "~a: updating from version ~a to version ~a...~%")
 328                       (package-name package)
 329                       (package-version package) version)
 330                 (for-each
 331                  (lambda (change)
 332                    (format (current-error-port)
 333                            (match (list (upstream-input-change-action change)
 334                                         (upstream-input-change-type change))
 335                              (('add 'regular)
 336                               (G_ "~a: consider adding this input: ~a~%"))
 337                              (('add 'native)
 338                               (G_ "~a: consider adding this native input: ~a~%"))
 339                              (('add 'propagated)
 340                               (G_ "~a: consider adding this propagated input: ~a~%"))
 341                              (('remove 'regular)
 342                               (G_ "~a: consider removing this input: ~a~%"))
 343                              (('remove 'native)
 344                               (G_ "~a: consider removing this native input: ~a~%"))
 345                              (('remove 'propagated)
 346                               (G_ "~a: consider removing this propagated input: ~a~%")))
 347                            (package-name package)
 348                            (upstream-input-change-name change)))
 349                  (upstream-source-input-changes source))
 350                 (let ((hash (call-with-input-file tarball
 351                               port-sha256)))
 352                   (update-package-source package source hash)))
 353               (warning (G_ "~a: version ~a could not be \
 354 downloaded and authenticated; not updating~%")
 355                        (package-name package) version))))
 356       (when warn?
 357         (warn-no-updater package))))
 358
 359 (define* (check-for-package-update package updaters #:key warn?)
 360   "Check whether an update is available for PACKAGE and print a message.  When
 361 WARN? is true and no updater exists for PACKAGE, print a warning."
 362   (match (package-latest-release package updaters)
 363     ((? upstream-source? source)
 364      (let ((loc (or (package-field-location package 'version)
 365                     (package-location package))))
 366        (case (version-compare (upstream-source-version source)
 367                               (package-version package))
 368          ((>)
 369           (info loc
 370                 (G_ "~a would be upgraded from ~a to ~a~%")
 371                 (package-name package) (package-version package)
 372                 (upstream-source-version source)))
 373          ((=)
 374           (when warn?
 375             (info loc
 376                   (G_ "~a is already the latest version of ~a~%")
 377                   (package-version package)
 378                   (package-name package))))
 379          (else
 380           (when warn?
 381             (warning loc
 382                      (G_ "~a is greater than \
 383 the latest known version of ~a (~a)~%")
 384                      (package-version package)
 385                      (package-name package)
 386                      (upstream-source-version source)))))))
 387     (#f
 388      (when warn?
 389        ;; Distinguish between "no updater" and "failing updater."
 390        (match (lookup-updater package updaters)
 391          ((? upstream-updater? updater)
 392           (warning (package-location package)
 393                    (G_ "'~a' updater failed to determine available \
 394 releases for ~a~%")
 395                    (upstream-updater-name updater)
 396                    (package-name package)))
 397          (#f
 398           (warn-no-updater package)))))))
 399
 400 \f
 401 ;;;
 402 ;;; Dependents.
 403 ;;;
 404
 405 (define (all-packages)
 406   "Return the list of all the distro's packages."
 407   (fold-packages (lambda (package result)
 408                    ;; Ignore deprecated packages.
 409                    (if (package-superseded package)
 410                        result
 411                        (cons package result)))
 412                  '()
 413                  #:select? (const #t)))           ;include hidden packages
 414
 415 (define (list-dependents packages)
 416   "List all the things that would need to be rebuilt if PACKAGES are changed."
 417   ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE
 418   ;; because it includes implicit dependencies.
 419   (define (full-name package)
 420     (string-append (package-name package) "@"
 421                    (package-version package)))
 422
 423   (mlet %store-monad ((edges (node-back-edges %bag-node-type
 424                                               (package-closure (all-packages)))))
 425     (let* ((dependents (node-transitive-edges packages edges))
 426            (covering   (filter (lambda (node)
 427                                  (null? (edges node)))
 428                                dependents)))
 429       (match dependents
 430         (()
 431          (format (current-output-port)
 432                  (N_ "No dependents other than itself: ~{~a~}~%"
 433                      "No dependents other than themselves: ~{~a~^ ~}~%"
 434                      (length packages))
 435                  (map full-name packages)))
 436
 437         ((x)
 438          (format (current-output-port)
 439                  (G_ "A single dependent package: ~a~%")
 440                  (full-name x)))
 441         (lst
 442          (format (current-output-port)
 443                  (N_ "Building the following ~*package would ensure ~d \
 444 dependent packages are rebuilt: ~{~a~^ ~}~%"
 445                      "Building the following ~d packages would ensure ~d \
 446 dependent packages are rebuilt: ~{~a~^ ~}~%"
 447                      (length covering))
 448                  (length covering) (length dependents)
 449                  (map full-name covering))))
 450       (return #t))))
 451
 452 (define (list-transitive packages)
 453   "List all the packages that would cause PACKAGES to be rebuilt if they are changed."
 454   ;; Using %BAG-NODE-TYPE is more accurate than using %PACKAGE-NODE-TYPE
 455   ;; because it includes implicit dependencies.
 456   (define (full-name package)
 457     (string-append (package-name package) "@"
 458                    (package-version package)))
 459
 460   (mlet %store-monad ((edges (node-edges %bag-node-type
 461                                          ;; Here we don't want the -boot0 packages.
 462                                          (fold-packages cons '()))))
 463     (let ((dependent (node-transitive-edges packages edges)))
 464       (match packages
 465         ((x)
 466          (format (current-output-port)
 467                  (G_ "~a depends on the following ~d packages: ~{~a~^ ~}~%.")
 468                  (full-name x) (length dependent) (map full-name dependent)))
 469         (lst
 470          (format (current-output-port)
 471                  (G_ "The following ~d packages \
 472 all are dependent packages: ~{~a~^ ~}~%")
 473                  (length dependent) (map full-name dependent))))
 474       (return #t))))
 475
 476 \f
 477 ;;;
 478 ;;; Manifest.
 479 ;;;
 480
 481 (define (manifest->packages manifest)
 482   "Return the list of packages in MANIFEST."
 483   (filter-map (lambda (entry)
 484                 (let ((item (manifest-entry-item entry)))
 485                   (if (package? item) item #f)))
 486               (manifest-entries manifest)))
 487
 488 (define (packages-from-manifest manifest)
 489   "Return the list of packages in loaded MANIFEST."
 490   (let* ((user-module (make-user-module '((guix profiles) (gnu))))
 491          (manifest    (load* manifest user-module)))
 492     (manifest->packages manifest)))
 493
 494 \f
 495 ;;;
 496 ;;; Entry point.
 497 ;;;
 498
 499 (define (guix-refresh . args)
 500   (define (parse-options)
 501     ;; Return the alist of option values.
 502     (parse-command-line args %options (list %default-options)
 503                         #:build-options? #f))
 504
 505   (define (options->updaters opts)
 506     ;; Return the list of updaters to use.
 507     (match (filter-map (match-lambda
 508                          (('updaters . names)
 509                           (map lookup-updater-by-name names))
 510                          (_ #f))
 511                        opts)
 512       (()
 513        ;; Use the default updaters.
 514        (force %updaters))
 515       (lists
 516        (concatenate lists))))
 517
 518   (let* ((opts            (parse-options))
 519          (update?         (assoc-ref opts 'update?))
 520          (updaters        (options->updaters opts))
 521          (recursive?      (assoc-ref opts 'recursive?))
 522          (list-dependent? (assoc-ref opts 'list-dependent?))
 523          (list-transitive? (assoc-ref opts 'list-transitive?))
 524          (key-download    (assoc-ref opts 'key-download))
 525
 526          ;; Warn about missing updaters when a package is explicitly given on
 527          ;; the command line.
 528          (warn?           (and (or (assoc-ref opts 'argument)
 529                                    (assoc-ref opts 'expression)
 530                                    (assoc-ref opts 'manifest))
 531                                (not recursive?))))
 532     (with-error-handling
 533       (with-store store
 534         (run-with-store store
 535           (mlet %store-monad ((packages (options->packages opts)))
 536             (cond
 537              (list-dependent?
 538               (list-dependents packages))
 539              (list-transitive?
 540               (list-transitive packages))
 541              (update?
 542               (parameterize ((%openpgp-key-server
 543                               (or (assoc-ref opts 'key-server)
 544                                   (%openpgp-key-server)))
 545                              (%gpg-command
 546                               (or (assoc-ref opts 'gpg-command)
 547                                   (%gpg-command)))
 548                              (current-keyring
 549                               (or (assoc-ref opts 'keyring)
 550                                   (string-append (config-directory)
 551                                                  "/upstream/trustedkeys.kbx"))))
 552                 (for-each
 553                  (cut update-package store <> updaters
 554                       #:key-download key-download
 555                       #:warn? warn?)
 556                  packages)
 557                 (return #t)))
 558              (else
 559               (for-each (cut check-for-package-update <> updaters
 560                              #:warn? warn?)
 561                         packages)
 562               (return #t)))))))))