From patchwork Fri Oct 22 12:45:19 2021 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: 34009 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 00ED327BBE3; Fri, 22 Oct 2021 13:47:43 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.9 required=5.0 tests=BAYES_00,MAILING_LIST_MULTI, RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id BEFD327BBE1 for ; Fri, 22 Oct 2021 13:47:42 +0100 (BST) Received: from localhost ([::1]:58248 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mdtxV-0003g2-Rv for patchwork@mira.cbaines.net; Fri, 22 Oct 2021 08:47:41 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:46548) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1mdtws-0003La-MJ for guix-patches@gnu.org; Fri, 22 Oct 2021 08:47:02 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:48113) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1mdtws-0000Zp-DV for guix-patches@gnu.org; Fri, 22 Oct 2021 08:47:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1mdtws-0003FF-AJ for guix-patches@gnu.org; Fri, 22 Oct 2021 08:47:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#51332] [PATCH 2/2] packages: Optionally validate Texinfo markup at expansion time. Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 22 Oct 2021 12:47:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 51332 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 51332@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 51332-submit@debbugs.gnu.org id=B51332.163490677612394 (code B ref 51332); Fri, 22 Oct 2021 12:47:02 +0000 Received: (at 51332) by debbugs.gnu.org; 22 Oct 2021 12:46:16 +0000 Received: from localhost ([127.0.0.1]:59658 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mdtw8-0003Dk-BT for submit@debbugs.gnu.org; Fri, 22 Oct 2021 08:46:16 -0400 Received: from eggs.gnu.org ([209.51.188.92]:48982) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1mdtvs-0003Cc-Ow for 51332@debbugs.gnu.org; Fri, 22 Oct 2021 08:46:01 -0400 Received: from fencepost.gnu.org ([2001:470:142:3::e]:42924) by eggs.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1mdtvm-0007VH-6t; Fri, 22 Oct 2021 08:45:54 -0400 Received: from [193.50.110.110] (port=53680 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 1mdtvl-0002o8-8v; Fri, 22 Oct 2021 08:45:53 -0400 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Fri, 22 Oct 2021 14:45:19 +0200 Message-Id: <20211022124519.28473-2-ludo@gnu.org> X-Mailer: git-send-email 2.33.0 In-Reply-To: <20211022124519.28473-1-ludo@gnu.org> References: <20211022124519.28473-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 * guix/packages.scm (validate-texinfo): New macro. ()[synopsis, description]: Add 'sanitize' property. --- guix/packages.scm | 52 ++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 49 insertions(+), 3 deletions(-) diff --git a/guix/packages.scm b/guix/packages.scm index e5a9d08bce..394f6aa39e 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -49,6 +49,7 @@ (define-module (guix packages) #:use-module (srfi srfi-35) #:use-module (rnrs bytevectors) #:use-module (web uri) + #:autoload (texinfo) (texi-fragment->stexi) #:re-export (%current-system %current-target-system search-path-specification) ;for convenience @@ -437,6 +438,49 @@ (define location (lambda (s) #,location))) body ...)))))) +(define-syntax validate-texinfo + (let ((validate? (getenv "GUIX_UNINSTALLED"))) + (define ensure-thread-safe-texinfo-parser! + ;; Work around for Guile <= 3.0.7. + (let ((patched? (or (> (string->number (major-version)) 3) + (> (string->number (minor-version)) 0) + (> (string->number (micro-version)) 7))) + (next-token-of/thread-safe + (lambda (pred port) + (let loop ((chars '())) + (match (read-char port) + ((? eof-object?) + (list->string (reverse! chars))) + (chr + (let ((chr* (pred chr))) + (if chr* + (loop (cons chr* chars)) + (begin + (unread-char chr port) + (list->string (reverse! chars))))))))))) + (lambda () + (unless patched? + (set! (@@ (texinfo) next-token-of) next-token-of/thread-safe) + (set! patched? #t))))) + + (lambda (s) + "Raise a syntax error when passed a literal string that is not valid +Texinfo. Otherwise, return the string." + (syntax-case s () + ((_ str) + (string? (syntax->datum #'str)) + (if validate? + (catch 'parser-error + (lambda () + (ensure-thread-safe-texinfo-parser!) + (texi-fragment->stexi (syntax->datum #'str)) + #'str) + (lambda _ + (syntax-violation 'package "invalid Texinfo markup" #'str))) + #'str)) + ((_ obj) + #'obj))))) + ;; A package. (define-record-type* package make-package @@ -471,9 +515,11 @@ (define-record-type* (replacement package-replacement ; package | #f (default #f) (thunked) (innate)) - (synopsis package-synopsis) ; one-line description - (description package-description) ; one or two paragraphs - (license package-license) ; instance or list + (synopsis package-synopsis + (sanitize validate-texinfo)) ; one-line description + (description package-description + (sanitize validate-texinfo)) ; one or two paragraphs + (license package-license) ; instance or list (home-page package-home-page) (supported-systems package-supported-systems ; list of strings (default %supported-systems))