[bug#50072] [PATCH v5 4/4] upstream: Support updating and fetching 'git-fetch' origins.

[Maxime Devos <maximedevos@telenet.be>]

From: Sarah Morgensen <iskarian@mgsn.dev>

Updaters need to be modified to return 'git-reference' objects.
This patch modifies the 'generic-git' and 'minetest' updater,
but others might need to be modified as well.

* guix/git.scm (git-reference->git-checkout): New procedure.
* guix/upstream.scm (package-update/git-fetch): New procedure.
  (<upstream-source>)[urls]: Document it can be a 'git-reference'.
  (%method-updates): Add 'git-fetch' mapping.
  (update-package-source): Support 'git-reference' sources.
  (upstream-source-compiler/url-fetch): Split off from ...
  (upstream-source-compiler): ... this, and call ...
  (upstream-source-compiler/git-fetch): ... this new procedure if the URL
  field contains a 'git-reference'.
* guix/import/git.scm
  (latest-git-tag-version): Always return two values and document that the tag
  is returned as well.
  (latest-git-release)[urls]: Use the 'git-reference' instead of the
  repository URL.
* guix/import/minetest.scm (latest-minetest-release)[urls]: Don't wrap the
  'git-reference' in a list.
* tests/minetest.scm (upstream-source->sexp): Adjust to new convention.

Co-authored-by: Maxime Devos <maximedevos@telenet.be>
---
 guix/git.scm             | 14 +++++++-
 guix/import/git.scm      | 22 +++++++-----
 guix/import/minetest.scm |  6 ++--
 guix/upstream.scm        | 73 ++++++++++++++++++++++++++++++++++++----
 tests/minetest.scm       |  7 ++--
 5 files changed, 98 insertions(+), 24 deletions(-)

diff --git a/guix/git.scm b/guix/git.scm
index dc2ca1be84..43e85a5026 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,6 +34,8 @@
   #:use-module (guix utils)
   #:use-module (guix records)
   #:use-module (guix gexp)
+  #:autoload   (guix git-download)
+  (git-reference-url git-reference-commit git-reference-recursive?)
   #:use-module (guix sets)
   #:use-module ((guix diagnostics) #:select (leave warning))
   #:use-module (guix progress)
@@ -65,7 +68,9 @@
             git-checkout-url
             git-checkout-branch
             git-checkout-commit
-            git-checkout-recursive?))
+            git-checkout-recursive?
+
+            git-reference->git-checkout))
 
 (define %repository-cache-directory
   (make-parameter (string-append (cache-directory #:ensure? #f)
@@ -672,6 +677,13 @@ is true, limit to only refs/tags."
   (commit  git-checkout-commit (default #f))      ;#f | tag | commit
   (recursive? git-checkout-recursive? (default #f)))
 
+(define (git-reference->git-checkout reference)
+  "Convert the <git-reference> REFERENCE to an equivalent <git-checkout>."
+  (git-checkout
+   (url (git-reference-url reference))
+   (commit (git-reference-commit reference))
+   (recursive? (git-reference-recursive? reference))))
+
 (define* (latest-repository-commit* url #:key ref recursive? log-port)
   ;; Monadic variant of 'latest-repository-commit'.
   (lambda (store)
diff --git a/guix/import/git.scm b/guix/import/git.scm
index 1eb219f3fe..4cf404677c 100644
--- a/guix/import/git.scm
+++ b/guix/import/git.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -34,6 +35,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
   #:export (%generic-git-updater
 
             ;; For tests.
@@ -172,21 +174,21 @@ repository at URL."
          (values version tag)))))))
 
 (define (latest-git-tag-version package)
-  "Given a PACKAGE, return the latest version of it, or #f if the latest version
-could not be determined."
+  "Given a PACKAGE, return the latest version of it and the corresponding git
+tag, or #false and #false if the latest version could not be determined."
   (guard (c ((or (git-no-tags-error? c) (git-no-valid-tags-error? c))
              (warning (or (package-field-location package 'source)
                           (package-location package))
                       (G_ "~a for ~a~%")
                       (condition-message c)
                       (package-name package))
-             #f)
+             (values #f #f))
             ((eq? (exception-kind c) 'git-error)
              (warning (or (package-field-location package 'source)
                           (package-location package))
                       (G_ "failed to fetch Git repository for ~a~%")
                       (package-name package))
-             #f))
+             (values #f #f)))
     (let* ((source (package-source package))
            (url (git-reference-url (origin-uri source)))
            (property (cute assq-ref (package-properties package) <>)))
@@ -208,14 +210,16 @@ could not be determined."
   "Return an <upstream-source> for the latest release of PACKAGE."
   (let* ((name (package-name package))
          (old-version (package-version package))
-         (url (git-reference-url (origin-uri (package-source package))))
-         (new-version (latest-git-tag-version package)))
-
-    (and new-version
+         (old-reference (origin-uri (package-source package)))
+         (new-version new-version-tag (latest-git-tag-version package)))
+    (and new-version new-version-tag
          (upstream-source
           (package name)
           (version new-version)
-          (urls (list url))))))
+          (urls (git-reference
+                 (url (git-reference-url old-reference))
+                 (commit new-version-tag)
+                 (recursive? (git-reference-recursive? old-reference))))))))
 
 (define %generic-git-updater
   (upstream-updater
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index a7bdbfebca..3b2cdcdcac 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -504,9 +504,9 @@ or #false if the latest release couldn't be determined."
        (upstream-source
         (package (package:package-name pkg))
         (version (release-version release))
-        (urls (list (download:git-reference
-                     (url (package-repository contentdb-package))
-                     (commit (release-commit release))))))))
+        (urls (download:git-reference
+               (url (package-repository contentdb-package))
+               (commit (release-commit release)))))))
 
 (define %minetest-updater
   (upstream-updater
diff --git a/guix/upstream.scm b/guix/upstream.scm
index 632e9ebc4f..1fe996ef3d 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -2,6 +2,8 @@
 ;;; 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>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -24,12 +26,15 @@
   #: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)
   #:use-module (guix ui)
   #:use-module (guix base32)
   #:use-module (guix gexp)
+  #:autoload   (guix git) (latest-repository-commit git-reference->git-checkout)
+  #:use-module (guix hash)
   #:use-module (guix store)
   #:use-module ((guix derivations) #:select (built-derivations derivation->output-path))
   #:autoload   (gcrypt hash) (port-sha256)
@@ -93,7 +98,7 @@
   upstream-source?
   (package        upstream-source-package)        ;string
   (version        upstream-source-version)        ;string
-  (urls           upstream-source-urls)           ;list of strings
+  (urls           upstream-source-urls)           ;list of strings|git-reference
   (signature-urls upstream-source-signature-urls  ;#f | list of strings
                   (default #f))
   (input-changes  upstream-source-input-changes
@@ -357,10 +362,9 @@ values: 'interactive' (default), 'always', and 'never'."
                         data url)
                #f)))))))
 
-(define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
-                                                system target)
-  "Download SOURCE from its first URL and lower it as a fixed-output
-derivation that would fetch it."
+(define (upstream-source-compiler/url-fetch source system)
+  "Lower SOURCE, an <upstream-source> pointing to a tarball, as a
+fixed-output derivation that would fetch it, and verify its authenticity."
   (mlet* %store-monad ((url -> (first (upstream-source-urls source)))
                        (signature
                         -> (and=> (upstream-source-signature-urls source)
@@ -378,6 +382,30 @@ derivation that would fetch it."
       (url-fetch url 'sha256 hash (store-path-package-name tarball)
                  #:system system))))
 
+(define (upstream-source-compiler/git-fetch source system)
+  "Lower SOURCE, an <upstream-source> using git, as a fixed-output
+derivation that would fetch it."
+  (mlet* %store-monad ((reference -> (upstream-source-urls source))
+                       (checkout
+                        (lower-object
+                         (git-reference->git-checkout reference)
+                         system)))
+    ;; Like in 'upstream-source-compiler/url-fetch', return a fixed-output
+    ;; derivation instead of CHECKOUT.
+    (git-fetch reference 'sha256
+               (file-hash* checkout #:recursive? #true #:select? (const #true))
+               (git-file-name (upstream-source-package source)
+                              (upstream-source-version source))
+               #:system system)))
+
+(define-gexp-compiler (upstream-source-compiler (source <upstream-source>)
+                                                system target)
+  "Download SOURCE, lower it as a fixed-output derivation that would fetch it,
+and verify its authenticity if possible."
+  (if (git-reference? (upstream-source-urls source))
+      (upstream-source-compiler/git-fetch source system)
+      (upstream-source-compiler/url-fetch source system)))
+
 (define (find2 pred lst1 lst2)
   "Like 'find', but operate on items from both LST1 and LST2.  Return two
 values: the item from LST1 and the item from LST2 that match PRED."
@@ -430,9 +458,24 @@ SOURCE, an <upstream-source>."
                                         #:key-download key-download)))
          (values version tarball source))))))
 
+(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>."
+  ;; TODO: it would be nice to authenticate commits, e.g. with
+  ;; "guix git authenticate" or a list of permitted signing keys.
+  (define ref (upstream-source-urls source)) ; a <git-reference>
+  (values (upstream-source-version source)
+          (latest-repository-commit
+           store
+           (git-reference-url ref)
+           #:ref `(tag-or-commit . ,(git-reference-commit ref))
+           #:recursive? (git-reference-recursive? ref))
+          source))
+
 (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))
@@ -492,9 +535,22 @@ new version string if an update was made, and #f otherwise."
                              (origin-hash (package-source package))))
                (old-url     (match (origin-uri (package-source package))
                               ((? string? url) url)
+                              ((? git-reference? ref)
+                               (git-reference-url ref))
                               (_ #f)))
                (new-url     (match (upstream-source-urls source)
-                              ((first _ ...) first)))
+                              ((first _ ...) first)
+                              ((? git-reference? ref)
+                               (git-reference-url ref))
+                              (_ #f)))
+               (old-commit  (match (origin-uri (package-source package))
+                              ((? git-reference? ref)
+                               (git-reference-commit ref))
+                              (_ #f)))
+               (new-commit  (match (upstream-source-urls source)
+                              ((? git-reference? ref)
+                               (git-reference-commit ref))
+                              (_ #f)))
                (file        (and=> (location-file loc)
                                    (cut search-path %load-path <>))))
           (if file
@@ -508,6 +564,9 @@ new version string if an update was made, and #f otherwise."
                                            'filename file))
                     (replacements `((,old-version . ,version)
                                     (,old-hash . ,hash)
+                                    ,@(if (and old-commit new-commit)
+                                          `((,old-commit . ,new-commit))
+                                          '())
                                     ,@(if (and old-url new-url)
                                           `((,(dirname old-url) .
                                              ,(dirname new-url)))
diff --git a/tests/minetest.scm b/tests/minetest.scm
index 77b9aa928f..cbb9e83889 100644
--- a/tests/minetest.scm
+++ b/tests/minetest.scm
@@ -387,10 +387,9 @@ during a dynamic extent where that package is available on ContentDB."
 
 ;; Update detection
 (define (upstream-source->sexp upstream-source)
-  (define urls (upstream-source-urls upstream-source))
-  (unless (= 1 (length urls))
-    (error "only a single URL is expected"))
-  (define url (first urls))
+  (define url (upstream-source-urls upstream-source))
+  (unless (git-reference? url)
+    (error "a <git-reference> is expected"))
   `(,(upstream-source-package upstream-source)
     ,(upstream-source-version upstream-source)
     ,(git-reference-url url)
-- 
2.30.2