GNU bug report logs - #63538
[PATCH] gnu: services: Error in MODIFY-SERVICES when services don't exist

Previous Next

Package: guix-patches;

Reported by: Brian Cully <bjc <at> spork.org>

Date: Tue, 16 May 2023 15:40:02 UTC

Severity: normal

Tags: patch

Done: Ludovic Courtès <ludo <at> gnu.org>

Bug is archived. No further changes may be made.

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 63538 in the body.
You can then email your comments to 63538 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

View this report as an mbox folder, status mbox, maintainer mbox

Report forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Tue, 16 May 2023 15:40:02 GMT) Full text and rfc822 format available.
Acknowledgement sent to Brian Cully <bjc <at> spork.org>:
New bug report received and forwarded. Copy sent to guix-patches <at> gnu.org. (Tue, 16 May 2023 15:40:02 GMT) Full text and rfc822 format available.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: guix-patches <at> gnu.org
Cc: Brian Cully <bjc <at> spork.org>
Subject: [PATCH 1/3] tests: Add tests for MODIFY-SERVICES procedure
Date: Tue, 16 May 2023 11:39:37 -0400

* tests/services.scm ("modify-services: do nothing")
("modify-services: delete service")
("modify-services: change value"): New tests.
---
 tests/services.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

diff --git a/tests/services.scm b/tests/services.scm
index 8e35758209..435f39e59b 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -286,4 +286,54 @@ (define-module (test-services)
          ((one) one)
          (x x))))
 
+(test-equal "modify-services: do nothing"
+  '(1 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))))
+    (sort (map service-value
+               (modify-services services))
+          <)))
+
+(test-equal "modify-services: delete service"
+  '(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 t3 3))))
+    (sort (map service-value
+               (modify-services services
+                 (delete t2)))
+          <)))
+
+(test-equal "modify-services: change value"
+  '(1 2 33)
+  (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))))
+    (sort (map service-value
+               (modify-services services
+                 (t3 value => 33)))
+          <)))
+
 (test-end)

base-commit: b363fab46f5af42b3f653e2fee1834477bd5aacd
prerequisite-patch-id: 8a03c5e8bcd4c526b93c558d550725887f932e41
prerequisite-patch-id: 89400c29b4c30dfbe8492aff1751ca583397b4f0
prerequisite-patch-id: a1963f772e753239b80e6a7b0d9f55e0ab4d662b
prerequisite-patch-id: b047430c30ba9ea274aea33a467cdb49d769884e
-- 
2.40.1
Information forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Tue, 16 May 2023 15:42:01 GMT) Full text and rfc822 format available.

Message #8 received at 63538 <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: 63538 <at> debbugs.gnu.org
Cc: Brian Cully <bjc <at> spork.org>
Subject: [PATCH 2/3] tests: Check for service existence in MODIFY-SERVICES
Date: Tue, 16 May 2023 11:41:41 -0400

* tests/services.scm ("modify-services: delete non-existing service")
("modify-services: change value for non-existing service"): New tests.
---
 tests/services.scm | 31 +++++++++++++++++++++++++++++++
 1 file changed, 31 insertions(+)

diff --git a/tests/services.scm b/tests/services.scm
index 435f39e59b..5a9cd47489 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -319,6 +319,21 @@ (define-module (test-services)
                  (delete t2)))
           <)))
 
