~ruther/guix-local

a1b0fde434f905a4fe3a478d2f6d7fb4b7cca6df — Nicolas Graves 6 months ago 0533284 
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 <ludo@gnu.org>
patch browse .tar.gz 
3 files changed, 304 insertions(+), 38 deletions(-)

M doc/guix.texi
M guix/scripts/style.scm
M tests/style.scm

M doc/guix.texi => doc/guix.texi +43 -0
@@ 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


M guix/scripts/style.scm => guix/scripts/style.scm +66 -1
@@ 1,6 1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021-2025 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2024 Herman Rimm <herman@rimm.ee>
;;; Copyright © 2025 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; 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))




@@ 559,6 566,62 @@ are put in alphabetical order."


;;;
;;; 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]...


M tests/style.scm => tests/style.scm +195 -37
@@ 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: