Merge branch 'master' into dbus-update

1 files changed, 65 insertions, 29 deletions

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 097059e372..6f7ca4a41b 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -25,7 +25,10 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix packages)
-  #:use-module (guix gnu-maintenance)
+  #:use-module (guix upstream)
+  #:use-module ((guix gnu-maintenance) #:select (%gnu-updater))
+  #:use-module (guix import elpa)
+  #:use-module (guix import cran)
   #:use-module (guix gnupg)
   #:use-module (gnu packages)
   #:use-module ((gnu packages commencement) #:select (%final-inputs))
@@ -63,6 +66,9 @@
                     (x
                      (leave (_ "~a: invalid selection; expected `core' or `non-core'~%")
                             arg)))))
+        (option '(#\t "type") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'updater (string->symbol arg) result)))
         (option '(#\l "list-dependent") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'list-dependent? #t result)))
@@ -104,6 +110,8 @@ specified with `--select'.\n"))
   -s, --select=SUBSET    select all the packages in SUBSET, one of
                          `core' or `non-core'"))
   (display (_ "
+  -t, --type=UPDATER     restrict to updates from UPDATER--e.g., 'gnu'"))
+  (display (_ "
   -l, --list-dependent   list top-level dependent packages that would need to
                          be rebuilt as a result of upgrading PACKAGE..."))
   (newline)
@@ -124,19 +132,33 @@ specified with `--select'.\n"))
   (newline)
   (show-bug-report-information))
 
-(define* (update-package store package #:key (key-download 'interactive))
+
+;;;
+;;; Updates.
+;;;
+
+(define %updaters
+  ;; List of "updaters" used by default.  They are consulted in this order.
+  (list %gnu-updater
+        %elpa-updater
+        %cran-updater))
+
+(define (lookup-updater name)
+  "Return the updater called NAME."
+  (find (lambda (updater)
+          (eq? name (upstream-updater-name updater)))
+        %updaters))
+
+(define* (update-package store package updaters
+                         #:key (key-download 'interactive))
   "Update the source file that defines PACKAGE with the new version.
 KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
 values: 'interactive' (default), 'always', and 'never'."
   (let-values (((version tarball)
-                (catch #t
-                  (lambda ()
-                    (package-update store package #:key-download key-download))
-                  (lambda _
-                    (values #f #f))))
+                (package-update store package updaters
+                                #:key-download key-download))
                ((loc)
-                (or (package-field-location package
-                                            'version)
+                (or (package-field-location package 'version)
                     (package-location package))))
     (when version
       (if (and=> tarball file-exists?)
@@ -153,7 +175,6 @@ values: 'interactive' (default), 'always', and 'never'."
 downloaded and authenticated; not updating~%")
                    (package-name package) version)))))
 
-
 
 ;;;
 ;;; Entry point.
@@ -169,6 +190,19 @@ downloaded and authenticated; not updating~%")
                   (alist-cons 'argument arg result))
                 %default-options))
 
+  (define (options->updaters opts)
+    ;; Return the list of updaters to use.
+    (match (filter-map (match-lambda
+                         (('updater . name)
+                          (lookup-updater name))
+                         (_ #f))
+                       opts)
+      (()
+       ;; Use the default updaters.
+       %updaters)
+      (lst
+       lst)))
+
   (define (keep-newest package lst)
     ;; If a newer version of PACKAGE is already in LST, return LST; otherwise
     ;; return LST minus the other version of PACKAGE in it, plus PACKAGE.
@@ -185,8 +219,8 @@ downloaded and authenticated; not updating~%")
 
   (define core-package?
     (let* ((input->package (match-lambda
-                            ((name (? package? package) _ ...) package)
-                            (_ #f)))
+                             ((name (? package? package) _ ...) package)
+                             (_ #f)))
            (final-inputs   (map input->package %final-inputs))
            (core           (append final-inputs
                                    (append-map (compose (cut filter-map input->package <>)
@@ -205,6 +239,7 @@ update would trigger a complete rebuild."
 
   (let* ((opts            (parse-options))
          (update?         (assoc-ref opts 'update?))
+         (updaters        (options->updaters opts))
          (list-dependent? (assoc-ref opts 'list-dependent?))
          (key-download    (assoc-ref opts 'key-download))
          (packages
@@ -215,18 +250,18 @@ update would trigger a complete rebuild."
                                 (specification->package spec))
                                (_ #f))
                              opts)
-                 (()                          ; default to all packages
-                  (let ((select? (match (assoc-ref opts 'select)
-                                        ('core core-package?)
-                                        ('non-core (negate core-package?))
-                                        (_ (const #t)))))
-                    (fold-packages (lambda (package result)
-                                     (if (select? package)
-                                         (keep-newest package result)
-                                         result))
-                                   '())))
-                 (some                        ; user-specified packages
-                  some))))
+            (()                                   ; default to all packages
+             (let ((select? (match (assoc-ref opts 'select)
+                              ('core core-package?)
+                              ('non-core (negate core-package?))
+                              (_ (const #t)))))
+               (fold-packages (lambda (package result)
+                                (if (select? package)
+                                    (keep-newest package result)
+                                    result))
+                              '())))
+            (some                                 ; user-specified packages
+             some))))
     (with-error-handling
       (cond
        (list-dependent?
@@ -258,18 +293,19 @@ dependent packages are rebuilt: ~{~a~^ ~}~%"
                           (or (assoc-ref opts 'gpg-command)
                               (%gpg-command))))
             (for-each
-             (cut update-package store <> #:key-download key-download)
+             (cut update-package store <> updaters
+                  #:key-download key-download)
              packages))))
        (else
         (for-each (lambda (package)
-                    (match (false-if-exception (package-update-path package))
-                      ((new-version . directory)
+                    (match (package-update-path package updaters)
+                      ((? upstream-source? source)
                        (let ((loc (or (package-field-location package 'version)
                                       (package-location package))))
                          (format (current-error-port)
                                  (_ "~a: ~a would be upgraded from ~a to ~a~%")
                                  (location->string loc)
                                  (package-name package) (package-version package)
-                                 new-version)))
-                      (_ #f)))
+                                 (upstream-source-version source))))
+                      (#f #f)))
                   packages))))))