[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
03/03: services: 'modify-services' preserves service ordering.
|
From: |
guix-commits |
|
Subject: |
03/03: services: 'modify-services' preserves service ordering. |
|
Date: |
Tue, 6 Jun 2023 05:56:15 -0400 (EDT) |
civodul pushed a commit to branch master
in repository guix.
commit 181951207339508789b28ba7cb914f983319920f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jun 6 11:41:39 2023 +0200
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.
---
gnu/services.scm | 93 +++++++++++++++++++++++++++++++++++-------------------
tests/services.scm | 37 +++++++++++-----------
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