From b6bc4c109b807c646e99ec40360e681122d85b2c Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sat, 1 Oct 2022 16:56:19 +0200
Subject: 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 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 39 insertions(+), 1 deletion(-)

(limited to 'guix')

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))
-- 
cgit v1.2.3