[bug#50072] [PATCH WIP 4/4] upstream: Support updating git-fetch origins.

[Sarah Morgensen <iskarian@mgsn.dev>]

* guix/git-download.scm (checkout-to-store): New procedure.
* guix/upstream.scm (guess-version-transform)
(package-update/git-fetch): New procedures.
(%method-updates): Add GIT-FETCH mapping.
---
 guix/git-download.scm | 18 +++++++++++++++++-
 guix/upstream.scm     | 41 ++++++++++++++++++++++++++++++++++++++++-
 2 files changed, 57 insertions(+), 2 deletions(-)

diff --git a/guix/git-download.scm b/guix/git-download.scm
index 5e624b9ae9..a7bdc16718 100644
--- a/guix/git-download.scm
+++ b/guix/git-download.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2017 Mathieu Lirzin <mthl@gnu.org>
 ;;; Copyright © 2017 Christopher Baines <mail@cbaines.net>
 ;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -26,6 +27,7 @@
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix modules)
+  #:use-module (guix git)
   #:autoload   (guix build-system gnu) (standard-packages)
   #:autoload   (git bindings)   (libgit2-init!)
   #:autoload   (git repository) (repository-open
@@ -53,7 +55,9 @@
             git-fetch
             git-version
             git-file-name
-            git-predicate))
+            git-predicate
+
+            checkout-to-store))
 
 ;;; Commentary:
 ;;;
@@ -287,4 +291,16 @@ absolute file name and STAT is the result of 'lstat'."
             (#f        #f)))))
     (const #f)))
 
+(define* (checkout-to-store store ref #:key (log (current-error-port)))
+  "Checkout REF to STORE.  Write progress reports to LOG.  RECURSIVE? has the
+same effect as the same-named parameter of 'latest-repository-commit'."
+  ;; XXX: (guix git) does not use shallow clones, so this will be slow
+  ;; for long-running repositories.
+  (match-record ref <git-reference>
+    (url commit recursive?)
+    (latest-repository-commit store url
+                              #:ref `(tag-or-commit . ,commit)
+                              #:recursive? recursive?
+                              #:log-port log)))
+
 ;;; git-download.scm ends here
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 632e9ebc4f..927260cd89 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -2,6 +2,7 @@
 ;;; Copyright © 2010, 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2015 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,6 +25,7 @@
   #:use-module (guix discovery)
   #:use-module ((guix download)
                 #:select (download-to-store url-fetch))
+  #:use-module (guix git-download)
   #:use-module (guix gnupg)
   #:use-module (guix packages)
   #:use-module (guix diagnostics)
@@ -430,9 +432,46 @@ SOURCE, an <upstream-source>."
                                         #:key-download key-download)))
          (values version tarball source))))))
 
+(define (guess-version-transform commit from-version)
+  "Return a one-argument proc that transforms FROM-VERSION to COMMIT, or #f
+if no such transformation could be determined."
+  ;; Just handle prefixes for now, since that's the most common.
+  (if (string-suffix? from-version commit)
+      (let* ((version-length (string-length from-version))
+             (commit-prefix (string-drop-right commit version-length)))
+        (lambda (version)
+          (string-append commit-prefix version)))
+      #f))
+
+(define* (package-update/git-fetch store package source
+                                   #:key key-download)
+  "Return the version, checkout, and SOURCE, to update PACKAGE to
+SOURCE, an <upstream-source>."
+
+  (define (uri-update/git old-uri old-version url version)
+    (let* ((old-commit (git-reference-commit old-uri))
+           (transform (guess-version-transform old-commit old-version)))
+      (and transform
+           (git-reference
+            (inherit old-uri)
+            (url url)
+            (commit (transform version))))))
+
+  ;; Only use the first element of URLS.
+  (match-record source <upstream-source>
+    (version urls)
+    (let* ((old-uri (origin-uri (package-source package)))
+           (old-version (package-version package))
+           (new-uri (uri-update/git old-uri old-version
+                                    (first urls) version)))
+      (if new-uri
+          (values version (checkout-to-store store new-uri) source)
+          (values #f #f #f)))))
+
 (define %method-updates
   ;; Mapping of origin methods to source update procedures.
-  `((,url-fetch . ,package-update/url-fetch)))
+  `((,url-fetch . ,package-update/url-fetch)
+    (,git-fetch . ,package-update/git-fetch)))
 
 (define* (package-update store package
                          #:optional (updaters (force %updaters))
-- 
2.31.1