style: git-source: Handle more URLs.

* guix/import/utils.scm (tarball-url->git-repository-url): New procedure.
* guix/scripts/style.scm (url-fetch->git-fetch)[transform-source]: Add
‘repository-url’ parameter.
Use ‘tarball-url->git-repository-url’ when ‘home-page’ is not a Git URL.
(transform-to-git-fetch): Rename ‘home-page’ to ‘repository-url’.
* tests/import/utils.scm ("tarball-url->git-repository-url, guile"): New test.
* tests/style.scm ("url-fetch->git-fetch, mirror:// URL"): New test.

Change-Id: I4f8ca7c67a58f917d69380678b62c00962b0f9cd
Signed-off-by: Ludovic Courtès <ludo@gnu.org>

4 files changed, 110 insertions, 23 deletions

diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 5f8a4c22f6e..c435981ca99 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012-2013, 2018-2020, 2023, 2025 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2013, 2018-2020, 2023, 2025-2026 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2016 Jelle Licht <jlicht@fsfe.org>
 ;;; Copyright © 2016 David Craven <david@craven.ch>
 ;;; Copyright © 2017, 2019, 2020, 2022, 2023, 2024, 2025 Ricardo Wurmus <rekado@elephly.net>
@@ -58,6 +58,11 @@
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 receive)
   #:use-module (ice-9 regex)
+  #:autoload   (web uri) (string->uri
+                          uri-scheme
+                          uri-host
+                          uri-path
+                          split-and-decode-uri-path)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
@@ -76,6 +81,7 @@
             peek-body
 
             git-repository-url?
+            tarball-url->git-repository-url
             download-git-repository
             git-origin
             git->origin
@@ -202,6 +208,36 @@ thrown."
       ;; Fallback.
       (string-suffix? ".git" url)))
 
