* [bug#73833] [PATCH v2 1/5] guix: import: utils: Add function git->origin.
2024-10-17 22:25 ` [bug#73833] [PATCH v2 0/5] Large improvements to import utils, composer import, and refresh Nicolas Graves via Guix-patches via
@ 2024-10-17 22:25 ` Nicolas Graves via Guix-patches via
2024-10-17 22:25 ` [bug#73833] [PATCH v2 2/5] tests: go: Add mock-git->origin function Nicolas Graves via Guix-patches via
` (3 subsequent siblings)
4 siblings, 0 replies; 7+ messages in thread
From: Nicolas Graves via Guix-patches via @ 2024-10-17 22:25 UTC (permalink / raw)
To: 73833; +Cc: Nicolas Graves
* guix/import/utils.scm: (git->origin): Add function.
* 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/minetest.scm
(download-git-repository): Remove function download-git-repository.
(make-minetest-sexp): Use function git->origin.
* tests/minetest.scm
(make-package-sexp): Use function git->origin.
(example-package): Adapt test-case to git->origin.
* guix/import/composer.scm
(make-php-sexp): Use function git->origin.
Change-Id: Ied05a63bdd60fbafe26fbbb4e115ff6f0bb9db3c
---
guix/import/composer.scm | 85 ++++++++++++++--------------------------
guix/import/elpa.scm | 44 ++++++---------------
guix/import/go.scm | 57 ++++++++-------------------
guix/import/minetest.scm | 28 ++-----------
guix/import/utils.scm | 39 ++++++++++++++++++
tests/go.scm | 29 ++++++++++----
tests/minetest.scm | 15 ++-----
7 files changed, 127 insertions(+), 170 deletions(-)
diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index abc9023be4..a6a482021f 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -19,12 +19,9 @@
(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 download) #:select (download-to-store))
#:use-module (guix hash)
#:use-module (guix i18n)
#:use-module (guix import json)
@@ -32,11 +29,10 @@ (define-module (guix import composer)
#: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-11)
#:use-module (srfi srfi-26)
#:export (composer->guix-package
%composer-updater
@@ -143,55 +139,34 @@ (define (make-php-sexp 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)
+ `(tag-or-commit . ,(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 46b6dc98a2..a755387242 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -208,11 +209,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."
@@ -232,29 +228,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)))
- (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
@@ -265,9 +247,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 dd9298808d..6e2ce2ed00 100644
--- a/guix/import/go.scm
+++ b/guix/import/go.scm
@@ -8,6 +8,7 @@
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -514,49 +515,24 @@ (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)))))
+;; 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))))
- ;; 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)))
-
-(define (vcs->origin vcs-type vcs-repo-url version)
+(define* (vcs->origin vcs-type vcs-repo-url version
+ #:key (transform-version #f))
"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)))
- (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)
+ #:ref->commit transform-version))
((hg)
`(origin
(method hg-fetch)
@@ -649,7 +625,8 @@ (define* (go-module->guix-package module-path #:key
(name ,guix-name)
(version ,(strip-v-prefix version*))
(source
- ,(vcs->origin vcs-type vcs-repo-url version*))
+ ,(vcs->origin vcs-type vcs-repo-url version*
+ #:transform-version transform-version))
(build-system go-build-system)
(arguments
(list ,@(if (version>? min-go-version (package-version (go-package)))
diff --git a/guix/import/minetest.scm b/guix/import/minetest.scm
index 5ea6e023ce..65ef242431 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@telenet.be>
;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -32,7 +33,6 @@ (define-module (guix import minetest)
#: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)
@@ -277,12 +277,6 @@ (define url (string-append (%contentdb-api) "packages/?type=" type
\f
-;; 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)
@@ -293,24 +287,8 @@ (define (make-minetest-sexp author/name version repository commit
(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))))
+ ,(git->origin
+ repository `(tag-or-commit . ,commit) #:ref->commit #t))
(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 b7756fcc40..8512e0d64c 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -13,6 +13,7 @@
;;; Copyright © 2022 Alice Brenon <alice.brenon@ens-lyon.fr>
;;; Copyright © 2022 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2022 Philip McGrath <philip@philipmcgrath.com>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -39,6 +40,8 @@ (define-module (guix import utils)
#:use-module (guix packages)
#: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)
@@ -63,6 +66,7 @@ (define-module (guix import utils)
url-fetch
guix-hash-url
+ git->origin
package-names->package-inputs
maybe-inputs
@@ -161,6 +165,41 @@ (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 #:key (ref->commit #f))
+ "Returns a generated `origin' block of a package depending on the git source
+control system, and the directory in the store where the package has been
+downloaded, in case further processing is necessary. REPO-URL or REF can be
+null. REF->COMMIT can be a function or #t, in which case the commit matching
+ref is used. If REF->COMMIT is not used, the value inside REF is used."
+ (let* ((version (and (pair? ref) (cdr ref)))
+ (directory commit
+ (if version
+ (with-store store
+ (latest-repository-commit store repo-url
+ #:ref (if version ref '())))
+ (values #f #f)))
+ (vcommit (match ref->commit
+ (#t commit)
+ (#f version)
+ ((? procedure?) (ref->commit version))
+ (_ #f))))
+ (values
+ `(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
+ ,(and version ; Version or commit is not always available.
+ (bytevector->nix-base32-string
+ (file-hash* directory
+ ;; 'git-fetch' already filtered out '.git'.
+ #:select? (const #true)
+ #:recursive? #true))))))
+ 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 f925c485c1..8402f3e978 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 <francois.joulaud@radiofrance.com>
;;; Copyright © 2021 Sarah Morgensen <iskarian@mgsn.dev>
+;;; Copyright © 2023 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,7 +25,6 @@ (define-module (tests-import-go)
#:use-module (guix base32)
#:use-module (guix build-system go)
#:use-module (guix import go)
- #:use-module (guix base32)
#:use-module ((guix utils) #:select (call-with-temporary-directory))
#:use-module (guix tests)
#:use-module (ice-9 match)
@@ -403,13 +403,26 @@ (define (mock-http-get testcase)
(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)))
+ (mock ((guix import utils) git->origin
+ ;; Mock an empty directory by replacing hash.
+ (lambda* (repo-url ref #:key (ref->commit #f))
+ (let* ((version (if (pair? ref)
+ (cdr ref)
+ #f))
+ (vcommit (match ref->commit
+ (#t commit)
+ (#f version)
+ ((? procedure?) (ref->commit version))
+ (_ #f))))
+ `(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
+ "0sjjj9z1dhilhpc8pq4154czrb79z9cm044jvn75kxcjv6v5l2m5"))))))
(go-module->guix-package* "github.com/go-check/check")))))))
(test-end "go")
diff --git a/tests/minetest.scm b/tests/minetest.scm
index bf1313ee22..94e93c64bf 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@telenet.be>
+;;; Copyright © 2023 Nicolas Graves <ngraves@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)
@@ -419,8 +412,8 @@ (define* (example-package #:key
(uri (git-reference
(url repo)
(commit commit #;"808f9ffbd3106da4c92d2367b118b98196c9e81e")))
- (sha256 #f) ; not important for the following tests
- (file-name (git-file-name name version)))
+ (file-name (git-file-name name version))
+ (sha256 #f)) ; not important for the following tests
source))
(build-system minetest-mod-build-system)
(license #f)
--
2.46.0
^ permalink raw reply related [flat|nested] 7+ messages in thread
* [bug#73833] [PATCH v2 3/5] guix: import: composer: Improve importer.
2024-10-17 22:25 ` [bug#73833] [PATCH v2 0/5] Large improvements to import utils, composer import, and refresh Nicolas Graves via Guix-patches via
2024-10-17 22:25 ` [bug#73833] [PATCH v2 1/5] guix: import: utils: Add function git->origin Nicolas Graves via Guix-patches via
2024-10-17 22:25 ` [bug#73833] [PATCH v2 2/5] tests: go: Add mock-git->origin function Nicolas Graves via Guix-patches via
@ 2024-10-17 22:25 ` Nicolas Graves via Guix-patches via
2024-10-17 22:26 ` [bug#73833] [PATCH v2 4/5] guix: refresh: Keep the version field of each update specification Nicolas Graves via Guix-patches via
2024-10-17 22:26 ` [bug#73833] [PATCH v2 5/5] guix: refresh: Implement basic upstream-source-inputs rich updates Nicolas Graves via Guix-patches via
4 siblings, 0 replies; 7+ messages in thread
From: Nicolas Graves via Guix-patches via @ 2024-10-17 22:25 UTC (permalink / raw)
To: 73833; +Cc: Nicolas Graves
* guix/import/composer.scm
(%composer-base-url): Move from here...
(%packagist-base-url): ...to here.
(requirements->prefixes): Add variable to read and take advantage of
version info in composer package requirements and...
(json->require): ...use it here. Rewrite of the function.
(composer-source): Add a sanitizer for composer-source-url.
(select-version): Add variable to select the most recent availble
version that is above to a given min-version and...
(composer-fetch): ...use it here. Improve the function.
(make-php-sexp, composer->guix-package): Adapt to requirements being
alists now.
(php-package?): Handle the particular phpunit case.
(dependency->input): Add min-version and max-version information. This
is currently limited to the first dependency suggested by
requirements.
(import-release): Fix git urls case. This is better but still a bit
buggy (refreshing can replace the version by a commit).
* tests/composer.scm
(%composer-base-url): Move from here...
(%packagist-base-url): ...to here.
---
guix/import/composer.scm | 151 +++++++++++++++++++++++++++------------
tests/composer.scm | 2 +-
2 files changed, 105 insertions(+), 48 deletions(-)
diff --git a/guix/import/composer.scm b/guix/import/composer.scm
index a6a482021f..d6af50da8c 100644
--- a/guix/import/composer.scm
+++ b/guix/import/composer.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu>
+;;; Copyright © 2023, 2024 Nicolas Graves <ngraves@ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +22,8 @@ (define-module (guix import composer)
#:use-module (json)
#:use-module (guix build-system composer)
#:use-module ((guix diagnostics) #:select (warning))
+ #:use-module ((guix import git) #:select (latest-git-tag-version))
+ #:use-module ((guix git-download) #:select (git-reference))
#:use-module ((guix download) #:select (download-to-store))
#:use-module (guix hash)
#:use-module (guix i18n)
@@ -34,13 +37,14 @@ (define-module (guix import composer)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-71)
#:export (composer->guix-package
%composer-updater
composer-recursive-import
- %composer-base-url))
+ %packagist-base-url))
-(define %composer-base-url
+(define %packagist-base-url
(make-parameter "https://repo.packagist.org"))
(define (fix-version version)
@@ -54,26 +58,40 @@ (define (fix-version version)
(substring version 1))
(else version)))
-(define (latest-version versions)
- (fold (lambda (a b) (if (version>? (fix-version a) (fix-version b)) a b))
- (car versions) versions))
+(define (requirements->prefixes str)
+ (let* ((processed-str (string-replace-substring str " || " "|"))
+ (prefix-strs (string-split processed-str #\|)))
+ (filter-map (match-lambda
+ ;; SemVer: ^ indicates major+minor match, not a whole match.
+ ((? (cut string-prefix? "^" <>) prefix)
+ (let ((pfx (string-drop prefix 1)))
+ (if (eq? 2 (string-count prefix #\.))
+ (string-take pfx (string-rindex pfx #\.))
+ pfx)))
+ ((? (cut string-suffix? ".*" <>) prefix)
+ (string-drop-right prefix 2))
+ (_ #f))
+ prefix-strs)))
(define (json->require dict)
- (if dict
- (let loop ((result '()) (require dict))
- (match require
- (() result)
- ((((? (cut string-contains <> "/") name) . _)
- require ...)
- (loop (cons name result) require))
- ((_ require ...) (loop result require))
- (_ result)))
+ (if (and dict (not (unspecified? dict)))
+ (filter-map
+ (match-lambda
+ (((? (cut string-contains <> "/") name) . requirements)
+ (list name (requirements->prefixes requirements)))
+ (_
+ #f))
+ dict)
'()))
(define-json-mapping <composer-source> make-composer-source composer-source?
json->composer-source
(type composer-source-type)
- (url composer-source-url)
+ (url composer-source-url "url"
+ (lambda (uri)
+ (if (string-suffix? ".git" uri)
+ (string-drop-right uri 4)
+ uri)))
(reference composer-source-reference))
(define-json-mapping <composer-package> make-composer-package composer-package?
@@ -98,31 +116,44 @@ (define (valid-version? v)
(not (string-contains d "beta"))
(not (string-contains d "rc")))))
+(define* (select-version packages #:key (min-version #f))
+ "Select the most recent available version in the PACKAGES list
+that is above or equal to MIN-VERSION. MIN-VERSION can be incomplete
+(e.g. version-major only)."
+ (let* ((points (and min-version (string-count min-version #\.)))
+ (min-prefix (and min-version
+ (match points
+ ((or 0 1) (fix-version min-version))
+ (_ #f)))))
+ (cdr
+ (fold
+ (lambda (new cur-max)
+ (match new
+ (((? valid-version? version) . tail)
+ (let ((valid-version (fix-version version)))
+ (if (and (version>? valid-version (fix-version (car cur-max)))
+ (or (not min-prefix)
+ (version-prefix? min-prefix valid-version)))
+ (cons* version tail)
+ cur-max)))
+ (_ cur-max)))
+ (cons* "0.0.0" #f)
+ packages))))
+
(define* (composer-fetch name #:key (version #f))
"Return a composer-package representation of the Composer metadata for the
package NAME with optional VERSION, or #f on failure."
- (let* ((url (string-append (%composer-base-url) "/p/" name ".json"))
+ (let* ((url (string-append (%packagist-base-url) "/p/" name ".json"))
(packages (and=> (json-fetch url)
(lambda (pkg)
(let ((pkgs (assoc-ref pkg "packages")))
(or (assoc-ref pkgs name) pkg))))))
- (if packages
- (json->composer-package
- (if version
- (assoc-ref packages version)
- (cdr
- (fold
- (lambda (new cur-max)
- (match new
- (((? valid-version? version) . tail)
- (if (version>? (fix-version version)
- (fix-version (car cur-max)))
- (cons* version tail)
- cur-max))
- (_ cur-max)))
- (cons* "0.0.0" #f)
- packages))))
- #f)))
+ (and packages
+ (let ((v (assoc-ref packages version)))
+ (and=>
+ (or (and v (not (unspecified? v)) v)
+ (select-version packages #:min-version version))
+ json->composer-package)))))
(define (php-package-name name)
"Given the NAME of a package on Packagist, return a Guix-compliant name for
@@ -136,9 +167,9 @@ (define (make-php-sexp composer-package)
"Return the `package' s-expression for a PHP package for the given
COMPOSER-PACKAGE."
(let* ((source (composer-package-source composer-package))
- (dependencies (map php-package-name
+ (dependencies (map (compose php-package-name car)
(composer-package-require composer-package)))
- (dev-dependencies (map php-package-name
+ (dev-dependencies (map (compose php-package-name car)
(composer-package-dev-require composer-package))))
`(package
(name ,(composer-package-name composer-package))
@@ -176,10 +207,14 @@ (define composer->guix-package
dependencies, or #f and the empty list on failure."
(let ((package (composer-fetch package-name #:version version)))
(if package
- (let* ((dependencies-names (composer-package-require package))
- (dev-dependencies-names (composer-package-dev-require package)))
- (values (make-php-sexp package)
- (append dependencies-names dev-dependencies-names)))
+ (values (make-php-sexp package)
+ (append-map
+ (match-lambda
+ ((head . tail)
+ (cons head (car tail)))
+ (_ #f))
+ (list (composer-package-require package)
+ (composer-package-dev-require package))))
(values #f '()))))))
(define (guix-name->composer-name name)
@@ -213,24 +248,46 @@ (define (php-package? package)
"Return true if PACKAGE is a PHP package from Packagist."
(and
(eq? (package-build-system package) composer-build-system)
- (string-prefix? "php-" (package-name package))))
+ (or (string-prefix? "php-" (package-name package))
+ (string=? "phpunit" (package-name package)))))
(define (dependency->input dependency type)
- (upstream-input
- (name dependency)
- (downstream-name (php-package-name dependency))
- (type type)))
+ (let* ((version (fix-version (caadr dependency)))
+ (points (and version (string-count version #\.)))
+ (max "99"))
+ (upstream-input
+ (name (car dependency))
+ (downstream-name (php-package-name (car dependency)))
+ (type type)
+ (min-version (match points
+ (0 (string-append version ".0.0"))
+ (1 (string-append version ".0"))
+ (2 version)
+ (_ 'any)))
+ (max-version (match points
+ (0 (string-append version "." max "." max))
+ (1 (string-append version "." max))
+ (2 version)
+ (_ 'any))))))
(define* (import-release package #:key (version #f))
"Return an <upstream-source> for VERSION or the latest release of PACKAGE."
(let* ((php-name (guix-package->composer-name package))
- (composer-package (composer-fetch php-name #:version version)))
+ (composer-package (composer-fetch php-name #:version version))
+ (new-version new-version-tag
+ (latest-git-tag-version package #:version version)))
(if composer-package
(upstream-source
(package (composer-package-name composer-package))
(version (composer-package-version composer-package))
- (urls (list (composer-source-url
- (composer-package-source composer-package))))
+ (urls
+ (let ((source (composer-package-source composer-package)))
+ (if (string=? (composer-source-type source) "git")
+ (git-reference
+ (url (composer-source-url source))
+ (commit (or new-version-tag
+ (composer-source-reference source))))
+ (list (composer-source-url source)))))
(inputs (append
(map (cut dependency->input <> 'regular)
(composer-package-require composer-package))
diff --git a/tests/composer.scm b/tests/composer.scm
index 9114fef19e..355ebab67c 100644
--- a/tests/composer.scm
+++ b/tests/composer.scm
@@ -61,7 +61,7 @@ (define test-source
;; Replace network resources with sample data.
(with-http-server `((200 ,test-json)
(200 ,test-source))
- (parameterize ((%composer-base-url (%local-url))
+ (parameterize ((%packagist-base-url (%local-url))
(current-http-proxy (%local-url)))
(match (composer->guix-package "foo/bar")
(`(package
--
2.46.0
^ permalink raw reply related [flat|nested] 7+ messages in thread