02/02: upstream: Correctly report failure to update Git checkouts.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 0bd1498fc40820be35125cc0a62482d015b58e9b
Author: Ludovic Courtès <address@hidden>
Date:   Fri Mar 8 23:13:56 2019 +0100

    upstream: Correctly report failure to update Git checkouts.
    
    Fixes <https://bugs.gnu.org/34778>.
    Reported by Gábor Boskovits <address@hidden>.
    
    * guix/upstream.scm (package-update/url-fetch): New procedure, with code
    formerly in 'package-update'.
    (%method-updates): New variable.
    (package-update): Check the method to download PACKAGE's source, and
    look up a corresponding update method in %METHOD-UPDATES, and raise an
    error if none was found.
---
 guix/upstream.scm | 53 ++++++++++++++++++++++++++++++++++++++++-------------
 1 file changed, 40 insertions(+), 13 deletions(-)

diff --git a/guix/upstream.scm b/guix/upstream.scm
index 9163478..55683dd 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic 
Courtès <address@hidden>
+;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 
Ludovic Courtès <address@hidden>
 ;;; Copyright © 2015 Alex Kost <address@hidden>
 ;;; Copyright © 2019 Ricardo Wurmus <address@hidden>
 ;;;
@@ -23,7 +23,7 @@
   #:use-module (guix utils)
   #:use-module (guix discovery)
   #:use-module ((guix download)
-                #:select (download-to-store))
+                #:select (download-to-store url-fetch))
   #:use-module (guix gnupg)
   #:use-module (guix packages)
   #:use-module (guix ui)
@@ -37,6 +37,8 @@
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:export (upstream-source
@@ -340,17 +342,13 @@ values: the item from LST1 and the item from LST2 that 
match PRED."
       (()
        (values #f #f)))))
 
-(define* (package-update store package updaters
-                         #:key (key-download 'interactive))
-  "Return the new version, the file name of the new version tarball, and input
-changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
-KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
-values: 'always', 'never', and 'interactive' (default)."
-  (match (package-latest-release* package updaters)
+(define* (package-update/url-fetch store package source
+                                   #:key key-download)
+  "Return the version, tarball, and input changes needed to update PACKAGE to
+SOURCE, an <upstream-source>."
+  (match source
     (($ <upstream-source> _ version urls signature-urls changes)
-     (let*-values (((name)
-                    (package-name package))
-                   ((archive-type)
+     (let*-values (((archive-type)
                     (match (and=> (package-source package) origin-uri)
                       ((? string? uri)
                        (let ((type (file-extension (basename uri))))
@@ -373,7 +371,36 @@ values: 'always', 'never', and 'interactive' (default)."
                            (or signature-urls (circular-list #f)))))
        (let ((tarball (download-tarball store url signature-url
                                         #:key-download key-download)))
-         (values version tarball changes))))
+         (values version tarball changes))))))
+
+(define %method-updates
+  ;; Mapping of origin methods to source update procedures.
+  `((,url-fetch . ,package-update/url-fetch)))
+
+(define* (package-update store package updaters
+                         #:key (key-download 'interactive))
+  "Return the new version, the file name of the new version tarball, and input
+changes for PACKAGE; return #f (three values) when PACKAGE is up-to-date.
+KEY-DOWNLOAD specifies a download policy for missing OpenPGP keys; allowed
+values: 'always', 'never', and 'interactive' (default)."
+  (match (package-latest-release* package updaters)
+    ((? upstream-source? source)
+     (let ((method (match (package-source package)
+                     ((? origin? origin)
+                      (origin-method origin))
+                     (_
+                      #f))))
+       (match (assq method %method-updates)
+         (#f
+          (raise (condition (&message
+                             (message (format #f (G_ "cannot download for \
+this method: ~s")
+                                              method)))
+                            (&error-location
+                             (location (package-location package))))))
+         ((_ . update)
+          (update store package source
+                  #:key-download key-download)))))
     (#f
      (values #f #f #f))))