From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: from mp10.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by ms9.migadu.com with LMTPS id EMXfDhKTGGRrfgAASxT56A (envelope-from ) for ; Mon, 20 Mar 2023 18:08:34 +0100 Received: from aspmx1.migadu.com ([2001:41d0:8:6d80::]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits)) by mp10.migadu.com with LMTPS id 8HDmDRKTGGS5LgAAG6o9tA (envelope-from ) for ; Mon, 20 Mar 2023 18:08:34 +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 B98B939471 for ; Mon, 20 Mar 2023 18:08:33 +0100 (CET) Authentication-Results: aspmx1.migadu.com; dkim=none; dmarc=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" ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=yhetil.org; s=key1; t=1679332114; 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=1g87pEg5q10ExT15Ysv7oK2m/2ENQHLsMLcXpRqaqd4=; b=T+td/8TJnLvHa0v8HavXTrwODr5vz4cbqR2wcnGJUjoptnBrhQ6QknVsG8NVXV3I8lqGxw TgSKC0ZanaMbnNtlE+BlIkxUudMu3D7YsJnNxk4ghSP2ivJwQ4EW4deeE+C3FjmbRWi6Fn yMR4gQKNFBqXlGO+0Rz8Bk2LBQperz8+X0QZB+mwRLY7V9u0Y4Qm0bpOt1Q19FMkcBIRtd Gp4G+fxdSRMxT0520EUbQ28iavBF4KZJ8woP8JPuciJ7o9UZg78m9qlTJlu0vUghBDGGaK Va8upjdMq7g+yvx02IfLH1JWpzYBtZlOmkiANkIsxUyVThVTlSoVLUlsbMQYYQ== ARC-Authentication-Results: i=1; aspmx1.migadu.com; dkim=none; dmarc=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" ARC-Seal: i=1; s=key1; d=yhetil.org; t=1679332114; a=rsa-sha256; cv=none; b=QWVSIaH1aLAjZXoLhAvtYjNve0ZVIiMgFtGscp3eVbVIiLb7EXHJhiZ8rcBgpnCmaMx98g QDjxUQpp0frXLbEfksm+Lw1G9MD4d2rAS1iv71rfBAaYeCE08EvjVHGCjzyc6JNBHww2AW YosPoHx9zv4AbOJ2858s/22JSFn7VzFKElRlBb3xmoBpjzaDOihFcmgwIzinPIl2PGLR5w LkPsEYpaord49U98OQJyx0hop2ucPU1YfnDDlEc+TTtWfTXDmOBLx4sKkFCZewwQGGr/Ol tDfR+Rb7ostYoo271eacMsLK1h5/OQFMnvS0DIuNqFl88x2twmSpuuc8w/Apvg== Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1peIzM-0002dX-Tm; Mon, 20 Mar 2023 13:08:04 -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 1peIzK-0002bg-KV for guix-patches@gnu.org; Mon, 20 Mar 2023 13:08:02 -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 1peIzK-0005o3-CA for guix-patches@gnu.org; Mon, 20 Mar 2023 13:08:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1peIzK-00030e-1L for guix-patches@gnu.org; Mon, 20 Mar 2023 13:08:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#62298] [PATCH 1/8] services: configuration: Add user-defined sanitizer support. Resent-From: Bruno Victal Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Mon, 20 Mar 2023 17:08: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.167933204211455 (code B ref 62298); Mon, 20 Mar 2023 17:08:02 +0000 Received: (at 62298) by debbugs.gnu.org; 20 Mar 2023 17:07:22 +0000 Received: from localhost ([127.0.0.1]:55631 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1peIyf-0002yf-0a for submit@debbugs.gnu.org; Mon, 20 Mar 2023 13:07:22 -0400 Received: from smtpmciv2.myservices.hosting ([185.26.107.238]:50986) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1peIyb-0002yI-Ub for 62298@debbugs.gnu.org; Mon, 20 Mar 2023 13:07:19 -0400 Received: from mail1.netim.hosting (unknown [185.26.106.173]) by smtpmciv2.myservices.hosting (Postfix) with ESMTP id 2BE0B20CBD; Mon, 20 Mar 2023 18:07:15 +0100 (CET) Received: from localhost (localhost [127.0.0.1]) by mail1.netim.hosting (Postfix) with ESMTP id D326C8009E; Mon, 20 Mar 2023 18:07:15 +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 u7dsVyVageXQ; Mon, 20 Mar 2023 18:07:14 +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 404918009B; Mon, 20 Mar 2023 18:07:14 +0100 (CET) From: Bruno Victal Date: Mon, 20 Mar 2023 17:07:06 +0000 Message-Id: <2f7b29de4dacdee7e60ede8830a67c643122c302.1679332019.git.mirai@makinata.eu> X-Mailer: git-send-email 2.39.1 In-Reply-To: References: 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: B98B939471 X-Spam-Score: -1.56 X-Migadu-Spam-Score: -1.56 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: HxTOnlXS7gPW 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 as 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. (deprecated-style-serializer?): New predicate. (get-sanitizer, get-serializer): 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 | 30 ++++++- gnu/services/configuration.scm | 97 ++++++++++++++++----- tests/services/configuration.scm | 145 ++++++++++++++++++++++++++++++- 3 files changed, 247 insertions(+), 25 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index fa9ea5a6ec..f84cadeeda 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -41127,7 +41127,7 @@ Complex Configurations (@var{field-name} (@var{type} @var{default-value}) @var{documentation} - @var{serializer}) + (serializer @var{serializer})) (@var{field-name} (@var{type}) @@ -41136,7 +41136,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 @@ -41159,6 +41170,21 @@ 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 the name of a procedure which takes one argument, +a user-supplied value, and returns a ``sanitized'' value for the field. +If none is specified, the predicate @code{@var{type}?} is automatically +used to construct an internal sanitizer that asserts the type correctness +of the field value. + +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 (throw '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 02d1aa1796..6ad9ade76d 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) @@ -44,6 +46,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 +119,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,8 +185,46 @@ (define (normalize-field-type+def s) (values #'(field-type %unset-value))))) (define (define-configuration-helper serialize? serializer-prefix syn) + + (define (deprecated-style-serializer? s) + ;; TODO: helper for deprecated style, remove later. + (syntax-case s () + ;; Case 1. Nothing after 'doc'. + (() #f) + ;; Case 2. Bare serializer after 'doc'. [deprecated] + ;; Until this case is removed, don't forget to add a check for your + ;; newly added field/literal here. + (proc + (not (or (maybe-value-set? (get-serializer s)) + (maybe-value-set? (get-sanitizer s)))) + (begin + (warning #f (G_ "specifying serializers after documentation is \ +deprecated, use (serializer ~a) instead~%") (car (syntax->datum #'proc))) #t)) + ;; Else, something after 'doc' in the updated style. + (else #f))) + + ;; The get-… procedures perform scanning to @var{extra-args} to allow for + ;; newly added fields to be specified in arbitrary order. + (define (get-sanitizer s) + (syntax-case s (sanitizer) + (((sanitizer proc) _ ...) + #'proc) + ((_ tail ...) + (get-sanitizer #'(tail ...))) + (() %unset-value))) + + (define (get-serializer s) + (syntax-case s (serializer empty-serializer) + (((serializer proc) _ ...) + #'proc) + ((empty-serializer _ ...) + #'empty-serializer) + ((_ tail ...) + (get-serializer #'(tail ...))) + (() %unset-value))) + (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 ...)))) @@ -200,21 +242,23 @@ (define (define-configuration-helper serialize? serializer-prefix syn) ((field-type default-value) default-value)) #'((field-type def) ...))) + ((field-sanitizer ...) + (map (compose maybe-value get-sanitizer) + #'((extra-args ...) ...))) ((field-serializer ...) - (map (lambda (type custom-serializer) + (map (lambda (type extra-args) (and serialize? - (match custom-serializer - ((serializer) - serializer) - (() - (if serializer-prefix - (id #'stem - serializer-prefix - #'serialize- type) - (id #'stem #'serialize- type)))))) + (or + (if (deprecated-style-serializer? extra-args) + (car extra-args) ; strip outer parenthesis + #f) + (maybe-value (get-serializer extra-args)) + (if serializer-prefix + (id #'stem serializer-prefix #'serialize- type) + (id #'stem #'serialize- type))))) #'(field-type ...) - #'((custom-serializer ...) ...)))) - (define (field-sanitizer name pred) + #'((extra-args ...) ...)))) + (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 +279,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 +313,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..c5569a9e50 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,145 @@ (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))))) + +(let () + ;; 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)))) + +(let () + ;; empty-serializer as literal/procedure tests + + ;; empty-serializer as literal + (define-configuration config-with-literal + (port + (port 80) + "Lorem Ipsum." + empty-serializer)) + + ;; empty-serializer as procedure + (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)))) + +(let () + ;; 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)))) + ;;; ;;; define-maybe macro. -- 2.39.1