diff --git a/doc/guix.texi b/doc/guix.texi index 6171919321b..a32bdd824f5 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 c45bdd44584..9b9695b6018 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 ;;; Copyright © 2024 Herman Rimm +;;; Copyright © 2025 Nicolas Graves ;;; ;;; 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)) @@ -557,6 +564,62 @@ are put in alphabetical order." rest)) #: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 3125f4cb1b6..3b74fa60bd0 100644 --- a/tests/style.scm +++ b/tests/style.scm @@ -17,55 +17,75 @@ ;;; along with GNU Guix. If not, see . (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)) + #:use-module (ice-9 pretty-print) + #:use-module (ice-9 vlist)) -(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* (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 base + (package + (inherit coreutils) + (inputs '()) + (native-inputs '()) + (propagated-inputs '()))) - (define (sdl-union . lst) - (package - (inherit base) - (name "sdl-union"))) + (define (sdl-union . lst) + (package + (inherit base) + (name "sdl-union"))) - (define-public my-coreutils - (package - (inherit base) - ,@inputs - (name "my-coreutils")))) - port))) + (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)))) + (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: