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

[guix-commits]

apteryx pushed a commit to branch master
in repository guix.

commit f66fa5f917e76935187935b09ae7ac037b8b35f8
Author: Brian Cully <bjc@spork.org>
AuthorDate: Mon Jul 17 13:02:19 2023 -0400

    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>
---
 gnu/services.scm   | 97 ++++++++++++++++++++++++++++++++----------------------
 tests/services.scm | 68 ++++++++++++++++++++++++++++++++++++++
 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)