+(test-error "modify-services: delete non-existing service"
+  #t
+  (let* ((t1 (service-type (name 't1)
+                           (extensions '())
+                           (description "")))
+         (t2 (service-type (name 't2)
+                           (extensions '())
+                           (description "")))
+         (t3 (service-type (name 't2)
+                           (extensions '())
+                           (description "")))
+         (services (list (service t1 1) (service t2 2))))
+    (modify-services services
+      (delete t3))))
+
 (test-equal "modify-services: change value"
   '(1 2 33)
   (let* ((t1 (service-type (name 't1)
@@ -336,4 +351,20 @@ (define-module (test-services)
                  (t3 value => 33)))
           <)))
 
+(test-error "modify-services: change value for non-existing service"
+  #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 t3 3))))
+    (map service-value
+         (modify-services services
+           (t2 value => 22)))))
+
 (test-end)
-- 
2.40.1
Information forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Tue, 16 May 2023 15:42:01 GMT) Full text and rfc822 format available.

Message #11 received at 63538 <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: 63538 <at> debbugs.gnu.org
Cc: Brian Cully <bjc <at> spork.org>
Subject: [PATCH 3/3] gnu: services: Error in MODIFY-SERVICES when services
 don't exist
Date: Tue, 16 May 2023 11:41:42 -0400

This patch causes MODIFY-SERVICES to raise an error if a reference is made to
a service which isn't in its service list. This it to help users notice if
they have an invalid rule, which is currently silently ignored.

* gnu/services.scm (%delete-service):  new procedure
(%apply-clauses): new syntax rule
(%modify-service): remove syntax rule
---
 gnu/services.scm | 47 ++++++++++++++++++++++++++++++-----------------
 1 file changed, 30 insertions(+), 17 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index d6c7ad0553..988325b253 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -296,20 +296,35 @@ (define (simple-service name target value)
                                   (description "This is a simple service."))))
     (service type value)))
 
-(define-syntax %modify-service
+(define (%delete-service kind services)
+  (let loop ((found #f)
+             (return '())
+             (services services))
+    (match services
+      ('()
+       (if found
+           (values return found)
+           (raise (formatted-message
+                   (G_ "modify-services: service '~a' not found in service list")
+                   (service-type-name kind)))))
+      ((svc . rest)
+       (if (eq? (service-kind svc) kind)
+           (loop svc return rest)
+           (loop found (cons svc return) rest))))))
+
+(define-syntax %apply-clauses
   (syntax-rules (=> delete)
-    ((_ svc (delete kind) clauses ...)
-     (if (eq? (service-kind svc) kind)
-         #f
-         (%modify-service svc clauses ...)))
-    ((_ service)
-     service)
-    ((_ svc (kind param => exp ...) clauses ...)
-     (if (eq? (service-kind svc) kind)
-         (let ((param (service-value svc)))
-           (service (service-kind svc)
-                    (begin exp ...)))
-         (%modify-service svc clauses ...)))))
+    ((_ ((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 ...))
+                 svcs)))))
+    ((_ () services)
+     services)))
 
 (define-syntax modify-services
   (syntax-rules ()
@@ -345,10 +360,8 @@ (define-syntax modify-services
 UDEV-SERVICE-TYPE.
 
 This is a shorthand for (filter-map (lambda (svc) ...) %base-services)."
-    ((_ services clauses ...)
-     (filter-map (lambda (service)
-                   (%modify-service service clauses ...))
-                 services))))
+    ((_ services . clauses)
+     (%apply-clauses clauses services))))
 
 
 ;;;
-- 
2.40.1
Changed bug title to '[PATCH] gnu: services: Error in MODIFY-SERVICES when services don't exist' from '[PATCH 1/3] tests: Add tests for MODIFY-SERVICES procedure' Request was from Brian Cully <bjc <at> spork.org> to control <at> debbugs.gnu.org. (Tue, 16 May 2023 17:55:02 GMT) Full text and rfc822 format available.
Information forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Fri, 26 May 2023 22:29:01 GMT) Full text and rfc822 format available.

Message #16 received at 63538 <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: 63538 <at> debbugs.gnu.org
Subject: Re: bug#63538: [PATCH] gnu: services: Error in MODIFY-SERVICES when
 services don't exist
Date: Fri, 26 May 2023 18:27:59 -0400

 The previous patch is incorrect, because it didn't continue recursing
 after a modify rule. The next set fixes that, and adds a test for it.
Information forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Fri, 26 May 2023 22:31:01 GMT) Full text and rfc822 format available.

Message #19 received at 63538 <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: 63538 <at> debbugs.gnu.org
Cc: Brian Cully <bjc <at> spork.org>
Subject: [PATCH v2 1/3] tests: Add tests for MODIFY-SERVICES procedure
Date: Fri, 26 May 2023 18:30:15 -0400

* tests/services.scm ("modify-services: do nothing")
("modify-services: delete service")
("modify-services: change value"): New tests.
---
 tests/services.scm | 50 ++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

