Package: guix-patches;
Reported by: Nicolas Graves <ngraves <at> ngraves.fr>
Date: Fri, 3 Mar 2023 10:37:01 UTC
Severity: normal
Tags: patch
Done: Nicolas Graves <ngraves <at> ngraves.fr>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Nicolas Graves <ngraves <at> ngraves.fr> To: 61930 <at> debbugs.gnu.org Cc: ngraves <at> ngraves.fr Subject: [bug#61930] [PATCH] import: factorising git->origin in guix/import/utils.scm. Date: Fri, 3 Mar 2023 12:06:19 +0100
---
guix/import/elpa.scm | 44 +++++++++++--------------------------
guix/import/go.scm | 47 +++++++++-------------------------------
guix/import/minetest.scm | 28 ++----------------------
guix/import/utils.scm | 36 ++++++++++++++++++++++++++++++
tests/minetest.scm | 11 ++--------
5 files changed, 63 insertions(+), 103 deletions(-)
diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm
index f9e9f2de53..cfd149a697 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune <at> gmail.com>
;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -45,7 +46,6 @@ (define-module (guix import elpa)
#:use-module ((guix serialization) #:select (write-file))
#:use-module (guix store)
#:use-module (guix ui)
- #:use-module (guix base32)
#:use-module (guix upstream)
#:use-module (guix packages)
#:use-module (guix memoization)
@@ -210,11 +210,6 @@ (define* (fetch-elpa-package name #:optional (repo 'gnu))
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."
@@ -234,28 +229,15 @@ (define (data->recipe data)
(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)))
- (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
@@ -266,9 +248,9 @@ (define (gitlab-repo->url repo)
(string-append "https://gitlab.com/" repo ".git"))
(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)))
+ ('github (git->origin (github-repo->url (assq-ref recipe ':repo)) (ref recipe)))
+ ('gitlab (git->origin (gitlab-repo->url (assq-ref recipe ':repo)) (ref recipe)))
+ ('git (git->origin (assq-ref recipe ':url) (ref recipe)))
(#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))
diff --git a/guix/import/go.scm b/guix/import/go.scm
index 90d4c8931d..c8ee16fd39 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -7,6 +7,7 @@
;;; Copyright © 2021 Xinglu Chen <public <at> yoctocell.xyz>
;;; Copyright © 2021 Sarah Morgensen <iskarian <at> mgsn.dev>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune <at> gmail.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -501,49 +502,21 @@ (define (module-meta-data-repo-url meta-data goproxy)
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))
- (update-cached-checkout url
- #:ref
- `(tag-or-commit . ,reference)))))
- (file-hash* checkout #:algorithm algorithm #:recursive? #true)))
+;; This is done because the version field of the package, which the generated
+;; quoted expression refers to, has been stripped of any 'v' prefixed.
+(define (transform-version version)
+ (let ((plain-version? (string=? version (go-version->git-ref version)))
+ (v-prefixed? (string-prefix? "v" version)))
+ ,(if (and plain-version? v-prefixed?)
+ '(string-append "v" version)
+ '(go-version->git-ref version))))
(define (vcs->origin vcs-type vcs-repo-url version)
"Generate the `origin' block of a package depending on what type of source
control system is being used."
(case vcs-type
((git)
- (let ((plain-version? (string=? version (go-version->git-ref version)))
- (v-prefixed? (string-prefix? "v" version)))
- `(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 ,(if (and plain-version? v-prefixed?)
- '(string-append "v" version)
- '(go-version->git-ref version)))))
- (file-name (git-file-name name version))
- (sha256
- (base32
- ,(bytevector->nix-base32-string
- (git-checkout-hash vcs-repo-url (go-version->git-ref version)
- (hash-algorithm sha256))))))))
+ (git->origin vcs-repo-url `(tag-or-commit . ,version) transform-version))
((hg)
`(origin
(method hg-fetch)
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index e5775e2fa9..f080539bda 100644
--- a/guix/import/minetest.scm
+++ b/guix/import/minetest.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021, 2022 Maxime Devos <maximedevos <at> telenet.be>
;;; Copyright © 2022 Hartmut Goebel <h.goebel <at> crazy-compilers.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -38,7 +39,6 @@ (define-module (guix import minetest)
#:use-module (guix import json)
#:use-module ((gcrypt hash) #:select (open-sha256-port port-sha256))
#:use-module (json)
- #:use-module (guix base32)
#:use-module (guix git)
#:use-module ((guix git-download) #:prefix download:)
#:use-module (guix hash)
@@ -283,12 +283,6 @@ (define url (string-append (%contentdb-api) "packages/?type=" type
-;; 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-minetest-sexp author/name version repository commit
inputs home-page synopsis
description media-license license)
@@ -298,25 +292,7 @@ (define (make-minetest-sexp author/name version repository commit
`(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 `(tag-or-commit . ,commit)))
(build-system minetest-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 72795d2c61..3b31338e00 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -13,6 +13,7 @@
;;; Copyright © 2022 Alice Brenon <alice.brenon <at> ens-lyon.fr>
;;; Copyright © 2022 Kyle Meyer <kyle <at> kyleam.com>
;;; Copyright © 2022 Philip McGrath <philip <at> philipmcgrath.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,6 +41,8 @@ (define-module (guix import utils)
#:use-module (guix discovery)
#:use-module (guix build-system)
#:use-module (guix gexp)
+ #:use-module (guix git)
+ #:use-module (guix hash)
#:use-module ((guix i18n) #:select (G_))
#:use-module (guix store)
#:use-module (guix download)
@@ -63,6 +66,7 @@ (define-module (guix import utils)
url-fetch
guix-hash-url
+ git->origin
package-names->package-inputs
maybe-inputs
@@ -153,6 +157,38 @@ (define (guix-hash-url filename)
"Return the hash of FILENAME in nix-base32 format."
(bytevector->nix-base32-string (file-sha256 filename)))
+(define* (git->origin repo-url ref #:optional ref->commit)
+ "Generate the `origin' block of a package depending on the git source
+control system. REPO-URL or REF can be null."
+ (let-values (((directory commit)
+ (with-store store
+ (latest-repository-commit store repo-url #:ref ref))))
+ (let* ((version (if (pair? ref)
+ (cdr ref)
+ #f))
+ (vcommit (match ref->commit
+ (#t
+ commit)
+ (null?
+ version)
+ (_
+ (ref->commit version)))))
+ `(origin
+ (method git-fetch)
+ (uri (git-reference
+ (url ,(and (not (eq? repo-url 'null)) repo-url))
+ (commit ,vcommit)))
+ (file-name (git-file-name name version))
+ (sha256
+ (base32
+ ,(if (pair? ref)
+ (bytevector->nix-base32-string
+ (file-hash* directory
+ ;; 'git-fetch' already filtered out the '.git' directory.
+ #:select? (const #true)
+ #:recursive? #true))
+ #f)))))))
+
(define %spdx-license-identifiers
;; https://spdx.org/licenses/
;; The gfl1.0, nmap, repoze
diff --git a/tests/minetest.scm b/tests/minetest.scm
index cbb9e83889..c03f731845 100644
--- a/tests/minetest.scm
+++ b/tests/minetest.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Maxime Devos <maximedevos <at> telenet.be>
+;;; Copyright © 2023 Nicolas Graves <ngraves <at> ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -57,15 +58,7 @@ (define* (make-package-sexp #:key
`(package
(name ,guix-name)
(version ,version)
- (source
- (origin
- (method git-fetch)
- (uri (git-reference
- (url ,(and (not (eq? repo 'null)) repo))
- (commit #f)))
- (sha256
- (base32 #f))
- (file-name (git-file-name name version))))
+ (source (git->origin repo #f))
(build-system minetest-mod-build-system)
,@(maybe-propagated-inputs inputs)
(home-page ,home-page)
--
2.39.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.