me
/
guix
Archived
1
0
Fork 0
Code

services: 'modify-services' preserves service ordering. 

Fixes <https://issues.guix.gnu.org/63921>.

The regression was introduced in
dbbc7e9461, 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.
master
Ludovic Courtès 2023-06-06 11:41:39 +02:00
parent dc0c5d56ee
commit 1819512073
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
2 changed files with 81 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

95
gnu/services.scm
View File

@ -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))
(match services
('()
(if found
(values return found)
(raise (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
(define-syntax clause-alist
(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)))
"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
(()
(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)
(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))))
;;;

37
tests/services.scm
View File

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