02/08: import/github: Return <git-reference> objects for git-fetch origins.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit f8306a501935f8012fba76a9de924f512c24883a
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Jan 6 20:50:11 2022 +0000

    import/github: Return <git-reference> objects for git-fetch origins.
    
    * guix/import/github.scm
      (latest-released-version): Also return the tag.
      (latest-release): Use this information to return <git-reference> objects
      when appropriate.
    
    Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/import/github.scm | 43 +++++++++++++++++++++++++++----------------
 1 file changed, 27 insertions(+), 16 deletions(-)

diff --git a/guix/import/github.scm b/guix/import/github.scm
index 888b148ffb..1adfb8d281 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2018 Eric Bavier <bavier@member.fsf.org>
 ;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -25,6 +26,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-71)
   #:use-module (guix utils)
   #:use-module (guix i18n)
   #:use-module (guix diagnostics)
@@ -181,12 +183,15 @@ empty list."
         (x x)))))
 
 (define (latest-released-version url package-name)
-  "Return a string of the newest released version name given a string URL like
+  "Return the newest released version and its tag given a string URL like
 'https://github.com/arq5x/bedtools2/archive/v2.24.0.tar.gz' and the name of
-the package e.g. 'bedtools2'.  Return #f if there is no releases"
+the package e.g. 'bedtools2'.  Return #f (two values) if there are no
+releases."
   (define (pre-release? x)
     (assoc-ref x "prerelease"))
 
+  ;; This procedure returns (version . tag) pair, or #f
+  ;; if RELEASE doesn't seyem to correspond to a version.
   (define (release->version release)
     (let ((tag (or (assoc-ref release "tag_name") ;a "release"
                    (assoc-ref release "name")))   ;a tag
@@ -197,22 +202,22 @@ the package e.g. 'bedtools2'.  Return #f if there is no 
releases"
        ((and (< name-length (string-length tag))
              (string=? (string-append package-name "-")
                        (substring tag 0 (+ name-length 1))))
-        (substring tag (+ name-length 1)))
+        (cons (substring tag (+ name-length 1)) tag))
        ;; some tags start with a "v" e.g. "v0.25.0"
        ;; or with the word "version" e.g. "version.2.1"
        ;; where some are just the version number
        ((string-prefix? "version" tag)
-        (if (char-set-contains? char-set:digit (string-ref tag 7))
-            (substring tag 7)
-            (substring tag 8)))
+        (cons (if (char-set-contains? char-set:digit (string-ref tag 7))
+                  (substring tag 7)
+                  (substring tag 8)) tag))
        ((string-prefix? "v" tag)
-        (substring tag 1))
+        (cons (substring tag 1) tag))
        ;; Finally, reject tags that don't start with a digit:
        ;; they may not represent a release.
        ((and (not (string-null? tag))
              (char-set-contains? char-set:digit
                                  (string-ref tag 0)))
-        tag)
+        (cons tag tag))
        (else #f))))
 
   (let* ((json (and=> (fetch-releases-or-tags url)
@@ -229,14 +234,14 @@ https://github.com/settings/tokens";))
                                  (match (remove pre-release? json)
                                    (() json) ; keep everything
                                    (releases releases)))
-                     version>?)
-          ((latest-release . _) latest-release)
-          (() #f)))))
+                     (lambda (x y) (version>? (car x) (car y))))
+          (((latest-version . tag) . _) (values latest-version tag))
+          (() (values #f #f))))))
 
 (define (latest-release pkg)
   "Return an <upstream-source> for the latest release of PKG."
-  (define (origin-github-uri origin)
-    (match (origin-uri origin)
+  (define (github-uri uri)
+    (match uri
       ((? string? url)
        url)                                       ;surely a github.com URL
       ((? download:git-reference? ref)
@@ -244,14 +249,20 @@ https://github.com/settings/tokens";))
       ((urls ...)
        (find (cut string-contains <> "github.com") urls))))
 
-  (let* ((source-uri (origin-github-uri (package-source pkg)))
+  (let* ((original-uri (origin-uri (package-source pkg)))
+         (source-uri (github-uri original-uri))
          (name (package-name pkg))
-         (newest-version (latest-released-version source-uri name)))
+         (newest-version version-tag
+                         (latest-released-version source-uri name)))
     (if newest-version
         (upstream-source
          (package name)
          (version newest-version)
-         (urls (list (updated-github-url pkg newest-version))))
+         (urls (if (download:git-reference? original-uri)
+                   (download:git-reference
+                    (inherit original-uri)
+                    (commit version-tag))
+                   (list (updated-github-url pkg newest-version)))))
         #f))) ; On GitHub but no proper releases
 
 (define %github-updater