futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

services: 'modify-services' preserves service ordering.

Browse Source 
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 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-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (srfi srfi-71)
#:use-module (ice-9 vlist) #:use-module (ice-9 vlist)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:autoload (ice-9 pretty-print) (pretty-print) #: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.")))) (description "This is a simple service."))))
(service type value))) (service type value)))
(define (%delete-service kind services) (define-syntax clause-alist
(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
(syntax-rules (=> delete) (syntax-rules (=> delete)
((_ ((delete kind) . rest) services) "Build an alist of clauses. Each element has the form (KIND PROC LOC)
(%apply-clauses rest (%delete-service kind services))) where PROC is the service transformation procedure to apply for KIND, and LOC
((_ ((kind param => exp ...) . rest) services) is the source location information."
(call-with-values (lambda () (%delete-service kind services)) ((_ (delete kind) rest ...)
(lambda (svcs found) (cons (list kind
(let ((param (service-value found))) (lambda (service)
(cons (service (service-kind found) #f)
(begin exp ...)) (current-source-location))
(%apply-clauses rest svcs)))))) (clause-alist rest ...)))
((_ () services) ((_ (kind param => exp ...) rest ...)
services))) (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 (define-syntax modify-services
(syntax-rules () (syntax-rules ()
@ -358,11 +389,9 @@ Consider this example:
It changes the configuration of the GUIX-SERVICE-TYPE instance, and that of 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 all the MINGETTY-SERVICE-TYPE instances, and it deletes instances of the
UDEV-SERVICE-TYPE. UDEV-SERVICE-TYPE."
((_ services clauses ...)
This is a shorthand for (filter-map (lambda (svc) ...) %base-services)." (apply-clauses (clause-alist clauses ...) services))))
((_ services . clauses)
(%apply-clauses clauses services))))
;;; ;;;

37
tests/services.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU ;;; 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. ;;; This file is part of GNU Guix.
;;; ;;;
@ -287,7 +287,7 @@
(x x)))) (x x))))
(test-equal "modify-services: do nothing" (test-equal "modify-services: do nothing"
'(1 2 3) '(1 2 3) ;note: service order must be preserved
(let* ((t1 (service-type (name 't1) (let* ((t1 (service-type (name 't1)
(extensions '()) (extensions '())
(description ""))) (description "")))
@ -298,12 +298,11 @@
(extensions '()) (extensions '())
(description ""))) (description "")))
(services (list (service t1 1) (service t2 2) (service t3 3)))) (services (list (service t1 1) (service t2 2) (service t3 3))))
(sort (map service-value (map service-value
(modify-services services)) (modify-services services))))
<)))
(test-equal "modify-services: delete service" (test-equal "modify-services: delete service"
'(1) '(1 4) ;note: service order must be preserved
(let* ((t1 (service-type (name 't1) (let* ((t1 (service-type (name 't1)
(extensions '()) (extensions '())
(description ""))) (description "")))
@ -313,12 +312,15 @@
(t3 (service-type (name 't3) (t3 (service-type (name 't3)
(extensions '()) (extensions '())
(description ""))) (description "")))
(services (list (service t1 1) (service t2 2) (service t3 3)))) (t4 (service-type (name 't4)
(sort (map service-value (extensions '())
(modify-services services (description "")))
(delete t3) (services (list (service t1 1) (service t2 2)
(delete t2))) (service t3 3) (service t4 4))))
<))) (map service-value
(modify-services services
(delete t3)
(delete t2)))))
(test-error "modify-services: delete non-existing service" (test-error "modify-services: delete non-existing service"
#t #t
@ -336,7 +338,7 @@
(delete t3)))) (delete t3))))
(test-equal "modify-services: change value" (test-equal "modify-services: change value"
'(2 11 33) '(11 2 33) ;note: service order must be preserved
(let* ((t1 (service-type (name 't1) (let* ((t1 (service-type (name 't1)
(extensions '()) (extensions '())
(description ""))) (description "")))
@ -347,11 +349,10 @@
(extensions '()) (extensions '())
(description ""))) (description "")))
(services (list (service t1 1) (service t2 2) (service t3 3)))) (services (list (service t1 1) (service t2 2) (service t3 3))))
(sort (map service-value (map service-value
(modify-services services (modify-services services
(t1 value => 11) (t1 value => 11)
(t3 value => 33))) (t3 value => 33)))))
<)))
(test-error "modify-services: change value for non-existing service" (test-error "modify-services: change value for non-existing service"
#t #t