This patch reverts the behavior introduced in 181951207339508789b28ba7cb914f983319920f which caused ‘modify-services’ clauses to only match a single instance of a service.
We will now match all service instances when doing a deletion or update, while still raising an exception when trying to match against a service that does not exist in the services list, or which was deleted explicitly by a ‘delete’ clause (or an update clause that returns ‘#f’ for the service). Fixes: #64106 * gnu/services.scm (%modify-services): New procedure. (modify-services): Use it. (apply-clauses): Add DELETED-SERVICES argument, change to modify one service at a time. * tests/services.scm ("modify-services: delete then modify"), ("modify-services: modify then delete"), ("modify-services: delete multiple services of the same type"), ("modify-services: modify multiple services of the same type"): New tests. --- gnu/services.scm | 95 +++++++++++++++++++++++++++------------------- tests/services.scm | 68 +++++++++++++++++++++++++++++++++ 2 files changed, 124 insertions(+), 39 deletions(-) diff --git a/gnu/services.scm b/gnu/services.scm index 109e050a23..4c5b9b16df 100644 --- a/gnu/services.scm +++ b/gnu/services.scm @@ -320,45 +320,62 @@ (define-syntax clause-alist ((_) '()))) -(define (apply-clauses clauses services) - "Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES, a list -of services. Use each clause at most once; raise an error if a clause was not -used." - (let loop ((services services) - (clauses clauses) - (result '())) - (match services - (() - (match clauses - (() ;all clauses fired, good - (reverse result)) - (((kind _ properties) _ ...) ;one or more clauses didn't match - (raise (make-compound-condition - (condition - (&error-location - (location (source-properties->location properties)))) - (formatted-message - (G_ "modify-services: service '~a' not found in service list") - (service-type-name kind))))))) - ((head . tail) - (let ((service clauses - (fold2 (lambda (clause service remainder) - (if service - (match clause - ((kind proc properties) - (if (eq? kind (service-kind service)) - (values (proc service) remainder) - (values service - (cons clause remainder))))) - (values #f (cons clause remainder)))) - head +(define (apply-clauses clauses service deleted-services) + (define (raise-if-deleted kind properties) + (match (find (lambda (deleted) + (match deleted + ((deleted-kind _) + (eq? kind deleted-kind)))) + deleted-services) + ((_ deleted-properties) + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message + (G_ "modify-services: service '~a' was deleted here: ~a") + (service-type-name kind) + (source-properties->location deleted-properties))))) + (_ #t))) + + (match clauses + (((kind proc properties) . rest) + (begin + (raise-if-deleted kind properties) + (if (eq? (and service (service-kind service)) + kind) + (let ((new-service (proc service))) + (apply-clauses rest new-service + (if new-service + deleted-services + (cons (list kind properties) + deleted-services)))) + (apply-clauses rest service deleted-services)))) + (() + service))) + +(define (%modify-services services clauses) + (define (raise-if-not-found clause) + (match clause + ((kind _ properties) + (when (not (find (lambda (service) + (eq? kind (service-kind service))) + services)) + (raise (make-compound-condition + (condition + (&error-location + (location (source-properties->location properties)))) + (formatted-message + (G_ "modify-services: service '~a' not found in service list") + (service-type-name kind)))))))) + + (for-each raise-if-not-found clauses) + (reverse (filter-map identity + (fold (lambda (service services) + (cons (apply-clauses clauses service '()) + services)) '() - clauses))) - (loop tail - (reverse clauses) - (if service - (cons service result) - result))))))) + services)))) (define-syntax modify-services (syntax-rules () @@ -393,7 +410,7 @@ (define-syntax modify-services all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the UDEV-SERVICE-TYPE." ((_ services clauses ...) - (apply-clauses (clause-alist clauses ...) services)))) + (%modify-services services (clause-alist clauses ...))))) ;;; diff --git a/tests/services.scm b/tests/services.scm index 20ff4d317e..98b584f6c0 100644 --- a/tests/services.scm +++ b/tests/services.scm @@ -370,4 +370,72 @@ (define-module (test-services) (modify-services services (t2 value => 22))))) +(test-error "modify-services: delete then modify" + #t + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) (service t3 3)))) + (map service-value + (modify-services services + (delete t2) + (t2 value => 22))))) + +(test-equal "modify-services: modify then delete" + '(2 3) + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) (service t3 3)))) + (map service-value + (modify-services services + (t1 value => 11) + (delete t1))))) + +(test-equal "modify-services: delete multiple services of the same type" + '(1 3) + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) + (service t2 2) (service t3 3)))) + (map service-value + (modify-services services + (delete t2))))) + +(test-equal "modify-services: modify multiple services of the same type" + '(1 12 13 4) + (let* ((t1 (service-type (name 't1) + (extensions '()) + (description ""))) + (t2 (service-type (name 't2) + (extensions '()) + (description ""))) + (t3 (service-type (name 't3) + (extensions '()) + (description ""))) + (services (list (service t1 1) (service t2 2) + (service t2 3) (service t3 4)))) + (map service-value + (modify-services services + (t2 value => (+ value 10)))))) + (test-end) base-commit: 29a7bd209c7a37bbc0c46a18de6d81bf0569041b -- 2.41.0