bug#64106: [PATCH] gnu: services: Revert to deleting and updating all matching services

[Brian Cully]

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