guix_mirror_bot pushed a commit to branch master
in repository guix.
commit a1b0fde434f905a4fe3a478d2f6d7fb4b7cca6df
Author: Nicolas Graves <[email protected]>
AuthorDate: Thu Sep 4 13:53:08 2025 +0200
style: Add git-source rule.
* guix/scripts/style.scm (transform-to-git-fetch)
(url-fetch->git-fetch): New procedures.
* doc/guix.texi: Add entry for git-source.
* tests/style.scm: Add tests for url-fetch->git-fetch.
Change-Id: I6192fba4d84619b81fbc75850542b9dbd2326d4a
Signed-off-by: Ludovic Courtès <[email protected]>
---
doc/guix.texi | 43 +++++++++
guix/scripts/style.scm | 67 +++++++++++++-
tests/style.scm | 232 +++++++++++++++++++++++++++++++++++++++++--------
3 files changed, 304 insertions(+), 38 deletions(-)
diff --git a/doc/guix.texi b/doc/guix.texi
index 6171919321..a32bdd824f 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -15801,6 +15801,49 @@ Note that changes made by the @code{arguments} rule do
not entail a
rebuild of the affected packages. Furthermore, if a package definition
happens to be using G-expressions already, @command{guix style} leaves
it unchanged.
+
+@item git-source
+If the @code{home-page} is a Git repository (as per
+@code{git-repository-url?}), and the actual Git repository is tagged
+with @code{version} or @code{(string-append ``v'' version)}, change the
+package origin to the @code{git-fetch} method
+(@pxref{origin Reference}). Consider this example:
+
+@lisp
+(define-public guile-json-4
+ (package
+ (inherit guile-json-3)
+ (name "guile-json")
+ (version "4.7.3")
+ (source (origin
+ (method url-fetch)
+ (uri (string-append "mirror://savannah/guile-json/guile-json-"
+ version ".tar.gz"))
+ (sha256
+ (base32
+ "127k2xc07w1gnyqs40z4865l8p3ra5xgpcn569dz04lxsa709fiq"))))))
+@end lisp
+
+@noindent
+Running @command{guix style -S git-source} on this package would rewrite
+its @code{source} field like to:
+
+@lisp
+(define-public guile-json-4
+ (package
+ (inherit guile-json-3)
+ (name "guile-json")
+ (version "4.7.3")
+ (source (origin
+ (method git-fetch)
+ (uri (git-reference (url
+ "https://github.com/aconchillo/guile-json";)
+ (commit version)))
+ (file-name (git-file-name name version))
+ (sha256 (base32
+
"0akhm8xjv8fl55fyq0w6c9c6hi5j7mifjx01w07np7qg1cjl9f06"))))))
+@end lisp
+
@end table
@item --list-stylings
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index c45bdd4458..9b9695b601 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2025 Ludovic Courtès <[email protected]>
;;; Copyright © 2024 Herman Rimm <[email protected]>
+;;; Copyright © 2025 Nicolas Graves <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -30,9 +31,13 @@
(define-module (guix scripts style)
#:autoload (gnu packages) (specification->package fold-packages)
+ #:autoload (guix import utils) (default-git-error
+ generate-git-source
+ git-repository-url?)
#:use-module (guix combinators)
#:use-module (guix scripts)
#:use-module ((guix scripts build) #:select (%standard-build-options))
+ #:use-module (guix download)
#:use-module (guix ui)
#:use-module (guix packages)
#:use-module (guix utils)
@@ -42,11 +47,13 @@
#: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)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
+ #:use-module (srfi srfi-71)
#:export (guix-style))
@@ -558,6 +565,62 @@ are put in alphabetical order."
#:sync? #f))))
+;;;
+;;; url-fetch->git-fetch
+;;;
+
+(define (transform-to-git-fetch location origin home-page 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
+ (('origin
+ ('method 'url-fetch)
+ ('uri uri-expr)
+ ('sha256 ('base32 _))
+ rest ...)
+ (let ((rest (filter (match-lambda
+ (('patches . _) #t)
+ (('modules . _) #t)
+ (('snippet . _) #t)
+ (_ #f))
+ rest)))
+ `(,@(generate-git-source home-page version
+ (default-git-error home-page location))
+ ,@rest)))
+ (_ #f)))
+
+(define* (url-fetch->git-fetch package
+ #:key
+ (policy 'safe)
+ (edit-expression edit-expression))
+ "Transform PACKAGE's source from url-fetch to git-fetch when appropriate."
+ (define (transform-source location 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
+ (package-version package))))
+ (if new-origin
+ (begin
+ (info location (G_ "transforming source from url-fetch to
git-fetch~%"))
+ (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 <>))))
+
+
;;;
;;; Options.
;;;
@@ -587,6 +650,7 @@ are put in alphabetical order."
("inputs" simplify-package-inputs)
("arguments" gexpify-package-arguments)
("format" format-package-definition)
+ ("git-source" url-fetch->git-fetch)
(_ (leave (G_ "~a: unknown styling~%")
arg)))
result)))
@@ -615,7 +679,8 @@ are put in alphabetical order."
(display (G_ "Available styling rules:\n"))
(display (G_ "- format: Format the given package definition(s)\n"))
(display (G_ "- inputs: Rewrite package inputs to the “new style”\n"))
- (display (G_ "- arguments: Rewrite package arguments to G-expressions\n")))
+ (display (G_ "- arguments: Rewrite package arguments to G-expressions\n"))
+ (display (G_ "- git-source: Rewrite source fetch method to Git.\n")))
(define (show-help)
(display (G_ "Usage: guix style [OPTION]... [PACKAGE]...
diff --git a/tests/style.scm b/tests/style.scm
index 3125f4cb1b..3b74fa60bd 100644
--- a/tests/style.scm
+++ b/tests/style.scm
@@ -17,55 +17,75 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (tests-style)
+ #:use-module ((gcrypt hash) #:select (port-sha256))
#:use-module (guix packages)
#:use-module (guix scripts style)
#:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module ((guix build utils) #:select (substitute*))
#:use-module (guix gexp) ;for the reader extension
#:use-module (guix diagnostics)
+ #:use-module (guix git)
+ #:use-module (guix tests)
+ #:use-module (guix tests git)
+ #:use-module (gnu packages)
#:use-module (gnu packages acl)
#:use-module (gnu packages multiprecision)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
- #:use-module (ice-9 pretty-print))
-
-(define (call-with-test-package inputs proc)
- (call-with-temporary-directory
- (lambda (directory)
- (call-with-output-file (string-append directory "/my-packages.scm")
- (lambda (port)
- (pretty-print
- `(begin
- (define-module (my-packages)
- #:use-module (guix)
- #:use-module (guix licenses)
- #:use-module (gnu packages acl)
- #:use-module (gnu packages base)
- #:use-module (gnu packages multiprecision)
- #:use-module (srfi srfi-1))
-
- (define base
- (package
- (inherit coreutils)
- (inputs '())
- (native-inputs '())
- (propagated-inputs '())))
-
- (define (sdl-union . lst)
- (package
- (inherit base)
- (name "sdl-union")))
-
- (define-public my-coreutils
- (package
- (inherit base)
- ,@inputs
- (name "my-coreutils"))))
- port)))
-
- (proc directory))))
+ #:use-module (ice-9 pretty-print)
+ #:use-module (ice-9 vlist))
+
+(define* (call-with-test-package inputs proc #:optional suffix)
+ (let ((module-name (if suffix
+ (string-append "my-packages-" suffix)
+ "my-packages"))
+ (name (if suffix
+ (string-append "my-coreutils-" suffix)
+ "my-coreutils")))
+ (call-with-temporary-directory
+ (lambda (directory)
+ (call-with-output-file (string-append directory "/" module-name ".scm")
+ (lambda (port)
+ (pretty-print
+ `(begin
+ (define-module (,(string->symbol module-name))
+ #:use-module (guix)
+ #:use-module (guix git-download) ; for -S git-source
+ #:use-module ((gnu packages) #:select (search-patches))
+ #:use-module (guix licenses)
+ #:use-module (gnu packages acl)
+ #:use-module (gnu packages base)
+ #:use-module (gnu packages multiprecision)
+ #:use-module (srfi srfi-1))
+
+ (define base
+ (package
+ (inherit coreutils)
+ (inputs '())
+ (native-inputs '())
+ (propagated-inputs '())))
+
+ (define (sdl-union . lst)
+ (package
+ (inherit base)
+ (name "sdl-union")))
+
+ (define-public ,(string->symbol name)
+ (package
+ (inherit base)
+ (name ,name)
+ ,@inputs
+ ;; XXX: The field below was added so that the 'inputs'
+ ;; field doesn't come last; if it did, 'read-package-field'
+ ;; in the tests below would read the three closing parens
+ ;; for each test.
+ (properties '()))))
+ port)))
+
+ (proc directory)))))
(define test-directory
;; Directory where the package definition lives.
@@ -546,6 +566,144 @@
(load file)
(read-package-field (@ (my-packages) my-coreutils) 'arguments 5))))
+;;;
+;;; url-fetch->git-fetch transformation
+;;;
+
+(test-equal "url-fetch->git-fetch, basic transformation"
+ `(origin
+ (method git-fetch)
+ (uri (git-reference (url "https://github.com/foo/bar";)
+ (commit version)))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32 "0j8vhvfj1d3jvbrd4kh20m50knmwj19xk0l3s78z1xxayp3c5zkk")))
+ (call-with-test-package
+ '((home-page "@substitute-me@")
+ (version "1.0")
+ (source
+ (origin
+ (method url-fetch)
+ (uri (string-append "https://example.com/foo-"; version ".tar.gz"))
+ (sha256
+ (base32 "0000000000000000000000000000000000000000000000000000")))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages-0.scm"))
+
+ (parameterize ((test-directory directory))
+ (with-temporary-git-repository repository
+ `((add "README" "Initial commit")
+ (commit "First commit")
+ (tag "1.0" "Initial release"))
+ (mock ((guix import utils) git-repository-url? (const #t))
+ (substitute* file
+ (("@substitute-me@")
+ (string-append "file://" repository)))
+ ;; XXX: Calling guix-style is necessary to use mock.
+ (guix-style "-L" directory "-S" "git-source" "my-coreutils-0")
+ (substitute* file
+ (((string-append "file://" repository))
+ "https://github.com/foo/bar";))
+
+ (load file)
+ (and=> (false-if-exception
+ (read-package-field (@ (my-packages-0) my-coreutils-0)
'source 8))
+ (cut call-with-input-string <> read))))))
+ "0"))
+
+(test-assert "url-fetch->git-fetch, preserved field"
+ (call-with-test-package
+ '((home-page "@substitute-me@")
+ (version "1.0")
+ (source
+ (origin
+ (method url-fetch)
+ (uri "https://example.com/foo.tar.gz";)
+ (sha256
+ (base32 "0000000000000000000000000000000000000000000000000000"))
+ (patches (search-patches "foo.patch")))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages-1.scm"))
+ (call-with-output-file (string-append directory "/foo.patch")
+ (const #t))
+
+ (parameterize ((test-directory directory)
+ (%patch-path (list directory))
+ (%package-module-path (list directory "")))
+ (with-temporary-git-repository repository
+ `((add "README" "Initial commit")
+ (commit "First commit")
+ (tag "1.0" "Initial release"))
+ (mock ((guix import utils) git-repository-url? (const #t))
+ (mock ((gnu packages) specification->package
+ (lambda (spec)
+ (car
+ (vhash-fold* cons '() spec
+ (fold-packages
+ (lambda (p r)
+ (vhash-cons (package-name p) p r))
+ vlist-null)))))
+ (substitute* file
+ (("@substitute-me@")
+ (string-append "file://" repository)))
+ ;; XXX: Calling guix-style is necessary to use mock.
+ (guix-style "-L" directory "-S" "git-source"
"my-coreutils-1")
+ (substitute* file
+ (((string-append "file://" repository))
+ "https://github.com/foo/bar";))
+ (load file)
+ (and=> (read-package-field
+ (@ (my-packages-1) my-coreutils-1) 'source 8)
+ (cut string-contains <> "patches")))))))
+ "1"))
+
+(test-assert "url-fetch->git-fetch, non-git home-page unchanged"
+ (call-with-test-package
+ '((home-page "https://www.example.com";)
+ (source
+ (origin
+ (method url-fetch)
+ (uri "https://example.com/foo.tar.gz";)
+ (sha256
+ (base32 "0000000000000000000000000000000000000000000000000000")))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+ (define before-hash
+ (call-with-input-file file port-sha256))
+
+ (system* "guix" "style" "-L" directory "-S" "git-source"
+ "my-coreutils")
+
+ ;; File should be unchanged
+ (equal? (call-with-input-file file port-sha256) before-hash))))
+
+(test-assert "url-fetch->git-fetch, already git-fetch unchanged"
+ (call-with-test-package
+ '((home-page "https://github.com/foo/bar";)
+ (source
+ (origin
+ (method git-fetch)
+ (uri (git-reference
+ (url "https://github.com/foo/bar";)
+ (commit version)))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32 "0000000000000000000000000000000000000000000000000000")))))
+ (lambda (directory)
+ (define file
+ (string-append directory "/my-packages.scm"))
+ (define before-hash
+ (call-with-input-file file port-sha256))
+
+ (system* "guix" "style" "-L" directory "-S" "git-source"
+ "my-coreutils")
+
+ ;; File should be unchanged
+ (equal? (call-with-input-file file port-sha256) before-hash))))
+
(test-end)
;; Local Variables:
