bug#64106: `modify-services` no longer affects multiple instances of the same service

bug#64106: `modify-services` no longer affects multiple instances of the same service

[David Wilson]

Hi Guix!

Recently there was a change to the behavior of `modify-services` that adds logic to check for any unused clauses so that an exception can be raised to alert the user of this case.

https://git.savannah.gnu.org/cgit/guix.git/commit/?id=181951207339508789b28ba7cb914f983319920f

It seems that the new logic has a bug that prevents a used clause from being executed on more than one instance of a compatible service in a single execution of `modify-services`.  Here's a new test case for `gnu/tests/services.scm` that exhibits the issue:

```
(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)))))
```

Here's the output of the test:

```
test-name: modify-services: delete multiple services of the same type
location: /home/daviwil/Projects/Code/guix/tests/services.scm:325
source:
+ (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)))))
expected-value: (1 3)
actual-value: (1 2 3)
result: FAIL
```

The problem occurs because of this `fold2` logic in `apply-clauses` of gnu/services.scm`:

```
                      (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
                             '()
                             clauses)))
```

In the #t case of checking the service kind, `(values (proc service remainder)` is returned, meaning the successful clause is not being added back to the list of clauses as `fold2` continues.  Any subsequent items of the service list will no longer be tested against the removed clause.

I believe this function's logic needs to be updated to keep a list of successful clauses to be diffed against the full clause list at the end of `apply-clauses` so that the unapplied clause list can be determined without having to remove successful clauses in-flight.

If anyone has any pointers on the best way to approach this, I'll be happy to submit a patch!

David

bug#64106: `modify-services` no longer affects multiple instances of the same service

[Josselin Poiret via Bug reports for GNU Guix]

[-- Attachment #1: Type: text/plain, Size: 825 bytes --]

merge 64106 63921
thankyou

Hi David,

"David Wilson" <david@daviwil.com> writes:

> Hi Guix!
>
> Recently there was a change to the behavior of `modify-services` that adds logic to check for any unused clauses so that an exception can be raised to alert the user of this case.
>
> https://git.savannah.gnu.org/cgit/guix.git/commit/?id=181951207339508789b28ba7cb914f983319920f
>
> It seems that the new logic has a bug that prevents a used clause from being executed on more than one instance of a compatible service in a single execution of `modify-services`.  Here's a new test case for `gnu/tests/services.scm` that exhibits the issue:

This was intended, but was probably not a good idea.  I'll look into how
we could revert this while keeping the main idea of the change.

Best,
-- 
Josselin Poiret

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 682 bytes --]

bug#64106: `modify-services` no longer affects multiple instances of the same service

[Ludovic Courtès]

Hi,

Josselin Poiret <dev@jpoiret.xyz> skribis:

> "David Wilson" <david@daviwil.com> writes:
>
>> Hi Guix!
>>
>> Recently there was a change to the behavior of `modify-services` that adds logic to check for any unused clauses so that an exception can be raised to alert the user of this case.
>>
>> https://git.savannah.gnu.org/cgit/guix.git/commit/?id=181951207339508789b28ba7cb914f983319920f
>>
>> It seems that the new logic has a bug that prevents a used clause from being executed on more than one instance of a compatible service in a single execution of `modify-services`.  Here's a new test case for `gnu/tests/services.scm` that exhibits the issue:
>
> This was intended, but was probably not a good idea.

It wasn’t really intended, more a side effect of the implementation, and
I agree it should be fixed.

Ludo’.

bug#64106: `modify-services` no longer affects multiple instances of the same service

[Brian Cully via Bug reports for GNU Guix]

Ludovic Courtès <ludo@gnu.org> writes:

> It wasn’t really intended, more a side effect of the implementation, and
> I agree it should be fixed.

There have been a number of complaints about the behavior change, and I
think the patch should probably be reverted. My only intention was to
raise an error for the cases where a service was used in
‘modify-services’ that wasn't defined, as that's something people would
probably want to know about and fix, but the sequelae to that change
have changed the primary behavior of ‘modify-services’ in a disruptive
way (and without a corresponding news item).

I've taken a number of stabs at tweaking the current code to satisfy
both my desire to raise an error for mis-configurations as well as match
every instance of a service, but I can't find a way to do it that also
preserves service ordering.

However, if ‘modify-services’ can be changed to do two passes, the first
as a sanity check which verifies service references and raises errors,
and the second to do the actual modification, that should work well. I'm
not concerned with efficiency particularly. Unless there are many
thousands of services I sincerely doubt anyone would notice the extra
pass, even on a Raspberry Pi.

WDYT?

-bjc

bug#64106: [PATCH] In modify-services, delete multiple services with one stanza. (Closes: #63921, #64106)

[Felix Lechner via Bug reports for GNU Guix]

With this commit, modify-services will delete all instances of the services
that match the indicated service-type. At the same time, it will also raise
errors for misconfigurations.

The patch was motivated by Brian Cully's statements about the difficult
tradeoff here. [1]

Using the changes respectfully submitted there, modify-services will extract
the "delete" clauses from the clause-alist via code inspired by SRFI-1's
lset-difference. It applies those deletions first, before then passing the
remaining clauses (and the remaining services) on to apply-clauses.

It is possible that apply-clauses can also be simplified since the "delete"
case is now gone, but I remain unsure about how to do that.

This commit was lightly tested on a production machine.

The author owes a deep debt of gratitude to Zipheir from the IRC channel
Libera:#scheme for their expert help in understanding the problem and in
coming up with an elegant solution.

Similarly, Bruno Victal (aka mirai) provided major encouragment with his
participation in the same conversation.

Thank you to both of you!

[1] https://issues.guix.gnu.org/64106#4

* gnu/services.scm: In modify-services, delete multiple services with one
stanza. (Closes: #63921, #64106)
---
 gnu/services.scm | 38 +++++++++++++++++++++++++++++++++++---
 1 file changed, 35 insertions(+), 3 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index 109e050a23..f3772ad6b9 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -46,6 +46,7 @@ (define-module (gnu services)
   #:use-module (gnu packages hurd)
   #:use-module (gnu system setuid)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-8)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-9 gnu)
   #:use-module (srfi srfi-26)
@@ -305,8 +306,7 @@ (define-syntax clause-alist
 is the source location information."
     ((_ (delete kind) rest ...)
      (cons (list kind
-                 (lambda (service)
-                   #f)
+                 #f
                  (current-source-location))
            (clause-alist rest ...)))
     ((_ (kind param => exp ...) rest ...)
@@ -320,6 +320,16 @@ (define-syntax clause-alist
     ((_)
      '())))
 
+(define (clause-kind clause)
+  (match clause
+    ((kind _ _)
+     kind)))
+
+(define (clause-proc clause)
+  (match clause
+    ((_ proc _)
+     proc)))
+
 (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
@@ -393,7 +403,29 @@ (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))))
+     (receive (others deletes) (partition clause-proc (clause-alist clauses ...))
+       (let ((reduced-services (remove (lambda (service)
+                                         (find (lambda (clause)
+                                                 (eq? (clause-kind clause)
+                                                      (service-kind service)))
+                                               deletes))
+                                       services))
+             (deletes-not-found (remove (lambda (clause)
+                                          (find (lambda (service)
+                                                  (eq? (clause-kind clause)
+                                                       (service-kind service)))
+                                                services))
+                                        deletes)))
+         (for-each (lambda (clause)
+                     (raise (make-compound-condition
+                             (condition
+                              (&error-location
+                               (location (current-source-location))))
+                             (formatted-message
+                              (G_ "modify-services: cannot delete '~a'; not present in service list")
+                              (service-type-name (clause-kind clause))))))
+                   deletes-not-found)
+         (apply-clauses others reduced-services))))))
 
 \f
 ;;;

base-commit: 269cfe341f242c2b5f37774cb9b1e17d9aa68e2c
-- 
2.40.1

bug#64106: `modify-services` no longer affects multiple instances of the same service

[Ludovic Courtès]

Hi,

Brian Cully <bjc@spork.org> skribis:

> However, if ‘modify-services’ can be changed to do two passes, the first
> as a sanity check which verifies service references and raises errors,
> and the second to do the actual modification, that should work well. I'm
> not concerned with efficiency particularly. Unless there are many
> thousands of services I sincerely doubt anyone would notice the extra
> pass, even on a Raspberry Pi.

Yeah I think we’ll have to do two passes, or to revert the whole thing.
The former sounds preferable for me.

Could you work on a patch?

Thanks in advance!

Ludo’.

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

[Brian Cully via Bug reports for GNU Guix]

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 ...)))))
 
 \f
 ;;;
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

bug#64106: `modify-services` no longer affects multiple instances of the same service

[Brian Cully via Bug reports for GNU Guix]

I sent a patch to this ticket yesterday, before remembering this morning
that y'all probably weren't auto-Cc'd on it by debbugs.

Please have a look over it, especially the tests, in case I missed some
functionality or misinterpreted some requirements.

This will probably be deserving of a news item, since it will cause
multiple deletes on the same service type to fail, and that's what at
least some people are doing due to the previous patch.

One option would be to convert the ‘raise’ incantations to warnings, at
least for a while to give people a chance to update without their
configs breaking, but I don't know a good way to do that.

-bjc

bug#65184: (modify-services … (delete …)) should delete all matching service types

[Maxim Cournoyer]

Hi Brian!

Brian Cully <bjc@spork.org> writes:

> 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.

[...]

I've applied the following cosmetic changes:

--8<---------------cut here---------------start------------->8---
1 file changed, 20 insertions(+), 18 deletions(-)
gnu/services.scm | 38 ++++++++++++++++++++------------------

modified   gnu/services.scm
@@ -325,11 +325,13 @@ (define-syntax clause-alist
      '())))
 
 (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 (lambda (deleted)
-                   (match deleted
-                     ((deleted-kind _)
-                      (eq? kind deleted-kind))))
+    (match (find (match-lambda
+                   ((deleted-kind _)
+                    (eq? kind deleted-kind)))
                  deleted-services)
       ((_ deleted-properties)
        (raise (make-compound-condition
@@ -344,27 +346,27 @@ (define (apply-clauses clauses service deleted-services)
 
   (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))))
+     (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)
-       (when (not (find (lambda (service)
-                          (eq? kind (service-kind service)))
-                        services))
+       (unless (find (lambda (service)
+                       (eq? kind (service-kind service)))
+                     services)
          (raise (make-compound-condition
                  (condition
                   (&error-location
--8<---------------cut here---------------end--------------->8---

and installed it.  Thanks for contributing to Guix!

-- 
Thanks,
Maxim

bug#64106: bug#65184: (modify-services … (delete …)) should delete all matching service types

[Felix Lechner via Bug reports for GNU Guix]

Hi Maxim,

On Thu, Aug 31, 2023 at 8:49 PM Maxim Cournoyer
<maxim.cournoyer@gmail.com> wrote:
>
> > Fixes: #64106

Thanks for taking action. Can Bug#63921 also be closed?

Kind regards
Felix