summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2022-10-01 16:56:19 +0200
committerLudovic Courtès <ludo@gnu.org>2022-10-10 11:16:07 +0200
commitb6bc4c109b807c646e99ec40360e681122d85b2c (patch)
tree02afbe98458dd5c23e057dbacb433d77d8072457 /guix
parent79b390a207adc70a1169c80e52c590d8b358f488 (diff)
packages: Raise an exception for invalid 'license' values.
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.
Diffstat (limited to 'guix')
-rw-r--r--guix/packages.scm40
1 files changed, 39 insertions, 1 deletions
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 @@
#: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 @@
&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 @@ Texinfo. Otherwise, return the string."
((_ 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 @@ Texinfo. Otherwise, return the string."
(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 @@ exist, return #f instead."
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))