From patchwork Sat Oct 1 16:20:58 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 43098 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id BEFB027BBEA; Sat, 1 Oct 2022 17:22:17 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id EDA8B27BBE9 for ; Sat, 1 Oct 2022 17:22:16 +0100 (BST) Received: from localhost ([::1]:35400 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oefFo-0005lO-0U for patchwork@mira.cbaines.net; Sat, 01 Oct 2022 12:22:16 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:33294) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oefFc-0005kw-Ae for guix-patches@gnu.org; Sat, 01 Oct 2022 12:22:05 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:46556) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oefFa-00060i-UQ for guix-patches@gnu.org; Sat, 01 Oct 2022 12:22:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1oefFa-0003oG-QS for guix-patches@gnu.org; Sat, 01 Oct 2022 12:22:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#58231] [PATCH 2/2] packages: Raise an exception for invalid 'license' values. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 01 Oct 2022 16:22:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 58231 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 58231@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 58231-submit@debbugs.gnu.org id=B58231.166464127514582 (code B ref 58231); Sat, 01 Oct 2022 16:22:02 +0000 Received: (at 58231) by debbugs.gnu.org; 1 Oct 2022 16:21:15 +0000 Received: from localhost ([127.0.0.1]:45633 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oefEp-0003n7-FV for submit@debbugs.gnu.org; Sat, 01 Oct 2022 12:21:15 -0400 Received: from eggs.gnu.org ([209.51.188.92]:60684) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oefEn-0003mj-NT for 58231@debbugs.gnu.org; Sat, 01 Oct 2022 12:21:14 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:46414) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oefEi-0005wq-80; Sat, 01 Oct 2022 12:21:08 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:References:In-Reply-To:Date:Subject:To: From; bh=I2nmzHNK9HXGeBXQ3+ODQXEZ49PlbKednOcnPUpGNtE=; b=LxxvMVSWe+S3S1lZXQir 6hsbyK+7ssC2FyPEtJhldfkryF12P9XJY3duGZ2n8/kbF2BieJSwh1ATYM46fu+lBLUJrYlFcn0Nt 9sQ7pJJIEW7rmB3ZR2jKnp2iLh/CSQybAHW8Zr8u+WioauYS6iTk6uBDFG2peI30sXuMUtqgw8VmH 4gHianNbTibfAk1Z8tB/5byji09xhAjduPfWCfGXEzOBTyougS0I0DziQinUsUAwywBPcES7TNJnJ k1hDvGriQ+vTSDPGeSW91vRmOyB6fjCNn+1GMTgDEvu815sTgNVR4sex6pInJ2j47MX5AVfhZ9usI jWelwbNv1P7ZUA==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201]:58544 helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oefEh-00088x-QX; Sat, 01 Oct 2022 12:21:08 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 1 Oct 2022 18:20:58 +0200 Message-Id: <20221001162058.8214-2-ludo@gnu.org> X-Mailer: git-send-email 2.37.3 In-Reply-To: <20221001162058.8214-1-ludo@gnu.org> References: <20221001162058.8214-1-ludo@gnu.org> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches 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. ()[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 . + (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 make-package @@ -574,7 +607,8 @@ (define-record-type* (sanitize validate-texinfo)) ; one-line description (description package-description (sanitize validate-texinfo)) ; one or two paragraphs - (license package-license) ; (list of) + (license package-license ; (list of) + (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")))))