diff --git a/tests/services.scm b/tests/services.scm
index 8e35758209..435f39e59b 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -286,4 +286,54 @@ (define-module (test-services)
          ((one) one)
          (x x))))
 
+(test-equal "modify-services: do nothing"
+  '(1 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))))
+    (sort (map service-value
+               (modify-services services))
+          <)))
+
+(test-equal "modify-services: delete service"
+  '(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 t3 3))))
+    (sort (map service-value
+               (modify-services services
+                 (delete t2)))
+          <)))
+
+(test-equal "modify-services: change value"
+  '(1 2 33)
+  (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))))
+    (sort (map service-value
+               (modify-services services
+                 (t3 value => 33)))
+          <)))
+
 (test-end)

base-commit: 1be6baed2b58a75868cdcc9f51b78624c2fefc4f
-- 
2.40.1
Information forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Fri, 26 May 2023 22:31:02 GMT) Full text and rfc822 format available.

Message #22 received at 63538 <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: 63538 <at> debbugs.gnu.org
Cc: Brian Cully <bjc <at> spork.org>
Subject: [PATCH v2 2/3] tests: Check for service existence in MODIFY-SERVICES
Date: Fri, 26 May 2023 18:30:16 -0400

* tests/services.scm ("modify-services: delete non-existing service")
("modify-services: change value for non-existing service"): New tests.
---
 tests/services.scm | 37 +++++++++++++++++++++++++++++++++++--
 1 file changed, 35 insertions(+), 2 deletions(-)

