From 42314ffa072f31cc1cb44df38b1f8fcca19d9d3c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Wed, 27 Mar 2019 14:56:23 +0100
Subject: [PATCH] refresh: Update the source code URL.

Reported by Tobias Geerinckx-Rice <me@tobias.gr>
in <https://bugs.gnu.org/35010>.

* guix/upstream.scm (update-package-source): Take 'source' instead of
'version' as the second argument.
[update-expression]: Change to take 'replacements', a list of
replacement pairs.
Compute OLD-URL and NEW-URL and replace the dirname of the OLD-URL with
that of NEW-URL.
* guix/scripts/refresh.scm (update-package): Adjust call to
'update-package-source' accordingly.
---
 guix/scripts/refresh.scm |  2 +-
 guix/upstream.scm        | 62 +++++++++++++++++++++++++++-------------
 2 files changed, 43 insertions(+), 21 deletions(-)

diff --git a/guix/scripts/refresh.scm b/guix/scripts/refresh.scm
index 6d77e2642b..dd7026a6a4 100644
--- a/guix/scripts/refresh.scm
+++ b/guix/scripts/refresh.scm
@@ -333,7 +333,7 @@ warn about packages that have no matching updater."
                  (upstream-source-input-changes source))
                 (let ((hash (call-with-input-file tarball
                               port-sha256)))
-                  (update-package-source package version hash)))
+                  (update-package-source package source hash)))
               (warning (G_ "~a: version ~a could not be \
 downloaded and authenticated; not updating~%")
                        (package-name package) version))))
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 2c70b3422d..1326b3db95 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -39,6 +39,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (rnrs bytevectors)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:export (upstream-source
@@ -404,36 +405,57 @@ this method: ~s")
     (#f
      (values #f #f #f))))
 
-(define (update-package-source package version hash)
-  "Modify the source file that defines PACKAGE to refer to VERSION,
-whose tarball has SHA256 HASH (a bytevector).  Return the new version string
-if an update was made, and #f otherwise."
-  (define (update-expression expr old-version version old-hash hash)
-    ;; Update package expression EXPR, replacing occurrences OLD-VERSION by
-    ;; VERSION and occurrences of OLD-HASH by HASH (base32 representation
-    ;; thereof).
-    (let ((old-hash (bytevector->nix-base32-string old-hash))
-          (hash     (bytevector->nix-base32-string hash)))
-      (string-replace-substring
-       (string-replace-substring expr old-hash hash)
-       old-version version)))
+(define* (update-package-source package source hash)
+  "Modify the source file that defines PACKAGE to refer to SOURCE, an
+<upstream-source> whose tarball has SHA256 HASH (a bytevector).  Return the
+new version string if an update was made, and #f otherwise."
+  (define (update-expression expr replacements)
+    ;; Apply REPLACEMENTS to package expression EXPR, a string.  REPLACEMENTS
+    ;; must be a list of replacement pairs, either bytevectors or strings.
+    (fold (lambda (replacement str)
+            (match replacement
+              (((? bytevector? old-bv) . (? bytevector? new-bv))
+               (string-replace-substring
+                str
+                (bytevector->nix-base32-string old-bv)
+                (bytevector->nix-base32-string new-bv)))
+              ((old . new)
+               (string-replace-substring str old new))))
+          expr
+          replacements))
 
   (let ((name        (package-name package))
+        (version     (upstream-source-version source))
         (version-loc (package-field-location package 'version)))
     (if version-loc
         (let* ((loc         (package-location package))
                (old-version (package-version package))
                (old-hash    (origin-sha256 (package-source package)))
+               (old-url     (match (origin-uri (package-source package))
+                              ((? string? url) url)
+                              (_ #f)))
+               (new-url     (match (upstream-source-urls source)
+                              ((first _ ...) first)))
                (file        (and=> (location-file loc)
                                    (cut search-path %load-path <>))))
           (if file
-              (and (edit-expression
-                    ;; Be sure to use absolute filename.
-                    (assq-set! (location->source-properties loc)
-                               'filename file)
-                    (cut update-expression <>
-                         old-version version old-hash hash))
-                   version)
+              ;; Be sure to use absolute filename.  Replace the URL directory
+              ;; when OLD-URL is available; this is useful notably for
+              ;; mirror://cpan/ URLs where the directory may change as a
+              ;; function of the person who uploads the package.  Note that
+              ;; package definitions usually concatenate fragments of the URL,
+              ;; which is why we only attempt to replace a subset of the URL.
+              (let ((properties (assq-set! (location->source-properties loc)
+                                           'filename file))
+                    (replacements `((,old-version . ,version)
+                                    (,old-hash . ,hash)
+                                    ,@(if (and old-url new-url)
+                                          `((,(dirname old-url) .
+                                             ,(dirname new-url)))
+                                          '()))))
+                (and (edit-expression properties
+                                      (cut update-expression <> replacements))
+                     version))
               (begin
                 (warning (G_ "~a: could not locate source file")
                          (location-file loc))