From 2ccbf3a45ccb5b1ac469f3d429faf4c51c56f38a Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 22 Jun 2022 23:39:50 +0200 Subject: style: Keep values next to their keyword. This ensures we print '#:key value' rather than insert a newline between '#:key' and 'value' as was the case before. * guix/scripts/style.scm (pretty-print-with-comments)[print-sequence]: When ITEM is a keyword, loop with FIRST? = true. * tests/style.scm: Add test. --- tests/style.scm | 12 ++++++++++++ 1 file changed, 12 insertions(+) (limited to 'tests') diff --git a/tests/style.scm b/tests/style.scm index 41f7e31cce..48d975df94 100644 --- a/tests/style.scm +++ b/tests/style.scm @@ -492,6 +492,18 @@ (define file '(#:phases %standard-phases #:tests? #f)))") +;; '#:key value' is kept on the same line. +(test-pretty-print "\ +(package + (name \"keyword-value-same-line\") + (arguments + (list #:phases #~(modify-phases %standard-phases + (add-before 'x 'y + (lambda* (#:key inputs #:allow-other-keys) + (foo bar baz)))) + #:make-flags #~'(\"ANSWER=42\") + #:tests? #f)))") + (test-equal "pretty-print-with-comments, canonicalize-comment" "\ (list abc -- cgit v1.2.3 From fb7e6ccba7cc243cd96cdc3fde3daa9a5f08e531 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 18 Jun 2022 22:37:20 +0200 Subject: services: configuration: Report the location of field type errors. Previously field type errors would be reported in a non-standard way, and without any source location information. This fixes it. * gnu/services/configuration.scm (configuration-field-error): Add a 'loc' parameter and honor it. Use 'formatted-message' instead of plain 'format'. (define-configuration-helper)[field-sanitizer]: New procedure. Use it. Use STEM as the identifier of the syntactic constructor of the record type. Add a 'sanitize' property to each field. Remove now useless STEM macro that would call 'validate-configuration'. * gnu/services/mail.scm (serialize-listener-configuration): Adjust to new 'configuration-field-error' prototype. * tests/services/configuration.scm ("wrong type for a field"): New test. * po/guix/POTFILES.in: Add gnu/services/configuration.scm. --- gnu/services/configuration.scm | 55 +++++++++++++++++++++++++++++++--------- gnu/services/mail.scm | 2 +- po/guix/POTFILES.in | 1 + tests/services/configuration.scm | 13 ++++++++++ 4 files changed, 58 insertions(+), 13 deletions(-) (limited to 'tests') diff --git a/gnu/services/configuration.scm b/gnu/services/configuration.scm index f6b20fb82b..c39ea5a02a 100644 --- a/gnu/services/configuration.scm +++ b/gnu/services/configuration.scm @@ -27,7 +27,8 @@ (define-module (gnu services configuration) #:use-module (guix records) #:use-module (guix gexp) #:use-module ((guix utils) #:select (source-properties->location)) - #:use-module ((guix diagnostics) #:select (formatted-message location-file)) + #:use-module ((guix diagnostics) + #:select (formatted-message location-file &error-location)) #:use-module ((guix modules) #:select (file-name->module-name)) #:use-module (guix i18n) #:autoload (texinfo) (texi-fragment->stexi) @@ -87,9 +88,17 @@ (define-condition-type &configuration-error &error (define (configuration-error message) (raise (condition (&message (message message)) (&configuration-error)))) -(define (configuration-field-error field val) - (configuration-error - (format #f "Invalid value for field ~a: ~s" field val))) +(define (configuration-field-error loc field value) + (raise (apply + make-compound-condition + (formatted-message (G_ "invalid value ~s for field '~a'") + value field) + (condition (&configuration-error)) + (if loc + (list (condition + (&error-location (location loc)))) + '())))) + (define (configuration-missing-field kind field) (configuration-error (format #f "~a configuration missing required field ~a" kind field))) @@ -210,9 +219,33 @@ (define (define-configuration-helper serialize? serializer-prefix syn) (id #'stem #'serialize- type)))))) #'(field-type ...) #'((custom-serializer ...) ...)))) + (define (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. + #`(define-syntax #,(id #'stem #'validate- #'stem #'- name) + (lambda (s) + ;; Make sure the given VALUE, for field NAME, passes PRED. + (syntax-case s () + ((_ value) + (with-syntax ((name #'#,name) + (pred #'#,pred) + (loc (datum->syntax #'value + (syntax-source #'value)))) + #'(if (pred value) + value + (configuration-field-error + (and=> 'loc source-properties->location) + 'name value)))))))) + #`(begin + ;; Define field validation macros. + #,@(map field-sanitizer + #'(field ...) + #'(field-predicate ...)) + (define-record-type* #,(id #'stem #'< #'stem #'>) - #,(id #'stem #'% #'stem) + stem #,(id #'stem #'make- #'stem) #,(id #'stem #'stem #'?) (%location #,(id #'stem #'stem #'-location) @@ -220,10 +253,13 @@ (define-record-type* #,(id #'stem #'< #'stem #'>) source-properties->location)) (innate)) #,@(map (lambda (name getter def) - #`(#,name #,getter (default #,def))) + #`(#,name #,getter (default #,def) + (sanitize + #,(id #'stem #'validate- #'stem #'- name)))) #'(field ...) #'(field-getter ...) #'(field-default ...))) + (define #,(id #'stem #'stem #'-fields) (list (configuration-field (name 'field) @@ -240,12 +276,7 @@ (define #,(id #'stem #'stem #'-fields) '#,(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)) diff --git a/gnu/services/mail.scm b/gnu/services/mail.scm index d99743ac31..c2fd4d8670 100644 --- a/gnu/services/mail.scm +++ b/gnu/services/mail.scm @@ -285,7 +285,7 @@ (define (serialize-listener-configuration field-name val) (serialize-fifo-listener-configuration field-name val)) ((inet-listener-configuration? val) (serialize-inet-listener-configuration field-name val)) - (else (configuration-field-error field-name val)))) + (else (configuration-field-error #f field-name val)))) (define (listener-configuration-list? val) (and (list? val) (and-map listener-configuration? val))) (define (serialize-listener-configuration-list field-name val) diff --git a/po/guix/POTFILES.in b/po/guix/POTFILES.in index 201e5dcc87..f50dd00422 100644 --- a/po/guix/POTFILES.in +++ b/po/guix/POTFILES.in @@ -4,6 +4,7 @@ gnu.scm gnu/packages.scm gnu/services.scm gnu/system.scm +gnu/services/configuration.scm gnu/services/shepherd.scm gnu/home/services.scm gnu/home/services/ssh.scm diff --git a/tests/services/configuration.scm b/tests/services/configuration.scm index 334a1e409b..6268525317 100644 --- a/tests/services/configuration.scm +++ b/tests/services/configuration.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Maxim Cournoyer ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,6 +20,7 @@ (define-module (tests services configuration) #:use-module (gnu services configuration) + #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (srfi srfi-34) #:use-module (srfi srfi-64)) @@ -43,6 +45,17 @@ (define-configuration port-configuration 80 (port-configuration-port (port-configuration))) +(test-equal "wrong type for a field" + '("configuration.scm" 57 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! + (port "This is not a number!")))) + (define-configuration port-configuration-cs (port (number 80) "The port number." empty-serializer)) -- cgit v1.2.3 From c31605b58228dbd10c819311a17341a22c9e5118 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Jun 2022 16:00:17 +0200 Subject: status: Change tests from SRFI-11 to SRFI-71. * tests/status.scm: Use SRFI-71 'let' instead of SRFI-11 'let-values'. --- tests/status.scm | 69 ++++++++++++++++++++++++++++---------------------------- 1 file changed, 34 insertions(+), 35 deletions(-) (limited to 'tests') diff --git a/tests/status.scm b/tests/status.scm index 01a61f7345..79024ba2b3 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2018, 2019 Ludovic Courtès +;;; Copyright © 2018, 2019, 2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -19,8 +19,8 @@ (define-module (test-status) #:use-module (guix status) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-11) #:use-module (srfi srfi-64) + #:use-module (srfi srfi-71) #:use-module (rnrs bytevectors) #:use-module (rnrs io ports) #:use-module (ice-9 match)) @@ -29,8 +29,7 @@ (define-module (test-status) (test-equal "compute-status, no-op" (build-status) - (let-values (((port get-status) - (build-event-output-port compute-status))) + (let ((port get-status (build-event-output-port compute-status))) (display "foo\nbar\n\baz\n" port) (get-status))) @@ -53,11 +52,11 @@ (define-module (test-status) #:transferred 500 #:start 'now #:end 'now))))) - (let-values (((port get-status) - (build-event-output-port (lambda (event status) - (compute-status event status - #:current-time - (const 'now)))))) + (let ((port get-status + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) (display "@ build-started foo.drv - x86_64-linux \n" port) (display "@ substituter-started bar\n" port) (display "@ download-started bar http://example.org/bar 500\n" port) @@ -100,11 +99,11 @@ (define-module (test-status) #:start 'now #:end 'now))))) ;; Below we omit 'substituter-started' events and the like. - (let-values (((port get-status) - (build-event-output-port (lambda (event status) - (compute-status event status - #:current-time - (const 'now)))))) + (let ((port get-status + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) (display "@ build-started foo.drv - x86_64-linux foo.log\n" port) (display "@ download-started bar http://example.org/bar 999\n" port) (display "various\nthings\nget\nwritten\n" port) @@ -119,8 +118,8 @@ (define-module (test-status) (test-equal "build-output-port, UTF-8" '((build-log #f "lambda is λ!\n")) - (let-values (((port get-status) (build-event-output-port cons '())) - ((bv) (string->utf8 "lambda is λ!\n"))) + (let ((port get-status (build-event-output-port cons '())) + (bv (string->utf8 "lambda is λ!\n"))) (put-bytevector port bv) (force-output port) (get-status))) @@ -129,7 +128,7 @@ (define-module (test-status) ;; What about a mixture of UTF-8 + garbage? (let ((replacement "�")) `((build-log #f ,(string-append "garbage: " replacement "lambda: λ\n")))) - (let-values (((port get-status) (build-event-output-port cons '()))) + (let ((port get-status (build-event-output-port cons '()))) (display "garbage: " port) (put-bytevector port #vu8(128)) (put-bytevector port (string->utf8 "lambda: λ\n")) @@ -156,14 +155,14 @@ (define-module (test-status) #:transferred 999 #:start 'now #:end 'now))))) - (let-values (((port get-status) - (build-event-output-port (lambda (event status) - (compute-status event status - #:current-time - (const 'now) - #:derivation-path->output-path - (match-lambda - ("bar.drv" "bar"))))))) + (let ((port get-status + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now) + #:derivation-path->output-path + (match-lambda + ("bar.drv" "bar"))))))) (display "@ build-started foo.drv - x86_64-linux 121\n" port) (display "@ build-started bar.drv - armhf-linux bar.log 144\n" port) (display "@ build-log 121 6\nHello!" port) @@ -192,11 +191,11 @@ (define-module (test-status) (build-status (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121 #:completion 100.))))) - (let-values (((port get-status) - (build-event-output-port (lambda (event status) - (compute-status event status - #:current-time - (const 'now)))))) + (let ((port get-status + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) (display "@ build-started foo.drv - x86_64-linux 121\n" port) (display "@ build-log 121 6\nHello!" port) (let ((first (get-status))) @@ -225,11 +224,11 @@ (define-module (test-status) (build-status (builds-completed (list (build "foo.drv" "x86_64-linux" #:id 121 #:phase 'install))))) - (let-values (((port get-status) - (build-event-output-port (lambda (event status) - (compute-status event status - #:current-time - (const 'now)))))) + (let ((port get-status + (build-event-output-port (lambda (event status) + (compute-status event status + #:current-time + (const 'now)))))) (display "@ build-started foo.drv - x86_64-linux 121\n" port) (display "@ build-log 121 27\nstarting phase `configure'\n" port) (display "@ build-log 121 6\nabcde!" port) -- cgit v1.2.3 From f99f00fc814a3e1a3e1cedb5059c896e3303677c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 26 Jun 2022 16:14:40 +0200 Subject: status: Relay "updating substitutes" messages. Until now, those messages would be accumulated and displayed all at once, when a '\n' was finally emitted by 'guix substitute'. In the meantime, clients would remain silent. * guix/status.scm (bytevector-index): Change 'number' parameter to 'numbers' and adjust accordingly. (build-event-output-port): Pass both #\newline and #\return to 'bytevector-index'. * tests/status.scm ("build-output-port, daemon messages with LF"): New test. --- guix/status.scm | 16 +++++++++++----- tests/status.scm | 14 ++++++++++++++ 2 files changed, 25 insertions(+), 5 deletions(-) (limited to 'tests') diff --git a/guix/status.scm b/guix/status.scm index b8905c9542..2c69f49fb5 100644 --- a/guix/status.scm +++ b/guix/status.scm @@ -667,13 +667,14 @@ (define (maybe-utf8->string bv) (close-port port) str))))) -(define (bytevector-index bv number offset count) - "Search for NUMBER in BV starting from OFFSET and reading up to COUNT bytes; -return the offset where NUMBER first occurs or #f if it could not be found." +(define (bytevector-index bv numbers offset count) + "Search for NUMBERS in BV starting from OFFSET and reading up to COUNT bytes; +return the offset where one of NUMBERS first occurs or #f if they could not be +found." (let loop ((offset offset) (count count)) (cond ((zero? count) #f) - ((= (bytevector-u8-ref bv offset) number) offset) + ((memv (bytevector-u8-ref bv offset) numbers) offset) (else (loop (+ 1 offset) (- count 1)))))) (define (split-lines str) @@ -774,7 +775,12 @@ (define (write! bv offset count) (set! %build-output '()) (set! %build-output-pid #f)) keep) - (match (bytevector-index bv (char->integer #\newline) + + ;; Search for both '\n' and '\r'; the latter is appears in progress + ;; messages sent by 'guix substitute' through the daemon. + (match (bytevector-index bv + (list (char->integer #\newline) + (char->integer #\return)) offset count) ((? integer? cr) (let* ((tail (maybe-utf8->string diff --git a/tests/status.scm b/tests/status.scm index 79024ba2b3..b0af619872 100644 --- a/tests/status.scm +++ b/tests/status.scm @@ -124,6 +124,20 @@ (define-module (test-status) (force-output port) (get-status))) +(test-equal "build-output-port, daemon messages with LF" + '((build-log #f "updating substitutes... 0%\r") + (build-log #f "updating substitutes... 50%\r") + (build-log #f "updating substitutes... 100%\r")) + (let ((port get-status (build-event-output-port cons '()))) + (for-each (lambda (suffix) + (let ((bv (string->utf8 + (string-append "updating substitutes... " + suffix "\r")))) + (put-bytevector port bv) + (force-output port))) + '("0%" "50%" "100%")) + (reverse (get-status)))) + (test-equal "current-build-output-port, UTF-8 + garbage" ;; What about a mixture of UTF-8 + garbage? (let ((replacement "�")) -- cgit v1.2.3