02/11: packages: Raise an exception for invalid 'license' values.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit b6bc4c109b807c646e99ec40360e681122d85b2c
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Oct 1 16:56:19 2022 +0200

    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.
---
 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 @@
   #: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))
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 @@
                     (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")))))