+(define (tarball-url->git-repository-url url)
+  "Given URL, the URL of a source code tarball, return the URL of the
+corresponding Git repository or #f if it could not be guessed."
+  (let ((uri (string->uri url)))
+    (match (uri-scheme uri)
+      ('mirror
+       (match (uri-host uri)
+         ((or "gnu" "savannah")
+          (string-append "https://https.git.savannah.gnu.org/git/"
+                         (match (split-and-decode-uri-path (uri-path uri))
+                           ((name _ ...)
+                            (string-append name ".git")))))
+         ("gnome"
+          (string-append "https://gitlab.gnome.org/GNOME/"
+                         (match (split-and-decode-uri-path (uri-path uri))
+                           (("sources" name _ ...)
+                            (string-append name ".git")))))
+         ;; TODO: Add "kernel" and other mirrors.
+         (_ #f)))
+      ((or 'https 'http)
+       (match (uri-host uri)
+         ((or "github.com" "gitlab.com")
+          (match (split-and-decode-uri-path (uri-path uri))
+            ((owner repository _ ...)
+             (string-append "https://" (uri-host uri)
+                            "/" owner "/" repository))))
+         (_
+          #f)))
+      (_ #f))))
+
 (define* (download-git-repository url ref #:key recursive?)
   "Fetch the given REF from the Git repository at URL.  Return three values :
 the commit hash, the downloaded directory and its content hash."
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index 9b9695b6018..049ce95b317 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021-2025 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021-2026 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
 ;;; Copyright © 2025 Nicolas Graves <ngraves@ngraves.fr>
 ;;;
@@ -33,7 +33,8 @@
   #:autoload   (gnu packages) (specification->package fold-packages)
   #:autoload   (guix import utils) (default-git-error
                                     generate-git-source
-                                    git-repository-url?)
+                                    git-repository-url?
+                                    tarball-url->git-repository-url)
   #:use-module (guix combinators)
   #:use-module (guix scripts)
   #:use-module ((guix scripts build) #:select (%standard-build-options))
@@ -47,7 +48,6 @@
   #:use-module (ice-9 control)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-2)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
@@ -569,7 +569,7 @@ are put in alphabetical order."
 ;;; url-fetch->git-fetch
 ;;;
 
-(define (transform-to-git-fetch location origin home-page version)
+(define (transform-to-git-fetch location origin repository-url version)
   "Transform an origin using url-fetch to use git-fetch if appropriate.
 Return the new origin S-expression or #f if transformation isn't applicable."
   (match origin
@@ -584,8 +584,8 @@ Return the new origin S-expression or #f if transformation isn't applicable."
                            (('snippet . _) #t)
                            (_ #f))
                          rest)))
-       `(,@(generate-git-source home-page version
-                                (default-git-error home-page location))
+       `(,@(generate-git-source repository-url version
+                                (default-git-error repository-url location))
          ,@rest)))
     (_ #f)))
 
@@ -594,12 +594,11 @@ Return the new origin S-expression or #f if transformation isn't applicable."
                                (policy 'safe)
                                (edit-expression edit-expression))
   "Transform PACKAGE's source from url-fetch to git-fetch when appropriate."
-  (define (transform-source location str)
+  (define (transform-source location repository-url str)
     (let* ((origin-exp (call-with-input-string str read-with-comments))
-           (home-page (package-home-page package))
            (new-origin (transform-to-git-fetch location
                                                origin-exp
-                                               home-page
+                                               repository-url
                                                (package-version package))))
       (if new-origin
           (begin
@@ -607,18 +606,26 @@ Return the new origin S-expression or #f if transformation isn't applicable."
             (object->string* new-origin (location-column location)))
           str)))
 
-  ;; Check if this package uses url-fetch and has a git repository home-page
-  (and-let* ((source (package-source package))
-             (home-page (package-home-page package))
-             (location                  ; source might be inherited
-              (and=> (and (origin? source)
-                          (eq? url-fetch (origin-method source))
-                          (git-repository-url? home-page)
-                          (package-field-location package 'source))
-                     absolute-location)))
-    (edit-expression
-     (location->source-properties location)
-     (cut transform-source location <>))))
+  ;; Check if this package uses 'url-fetch' and has a known corresponding Git
+  ;; repository.
+  (let* ((source (package-source package))
+         (home-page (package-home-page package))
+         (repository-url (and (origin? source)
+                              (eq? url-fetch (origin-method source))
+                              (or (and (git-repository-url? home-page)
+                                       home-page)
+                                  (and=> (match (origin-uri source)
+                                           (((? string? head) . _) head)
+                                           ((? string? url) url)
+                                           (_ #f))
+                                         tarball-url->git-repository-url))))
+         (location                                ;source might be inherited
+          (and=> (package-field-location package 'source)
+                 absolute-location)))
+    (when (and repository-url location)
+      (edit-expression
+       (location->source-properties location)
+       (cut transform-source location repository-url <>)))))
 
 
 ;;;
diff --git a/tests/import/utils.scm b/tests/import/utils.scm
index b631ba23268..c82fef78ec7 100644
--- a/tests/import/utils.scm
+++ b/tests/import/utils.scm
@@ -344,4 +344,13 @@ error procedure has been called."
   (let ((sexp error-called? (test-generate-git-source "1.0.0" "2.0.0")))
     error-called?))
 
+(test-equal "tarball-url->git-repository-url, guile"
+  '("https://https.git.savannah.gnu.org/git/guile.git"
+    "https://gitlab.gnome.org/GNOME/brasero.git"
+    "https://github.com/aide/aide")
+  (map tarball-url->git-repository-url
+       '("mirror://gnu/guile/guile-3.0.11.tar.gz"
+         "mirror://gnome/sources/brasero/3.12/brasero-3.12.3.tar.xz"
+         "https://github.com/aide/aide/releases/download/v0.19.3/aide-0.19.3.tar.gz")))
+
 (test-end "import-utils")
diff --git a/tests/style.scm b/tests/style.scm
index bc918a68bbd..350feed22b0 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021-2024 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021-2024, 2026 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -669,6 +669,41 @@
                              (cut string-contains <> "patches")))))))
     "1"))
 
+(unless (false-if-exception
+         (getaddrinfo "https.git.savannah.gnu.org" "https"))
+  (test-skip 1))
+(test-equal "url-fetch->git-fetch, mirror:// URL"
+  '(origin
+     (method git-fetch)
+     (uri (git-reference
+            (url "https://https.git.savannah.gnu.org/git/sed.git")
+            (commit (string-append "v" version))))
+     (file-name (git-file-name name version))
+     (sha256
+      (base32
+       "00p6v3aa22jz365scmifr06fspkylzrvbqda0waz4x06q5qv0263")))
+  (call-with-test-package
+      '((version "4.9")
+        (source
+         (origin
+           (method url-fetch)
+           (uri (string-append "mirror://gnu/sed/sed-"
+                               version ".tar.gz"))
+           (sha256
+            (base32 "0000000000000000000000000000000000000000000000000000")))))
+    (lambda (directory)
+      (define file
+        (string-append directory "/my-packages-1.scm"))
+
+      ;; Note: This ends up cloning the 'sed' repository on Savannah.
+      (system* "guix" "style" "-L" directory "-S" "git-source" "my-coreutils-1")
+
+      (load file)
+      (call-with-input-string (read-package-field
+                               (@ (my-packages-1) my-coreutils-1) 'source 8)
+        read))
+    "1"))
+
 (test-assert "url-fetch->git-fetch, non-git home-page unchanged"
   (call-with-test-package
       '((home-page "https://www.example.com")