Package: guix-patches;
Reported by: Nicolas Graves <ngraves <at> ngraves.fr>
Date: Mon, 24 Mar 2025 07:21:01 UTC
Severity: normal
Tags: patch
View this message in rfc822 format
From: Nicolas Graves <ngraves <at> ngraves.fr> To: 77231 <at> debbugs.gnu.org Cc: jelle.licht <at> fsfe.org, Nicolas Graves <ngraves <at> ngraves.fr> Subject: [bug#77231] [PATCH 5/6] import: npm-binary: Handle vector of licenses. Date: Mon, 24 Mar 2025 08:29:16 +0100
* guix/import/npm-binary.scm (<package-revision>)[license]: Handle the
case where a vector of licenses is used.
* tests/npm-binary.scm (foo-json): Redefine as a procedure with
license keyword.
(test-source-hash): Redefine with direct reference to test-source.
(foo-sexp): Redefine as a procedure with license keyword.
(npm-binary->guix-package test): Use foo-json and foo-sexp.
(npm-binary->guix-package with multiple licenses): Add test.
---
guix/import/npm-binary.scm | 16 +++-
tests/npm-binary.scm | 158 +++++++++++++++++++++----------------
2 files changed, 102 insertions(+), 72 deletions(-)
diff --git a/guix/import/npm-binary.scm b/guix/import/npm-binary.scm
index 60d7c07a8e..01079c2814 100644
--- a/guix/import/npm-binary.scm
+++ b/guix/import/npm-binary.scm
@@ -105,7 +105,17 @@ (define-json-mapping <package-revision> make-package-revision package-revision?
(match (assoc "type" alist)
((_ . (? string? type))
(spdx-string->license type))
- (_ #f)))))
+ (_ #f)))
+ ((? vector? vector)
+ (match (filter-map
+ (match-lambda
+ ((? string? str) (spdx-string->license str))
+ (_ #f))
+ (vector->list vector))
+ ((license rest ...)
+ (cons* license rest))
+ ((license)
+ license)))))
(description package-revision-description ;string
"description" empty-or-string)
(dist package-revision-dist "dist" json->dist)) ;dist
@@ -250,7 +260,9 @@ (define resolve-spec
(home-page ,home-page)
(synopsis ,synopsis)
(description ,description)
- (license ,license))
+ (license ,(if (list? license)
+ `(list ,@license)
+ license)))
(map (match-lambda (($ <package-revision> name version)
(list name (semver->string version))))
resolved-deps))))
diff --git a/tests/npm-binary.scm b/tests/npm-binary.scm
index 0cc2864546..b1c6174020 100755
--- a/tests/npm-binary.scm
+++ b/tests/npm-binary.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2024 Jelle Licht <jlicht <at> fsfe.org>
+;;; Copyright © 2025 Nicolas Graves <ngraves <at> ngraves.fr>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -24,42 +25,35 @@ (define-module (test-npm-binary)
#:use-module (srfi srfi-64)
#:use-module (ice-9 iconv)
#:use-module (ice-9 match)
+ #:use-module (json)
#:export (run-test))
-(define foo-json
- "{
- \"name\": \"foo\",
- \"dist-tags\": {
- \"latest\": \"1.2.3\",
- \"next\": \"2.0.1-beta4\"
- },
- \"description\": \"General purpose utilities to foo your bars\",
- \"homepage\": \"https://github.com/quartz/foo\",
- \"repository\": \"quartz/foo\",
- \"versions\": {
- \"1.2.3\": {
- \"name\": \"foo\",
- \"description\": \"General purpose utilities to foo your bars\",
- \"version\": \"1.2.3\",
- \"author\": \"Jelle Licht <jlicht <at> fsfe.org>\",
- \"devDependencies\": {
- \"node-megabuilder\": \"^0.0.2\"
- },
- \"dependencies\": {
- \"bar\": \"^0.1.0\"
- },
- \"repository\": {
- \"url\": \"quartz/foo\"
- },
- \"homepage\": \"https://github.com/quartz/foo\",
- \"license\": \"MIT\",
- \"dist\": {
- \"tarball\": \"https://registry.npmjs.org/foo/-/foo-1.2.3.tgz\"
- }
- }
- }
-}")
+(define* (foo-json #:key (license "MIT"))
+ "Create a JSON description of an example foo npm package, optionally using a
+different @var{license}."
+ (scm->json-string
+ `((name . "foo")
+ (dist-tags . ((latest . "1.2.3")
+ (next . "2.0.1-beta4")))
+ (description . "General purpose utilities to foo your bars")
+ (homepage . "https://github.com/quartz/foo")
+ (repository . "quartz/foo")
+ (versions
+ . ((1.2.3
+ . ((name . "foo")
+ (description . "General purpose utilities to foo your bars")
+ (version . "1.2.3")
+ (author . "Jelle Licht <jlicht <at> fsfe.org>")
+ (devDependencies . ((node-megabuilder . "^0.0.2")))
+ (dependencies . ((bar . "^0.1.0")))
+ (repository . ((url . "quartz/foo")))
+ (homepage . "https://github.com/quartz/foo")
+ (license . ,license)
+ (dist
+ . ((tarball
+ . "https://registry.npmjs.org/foo/-/foo-1.2.3.tgz"))))))))))
+;; Dependency JSON for the bar package
(define bar-json
"{
\"name\": \"bar\",
@@ -87,61 +81,85 @@ (define bar-json
}
}")
-(define test-source-hash
- "")
-
(define test-source
"Empty file\n")
+(define test-source-hash
+ (bytevector->nix-base32-string
+ (gcrypt-sha256 (string->bytevector test-source "utf-8"))))
+
(define have-guile-semver?
(false-if-exception (resolve-interface '(semver))))
+(define* (foo-sexp #:key (license 'license:expat))
+ `(package
+ (name "node-foo")
+ (version "1.2.3")
+ (source (origin
+ (method url-fetch)
+ (uri "https://registry.npmjs.org/foo/-/foo-1.2.3.tgz")
+ (sha256
+ (base32 "1n0h7zg9zzv4f7yn2gp0mq1v107im7pi6qq4k6q86rixz71ijklh"))))
+ (build-system node-build-system)
+ (arguments
+ (list #:tests? #f
+ #:phases
+ (gexp (modify-phases %standard-phases
+ (delete 'build)
+ (add-after 'patch-dependencies 'delete-dev-dependencies
+ (lambda _
+ (modify-json
+ (delete-dependencies '("node-megabuilder")))))))))
+ (inputs (list node-bar-0.1.2))
+ (home-page "https://github.com/quartz/foo")
+ (synopsis "General purpose utilities to foo your bars")
+ (description "General purpose utilities to foo your bars")
+ (license ,license)))
+
(test-begin "npm")
(unless have-guile-semver? (test-skip 1))
-(test-assert "npm-binary->guix-package"
+(test-assert "npm-binary->guix-package base case"
(mock ((guix http-client) http-fetch
(lambda* (url #:rest _)
(match url
("https://registry.npmjs.org/foo"
- (values (open-input-string foo-json)
- (string-length foo-json)))
+ (let ((json-foo (foo-json)))
+ (values (open-input-string json-foo)
+ (string-length json-foo))))
("https://registry.npmjs.org/bar"
(values (open-input-string bar-json)
(string-length bar-json)))
("https://registry.npmjs.org/foo/-/foo-1.2.3.tgz"
- (set! test-source-hash
- (bytevector->nix-base32-string
- (gcrypt-sha256 (string->bytevector test-source "utf-8"))))
(values (open-input-string test-source)
(string-length test-source))))))
- (match (npm-binary->guix-package "foo")
- (`(package
- (name "node-foo")
- (version "1.2.3")
- (source (origin
- (method url-fetch)
- (uri "https://registry.npmjs.org/foo/-/foo-1.2.3.tgz")
- (sha256
- (base32
- ,test-source-hash))))
- (build-system node-build-system)
- (arguments
- (list #:tests? #f
- #:phases
- (gexp (modify-phases %standard-phases
- (delete 'build)
- (add-after 'patch-dependencies 'delete-dev-dependencies
- (lambda _
- (modify-json
- (delete-dependencies '("node-megabuilder")))))))))
- (inputs (list node-bar-0.1.2))
- (home-page "https://github.com/quartz/foo")
- (synopsis "General purpose utilities to foo your bars")
- (description "General purpose utilities to foo your bars")
- (license license:expat))
- #t)
- (x
- (pk 'fail x #f)))))
+ (let ((sexp-foo (foo-sexp)))
+ (match (npm-binary->guix-package "foo")
+ (sexp-foo
+ #t)
+ (x
+ (pk 'fail x #f))))))
+
+(test-assert "npm-binary->guix-package with multiple licenses"
+ (mock ((guix http-client) http-fetch
+ (lambda* (url #:rest _)
+ (match url
+ ("https://registry.npmjs.org/foo"
+ (let ((json-foo (foo-json #:license #("MIT" "Apache2.0"))))
+ (values (open-input-string json-foo)
+ (string-length json-foo))))
+ ("https://registry.npmjs.org/bar"
+ (values (open-input-string bar-json)
+ (string-length bar-json)))
+ ("https://registry.npmjs.org/foo/-/foo-1.2.3.tgz"
+ (values (open-input-string test-source)
+ (string-length test-source))))))
+ (let ((sexp-foo (foo-sexp
+ #:license '(list license:expat license:asl2.0))))
+ (match (npm-binary->guix-package "foo")
+ (sexp-foo
+ #t)
+ (x
+ (pk 'fail x #f))))))
(test-end "npm")
--
2.48.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.