mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 07:26:13 -05:00
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.
This commit is contained in:
Ludovic Courtès
parent
dc0c5d56ee
commit
1819512073
2 changed files with 81 additions and 51 deletions
|
|
@ -51,6 +51,7 @@ (define-module (gnu services)
|
|||
#: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 @@ (define (simple-service name target value)
|
|||
(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 @@ (define-syntax modify-services
|
|||
|
||||
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))))
|
||||
|
||||
|
||||
;;;
|
||||
|
|
|
|||
|
|
@ -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 @@ (define-module (test-services)
|
|||
(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 @@ (define-module (test-services)
|
|||
(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 @@ (define-module (test-services)
|
|||
(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 @@ (define-module (test-services)
|
|||
(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 @@ (define-module (test-services)
|
|||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue