guix/scripts/refresh.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
   4 ;;;
   5 ;;; This file is part of GNU Guix.
   6 ;;;
   7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   8 ;;; under the terms of the GNU General Public License as published by
   9 ;;; the Free Software Foundation; either version 3 of the License, or (at
  10 ;;; your option) any later version.
  11 ;;;
  12 ;;; GNU Guix is distributed in the hope that it will be useful, but
  13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;;; GNU General Public License for more details.
  16 ;;;
  17 ;;; You should have received a copy of the GNU General Public License
  18 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 (define-module (guix scripts refresh)
  21   #:use-module (guix ui)
  22   #:use-module (guix hash)
  23   #:use-module (guix store)
  24   #:use-module (guix utils)
  25   #:use-module (guix packages)
  26   #:use-module (guix gnu-maintenance)
  27   #:use-module (guix gnupg)
  28   #:use-module (gnu packages)
  29   #:use-module ((gnu packages base) #:select (%final-inputs))
  30   #:use-module (ice-9 match)
  31   #:use-module (ice-9 regex)
  32   #:use-module (srfi srfi-1)
  33   #:use-module (srfi srfi-11)
  34   #:use-module (srfi srfi-26)
  35   #:use-module (srfi srfi-37)
  36   #:use-module (rnrs io ports)
  37   #:export (guix-refresh))
  38
  39 \f
  40 ;;;
  41 ;;; Command-line options.
  42 ;;;
  43
  44 (define %default-options
  45   ;; Alist of default option values.
  46   '())
  47
  48 (define %options
  49   ;; Specification of the command-line options.
  50   (list (option '(#\u "update") #f #f
  51                 (lambda (opt name arg result)
  52                   (alist-cons 'update? #t result)))
  53         (option '(#\s "select") #t #f
  54                 (lambda (opt name arg result)
  55                   (match arg
  56                     ((or "core" "non-core")
  57                      (alist-cons 'select (string->symbol arg)
  58                                  result))
  59                     (x
  60                      (leave (_ "~a: invalid selection; expected `core' or `non-core'")
  61                             arg)))))
  62
  63         (option '("key-server") #t #f
  64                 (lambda (opt name arg result)
  65                   (alist-cons 'key-server arg result)))
  66         (option '("gpg") #t #f
  67                 (lambda (opt name arg result)
  68                   (alist-cons 'gpg-command arg result)))
  69         (option '("key-download") #t #f
  70                 (lambda (opt name arg result)
  71                   (match arg
  72                     ((or "interactive" "always" "never")
  73                      (alist-cons 'key-download (string->symbol arg)
  74                                  result))
  75                     (_
  76                      (leave (_ "unsupported policy: ~a~%")
  77                             arg)))))
  78
  79         (option '(#\h "help") #f #f
  80                 (lambda args
  81                   (show-help)
  82                   (exit 0)))
  83         (option '(#\V "version") #f #f
  84                 (lambda args
  85                   (show-version-and-exit "guix refresh")))))
  86
  87 (define (show-help)
  88   (display (_ "Usage: guix refresh [OPTION]... PACKAGE...
  89 Update package definitions to match the latest upstream version.
  90
  91 When PACKAGE... is given, update only the specified packages.  Otherwise
  92 update all the packages of the distribution, or the subset thereof
  93 specified with `--select'.\n"))
  94   (display (_ "
  95   -u, --update           update source files in place"))
  96   (display (_ "
  97   -s, --select=SUBSET    select all the packages in SUBSET, one of
  98                          `core' or `non-core'"))
  99   (newline)
 100   (display (_ "
 101       --key-server=HOST  use HOST as the OpenPGP key server"))
 102   (display (_ "
 103       --gpg=COMMAND      use COMMAND as the GnuPG 2.x command"))
 104   (display (_ "
 105       --key-download=POLICY
 106                          handle missing OpenPGP keys according to POLICY:
 107                          'always', 'never', and 'interactive', which is also
 108                          used when 'key-download' is not specified"))
 109   (newline)
 110   (display (_ "
 111   -h, --help             display this help and exit"))
 112   (display (_ "
 113   -V, --version          display version information and exit"))
 114   (newline)
 115   (show-bug-report-information))
 116
 117 (define* (update-package store package #:key (key-download 'interactive))
 118   "Update the source file that defines PACKAGE with the new version.
 119 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 120 values: 'interactive' (default), 'always', and 'never'."
 121   (let-values (((version tarball)
 122                 (catch #t
 123                   (lambda ()
 124                     (package-update store package #:key-download key-download))
 125                   (lambda _
 126                     (values #f #f))))
 127                ((loc)
 128                 (or (package-field-location package
 129                                             'version)
 130                     (package-location package))))
 131     (when version
 132       (if (and=> tarball file-exists?)
 133           (begin
 134             (format (current-error-port)
 135                     (_ "~a: ~a: updating from version ~a to version ~a...~%")
 136                     (location->string loc)
 137                     (package-name package)
 138                     (package-version package) version)
 139             (let ((hash (call-with-input-file tarball
 140                           port-sha256)))
 141               (update-package-source package version hash)))
 142           (warning (_ "~a: version ~a could not be \
 143 downloaded and authenticated; not updating")
 144                    (package-name package) version)))))
 145
 146
 147 \f
 148 ;;;
 149 ;;; Entry point.
 150 ;;;
 151
 152 (define (guix-refresh . args)
 153   (define (parse-options)
 154     ;; Return the alist of option values.
 155     (args-fold* args %options
 156                 (lambda (opt name arg result)
 157                   (leave (_ "~A: unrecognized option~%") name))
 158                 (lambda (arg result)
 159                   (alist-cons 'argument arg result))
 160                 %default-options))
 161
 162   (define (keep-newest package lst)
 163     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
 164     ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
 165     (let ((name (package-name package)))
 166       (match (find (lambda (p)
 167                      (string=? (package-name p) name))
 168                    lst)
 169         ((? package? other)
 170          (if (version>? (package-version other) (package-version package))
 171              lst
 172              (cons package (delq other lst))))
 173         (_
 174          (cons package lst)))))
 175
 176   (define core-package?
 177     (let* ((input->package (match-lambda
 178                             ((name (? package? package) _ ...) package)
 179                             (_ #f)))
 180            (final-inputs   (map input->package %final-inputs))
 181            (core           (append final-inputs
 182                                    (append-map (compose (cut filter-map input->package <>)
 183                                                         package-transitive-inputs)
 184                                                final-inputs)))
 185            (names          (delete-duplicates (map package-name core))))
 186       (lambda (package)
 187         "Return true if PACKAGE is likely a \"core package\"---i.e., one whose
 188 update would trigger a complete rebuild."
 189         ;; Compare by name because packages in base.scm basically inherit
 190         ;; other packages.  So, even if those packages are not core packages
 191         ;; themselves, updating them would also update those who inherit from
 192         ;; them.
 193         ;; XXX: Fails to catch MPFR/MPC, whose *source* is used as input.
 194         (member (package-name package) names))))
 195
 196   (let* ((opts         (parse-options))
 197          (update?      (assoc-ref opts 'update?))
 198          (key-download (assoc-ref opts 'key-download))
 199          (packages
 200           (match (concatenate
 201                   (filter-map (match-lambda
 202                                (('argument . value)
 203                                 (let ((p (find-packages-by-name value)))
 204                                   (unless p
 205                                     (leave (_ "~a: no package by that name")
 206                                            value))
 207                                   p))
 208                                (_ #f))
 209                               opts))
 210                  (()                          ; default to all packages
 211                   (let ((select? (match (assoc-ref opts 'select)
 212                                         ('core core-package?)
 213                                         ('non-core (negate core-package?))
 214                                         (_ (const #t)))))
 215                     (fold-packages (lambda (package result)
 216                                      (if (select? package)
 217                                          (keep-newest package result)
 218                                          result))
 219                                    '())))
 220                  (some                        ; user-specified packages
 221                   some))))
 222     (with-error-handling
 223       (if update?
 224           (let ((store (open-connection)))
 225             (parameterize ((%openpgp-key-server
 226                             (or (assoc-ref opts 'key-server)
 227                                 (%openpgp-key-server)))
 228                            (%gpg-command
 229                             (or (assoc-ref opts 'gpg-command)
 230                                 (%gpg-command))))
 231               (for-each
 232                (cut update-package store <> #:key-download key-download)
 233                packages)))
 234           (for-each (lambda (package)
 235                       (match (false-if-exception (package-update-path package))
 236                         ((new-version . directory)
 237                          (let ((loc (or (package-field-location package 'version)
 238                                         (package-location package))))
 239                            (format (current-error-port)
 240                                    (_ "~a: ~a would be upgraded from ~a to ~a~%")
 241                                    (location->string loc)
 242                                    (package-name package) (package-version package)
 243                                    new-version)))
 244                         (_ #f)))
 245                     packages)))))