summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBrian Cully <bjc@spork.org>2023-07-17 13:02:19 -0400
committerMaxim Cournoyer <maxim.cournoyer@gmail.com>2023-08-31 23:31:50 -0400
commitf66fa5f917e76935187935b09ae7ac037b8b35f8 (patch)
treea867e51a541e2525568f76b3b55d7fc6e9dc190d
parent69f6edc1a8596d2cb4c67e0435d35633af6f3cbc (diff)
gnu: services: Revert to deleting and updating all matching services
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. Signed-off-by: Maxim Cournoyer <maxim.cournoyer@gmail.com> Modified-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
-rw-r--r--gnu/services.scm97
-rw-r--r--tests/services.scm68
2 files changed, 126 insertions, 39 deletions
diff --git a/gnu/services.scm b/gnu/services.scm
index eb9258977e..ff153fbc7b 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -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 ...)))))
;;;
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 @@
(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)