From debbugs-submit-bounces@debbugs.gnu.org Wed Apr 20 05:17:26 2022 Received: (at 54674) by debbugs.gnu.org; 20 Apr 2022 09:17:26 +0000 Received: from localhost ([127.0.0.1]:45075 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nh6Sj-0006Xq-Hc for submit@debbugs.gnu.org; Wed, 20 Apr 2022 05:17:26 -0400 Received: from mail-ej1-f53.google.com ([209.85.218.53]:38466) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1nh6Sh-0006XZ-Ne for 54674@debbugs.gnu.org; Wed, 20 Apr 2022 05:17:24 -0400 Received: by mail-ej1-f53.google.com with SMTP id r13so2210245ejd.5 for <54674@debbugs.gnu.org>; Wed, 20 Apr 2022 02:17:23 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20210112; h=sender:from:to:cc:subject:date:message-id:mime-version :content-transfer-encoding; bh=+iyFTRtqAtXkgYiGtD4uae6oIfGkmk+wBlwrs0+AIjM=; b=KMuRhwgYyduIoiobXGYuRX5dNaZxtSRVs3rYvJgldzS6nKzbi4fg03W6T95n9KHsXZ s3cOFkIVQBvFyagkzddoPDHrhdVhBRYklv1lsB59co8e9Ubqvp1U5JKTShvIyux19UEb g17JIXXV1FGxoRX9gjLRV7c3pkWFQ5MB6U17/F0lfkweQMBJmL6lejY/ak3b9hb1xS43 O05N0teCWEnWgm9G1I/BhVr1rOK3e+R2+ZOimtbhJpEYP7DnDiVTFExJpa7EL2J51Xv9 sBU9780oMKozxh2a1xh4AjYf4Ep9wcYYZu8UhkwcY2oWaYtsBYxBWyZUOub9cBuYIbPI AdZA== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:sender:from:to:cc:subject:date:message-id :mime-version:content-transfer-encoding; bh=+iyFTRtqAtXkgYiGtD4uae6oIfGkmk+wBlwrs0+AIjM=; b=4Vih30GhNSAU8NjIVoUguz0fElhCSqjsJ1ttibcevyqtmW+2tl53S+COwPi61d1yza u4un82e2D5i21NPJVXETwq7FESpCJmoPVUuP4HxofhBUbM9ocfnLsQcefisMugmT0vUR TQk4vthU+xgxeWZ+SB1DD4TpIeF5ykRrPsRO6YcovFCf9/YKw0K8UDRDPDH1/9Rplalx PgBQpDdMxVgn3FbOrHt41ShwinQ/frAbBPA5yuDTWHUII5RrIDUDUIAC3MT05Dt/BDRI ds0GdjMGNqNj4/CZS5Qbt6GQzsAH9K4P8fL/QAqSPeBviCqKHliNBJybPFR7IBLBQwwB 5zRw== X-Gm-Message-State: AOAM533KxeNUuPh0BsBHZZITzS2+1hMrpK0fSIehDzMEE7UHwQJQeHnj meENqQ/OYsNPG9+C8uLkmYhlU8Ne1a0= X-Google-Smtp-Source: ABdhPJydOQeH8KZol5cGh0hWRFIJ00z1vvyg3htviWKqcVe2ZWIZp1wvzpdoHywCQ5rhX79T/fbyug== X-Received: by 2002:a17:906:7948:b0:6da:64ed:178e with SMTP id l8-20020a170906794800b006da64ed178emr18012513ejo.523.1650446237677; Wed, 20 Apr 2022 02:17:17 -0700 (PDT) Received: from lelap.local (catv-89-132-245-188.catv.fixed.vodafone.hu. [89.132.245.188]) by smtp.gmail.com with ESMTPSA id n25-20020aa7db59000000b00415965e9727sm9598101edt.18.2022.04.20.02.17.16 (version=TLS1_3 cipher=TLS_AES_256_GCM_SHA384 bits=256/256); Wed, 20 Apr 2022 02:17:17 -0700 (PDT) From: Attila Lendvai To: 54674@debbugs.gnu.org Subject: [PATCH v4 1/2] services: configuration: Support (field1 maybe-number "") format. Date: Wed, 20 Apr 2022 11:15:53 +0200 Message-Id: <20220420091553.26732-1-attila@lendvai.name> X-Mailer: git-send-email 2.35.1 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit X-Spam-Score: 2.1 (++) X-Spam-Report: Spam detection software, running on the system "debbugs.gnu.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see the administrator of that system for details. Content preview: As opposed to explicitly using 'disabled as value, or using the (field1 (maybe-number) "") format. It's mostly the work of Maxime Devos shared under #54674, with some modifications by Attila Lendvai. Content analysis details: (2.1 points, 10.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- 0.2 HEADER_FROM_DIFFERENT_DOMAINS From and EnvelopeFrom 2nd level mail domains are different -0.0 SPF_PASS SPF: sender matches SPF record 0.0 SPF_HELO_NONE SPF: HELO does not publish an SPF Record 0.0 FREEMAIL_FROM Sender email is commonly abused enduser mail provider (attila.lendvai[at]gmail.com) 1.6 PDS_OTHER_BAD_TLD Untrustworthy TLDs [URI: yoctocell.xyz (xyz)] -0.0 RCVD_IN_DNSWL_NONE RBL: Sender listed at https://www.dnswl.org/, no trust [209.85.218.53 listed in list.dnswl.org] 0.0 RCVD_IN_MSPIKE_H3 RBL: Good reputation (+3) [209.85.218.53 listed in wl.mailspike.net] 0.0 RCVD_IN_MSPIKE_WL Mailspike good senders 0.2 FREEMAIL_FORGED_FROMDOMAIN 2nd level domains in From and EnvelopeFrom freemail headers are different -0.0 T_SCC_BODY_TEXT_LINE No description available. X-Debbugs-Envelope-To: 54674 Cc: Attila Lendvai X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: debbugs-submit-bounces@debbugs.gnu.org Sender: "Debbugs-submit" X-Spam-Score: 1.1 (+) X-Spam-Report: Spam detection software, running on the system "debbugs.gnu.org", has NOT identified this incoming email as spam. The original message has been attached to this so you can view it or label similar future email. If you have any questions, see the administrator of that system for details. Content preview: As opposed to explicitly using 'disabled as value, or using the (field1 (maybe-number) "") format. It's mostly the work of Maxime Devos shared under #54674, with some modifications by Attila Lendvai. Content analysis details: (1.1 points, 10.0 required) pts rule name description ---- ---------------------- -------------------------------------------------- -0.0 RCVD_IN_DNSWL_NONE RBL: Sender listed at https://www.dnswl.org/, no trust [209.85.218.53 listed in list.dnswl.org] 0.0 RCVD_IN_MSPIKE_H3 RBL: Good reputation (+3) [209.85.218.53 listed in wl.mailspike.net] 0.2 HEADER_FROM_DIFFERENT_DOMAINS From and EnvelopeFrom 2nd level mail domains are different -0.0 SPF_PASS SPF: sender matches SPF record 0.0 SPF_HELO_NONE SPF: HELO does not publish an SPF Record 0.0 FREEMAIL_FROM Sender email is commonly abused enduser mail provider (attila.lendvai[at]gmail.com) 1.6 PDS_OTHER_BAD_TLD Untrustworthy TLDs [URI: yoctocell.xyz (xyz)] 0.0 RCVD_IN_MSPIKE_WL Mailspike good senders 0.2 FREEMAIL_FORGED_FROMDOMAIN 2nd level domains in From and EnvelopeFrom freemail headers are different -0.0 T_SCC_BODY_TEXT_LINE No description available. -1.0 MAILING_LIST_MULTI Multiple indicators imply a widely-seen list manager As opposed to explicitly using 'disabled as value, or using the (field1 (maybe-number) "") format. It's mostly the work of Maxime Devos shared under #54674, with some modifications by Attila Lendvai. * gnu/services/configuration.scm (normalize-field-type+def): New function. (define-configuration-helper) (define-configuration): Support new field format. * tests/services/configuration.scm (config-with-maybe-number->string): New function. ("maybe value serialization of the instance"): New test. ("maybe value serialization of the instance, unspecified"): New test. --- v4: the only change is to drop the extra parens around the type in all the (field1 (maybe-foo) "") forms. gnu/services/configuration.scm | 169 +++++++++++++++++-------------- tests/services/configuration.scm | 28 ++++- 2 files changed, 114 insertions(+), 83 deletions(-) diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index 0de350a4df..bdca33ed68 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2021 Xinglu Chen ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2022 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -162,78 +163,90 @@ (define-maybe-helper #t #f #'(_ stem)))))) (define-syntax-rule (define-maybe/no-serialization stem) (define-maybe stem (no-serialization))) +(define (normalize-field-type+def s) + (syntax-case s () + ((field-type def) + (identifier? #'field-type) + (values #'(field-type def))) + ((field-type) + (identifier? #'field-type) + (values #'(field-type 'disabled))) + (field-type + (identifier? #'field-type) + (values #'(field-type 'disabled))))) + (define (define-configuration-helper serialize? serializer-prefix syn) (syntax-case syn () - ((_ stem (field (field-type def ...) doc custom-serializer ...) ...) - (with-syntax (((field-getter ...) - (map (lambda (field) - (id #'stem #'stem #'- field)) - #'(field ...))) - ((field-predicate ...) - (map (lambda (type) - (id #'stem type #'?)) - #'(field-type ...))) - ((field-default ...) - (map (match-lambda - ((field-type default-value) - default-value) - ((field-type) - ;; Quote `undefined' to prevent a possibly - ;; unbound warning. - (syntax 'undefined))) - #'((field-type def ...) ...))) - ((field-serializer ...) - (map (lambda (type custom-serializer) - (and serialize? - (match custom-serializer - ((serializer) - serializer) - (() - (if serializer-prefix - (id #'stem - serializer-prefix - #'serialize- type) - (id #'stem #'serialize- type)))))) - #'(field-type ...) - #'((custom-serializer ...) ...)))) - #`(begin - (define-record-type* #,(id #'stem #'< #'stem #'>) - #,(id #'stem #'% #'stem) - #,(id #'stem #'make- #'stem) - #,(id #'stem #'stem #'?) - (%location #,(id #'stem #'stem #'-location) - (default (and=> (current-source-location) - source-properties->location)) - (innate)) - #,@(map (lambda (name getter def) - (if (eq? (syntax->datum def) (quote 'undefined)) - #`(#,name #,getter) - #`(#,name #,getter (default #,def)))) - #'(field ...) - #'(field-getter ...) - #'(field-default ...))) - (define #,(id #'stem #'stem #'-fields) - (list (configuration-field - (name 'field) - (type 'field-type) - (getter field-getter) - (predicate field-predicate) - (serializer field-serializer) - (default-value-thunk - (lambda () - (display '#,(id #'stem #'% #'stem)) - (if (eq? (syntax->datum field-default) - 'undefined) - (configuration-no-default-value - '#,(id #'stem #'% #'stem) 'field) - field-default))) - (documentation doc)) - ...)) - (define-syntax-rule (stem arg (... ...)) - (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) - (validate-configuration conf - #,(id #'stem #'stem #'-fields)) - conf))))))) + ((_ stem (field field-type+def doc custom-serializer ...) ...) + (with-syntax + ((((field-type def) ...) + (map normalize-field-type+def #'(field-type+def ...)))) + (with-syntax + (((field-getter ...) + (map (lambda (field) + (id #'stem #'stem #'- field)) + #'(field ...))) + ((field-predicate ...) + (map (lambda (type) + (id #'stem type #'?)) + #'(field-type ...))) + ((field-default ...) + (map (match-lambda + ((field-type default-value) + default-value)) + #'((field-type def) ...))) + ((field-serializer ...) + (map (lambda (type custom-serializer) + (and serialize? + (match custom-serializer + ((serializer) + serializer) + (() + (if serializer-prefix + (id #'stem + serializer-prefix + #'serialize- type) + (id #'stem #'serialize- type)))))) + #'(field-type ...) + #'((custom-serializer ...) ...)))) + #`(begin + (define-record-type* #,(id #'stem #'< #'stem #'>) + #,(id #'stem #'% #'stem) + #,(id #'stem #'make- #'stem) + #,(id #'stem #'stem #'?) + (%location #,(id #'stem #'stem #'-location) + (default (and=> (current-source-location) + source-properties->location)) + (innate)) + #,@(map (lambda (name getter def) + (if (eq? (syntax->datum def) (quote 'undefined)) + #`(#,name #,getter) + #`(#,name #,getter (default #,def)))) + #'(field ...) + #'(field-getter ...) + #'(field-default ...))) + (define #,(id #'stem #'stem #'-fields) + (list (configuration-field + (name 'field) + (type 'field-type) + (getter field-getter) + (predicate field-predicate) + (serializer field-serializer) + (default-value-thunk + (lambda () + (display '#,(id #'stem #'% #'stem)) + (if (eq? (syntax->datum field-default) + 'undefined) + (configuration-no-default-value + '#,(id #'stem #'% #'stem) 'field) + field-default))) + (documentation doc)) + ...)) + (define-syntax-rule (stem arg (... ...)) + (let ((conf (#,(id #'stem #'% #'stem) arg (... ...)))) + (validate-configuration conf + #,(id #'stem #'stem #'-fields)) + conf)))))))) (define no-serialization ;syntactic keyword for 'define-configuration' '(no serialization)) @@ -241,26 +254,26 @@ (define no-serialization ;syntactic keyword for 'define-configuration' (define-syntax define-configuration (lambda (s) (syntax-case s (no-serialization prefix) - ((_ stem (field (field-type def ...) doc custom-serializer ...) ... + ((_ stem (field field-type+def doc custom-serializer ...) ... (no-serialization)) (define-configuration-helper - #f #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) + #f #f #'(_ stem (field field-type+def doc custom-serializer ...) ...))) - ((_ stem (field (field-type def ...) doc custom-serializer ...) ... + ((_ stem (field field-type+def doc custom-serializer ...) ... (prefix serializer-prefix)) (define-configuration-helper - #t #'serializer-prefix #'(_ stem (field (field-type def ...) + #t #'serializer-prefix #'(_ stem (field field-type+def doc custom-serializer ...) ...))) - ((_ stem (field (field-type def ...) doc custom-serializer ...) ...) + ((_ stem (field field-type+def doc custom-serializer ...) ...) (define-configuration-helper - #t #f #'(_ stem (field (field-type def ...) doc custom-serializer ...) + #t #f #'(_ stem (field field-type+def doc custom-serializer ...) ...)))))) (define-syntax-rule (define-configuration/no-serialization - stem (field (field-type def ...) + stem (field field-type+def doc custom-serializer ...) ...) - (define-configuration stem (field (field-type def ...) + (define-configuration stem (field field-type+def doc custom-serializer ...) ... (no-serialization))) diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 86a36a388d..0debf8095b 100644 --- a/tests/services/configuration.scm +++ b/tests/services/configuration.scm @@ -27,6 +27,9 @@ (define-module (tests services configuration) (test-begin "services-configuration") +(define (serialize-number field value) + (format #f "~a=~a" field value)) + ;;; ;;; define-configuration macro. @@ -47,7 +50,6 @@ (define-configuration port-configuration-cs 80 (port-configuration-cs-port (port-configuration-cs))) -(define serialize-number "") (define-configuration port-configuration-ndv (port (number) "The port number.")) @@ -101,15 +103,31 @@ (define-configuration configuration-with-prefix (define-maybe number) (define-configuration config-with-maybe-number - (port (maybe-number 80) "The port number.")) - -(define (serialize-number field value) - (format #f "~a=~a" field value)) + (port (maybe-number 80) "") + (count maybe-number "")) (test-equal "maybe value serialization" "port=80" (serialize-maybe-number "port" 80)) +(define (config-with-maybe-number->string x) + (eval (gexp->approximate-sexp + (serialize-configuration x config-with-maybe-number-fields)) + (current-module))) + +(test-equal "maybe value serialization of the instance" + "port=42count=43" + (config-with-maybe-number->string + (config-with-maybe-number + (port 42) + (count 43)))) + +(test-equal "maybe value serialization of the instance, unspecified" + "port=42" + (config-with-maybe-number->string + (config-with-maybe-number + (port 42)))) + (define-maybe/no-serialization string) (define-configuration config-with-maybe-string/no-serialization -- 2.35.1