From 78ddf62bfe2264c0085fdce4b2cbcad07f6eaf16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 4 Mar 2026 21:48:22 +0100 Subject: [PATCH] style: git-source: Handle more URLs. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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 --- 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 +;;; Copyright © 2012-2013, 2018-2020, 2023, 2025-2026 Ludovic Courtès ;;; Copyright © 2016 Jelle Licht ;;; Copyright © 2016 David Craven ;;; Copyright © 2017, 2019, 2020, 2022, 2023, 2024, 2025 Ricardo Wurmus @@ -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 +;;; Copyright © 2021-2026 Ludovic Courtès ;;; Copyright © 2024 Herman Rimm ;;; Copyright © 2025 Nicolas Graves ;;; @@ -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 +;;; Copyright © 2021-2024, 2026 Ludovic Courtès ;;; ;;; 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")