TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

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 @@ is the source location information."
((_)
'())))
(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)
"Apply CLAUSES, an alist as returned by 'clause-alist', to SERVICE. An
exception is raised if a clause attempts to modify a service
present in DELETED-SERVICES."
(define (raise-if-deleted kind properties)
(match (find (match-lambda
((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)
(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)
"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)))
(loop tail
(reverse clauses)
(if service
(cons service result)
result)))))))
services))))
(define-syntax modify-services
(syntax-rules ()
@ -397,7 +416,7 @@ It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of
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 ...)))))
;;;

68
tests/services.scm
View File

@ -370,4 +370,72 @@
(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)