guix_mirror_bot pushed a commit to branch master
in repository guix.
commit bd2470ca4d2c1bbb8a707b64d544e8aa2731f4ec
Author: Nicolas Graves via Guix-patches via <[email protected]>
AuthorDate: Sun Feb 4 00:07:11 2024 +0100
import: utils: Add function git->origin.
* guix/import/utils.scm: (git-origin, git->origin): Add procedures.
* guix/import/elpa.scm
(download-git-repository): Remove function download-git-repository.
(git-repository->origin): Remove function git-repository->origin.
(ref): Add function ref.
(melpa-recipe->origin): Use functions git->origin and ref.
* guix/import/go.scm
(git-checkout-hash): Remove function git-checkout-hash.
(transform-version): Add function transform-version.
(vcs->origin): Use functions git->origin and transform-version. Add
optional argument transform-version.
* tests/import/go.scm
(go-module->guix-package): Adapt test case to changes in guix/import/go.scm.
* guix/import/luanti.scm
(download-git-repository): Remove function download-git-repository.
(make-luanti-sexp): Use function git->origin.
* tests/luanti.scm
(make-package-sexp): Refresh function accordingly.
* guix/import/composer.scm
(make-php-sexp): Use function git->origin.
Change-Id: Ied05a63bdd60fbafe26fbbb4e115ff6f0bb9db3c
Signed-off-by: Liliana Marie Prikler <[email protected]>
---
guix/import/composer.scm | 86 +++++++++++++++++-------------------------------
guix/import/elpa.scm | 62 +++++++++++++---------------------
guix/import/go.scm | 77 +++++++++++++------------------------------
guix/import/luanti.scm | 27 +--------------
guix/import/utils.scm | 47 +++++++++++++++++++++++++-
tests/go.scm | 17 +++++-----
tests/luanti.scm | 8 ++---
7 files changed, 135 insertions(+), 189 deletions(-)
diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index 5c8570bbf2..5c6706a913 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -20,25 +20,20 @@
(define-module (guix import composer)
#:use-module (ice-9 match)
#:use-module (json)
- #:use-module (guix base32)
- #:use-module (guix build git)
- #:use-module (guix build utils)
- #:use-module (guix build-system)
#:use-module (guix build-system composer)
#:use-module ((guix diagnostics) #:select (warning))
- #:use-module (guix hash)
+ #:use-module ((guix download) #:select (download-to-store))
#:use-module (guix i18n)
#:use-module (guix import json)
#:use-module (guix import utils)
#:use-module ((guix licenses) #:prefix license:)
#:use-module (guix memoization)
#:use-module (guix packages)
- #:use-module (guix serialization)
+ #:use-module (guix store)
#:use-module (guix upstream)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
- #:use-module (srfi srfi-11)
#:use-module (srfi srfi-26)
#:export (composer->guix-package
%composer-updater
@@ -135,55 +130,34 @@ COMPOSER-PACKAGE."
(dependencies (map php-package-name
(composer-package-require composer-package)))
(dev-dependencies (map php-package-name
- (composer-package-dev-require
composer-package)))
- (git? (equal? (composer-source-type source) "git")))
- ((if git? call-with-temporary-directory call-with-temporary-output-file)
- (lambda* (temp #:optional port)
- (and (if git?
- (begin
- (mkdir-p temp)
- (git-fetch (composer-source-url source)
- (composer-source-reference source)
- temp))
- (url-fetch (composer-source-url source) temp))
- `(package
- (name ,(composer-package-name composer-package))
- (version ,(composer-package-version composer-package))
- (source
- (origin
- ,@(if git?
- `((method git-fetch)
- (uri (git-reference
- (url ,(if (string-suffix?
- ".git"
- (composer-source-url source))
- (string-drop-right
- (composer-source-url source)
- (string-length ".git"))
- (composer-source-url source)))
- (commit ,(composer-source-reference source))))
- (file-name (git-file-name name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string
- (file-hash* temp)))))
- `((method url-fetch)
- (uri ,(composer-source-url source))
- (sha256 (base32 ,(guix-hash-url temp)))))))
- (build-system composer-build-system)
- ,@(if (null? dependencies)
- '()
- `((inputs
- (list ,@(map string->symbol dependencies)))))
- ,@(if (null? dev-dependencies)
- '()
- `((native-inputs
- (list ,@(map string->symbol dev-dependencies)))))
- (synopsis "")
- (description ,(composer-package-description composer-package))
- (home-page ,(composer-package-homepage composer-package))
- (license ,(or (composer-package-license composer-package)
- 'unknown-license!))))))))
+ (composer-package-dev-require
composer-package))))
+ `(package
+ (name ,(composer-package-name composer-package))
+ (version ,(composer-package-version composer-package))
+ (source
+ ,(if (string= (composer-source-type source) "git")
+ (git->origin (composer-source-url source)
+ (const (composer-source-reference source)))
+ (let* ((source (composer-source-url source))
+ (tarball (with-store store (download-to-store store
source))))
+ `(origin
+ (method url-fetch)
+ (uri ,source)
+ (sha256 (base32 ,(guix-hash-url tarball)))))))
+ (build-system composer-build-system)
+ ,@(if (null? dependencies)
+ '()
+ `((inputs
+ (list ,@(map string->symbol dependencies)))))
+ ,@(if (null? dev-dependencies)
+ '()
+ `((native-inputs
+ (list ,@(map string->symbol dev-dependencies)))))
+ (synopsis "")
+ (description ,(composer-package-description composer-package))
+ (home-page ,(composer-package-homepage composer-package))
+ (license ,(or (composer-package-license composer-package)
+ 'unknown-license!)))))
(define composer->guix-package
(memoize
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index eda3d6d60b..52d0513548 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <[email protected]>
;;; Copyright © 2021 Simon Tournier <[email protected]>
;;; Copyright © 2022 Hartmut Goebel <[email protected]>
+;;; Copyright © 2023 Nicolas Graves <[email protected]>
;;; Copyright © 2025 jgart <[email protected]>
;;;
;;; This file is part of GNU Guix.
@@ -212,11 +213,6 @@ include VERSION."
url)))
(_ #f))))
-(define* (download-git-repository url ref)
- "Fetch the given REF from the Git repository at URL."
- (with-store store
- (latest-repository-commit store url #:ref ref)))
-
(define (package-name->melpa-recipe package-name)
"Fetch the MELPA recipe for PACKAGE-NAME, represented as an alist from
keywords to values."
@@ -236,46 +232,34 @@ keywords to values."
(close-port port)
(data->recipe (cons ':name data))))
-(define (git-repository->origin recipe url)
- "Fetch origin details from the Git repository at URL for the provided MELPA
-RECIPE."
- (define ref
- (cond
- ((assoc-ref recipe #:branch)
- => (lambda (branch) (cons 'branch branch)))
- ((assoc-ref recipe #:commit)
- => (lambda (commit) (cons 'commit commit)))
- (else
- '())))
-
- (let-values (((directory commit) (download-git-repository url ref)))
- `(origin
- (method git-fetch)
- (uri (git-reference
- (url ,url)
- (commit ,commit)))
- (file-name (git-file-name name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string
- (file-hash* directory #:recursive? #true)))))))
+(define (ref recipe)
+ "Create REF from MELPA RECIPE."
+ (cond
+ ((assoc-ref recipe #:branch)
+ => (lambda (branch) (cons 'branch branch)))
+ ((assoc-ref recipe #:commit)
+ => (lambda (commit) (cons 'commit commit)))
+ (else
+ '())))
(define* (melpa-recipe->origin recipe)
"Fetch origin details from the MELPA recipe and associated repository for
the package named PACKAGE-NAME."
- (define (github-repo->url repo)
- (string-append "https://github.com/"; repo ".git"))
- (define (gitlab-repo->url repo)
- (string-append "https://gitlab.com/"; repo ".git"))
+ (define (recipe->origin url)
+ (git->origin url (const #f) #:ref (ref recipe)))
(match (assq-ref recipe ':fetcher)
- ('github (git-repository->origin recipe (github-repo->url (assq-ref recipe
':repo))))
- ('gitlab (git-repository->origin recipe (gitlab-repo->url (assq-ref recipe
':repo))))
- ('git (git-repository->origin recipe (assq-ref recipe ':url)))
- (#f #f) ; if we're not using melpa then this stops us printing a warning
- (_ (warning (G_ "unsupported MELPA fetcher: ~a, falling back to unstable
MELPA source~%")
- (assq-ref recipe ':fetcher))
- #f)))
+ ('github (recipe->origin
+ (string-append "https://github.com/"; (assq-ref recipe ':repo))))
+ ('gitlab (recipe->origin
+ (string-append "https://gitlab.com/"; (assq-ref recipe ':repo))))
+ ('git (recipe->origin (assq-ref recipe ':repo)))
+ ;; XXX: if we're not using melpa then this stops us printing a warning
+ (#f #f)
+ (_ (warning (G_ "\
+unsupported MELPA fetcher: ~a, falling back to unstable MELPA source~%")
+ (assq-ref recipe ':fetcher))
+ #f)))
(define (elpa-dependency->upstream-input dependency)
"Convert DEPENDENCY, an sexp as returned by 'elpa-package-inputs', into an
diff --git a/guix/import/go.scm b/guix/import/go.scm
index 46600c2116..07a0303b83 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <[email protected]>
;;; Copyright © 2021, 2024 Simon Tournier <[email protected]>
;;; Copyright © 2023 Efraim Flashner <[email protected]>
+;;; Copyright © 2023 Nicolas Graves <[email protected]>
;;; Copyright © 2024 Christina O'Donnell <[email protected]>
;;;
;;; This file is part of GNU Guix.
@@ -549,65 +550,33 @@ source."
goproxy
(module-meta-repo-root meta-data)))
-(define* (git-checkout-hash url reference algorithm)
- "Return the ALGORITHM hash of the checkout of URL at REFERENCE, a commit or
-tag."
- (define cache
- (string-append (or (getenv "TMPDIR") "/tmp")
- "/guix-import-go-"
- (passwd:name (getpwuid (getuid)))))
-
- ;; Use a custom cache to avoid cluttering the default one under
- ;; ~/.cache/guix, but choose one under /tmp so that it's persistent across
- ;; subsequent "guix import" invocations.
- (mkdir-p cache)
- (chmod cache #o700)
- (let-values (((checkout commit _)
- (parameterize ((%repository-cache-directory cache))
- (catch 'git-error
- (lambda ()
- (update-cached-checkout url
- #:ref
- `(tag-or-commit . ,reference)))
- (lambda (key err)
- (warning (G_ "failed to check out ~s from Git repository
at '~a': ~a~%")
- reference url (git-error-message err))
- (values #f #f #f))))))
- (if (and checkout commit)
- (file-hash* checkout #:algorithm algorithm #:recursive? #true)
- (nix-base32-string->bytevector
- "0000000000000000000000000000000000000000000000000000"))))
-
(define (vcs->origin vcs-type vcs-repo-url version subdir)
"Generate the `origin' block of a package depending on what type of source
-control system is being used."
+control system is being used. Optionally use the function TRANSFORM-VERSION
+which takes version as an input."
(case vcs-type
((git)
- (let* ((plain-version? (string=? version (go-version->git-ref version
- #:subdir
subdir)))
+ ;; XXX: The version field of the package, which the generated quoted
+ ;; expression refers to, has been stripped of any 'v' prefixed.
+ (let* ((git-ref (go-version->git-ref version #:subdir subdir))
+ (plain-version? (string=? version git-ref))
(v-prefixed? (string-prefix? "v" version))
- ;; This is done because the version field of the package,
- ;; which the generated quoted expression refers to, has been
- ;; stripped of any 'v' prefixed.
- (version-expr (if (and plain-version? v-prefixed?)
- '(string-append "v" version)
- `(go-version->git-ref version
- ,@(if subdir `(#:subdir
,subdir) '())))))
- `(origin
- (method git-fetch)
- (uri (git-reference
- (url ,vcs-repo-url)
- ;; This is done because the version field of the package,
- ;; which the generated quoted expression refers to, has been
- ;; stripped of any 'v' prefixed.
- (commit ,version-expr)))
- (file-name (git-file-name name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string
- (git-checkout-hash vcs-repo-url (go-version->git-ref version
- #:subdir
subdir)
- (hash-algorithm sha256))))))))
+ (pure-version (if v-prefixed?
+ (string-drop version 1)
+ version)))
+ (if (and plain-version? v-prefixed?)
+ (git->origin vcs-repo-url
+ (peekable-lambda (version)
+ (string-append "v" version))
+ pure-version)
+ (git->origin vcs-repo-url
+ (if subdir
+ (peekable-lambda (version subdir)
+ (go-version->git-ref version #:subdir subdir))
+ (peekable-lambda (version subdir)
+ (go-version->git-ref version)))
+ pure-version
+ subdir))))
((hg)
`(origin
(method hg-fetch)
diff --git a/guix/import/luanti.scm b/guix/import/luanti.scm
index 1db660655e..3b52a30896 100644
--- a/guix/import/luanti.scm
+++ b/guix/import/luanti.scm
@@ -33,7 +33,6 @@
#:use-module (guix import utils)
#:use-module (guix import json)
#:use-module (json)
- #:use-module (guix base32)
#:use-module (guix git)
#:use-module ((guix git-download) #:prefix download:)
#:use-module (guix hash)
@@ -278,12 +277,6 @@ results. The return value is a list of <package-keys>
records."
-;; XXX copied from (guix import elpa)
-(define* (download-git-repository url ref)
- "Fetch the given REF from the Git repository at URL."
- (with-store store
- (latest-repository-commit store url #:ref ref)))
-
(define (make-luanti-sexp author/name version repository commit
inputs home-page synopsis
description media-license license)
@@ -293,25 +286,7 @@ MEDIA-LICENSE and LICENSE."
`(package
(name ,(contentdb->package-name author/name))
(version ,version)
- (source
- (origin
- (method git-fetch)
- (uri (git-reference
- (url ,repository)
- (commit ,commit)))
- (sha256
- (base32
- ;; The git commit is not always available.
- ,(and commit
- (bytevector->nix-base32-string
- (file-hash*
- (download-git-repository repository
- `(commit . ,commit))
- ;; 'download-git-repository' already filtered out the '.git'
- ;; directory.
- #:select? (const #true)
- #:recursive? #true)))))
- (file-name (git-file-name name version))))
+ (source ,(git->origin repository (const #f)))
(build-system luanti-mod-build-system)
,@(maybe-propagated-inputs (map contentdb->package-name inputs))
(home-page ,home-page)
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index ce7671f4e8..78aad3ad94 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -13,8 +13,8 @@
;;; Copyright © 2022 Alice Brenon <[email protected]>
;;; Copyright © 2022 Kyle Meyer <[email protected]>
;;; Copyright © 2022 Philip McGrath <[email protected]>
+;;; Copyright © 2023, 2025 Nicolas Graves <[email protected]>
;;; Copyright © 2025 Cayetano Santos <[email protected]>
-;;; Copyright © 2025 Nicolas Graves <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -42,6 +42,8 @@
#:use-module (guix deprecation)
#:use-module (guix discovery)
#:use-module (guix build-system)
+ #:use-module (guix git)
+ #:use-module (guix hash)
#:use-module ((guix i18n) #:select (G_))
#:use-module (guix store)
#:use-module (guix download)
@@ -70,6 +72,10 @@
peekable-lambda
peek-body
+ download-git-repository
+ git-origin
+ git->origin
+
package-names->package-inputs
maybe-inputs
maybe-native-inputs
@@ -177,6 +183,45 @@ thrown."
(define (peek-body proc)
(procedure-property proc 'body))
+(define (download-git-repository url ref)
+ "Fetch the given REF from the Git repository at URL. Return three values :
+the commit hash, the downloaded directory and its content hash."
+ (with-store store
+ (let (((values checkout commit-hash)
+ (latest-repository-commit store url #:ref ref)))
+ (values commit-hash
+ checkout
+ (bytevector->nix-base32-string
+ (query-path-hash store checkout))))))
+
+(define (git-origin url commit hash)
+ "Simple helper to generate a Git origin s-expression."
+ `(origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,(and (not (eq? url 'null)) url))
+ (commit ,commit)))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32 ,hash))))
+
+(define* (git->origin url proc #:key ref #:rest rest)
+ "Return a generated `origin' block of a package depending on the Git version
+control system, and the directory in the store where the package has been
+downloaded, in case further processing is necessary.
+
+Unless overwritten with REF, the ref (as defined by the (guix git) module)
+is calculated from the evaluation of PROC with trailing arguments. PROC must
+be a procedure with a 'body property, used to generate the origin sexp."
+ (let* ((args (strip-keyword-arguments '(#:ref) rest))
+ (commit (apply proc args))
+ (ref (or ref (and commit `(tag-or-commit . ,commit))))
+ (_ directory hash
+ (if (or ref commit)
+ (download-git-repository url ref)
+ (values #f #f #f))))
+ (values (git-origin url (peek-body proc) hash) directory)))
+
(define %spdx-license-identifiers
;; https://spdx.org/licenses/
;; The gfl1.0, nmap, repoze
diff --git a/tests/go.scm b/tests/go.scm
index 1ba089c788..a72f306871 100644
--- a/tests/go.scm
+++ b/tests/go.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 François Joulaud <[email protected]>
;;; Copyright © 2021 Sarah Morgensen <[email protected]>
+;;; Copyright © 2023 Nicolas Graves <[email protected]>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,7 +25,7 @@
#:use-module (guix base32)
#:use-module (guix build-system go)
#:use-module (guix import go)
- #:use-module (guix base32)
+ #:use-module (guix import utils)
#:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module (guix tests)
#:use-module (ice-9 match)
@@ -407,13 +408,11 @@ package.")
(mock-http-get fixtures-go-check-test))
(mock ((guix http-client) http-fetch
(mock-http-fetch fixtures-go-check-test))
- (mock ((guix git) update-cached-checkout
- (lambda* (url #:key ref)
- ;; Return an empty directory and its hash.
- (values checkout
- (nix-base32-string->bytevector
-
"0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")
- #f)))
- (go-module->guix-package* "github.com/go-check/check")))))))
+ (mock ((guix import utils) git->origin
+ ;; Mock an empty directory by replacing hash.
+ (lambda* (url proc #:key ref #:rest args)
+ (git-origin url (peek-body proc) "\
+0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5")))
+ (go-module->guix-package* "github.com/go-check/check")))))))
(test-end "go")
diff --git a/tests/luanti.scm b/tests/luanti.scm
index 6ee0340e93..6df547c8f4 100644
--- a/tests/luanti.scm
+++ b/tests/luanti.scm
@@ -61,11 +61,11 @@
(origin
(method git-fetch)
(uri (git-reference
- (url ,(and (not (eq? repo 'null)) repo))
- (commit #f)))
+ (url ,(and (not (eq? repo 'null)) repo))
+ (commit #f)))
+ (file-name (git-file-name name version))
(sha256
- (base32 #f))
- (file-name (git-file-name name version))))
+ (base32 #f))))
(build-system luanti-mod-build-system)
,@(maybe-propagated-inputs inputs)
(home-page ,home-page)