diff --git a/tests/services.scm b/tests/services.scm
index 435f39e59b..8cdb1b2a31 100644
--- a/tests/services.scm
+++ b/tests/services.scm
@@ -303,7 +303,7 @@ (define-module (test-services)
           <)))
 
 (test-equal "modify-services: delete service"
-  '(1 3)
+  '(1)
   (let* ((t1 (service-type (name 't1)
                            (extensions '())
                            (description "")))
@@ -316,11 +316,27 @@ (define-module (test-services)
          (services (list (service t1 1) (service t2 2) (service t3 3))))
     (sort (map service-value
                (modify-services services
+                 (delete t3)
                  (delete t2)))
           <)))
 
+(test-error "modify-services: delete non-existing service"
+  #t
+  (let* ((t1 (service-type (name 't1)
+                           (extensions '())
+                           (description "")))
+         (t2 (service-type (name 't2)
+                           (extensions '())
+                           (description "")))
+         (t3 (service-type (name 't2)
+                           (extensions '())
+                           (description "")))
+         (services (list (service t1 1) (service t2 2))))
+    (modify-services services
+      (delete t3))))
+
 (test-equal "modify-services: change value"
-  '(1 2 33)
+  '(2 11 33)
   (let* ((t1 (service-type (name 't1)
                            (extensions '())
                            (description "")))
@@ -333,7 +349,24 @@ (define-module (test-services)
          (services (list (service t1 1) (service t2 2) (service t3 3))))
     (sort (map service-value
                (modify-services services
+                 (t1 value => 11)
                  (t3 value => 33)))
           <)))
 
+(test-error "modify-services: change value for non-existing service"
+  #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 t3 3))))
+    (map service-value
+         (modify-services services
+           (t2 value => 22)))))
+
 (test-end)
-- 
2.40.1
Information forwarded to guix-patches <at> gnu.org:
bug#63538; Package guix-patches. (Fri, 26 May 2023 22:31:02 GMT) Full text and rfc822 format available.

Message #25 received at 63538 <at> debbugs.gnu.org (full text, mbox):

From: Brian Cully <bjc <at> spork.org>
To: 63538 <at> debbugs.gnu.org
Cc: Brian Cully <bjc <at> spork.org>
Subject: [PATCH v2 3/3] gnu: services: Error in MODIFY-SERVICES when services
 don't exist
Date: Fri, 26 May 2023 18:30:17 -0400

This patch causes MODIFY-SERVICES to raise an error if a reference is made to
a service which isn't in its service list. This it to help users notice if
they have an invalid rule, which is currently silently ignored.

* gnu/services.scm (%delete-service):  new procedure
(%apply-clauses): new syntax rule
(%modify-service): remove syntax rule
---
 gnu/services.scm | 47 ++++++++++++++++++++++++++++++-----------------
 1 file changed, 30 insertions(+), 17 deletions(-)

diff --git a/gnu/services.scm b/gnu/services.scm
index 31eba9f035..a58cffe536 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -296,20 +296,35 @@ (define (simple-service name target value)
                                   (description "This is a simple service."))))
     (service type value)))
 
-(define-syntax %modify-service
+(define (%delete-service kind services)
+  (let loop ((found #f)
+             (return '())
+             (services services))
+    (match services
+      ('()
+       (if found
+           (values return found)
+           (raise (formatted-message
+                   (G_ "modify-services: service '~a' not found in service list")
+                   (service-type-name kind)))))
+      ((svc . rest)
+       (if (eq? (service-kind svc) kind)
+           (loop svc return rest)
+           (loop found (cons svc return) rest))))))
+
+(define-syntax %apply-clauses
   (syntax-rules (=> delete)
-    ((_ svc (delete kind) clauses ...)
-     (if (eq? (service-kind svc) kind)
-         #f
-         (%modify-service svc clauses ...)))
-    ((_ service)
-     service)
-    ((_ svc (kind param => exp ...) clauses ...)
-     (if (eq? (service-kind svc) kind)
-         (let ((param (service-value svc)))
-           (service (service-kind svc)
-                    (begin exp ...)))
-         (%modify-service svc clauses ...)))))
+    ((_ ((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)))
 
 (define-syntax modify-services
   (syntax-rules ()
@@ -345,10 +360,8 @@ (define-syntax modify-services
 UDEV-SERVICE-TYPE.
 
 This is a shorthand for (filter-map (lambda (svc) ...) %base-services)."
-    ((_ services clauses ...)
-     (filter-map (lambda (service)
-                   (%modify-service service clauses ...))
-                 services))))
+    ((_ services . clauses)
+     (%apply-clauses clauses services))))
 
 
 ;;;
-- 
2.40.1
Reply sent to Ludovic Courtès <ludo <at> gnu.org>:
You have taken responsibility. (Fri, 02 Jun 2023 14:23:03 GMT) Full text and rfc822 format available.
Notification sent to Brian Cully <bjc <at> spork.org>:
bug acknowledged by developer. (Fri, 02 Jun 2023 14:23:03 GMT) Full text and rfc822 format available.

Message #30 received at 63538-done <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: Brian Cully <bjc <at> spork.org>
Cc: 63538-done <at> debbugs.gnu.org
Subject: Re: bug#63538: [PATCH] gnu: services: Error in MODIFY-SERVICES when
 services don't exist
Date: Fri, 02 Jun 2023 16:22:44 +0200

[Message part 1 (text/plain, inline)]
Hi Brian,

Applied with the minor change below.  Thanks for working on this!

Ludo’.


[Message part 2 (text/x-patch, inline)]
diff --git a/gnu/services.scm b/gnu/services.scm
index a58cffe536..a990d297c9 100644
--- a/gnu/services.scm
+++ b/gnu/services.scm
@@ -6,6 +6,7 @@
 ;;; Copyright © 2021 raid5atemyhomework <raid5atemyhomework <at> protonmail.com>
 ;;; Copyright © 2020 Christine Lemmer-Webber <cwebber <at> dustycloud.org>
 ;;; Copyright © 2020, 2021 Brice Waegeneire <brice <at> waegenei.re>
+;;; Copyright © 2023 Brian Cully <bjc <at> spork.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -307,10 +308,10 @@ (define (%delete-service kind services)
            (raise (formatted-message
                    (G_ "modify-services: service '~a' not found in service list")
                    (service-type-name kind)))))
-      ((svc . rest)
-       (if (eq? (service-kind svc) kind)
-           (loop svc return rest)
-           (loop found (cons svc return) rest))))))
+      ((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)
bug archived. Request was from Debbugs Internal Request <help-debbugs <at> gnu.org> to internal_control <at> debbugs.gnu.org. (Sat, 01 Jul 2023 11:24:08 GMT) Full text and rfc822 format available.
This bug report was last modified 1 year and 315 days ago.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.