[bug#63538] [PATCH 1/3] tests: Add tests for MODIFY-SERVICES procedure

[bug#63538] [PATCH 1/3] tests: Add tests for MODIFY-SERVICES procedure

[Brian Cully via Guix-patches via]

* 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

[bug#63538] [PATCH v2 1/3] tests: Add tests for MODIFY-SERVICES procedure

[Brian Cully via Guix-patches via]

* 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

[bug#63538] [PATCH v2 2/3] tests: Check for service existence in MODIFY-SERVICES

[Brian Cully via Guix-patches via]

* 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

[bug#63538] [PATCH v2 3/3] gnu: services: Error in MODIFY-SERVICES when services don't exist

[Brian Cully via Guix-patches via]

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

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

[Ludovic Courtès]

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

Hi Brian,

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

Ludo’.


[-- Attachment #2: Type: text/x-patch, Size: 1099 bytes --]

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@protonmail.com>
 ;;; Copyright © 2020 Christine Lemmer-Webber <cwebber@dustycloud.org>
 ;;; Copyright © 2020, 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2023 Brian Cully <bjc@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)