From: "Ludovic Courtès" <ludo@gnu.org>
To: 58231@debbugs.gnu.org
Cc: "Ludovic Courtès" <ludo@gnu.org>
Subject: [bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values.
Date: Sat, 1 Oct 2022 18:20:58 +0200 [thread overview]
Message-ID: <20221001162058.8214-2-ludo@gnu.org> (raw)
In-Reply-To: <20221001162058.8214-1-ludo@gnu.org>
This is written in such a way that the type check turns into a no-op at
macro-expansion time for trivial cases:
> ,optimize (validate-license gpl3+)
$18 = gpl3+
> ,optimize (validate-license (list gpl3+ gpl2+))
$19 = (list gpl3+ gpl2+)
* guix/packages.scm (valid-license-value?, validate-license): New
macros.
(<package>)[license]: Add 'sanitize' option.
(&package-license-error): New error condition type.
* tests/packages.scm ("license type checking"): New test.
---
guix/packages.scm | 40 +++++++++++++++++++++++++++++++++++++++-
tests/packages.scm | 7 +++++++
2 files changed, 46 insertions(+), 1 deletion(-)
diff --git a/guix/packages.scm b/guix/packages.scm
index 94e464cd01..704b4ee710 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -41,6 +41,9 @@ (define-module (guix packages)
#:use-module (guix search-paths)
#:use-module (guix sets)
#:use-module (guix deprecation)
+ #:use-module ((guix diagnostics)
+ #:select (formatted-message define-with-syntax-properties))
+ #:autoload (guix licenses) (license?)
#:use-module (guix i18n)
#:use-module (ice-9 match)
#:use-module (ice-9 vlist)
@@ -159,6 +162,8 @@ (define-module (guix packages)
&package-error
package-error?
package-error-package
+ package-license-error?
+ package-error-invalid-license
&package-input-error
package-input-error?
package-error-invalid-input
@@ -533,6 +538,34 @@ (define ensure-thread-safe-texinfo-parser!
((_ obj)
#'obj)))))
+(define-syntax valid-license-value?
+ (syntax-rules (list package-license)
+ "Return #t if the given value is a valid license field, #f otherwise."
+ ;; Arrange so that the answer can be given at macro-expansion time in the
+ ;; most common cases.
+ ((_ (list x ...))
+ (and (license? x) ...))
+ ((_ (package-license _))
+ #t)
+ ((_ obj)
+ (or (license? obj)
+ ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>.
+ (eq? #f obj) ;#f is considered valid
+ (let ((x obj))
+ (and (pair? x) (every license? x)))))))
+
+(define-with-syntax-properties (validate-license (value properties))
+ (unless (valid-license-value? value)
+ (raise
+ (make-compound-condition
+ (condition
+ (&error-location
+ (location (source-properties->location properties))))
+ (condition
+ (&package-license-error (package #f) (license value)))
+ (formatted-message (G_ "~s: invalid package license~%") value))))
+ value)
+
;; A package.
(define-record-type* <package>
package make-package
@@ -574,7 +607,8 @@ (define-record-type* <package>
(sanitize validate-texinfo)) ; one-line description
(description package-description
(sanitize validate-texinfo)) ; one or two paragraphs
- (license package-license) ; (list of) <license>
+ (license package-license ; (list of) <license>
+ (sanitize validate-license))
(home-page package-home-page)
(supported-systems package-supported-systems ; list of strings
(default %supported-systems))
@@ -737,6 +771,10 @@ (define-condition-type &package-error &error
package-error?
(package package-error-package))
+(define-condition-type &package-license-error &package-error
+ package-license-error?
+ (license package-error-invalid-license))
+
(define-condition-type &package-input-error &package-error
package-input-error?
(input package-error-invalid-input))
diff --git a/tests/packages.scm b/tests/packages.scm
index 6cbc34ba0b..dc03b13417 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -94,6 +94,13 @@ (define %store
(write
(dummy-package "foo" (location #f)))))))
+(test-equal "license type checking"
+ 'bad-license
+ (guard (c ((package-license-error? c)
+ (package-error-invalid-license c)))
+ (dummy-package "foo"
+ (license 'bad-license))))
+
(test-assert "hidden-package"
(and (hidden-package? (hidden-package (dummy-package "foo")))
(not (hidden-package? (dummy-package "foo")))))
--
2.37.3
next prev parent reply other threads:[~2022-10-01 16:22 UTC|newest]
Thread overview: 10+ messages / expand[flat|nested] mbox.gz Atom feed top
2022-10-01 16:19 [bug#58231] [PATCH 0/2] Checking the 'license' field of packages Ludovic Courtès
2022-10-01 16:20 ` [bug#58231] [PATCH 1/2] licenses: Let 'license?' expand to #t in trivial cases Ludovic Courtès
2022-10-01 16:20 ` Ludovic Courtès [this message]
2022-10-10 10:22 ` [bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values zimoun
2022-10-10 14:52 ` Ludovic Courtès
2022-10-15 22:12 ` Philip McGrath
2022-10-08 11:44 ` [bug#58231] [PATCH 0/2] Checking the 'license' field of packages pelzflorian (Florian Pelz)
2022-10-10 7:36 ` Ludovic Courtès
2022-10-10 7:51 ` Ludovic Courtès
2022-10-10 9:20 ` Heads-up: Run “make clean-go && make” Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20221001162058.8214-2-ludo@gnu.org \
--to=ludo@gnu.org \
--cc=58231@debbugs.gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this external index
https://git.savannah.gnu.org/cgit/guix.git
This is an external index of several public inboxes,
see mirroring instructions on how to clone and mirror
all data and code used by this external index.