From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp11.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms9.migadu.com with LMTPS id 6Er1LNNEHmSeOwEASxT56A (envelope-from ) for ; Sat, 25 Mar 2023 01:48:19 +0100 Received: from aspmx1.migadu.com ([2001:41d0:2:4a6f::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp11.migadu.com with LMTPS id mBzxLNNEHmR6hAEA9RJhRA (envelope-from ) for ; Sat, 25 Mar 2023 01:48:19 +0100 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by aspmx1.migadu.com (Postfix) with ESMTPS id 0F52228AAD for ; Sat, 25 Mar 2023 01:48:19 +0100 (CET) Authentication-Results: aspmx1.migadu.com; dkim=none; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=none ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1679705299; h=from:from:sender:sender:reply-to:subject:subject:date:date: message-id:message-id:to:to:cc:cc:mime-version:mime-version: content-type:content-type: content-transfer-encoding:content-transfer-encoding:resent-cc: resent-from:resent-sender:resent-message-id:in-reply-to:in-reply-to: references:references:list-id:list-help:list-unsubscribe: list-subscribe:list-post; bh=nIU9PuyMyyRGqGapQqhaOnqAJOqTHbVbky7OTXlrdKU=; b=bMgAKHj4W3UER5fJ0RowBR8Hf6Nu09l6xT/HJuCl4HSWHsuPnpVaCx74GspTGzryu0ZzIP WkVo12yYZ4yETY8gCxWyPYKzGN0C2yjMMUm8/zEv98xhQzaw0Rh6QYbyj02r6muyYOpr1x PBxWY60iu4ijpDU83LyjjoEzP7SyNx+v/i5SX9cJf0A/paYmGSDfZ8Sm0C2kQzxCN5Bp/5 S+wUOdsdA5X68gz+H/cKtagiAqc3IYPfn3bV27980MlxwbMn8PSG3A+DziIU5J4nRNGbke +hBvEUpSxZQuz076DRGbCa51uaZf1ENGD1Rur4OYhPXWMeDlL9u2eBJb2DJwyQ== ARC-Seal: i=1; s=key1; d=yhetil.org; t=1679705299; a=rsa-sha256; cv=none; b=oSg4oEiAPu/po5HW7+192VN3qg3QC9CjNG3IojnJrQTbEfCPb2XSq4arn2v8gGIOqQ8YFu dETzk2aQaRHsTdDm/HytkKz+g+RtSCEaIz7cqVmP9RS79ZxRUSsgzHIyy8ORte/ys4O0bN g0h4vWgRPmrgYZQxksi4Y+mKfPj7PJ1lIHJGMLAWeghAZTDjgz6cq5WO/da5Zu287I8Fft LvzTphIG3DpQHgwqB7NyZ8dEbPb+vBjTSuGa9z/ja37I6g9dP5hnMHfWcGFTZO4PirsxEk fJlPYxIjb67p90AeJaujOMu89JuF0T2kMHeb37+34xLAfVXF2W8TmgDjJ7PCdQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=none; spf=pass (aspmx1.migadu.com: domain of "guix-patches-bounces+larch=yhetil.org@gnu.org" designates 209.51.188.17 as permitted sender) smtp.mailfrom="guix-patches-bounces+larch=yhetil.org@gnu.org"; dmarc=none Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1pfs4n-0000JE-OY; Fri, 24 Mar 2023 20:48:09 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1pfs4k-0000Fm-8H for guix-patches@gnu.org; Fri, 24 Mar 2023 20:48:06 -0400 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1pfs4h-00068S-GI for guix-patches@gnu.org; Fri, 24 Mar 2023 20:48:03 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1pfs4g-00088U-Bi for guix-patches@gnu.org; Fri, 24 Mar 2023 20:48:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#62298] [PATCH v3 1/5] services: configuration: Add user-defined sanitizer support. References: In-Reply-To: Resent-From: Bruno Victal Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 25 Mar 2023 00:48:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 62298 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 62298@debbugs.gnu.org Cc: ludo@gnu.org, Bruno Victal , liliana.prikler@gmail.com, maxim.cournoyer@gmail.com Received: via spool by 62298-submit@debbugs.gnu.org id=B62298.167970522931060 (code B ref 62298); Sat, 25 Mar 2023 00:48:02 +0000 Received: (at 62298) by debbugs.gnu.org; 25 Mar 2023 00:47:09 +0000 Received: from localhost ([127.0.0.1]:41758 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pfs3o-00084s-5H for submit@debbugs.gnu.org; Fri, 24 Mar 2023 20:47:09 -0400 Received: from smtpmciv4.myservices.hosting ([185.26.107.240]:51052) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1pfs3l-00084j-Bs for 62298@debbugs.gnu.org; Fri, 24 Mar 2023 20:47:06 -0400 Received: from mail1.netim.hosting (unknown [185.26.106.173]) by smtpmciv4.myservices.hosting (Postfix) with ESMTP id 909CD20820; Sat, 25 Mar 2023 01:47:03 +0100 (CET) Received: from localhost (localhost [127.0.0.1]) by mail1.netim.hosting (Postfix) with ESMTP id 316FF8009C; Sat, 25 Mar 2023 01:47:03 +0100 (CET) X-Virus-Scanned: Debian amavisd-new at mail1.netim.hosting Received: from mail1.netim.hosting ([127.0.0.1]) by localhost (mail1-2.netim.hosting [127.0.0.1]) (amavisd-new, port 10026) with ESMTP id 3O8FTV5fqF86; Sat, 25 Mar 2023 01:47:01 +0100 (CET) Received: from guix-nuc.home.arpa (bl9-119-177.dsl.telepac.pt [85.242.119.177]) (Authenticated sender: lumen@makinata.eu) by mail1.netim.hosting (Postfix) with ESMTPSA id 8143C80097; Sat, 25 Mar 2023 01:47:01 +0100 (CET) From: Bruno Victal Date: Sat, 25 Mar 2023 00:46:44 +0000 Message-Id: X-Mailer: git-send-email 2.39.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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: X-Migadu-Queue-Id: 0F52228AAD X-Spam-Score: -0.73 X-Migadu-Spam-Score: -0.73 X-Migadu-Scanner: scn0.migadu.com List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+larch=yhetil.org@gnu.org Sender: guix-patches-bounces+larch=yhetil.org@gnu.org X-Migadu-Country: US X-Migadu-Flow: FLOW_IN X-TUID: BtfKwWXsswvh This changes the 'custom-serializer' field into a generic 'extra-args' field that can be extended to support new literals. With this mechanism, the literals 'sanitizer' allow for user-defined sanitizer procedures while the 'serializer' literal is used for custom serializer procedures. The 'empty-serializer' was also added as a 'literal' and can be used just like it was previously. With the repurposing of 'custom-serializer' into 'extra-args', to prevent intolerable confusion, the custom serializer procedures should be specified using the new 'literals' approach, with the previous “style” being considered deprecated. * gnu/services/configuration.scm (define-configuration-helper): Rename 'custom-serializer' to 'extra-args'. Add support for literals 'sanitizer', 'serializer' and 'empty-serializer'. Rename procedure 'field-sanitizer' to 'default-field-sanitizer' to avoid syntax clash. Only define default field sanitizers if user-defined ones are absent. (normalize-extra-args): New procedure. ()[sanitizer]: New field. * doc/guix.texi (Complex Configurations): Document the newly added literals. * tests/services/configuration.scm: Add tests for the new literals. --- doc/guix.texi | 29 ++++- gnu/services/configuration.scm | 90 +++++++++++---- tests/services/configuration.scm | 183 ++++++++++++++++++++++++++++++- 3 files changed, 276 insertions(+), 26 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 3e335306f1..8604b95f94 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -41216,7 +41216,7 @@ Complex Configurations (@var{field-name} (@var{type} @var{default-value}) @var{documentation} - @var{serializer}) + (serializer @var{serializer})) (@var{field-name} (@var{type}) @@ -41225,7 +41225,18 @@ Complex Configurations (@var{field-name} (@var{type}) @var{documentation} - @var{serializer}) + (serializer @var{serializer})) + +(@var{field-name} + (@var{type}) + @var{documentation} + (sanitizer @var{sanitizer}) + +(@var{field-name} + (@var{type}) + @var{documentation} + (sanitizer @var{sanitizer}) + (serializer @var{serializer})) @end example @var{field-name} is an identifier that denotes the name of the field in @@ -41248,6 +41259,20 @@ Complex Configurations @var{documentation} is a string formatted with Texinfo syntax which should provide a description of what setting this field does. +@var{sanitizer} is a procedure which takes one argument, +a user-supplied value, and returns a ``sanitized'' value for the field. +If no sanitizer is specified, a default sanitizer is used, which raises +an error if the value is not of type @var{type}. + +An example of a sanitizer for a field that accepts both strings and +symbols looks like this: +@lisp +(define (sanitize-foo value) + (cond ((string? value) value) + ((symbol? value) (symbol->string value)) + (else (error "bad value")))) +@end lisp + @var{serializer} is the name of a procedure which takes two arguments, the first is the name of the field, and the second is the value corresponding to the field. The procedure should return a string or diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 174c2f20d2..4f3c6e2331 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2021, 2022 Maxim Cournoyer ;;; Copyright © 2021 Andrew Tropin ;;; Copyright © 2022 Maxime Devos +;;; Copyright © 2023 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -28,7 +29,8 @@ (define-module (gnu services configuration) #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) #:use-module ((guix diagnostics) - #:select (formatted-message location-file &error-location)) + #:select (formatted-message location-file &error-location + warning)) #:use-module ((guix modules) #:select (file-name->module-name)) #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) @@ -37,6 +39,7 @@ (define-module (gnu services configuration) #:use-module (ice-9 format) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (configuration-field @@ -44,6 +47,7 @@ (define-module (gnu services configuration) configuration-field-type configuration-missing-field configuration-field-error + configuration-field-sanitizer configuration-field-serializer configuration-field-getter configuration-field-default-value-thunk @@ -116,6 +120,7 @@ (define-record-type* (type configuration-field-type) (getter configuration-field-getter) (predicate configuration-field-predicate) + (sanitizer configuration-field-sanitizer) (serializer configuration-field-serializer) (default-value-thunk configuration-field-default-value-thunk) (documentation configuration-field-documentation)) @@ -181,11 +186,44 @@ (define (normalize-field-type+def s) (values #'(field-type %unset-value))))) (define (define-configuration-helper serialize? serializer-prefix syn) + + (define (normalize-extra-args s) + "Extract and normalize arguments following @var{doc}." + (let loop ((s s) + (sanitizer* %unset-value) + (serializer* %unset-value)) + (syntax-case s (sanitizer serializer empty-serializer) + (((sanitizer proc) tail ...) + (if (maybe-value-set? sanitizer*) + (syntax-violation 'sanitizer "duplicate entry" + #'proc) + (loop #'(tail ...) #'proc serializer*))) + (((serializer proc) tail ...) + (if (maybe-value-set? serializer*) + (syntax-violation 'serializer "duplicate or conflicting entry" + #'proc) + (loop #'(tail ...) sanitizer* #'proc))) + ((empty-serializer tail ...) + (if (maybe-value-set? serializer*) + (syntax-violation 'empty-serializer + "duplicate or conflicting entry" #f) + (loop #'(tail ...) sanitizer* #'empty-serializer))) + (() ; stop condition + (values (list sanitizer* serializer*))) + ((proc) ; TODO: deprecated, to be removed + (null? (filter-map maybe-value-set? (list sanitizer* serializer*))) + (begin + (warning #f (G_ "specifying serializers after documentation is \ +deprecated, use (serializer ~a) instead~%") (syntax->datum #'proc)) + (values (list %unset-value #'proc))))))) + (syntax-case syn () - ((_ stem (field field-type+def doc custom-serializer ...) ...) + ((_ stem (field field-type+def doc extra-args ...) ...) (with-syntax ((((field-type def) ...) - (map normalize-field-type+def #'(field-type+def ...)))) + (map normalize-field-type+def #'(field-type+def ...))) + (((sanitizer* serializer*) ...) + (map normalize-extra-args #'((extra-args ...) ...)))) (with-syntax (((field-getter ...) (map (lambda (field) @@ -200,21 +238,18 @@ (define (define-configuration-helper serialize? serializer-prefix syn) ((field-type default-value) default-value)) #'((field-type def) ...))) + ((field-sanitizer ...) + (map maybe-value #'(sanitizer* ...))) ((field-serializer ...) - (map (lambda (type custom-serializer) + (map (lambda (type proc) (and serialize? - (match custom-serializer - ((serializer) - serializer) - (() - (if serializer-prefix - (id #'stem - serializer-prefix - #'serialize- type) - (id #'stem #'serialize- type)))))) + (or (maybe-value proc) + (if serializer-prefix + (id #'stem serializer-prefix #'serialize- type) + (id #'stem #'serialize- type))))) #'(field-type ...) - #'((custom-serializer ...) ...)))) - (define (field-sanitizer name pred) + #'(serializer* ...)))) + (define (default-field-sanitizer name pred) ;; Define a macro for use as a record field sanitizer, where NAME ;; is the name of the field and PRED is the predicate that tells ;; whether a value is valid for this field. @@ -235,21 +270,29 @@ (define (define-configuration-helper serialize? serializer-prefix syn) #`(begin ;; Define field validation macros. - #,@(map field-sanitizer - #'(field ...) - #'(field-predicate ...)) + #,@(filter-map (lambda (name pred sanitizer) + (if sanitizer + #f + (default-field-sanitizer name pred))) + #'(field ...) + #'(field-predicate ...) + #'(field-sanitizer ...)) (define-record-type* #,(id #'stem #'< #'stem #'>) stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) - #,@(map (lambda (name getter def) - #`(#,name #,getter (default #,def) + #,@(map (lambda (name getter def sanitizer) + #`(#,name #,getter + (default #,def) (sanitize - #,(id #'stem #'validate- #'stem #'- name)))) + #,(or sanitizer + (id #'stem + #'validate- #'stem #'- name))))) #'(field ...) #'(field-getter ...) - #'(field-default ...)) + #'(field-default ...) + #'(field-sanitizer ...)) (%location #,(id #'stem #'stem #'-source-location) (default (and=> (current-source-location) source-properties->location)) @@ -261,6 +304,9 @@ (define (define-configuration-helper serialize? serializer-prefix syn) (type 'field-type) (getter field-getter) (predicate field-predicate) + (sanitizer + (or field-sanitizer + (id #'stem #'validate- #'stem #'- #'field))) (serializer field-serializer) (default-value-thunk (lambda () diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 4f8a74dc8a..0392cce927 100644 --- a/tests/services/configuration.scm +++ b/tests/services/configuration.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2021, 2022 Maxim Cournoyer ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2022 Ludovic Courtès +;;; Copyright © 2023 Bruno Victal ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +23,7 @@ (define-module (tests services configuration) #:use-module (gnu services configuration) #:use-module (guix diagnostics) #:use-module (guix gexp) + #:autoload (guix i18n) (G_) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) @@ -46,14 +48,14 @@ (define-configuration port-configuration (port-configuration-port (port-configuration))) (test-equal "wrong type for a field" - '("configuration.scm" 57 11) ;error location + '("configuration.scm" 59 11) ;error location (guard (c ((configuration-error? c) (let ((loc (error-location c))) (list (basename (location-file loc)) (location-line loc) (location-column loc))))) (port-configuration - ;; This is line 56; the test relies on line/column numbers! + ;; This is line 58; the test relies on line/column numbers! (port "This is not a number!")))) (define-configuration port-configuration-cs @@ -109,6 +111,183 @@ (define-configuration configuration-with-prefix (let ((config (configuration-with-prefix))) (serialize-configuration config configuration-with-prefix-fields)))) + +;;; +;;; define-configuration macro, extra-args literals +;;; + +(define (eval-gexp x) + "Get serialized config as string." + (eval (gexp->approximate-sexp x) + (current-module))) + +(define (port? value) + (or (string? value) (number? value))) + +(define (sanitize-port value) + (cond ((number? value) value) + ((string? value) (string->number value)) + (else (raise (formatted-message (G_ "Bad value: ~a") value))))) + +(test-group "Basic sanitizer literal tests" + (define serialize-port serialize-number) + + (define-configuration config-with-sanitizer + (port + (port 80) + "Lorem Ipsum." + (sanitizer sanitize-port))) + + (test-equal "default value, sanitizer" + 80 + (config-with-sanitizer-port (config-with-sanitizer))) + + (test-equal "string value, sanitized to number" + 56 + (config-with-sanitizer-port (config-with-sanitizer + (port "56")))) + + (define (custom-serialize-port field-name value) + (number->string value)) + + (define-configuration config-serializer + (port + (port 80) + "Lorem Ipsum." + (serializer custom-serialize-port))) + + (test-equal "default value, serializer literal" + "80" + (eval-gexp + (serialize-configuration (config-serializer) + config-serializer-fields)))) + +(test-group "empty-serializer as literal/procedure tests" + (define-configuration config-with-literal + (port + (port 80) + "Lorem Ipsum." + empty-serializer)) + + (define-configuration config-with-proc + (port + (port 80) + "Lorem Ipsum." + (serializer empty-serializer))) + + (test-equal "empty-serializer as literal" + "" + (eval-gexp + (serialize-configuration (config-with-literal) + config-with-literal-fields))) + + (test-equal "empty-serializer as procedure" + "" + (eval-gexp + (serialize-configuration (config-with-proc) + config-with-proc-fields)))) + +(test-group "permutation tests" + (define-configuration config-san+empty-ser + (port + (port 80) + "Lorem Ipsum." + (sanitizer sanitize-port) + empty-serializer)) + + (define-configuration config-san+ser + (port + (port 80) + "Lorem Ipsum." + (sanitizer sanitize-port) + (serializer (lambda _ "foo")))) + + (test-equal "default value, sanitizer, permutation" + 80 + (config-san+empty-ser-port (config-san+empty-ser))) + + (test-equal "default value, serializer, permutation" + "foo" + (eval-gexp + (serialize-configuration (config-san+ser) config-san+ser-fields))) + + (test-equal "string value sanitized to number, permutation" + 56 + (config-san+ser-port (config-san+ser + (port "56")))) + + ;; Ordering tests. + (define-configuration config-ser+san + (port + (port 80) + "Lorem Ipsum." + (sanitizer sanitize-port) + (serializer (lambda _ "foo")))) + + (define-configuration config-empty-ser+san + (port + (port 80) + "Lorem Ipsum." + empty-serializer + (sanitizer sanitize-port))) + + (test-equal "default value, sanitizer, permutation 2" + 56 + (config-empty-ser+san-port (config-empty-ser+san + (port "56")))) + + (test-equal "default value, serializer, permutation 2" + "foo" + (eval-gexp + (serialize-configuration (config-ser+san) config-ser+san-fields)))) + +(test-group "duplicated/conflicting entries" + (test-error + "duplicate sanitizer" #t + (macroexpand '(define-configuration dupe-san + (foo + (list '()) + "Lorem Ipsum." + (sanitizer (lambda () #t)) + (sanitizer (lambda () #t)))))) + + (test-error + "duplicate serializer" #t + (macroexpand '(define-configuration dupe-ser + (foo + (list '()) + "Lorem Ipsum." + (serializer (lambda _ "")) + (serializer (lambda _ "")))))) + + (test-error + "conflicting use of serializer + empty-serializer" #t + (macroexpand '(define-configuration ser+empty-ser + (foo + (list '()) + "Lorem Ipsum." + (serializer (lambda _ "lorem")) + empty-serializer))))) + +(test-group "Mix of deprecated and new syntax" + (test-error + "Mix of bare serializer and new syntax" #t + (macroexpand '(define-configuration mixed + (foo + (list '()) + "Lorem Ipsum." + (sanitizer (lambda () #t)) + (lambda _ "lorem"))))) + + (test-error + "Mix of bare serializer and new syntax, permutation)" #t + (macroexpand '(define-configuration mixed + (foo + (list '()) + "Lorem Ipsum." + (lambda _ "lorem") + (sanitizer (lambda () #t))))))) + ;;; ;;; define-maybe macro. -- 2.39.1