wangliu-iscas/guix-mirror
1
0
Fork 0
mirror of https://codeberg.org/guix/guix.git synced 2026-04-28 06:34:05 +00:00
Code Issues Packages Projects Releases Wiki Activity

style: git-source: Handle more URLs.

Browse Source 
* 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>
This commit is contained in:
Ludovic Courtès
2026-03-04 21:48:22 +01:00
parent feb52586ec
commit 78ddf62bfe
4 changed files with 110 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

38
guix/import/utils.scm
View File

@@ -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."

49
guix/scripts/style.scm
View File

@@ -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 <>)))))
;;;

9
tests/import/utils.scm
View File

@@ -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")

37
tests/style.scm
View File

@@ -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")