guix_mirror_bot pushed a commit to branch master
in repository guix.
commit 78ddf62bfe2264c0085fdce4b2cbcad07f6eaf16
Author: Ludovic Courtès <[email protected]>
AuthorDate: Wed Mar 4 21:48:22 2026 +0100
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 <[email protected]>
---
guix/import/utils.scm | 38 +++++++++++++++++++++++++++++++++++++-
guix/scripts/style.scm | 49 ++++++++++++++++++++++++++++---------------------
tests/import/utils.scm | 9 +++++++++
tests/style.scm | 37 ++++++++++++++++++++++++++++++++++++-
4 files changed, 110 insertions(+), 23 deletions(-)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 5f8a4c22f6..c435981ca9 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 <[email protected]>
+;;; Copyright © 2012-2013, 2018-2020, 2023, 2025-2026 Ludovic Courtès
<[email protected]>
;;; Copyright © 2016 Jelle Licht <[email protected]>
;;; Copyright © 2016 David Craven <[email protected]>
;;; Copyright © 2017, 2019, 2020, 2022, 2023, 2024, 2025 Ricardo Wurmus
<[email protected]>
@@ -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 9b9695b601..049ce95b31 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 <[email protected]>
+;;; Copyright © 2021-2026 Ludovic Courtès <[email protected]>
;;; Copyright © 2024 Herman Rimm <[email protected]>
;;; Copyright © 2025 Nicolas Graves <[email protected]>
;;;
@@ -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 b631ba2326..c82fef78ec 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 bc918a68bb..350feed22b 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 <[email protected]>
+;;; Copyright © 2021-2024, 2026 Ludovic Courtès <[email protected]>
;;;
;;; 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";)
