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.

2 files changed, 80 insertions, 50 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))))
 
 
 ;;;
diff --git a/tests/services.scm b/tests/services.scm
index 8cdb1b2a31..20ff4d317e 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015-2019, 2022 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015-2019, 2022, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -287,7 +287,7 @@
          (x x))))
 
 (test-equal "modify-services: do nothing"
-  '(1 2 3)
+  '(1 2 3)                              ;note: service order must be preserved
   (let* ((t1 (service-type (name 't1)
                            (extensions '())
                            (description "")))
@@ -298,12 +298,11 @@
                            (extensions '())
                            (description "")))
          (services (list (service t1 1) (service t2 2) (service t3 3))))
-    (sort (map service-value
-               (modify-services services))
-          <)))
+    (map service-value
+         (modify-services services))))
 
 (test-equal "modify-services: delete service"
-  '(1)
+  '(1 4)                                ;note: service order must be preserved
   (let* ((t1 (service-type (name 't1)
                            (extensions '())
                            (description "")))
@@ -313,12 +312,15 @@
          (t3 (service-type (name 't3)
                            (extensions '())
                            (description "")))
-         (services (list (service t1 1) (service t2 2) (service t3 3))))
-    (sort (map service-value
-               (modify-services services
-                 (delete t3)
-                 (delete t2)))
-          <)))
+         (t4 (service-type (name 't4)
+                           (extensions '())
+                           (description "")))
+         (services (list (service t1 1) (service t2 2)
+                         (service t3 3) (service t4 4))))
+    (map service-value
+         (modify-services services
+           (delete t3)
+           (delete t2)))))
 
 (test-error "modify-services: delete non-existing service"
   #t
@@ -336,7 +338,7 @@
       (delete t3))))
 
 (test-equal "modify-services: change value"
-  '(2 11 33)
+  '(11 2 33)                            ;note: service order must be preserved
   (let* ((t1 (service-type (name 't1)
                            (extensions '())
                            (description "")))
@@ -347,11 +349,10 @@
                            (extensions '())
                            (description "")))
          (services (list (service t1 1) (service t2 2) (service t3 3))))
-    (sort (map service-value
-               (modify-services services
-                 (t1 value => 11)
-                 (t3 value => 33)))
-          <)))
+    (map service-value
+         (modify-services services
+           (t1 value => 11)
+           (t3 value => 33)))))
 
 (test-error "modify-services: change value for non-existing service"
   #t