services: 'modify-services' preserves service ordering.

Fixes <https://issues.guix.gnu.org/63921>.

The regression was introduced in
dbbc7e946131ba257728f1d05b96c4339b7ee88b, which changed the order of
services.  As a result, someone using 'modify-services' could find
themselves with incorrect ordering of expressions in the "boot" script,
whereby the cleanup expressions would come after (execl ".../shepherd").
This, in turn, would lead shepherd to error out at boot with EADDRINUSE
on /var/run/shepherd/socket.

* gnu/services.scm (%delete-service, %apply-clauses): Remove.
(clause-alist): New macro.
(apply-clauses): New procedure.
(modify-services): Use it.  Adjust docstring.
* tests/services.scm ("modify-services: do nothing"): Remove 'sort' call.
("modify-services: delete service"): Likewise, and add 't4' service.
("modify-services: change value"): Remove 'sort' call and fix expected value.

1 files changed, 61 insertions, 32 deletions

diff --git a/gnu/services.scm b/gnu/services.scm
index a990d297c9..5410d31971 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -51,6 +51,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:autoload   (ice-9 pretty-print) (pretty-print)
@@ -297,35 +298,65 @@ singleton service type NAME, of which the returned service is an instance."
                                   (description "This is a simple service."))))
     (service type value)))
 
-(define (%delete-service kind services)
-  (let loop ((found #f)
-             (return '())
-             (services services))
+(define-syntax clause-alist
+  (syntax-rules (=> delete)
+    "Build an alist of clauses.  Each element has the form (KIND PROC LOC)
+where PROC is the service transformation procedure to apply for KIND, and LOC
+is the source location information."
+    ((_ (delete kind) rest ...)
+     (cons (list kind
+                 (lambda (service)
+                   #f)
+                 (current-source-location))
+           (clause-alist rest ...)))
+    ((_ (kind param => exp ...) rest ...)
+     (cons (list kind
+                 (lambda (svc)
+                   (let ((param (service-value svc)))
+                     (service (service-kind svc)
+                              (begin exp ...))))
+                 (current-source-location))
+           (clause-alist rest ...)))
+    ((_)
+     '())))
+
+(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
-      ('()
-       (if found
-           (values return found)
-           (raise (formatted-message
+      (()
+       (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)))))
-      ((service . rest)
-       (if (eq? (service-kind service) kind)
-           (loop service return rest)
-           (loop found (cons service return) rest))))))
-
-(define-syntax %apply-clauses
-  (syntax-rules (=> delete)
-    ((_ ((delete kind) . rest) services)
-     (%apply-clauses rest (%delete-service kind services)))
-    ((_ ((kind param => exp ...) . rest) services)
-     (call-with-values (lambda () (%delete-service kind services))
-       (lambda (svcs found)
-         (let ((param (service-value found)))
-           (cons (service (service-kind found)
-                          (begin exp ...))
-                 (%apply-clauses rest svcs))))))
-    ((_ () services)
-     services)))
+                   (service-type-name kind)))))))
+      ((head . tail)
+       (let ((service clauses
+                      (fold2 (lambda (clause service remainder)
+                               (match clause
+                                 ((kind proc properties)
+                                  (if (eq? kind (service-kind service))
+                                      (values (proc service) remainder)
+                                      (values service
+                                              (cons clause remainder))))))
+                             head
+                             '()
+                             clauses)))
+         (loop tail
+               (reverse clauses)
+               (if service
+                   (cons service result)
+                   result)))))))
 
 (define-syntax modify-services
   (syntax-rules ()
@@ -358,11 +389,9 @@ Consider this example:
 
 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.
-
-This is a shorthand for (filter-map (lambda (svc) ...) %base-services)."
-    ((_ services . clauses)
-     (%apply-clauses clauses services))))
+UDEV-SERVICE-TYPE."
+    ((_ services clauses ...)
+     (apply-clauses (clause-alist clauses ...) services))))
 
 
 ;;;