ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 07:26:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

gnu: services: Revert to deleting and updating all matching services

Browse source 
This patch reverts the behavior introduced in
1819512073 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.

Signed-off-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Modified-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
This commit is contained in:
Brian Cully 2023-07-17 13:02:19 -04:00 committed by Maxim Cournoyer
parent 69f6edc1a8
commit f66fa5f917
No known key found for this signature in database
GPG key ID: 1260E46482E63562
2 changed files with 126 additions and 39 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

97
gnu/services.scm
View file

@ -324,45 +324,64 @@ (define-syntax clause-alist
((_) ((_)
'()))) '())))
(define (apply-clauses clauses services) (define (apply-clauses clauses service deleted-services)
"Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES, a list "Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICE. An
of services. Use each clause at most once; raise an error if a clause was not exception is raised if a clause attempts to modify a service
used." present in DELETED-SERVICES."
(let loop ((services services) (define (raise-if-deleted kind properties)
(clauses clauses) (match (find (match-lambda
(result '())) ((deleted-kind _)
(match services (eq? kind deleted-kind)))
(() deleted-services)
(match clauses ((_ deleted-properties)
(() ;all clauses fired, good (raise (make-compound-condition
(reverse result)) (condition
(((kind _ properties) _ ...) ;one or more clauses didn't match (&error-location
(raise (make-compound-condition (location (source-properties->location properties))))
(condition (formatted-message
(&error-location (G_ "modify-services: service '~a' was deleted here: ~a")
(location (source-properties->location properties)))) (service-type-name kind)
(formatted-message (source-properties->location deleted-properties)))))
(G_ "modify-services: service '~a' not found in service list") (_ #t)))
(service-type-name kind)))))))
((head . tail) (match clauses
(let ((service clauses (((kind proc properties) . rest)
(fold2 (lambda (clause service remainder) (raise-if-deleted kind properties)
(if service (if (eq? (and service (service-kind service)) kind)
(match clause (let ((new-service (proc service)))
((kind proc properties) (apply-clauses rest new-service
(if (eq? kind (service-kind service)) (if new-service
(values (proc service) remainder) deleted-services
(values service (cons (list kind properties)
(cons clause remainder))))) deleted-services))))
(values #f (cons clause remainder)))) (apply-clauses rest service deleted-services)))
head (()
service)))
(define (%modify-services services clauses)
"Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICES. An
exception is raised if a clause attempts to modify a missing service."
(define (raise-if-not-found clause)
(match clause
((kind _ properties)
(unless (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))) services))))
(loop tail
(reverse clauses)
(if service
(cons service result)
result)))))))
(define-syntax modify-services (define-syntax modify-services
(syntax-rules () (syntax-rules ()
@ -397,7 +416,7 @@ (define-syntax modify-services
all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the
UDEV-SERVICE-TYPE." UDEV-SERVICE-TYPE."
((_ services clauses ...) ((_ services clauses ...)
(apply-clauses (clause-alist clauses ...) services)))) (%modify-services services (clause-alist clauses ...)))))
;;; ;;;

68
tests/services.scm
View file

@ -370,4 +370,72 @@ (define-module (test-services)
(modify-services services (modify-services services
(t2 value => 22))))) (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) (test-end)