* modules/shepherd/service.scm (endpoint->listening-socket)
(open-sockets): New procedures.
(make-inetd-constructor): Change 'address' parameter to 'endpoints'.
Mark #:socket-style, #:socket-owner, #:socket-group,
#:socket-directory-permissions,
and #:listen-backlog as deprecated.
[spawn-child-service, accept-clients]: Take 'server-address' parameter
and use it. Update callers.
Add compatibility later for when ENDPOINTS is an address.
(make-inetd-destructor): Adjust.
(make-systemd-destructor)[endpoint->listening-socket, open-sockets]:
Remove.
Adjust to new return value of 'open-sockets'.
* NEWS: Mention it.
---
NEWS | 13 ++
doc/shepherd.texi | 54 ++++----
modules/shepherd/service.scm | 255 +++++++++++++++++------------------
3 files changed, 161 insertions(+), 161 deletions(-)
diff --git a/NEWS b/NEWS
index c51e8e2..4ce7a48 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,19 @@ Copyright © 2013-2014, 2016, 2018-2020, 2022 Ludovic Courtès
<l...@gnu.org>
Please send Shepherd bug reports to bug-guix@gnu.org.
* Changes in version 0.9.1
+** ‘make-inetd-constructor’ now accepts a list of endpoints
+
+In 0.9.0, ‘make-inetd-constructor’ would take a single address as returned by
+‘make-socket-address’. This was insufficiently flexible since it didn’t let
+you have an inetd service with multiple endpoints. ‘make-inetd-constructor’
+now takes a list of endpoints, similar to what ‘make-systemd-constructor’
+already did.
+
+For compatibility with 0.9.0, if the second argument to
+‘make-systemd-constructor’ is an address, it is automatically converted to a
+list of endpoints. This behavior will be preserved for at least the whole
+0.9.x series.
+
** ‘shepherd’ reports whether a service is transient
** ‘herd status’ shows whether a service is transient
** Fix possible file descriptor leak in ‘make-inetd-constructor’
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 3d01186..9efc48e 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1082,11 +1082,28 @@ services, specifically those in @code{nowait} mode
where the daemon is
passed the newly-accepted socket connection while @command{shepherd} is
in charge of listening.
-@deffn {procedure} make-inetd-constructor @var{command} @var{address}
- [#:service-name-stem _] [#:requirements '()] @
- [#:socket-style SOCK_STREAM] [#:listen-backlog 10] @
+Listening endpoints for such services are described as records built
+using the @code{endpoint} procedure:
+
+@deffn {procedure} endpoint @var{address} [#:name "unknown"] @
+ [#:style SOCK_STREAM] [#:backlog 128] @
[#:socket-owner (getuid)] [#:socket-group (getgid)] @
- [#:socket-directory-permissions #o755] @
+ [#:socket-directory-permissions #o755]
+Return a new endpoint called @var{name} of @var{address}, an address as
+return by @code{make-socket-address}, with the given @var{style} and
+@var{backlog}.
+
+When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
+@var{socket-group} are strings or integers that specify its ownership and that
+of its parent directory; @var{socket-directory-permissions} specifies the
+permissions for its parent directory.
+@end deffn
+
+The inetd service constructor takes a command and a list of such
+endpoints:
+
+@deffn {procedure} make-inetd-constructor @var{command} @var{endpoints}
+ [#:service-name-stem _] [#:requirements '()] @
[#:max-connections (default-inetd-max-connections)] @
[#:user #f] @
[#:group #f] @
@@ -1095,14 +1112,9 @@ in charge of listening.
[#:file-creation-mask #f] [#:create-session? #t] @
[#:resource-limits '()] @
[#:environment-variables (default-environment-variables)]
-Return a procedure that opens a socket listening to @var{address}, an
-object as returned by @code{make-socket-address}, and accepting connections in
-the background; the @var{listen-backlog} argument is passed to @var{accept}.
-
-When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
-@var{socket-group} are strings or integers that specify its ownership and that
-of its parent directory; @var{socket-directory-permissions} specifies the
-permissions for its parent directory.
+Return a procedure that opens sockets listening to @var{endpoints}, a list
+of objects as returned by @code{endpoint}, and accepting connections in the
+background.
Upon a client connection, a transient service running @var{command} is
spawned. Only up to @var{max-connections} simultaneous connections are
@@ -1133,24 +1145,6 @@ environment (see below), which usually checks them using
the libsystemd
or libelogind
@uref{https://www.freedesktop.org/software/systemd/man/sd_listen_fds.html,
client library helper functions}.
-
-Listening endpoints for such services are described as records built
-using the @code{endpoint} procedure:
-
-@deffn {procedure} endpoint @var{address} [#:name "unknown"] @
- [#:style SOCK_STREAM] [#:backlog 128] @
- [#:socket-owner (getuid)] [#:socket-group (getgid)] @
- [#:socket-directory-permissions #o755]
-Return a new endpoint called @var{name} of @var{address}, an address as
-return by @code{make-socket-address}, with the given @var{style} and
-@var{backlog}.
-
-When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
-@var{socket-group} are strings or integers that specify its ownership and that
-of its parent directory; @var{socket-directory-permissions} specifies the
-permissions for its parent directory.
-@end deffn
-
The constructor and destructor for systemd-style daemons are described
below.
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index ded8283..e93466a 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -1225,6 +1225,90 @@ as argument, where SIGNAL defaults to `SIGTERM'."
(lambda (ignored . args)
(not (zero? (status:exit-val (system (apply string-append command)))))))
+
+;;;
+;;; Server endpoints.
+;;;
+
+;; Endpoint of a systemd-style or inetd-style service.
+(define-record-type <endpoint>
+ (make-endpoint name address style backlog owner group permissions)
+ endpoint?
+ (name endpoint-name) ;string
+ (address endpoint-address) ;socket address
+ (style endpoint-style) ;SOCK_STREAM, etc.
+ (backlog endpoint-backlog) ;integer
+ (owner endpoint-socket-owner) ;integer
+ (group endpoint-socket-group) ;integer
+ (permissions endpoint-socket-directory-permissions)) ;integer
+
+(define* (endpoint address
+ #:key (name "unknown") (style SOCK_STREAM)
+ (backlog 128)
+ (socket-owner (getuid)) (socket-group (getgid))
+ (socket-directory-permissions #o755))
+ "Return a new endpoint called @var{name} of @var{address}, an address as
+return by @code{make-socket-address}, with the given @var{style} and
+@var{backlog}.
+
+When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
+@var{socket-group} are strings or integers that specify its ownership and that
+of its parent directory; @var{socket-directory-permissions} specifies the
+permissions for its parent directory."
+ (make-endpoint name address style backlog
+ socket-owner socket-group
+ socket-directory-permissions))
+
+(define (endpoint->listening-socket endpoint)
+ "Return a listening socket for ENDPOINT."
+ (match endpoint
+ (($ <endpoint> name address style backlog
+ owner group permissions)
+ (let* ((sock (non-blocking-port
+ (socket (sockaddr:fam address) style 0)))
+ (owner (if (integer? owner)
+ owner
+ (passwd:uid (getpwnam owner))))
+ (group (if (integer? group)
+ group
+ (group:gid (getgrnam group)))))
+ (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+ (when (= AF_UNIX (sockaddr:fam address))
+ (mkdir-p (dirname (sockaddr:path address)) permissions)
+ (chown (dirname (sockaddr:path address)) owner group)
+ (catch-system-error (delete-file (sockaddr:path address))))
+
+ (bind sock address)
+ (listen sock backlog)
+
+ (when (= AF_UNIX (sockaddr:fam address))
+ (chown sock owner group)
+ (chmod sock #o666))
+
+ sock))))
+
+(define (open-sockets endpoints)
+ "Return a list of listening sockets corresponding to ENDPOINTS, in the same
+order as ENDPOINTS. If opening of binding one of them fails, an exception is
+thrown an previously-opened sockets are closed."
+ (let loop ((endpoints endpoints)
+ (result '()))
+ (match endpoints
+ (()
+ (reverse result))
+ ((head tail ...)
+ (let ((sock (catch 'system-error
+ (lambda ()
+ (endpoint->listening-socket head))
+ (lambda args
+ ;; When opening one socket fails, abort the whole
+ ;; process.
+ (for-each (match-lambda
+ ((_ . socket) (close-port socket)))
+ result)
+ (apply throw args)))))
+ (loop tail (cons sock result)))))))
+
;;;
;;; Inetd-style services.
@@ -1311,18 +1395,13 @@ as argument, where SIGNAL defaults to `SIGTERM'."
;; service.
(make-parameter 100))
-(define* (make-inetd-constructor command address
+(define* (make-inetd-constructor command endpoints
#:key
(service-name-stem
(match command
((program . _)
(basename program))))
(requirements '())
- (socket-style SOCK_STREAM)
- (socket-owner (getuid))
- (socket-group (getgid))
- (socket-directory-permissions #o755)
- (listen-backlog 10)
(max-connections
(default-inetd-max-connections))
(user #f)
@@ -1333,15 +1412,17 @@ as argument, where SIGNAL defaults to `SIGTERM'."
(create-session? #t)
(environment-variables
(default-environment-variables))
- (resource-limits '()))
- "Return a procedure that opens a socket listening to @var{address}, an
-object as returned by @code{make-socket-address}, and accepting connections in
-the background; the @var{listen-backlog} argument is passed to @var{accept}.
+ (resource-limits '())
-When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
-@var{socket-group} are strings or integers that specify its ownership and that
-of its parent directory; @var{socket-directory-permissions} specifies the
-permissions for its parent directory.
+ ;; Deprecated.
+ (socket-style SOCK_STREAM)
+ (socket-owner (getuid))
+ (socket-group (getgid))
+ (socket-directory-permissions #o755)
+ (listen-backlog 10))
+ "Return a procedure that opens sockets listening to @var{endpoints}, a list
+of objects as returned by @code{endpoint}, and accepting connections in the
+background.
Upon a client connection, a transient service running @var{command} is
spawned. Only up to @var{max-connections} simultaneous connections are
@@ -1370,7 +1451,7 @@ The remaining arguments are as for
@code{make-forkexec-constructor}."
connection-count (canonical-name service))
(default-service-termination-handler service status))
- (define (spawn-child-service connection client-address)
+ (define (spawn-child-service connection server-address client-address)
(let* ((name (child-service-name))
(service (make <service>
#:provides (list name)
@@ -1387,7 +1468,7 @@ The remaining arguments are as for
@code{make-forkexec-constructor}."
#:file-creation-mask file-creation-mask
#:create-session? create-session?
#:environment-variables
- (append (inetd-variables address
+ (append (inetd-variables server-address
client-address)
environment-variables)
#:resource-limits resource-limits)
@@ -1396,7 +1477,7 @@ The remaining arguments are as for
@code{make-forkexec-constructor}."
(register-services service)
(start service)))
- (define (accept-clients sock)
+ (define (accept-clients server-address sock)
;; Return a thunk that accepts client connections from SOCK.
(lambda ()
(let loop ()
@@ -1407,7 +1488,7 @@ The remaining arguments are as for
@code{make-forkexec-constructor}."
(local-output
(l10n "Maximum number of ~a clients reached; \
rejecting connection from ~:[~a~;~*local process~].")
- (socket-address->string address)
+ (socket-address->string server-address)
(= AF_UNIX (sockaddr:fam client-address))
(socket-address->string client-address))
(close-port connection))
@@ -1415,46 +1496,35 @@ rejecting connection from ~:[~a~;~*local process~].")
(set! connection-count (+ 1 connection-count))
(local-output
(l10n "Accepted connection on ~a from ~:[~a~;~*local
process~].")
- (socket-address->string address)
+ (socket-address->string server-address)
(= AF_UNIX (sockaddr:fam client-address))
(socket-address->string client-address))
- (spawn-child-service connection client-address)))))
+ (spawn-child-service connection
+ server-address client-address)))))
(loop))))
(lambda args
- (let ((owner (if (integer? socket-owner)
- socket-owner
- (passwd:uid (getpwnam socket-owner))))
- (group (if (integer? socket-group)
- socket-group
- (group:gid (getgrnam socket-group))))
- (sock (socket (sockaddr:fam address) socket-style 0)))
- (catch #t
- (lambda ()
- (non-blocking-port sock)
- (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
-
- (when (= AF_UNIX (sockaddr:fam address))
- (mkdir-p (dirname (sockaddr:path address))
- socket-directory-permissions)
- (chown (dirname (sockaddr:path address)) owner group)
- (catch-system-error (delete-file (sockaddr:path address))))
- (bind sock address)
- (when (= AF_UNIX (sockaddr:fam address))
- (chown sock owner group)
- (chmod sock #o666))
-
- (listen sock listen-backlog)
- (spawn-fiber (accept-clients sock))
- sock)
- (lambda args
- (close-port sock)
- (apply throw args))))))
+ (let* ((endpoints (match endpoints
+ (((? endpoint?) ...) endpoints)
+ (address (list (endpoint address
+ #:style socket-style
+ #:backlog listen-backlog
+ #:socket-owner socket-owner
+ #:socket-group socket-group
+ #:socket-directory-permissions
+
socket-directory-permissions)))))
+ (sockets (open-sockets endpoints)))
+ (for-each (lambda (endpoint socket)
+ (spawn-fiber
+ (accept-clients (endpoint-address endpoint)
+ socket)))
+ endpoints sockets)
+ sockets)))
(define (make-inetd-destructor)
"Return a procedure that terminates an inetd service."
- (lambda (sock)
- (close-port sock)
+ (lambda (sockets)
+ (for-each close-port sockets)
#f))
@@ -1462,35 +1532,6 @@ rejecting connection from ~:[~a~;~*local process~].")
;;; systemd-style services.
;;;
-;; Endpoint of a systemd-style service.
-(define-record-type <endpoint>
- (make-endpoint name address style backlog owner group permissions)
- endpoint?
- (name endpoint-name) ;string
- (address endpoint-address) ;socket address
- (style endpoint-style) ;SOCK_STREAM, etc.
- (backlog endpoint-backlog) ;integer
- (owner endpoint-socket-owner) ;integer
- (group endpoint-socket-group) ;integer
- (permissions endpoint-socket-directory-permissions)) ;integer
-
-(define* (endpoint address
- #:key (name "unknown") (style SOCK_STREAM)
- (backlog 128)
- (socket-owner (getuid)) (socket-group (getgid))
- (socket-directory-permissions #o755))
- "Return a new endpoint called @var{name} of @var{address}, an address as
-return by @code{make-socket-address}, with the given @var{style} and
-@var{backlog}.
-
-When @var{address} is of type @code{AF_UNIX}, @var{socket-owner} and
-@var{socket-group} are strings or integers that specify its ownership and that
-of its parent directory; @var{socket-directory-permissions} specifies the
-permissions for its parent directory."
- (make-endpoint name address style backlog
- socket-owner socket-group
- socket-directory-permissions))
-
(define (wait-for-readable ports)
"Suspend the current task until one of @var{ports} is available for
reading."
@@ -1538,58 +1579,10 @@ The colon-separated list of endpoint names.
This must be paired with @code{make-systemd-destructor}."
(lambda args
- (define (endpoint->listening-socket endpoint)
- ;; Return a listening socket for ENDPOINT.
- (match endpoint
- (($ <endpoint> name address style backlog
- owner group permissions)
- (let* ((sock (non-blocking-port
- (socket (sockaddr:fam address) style 0)))
- (owner (if (integer? owner)
- owner
- (passwd:uid (getpwnam owner))))
- (group (if (integer? group)
- group
- (group:gid (getgrnam group)))))
- (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
- (when (= AF_UNIX (sockaddr:fam address))
- (mkdir-p (dirname (sockaddr:path address)) permissions)
- (chown (dirname (sockaddr:path address)) owner group)
- (catch-system-error (delete-file (sockaddr:path address))))
-
- (bind sock address)
- (listen sock backlog)
-
- (when (= AF_UNIX (sockaddr:fam address))
- (chown sock owner group)
- (chmod sock #o666))
-
- sock))))
-
- (define (open-sockets addresses)
- (let loop ((endpoints endpoints)
- (result '()))
- (match endpoints
- (()
- (reverse result))
- ((head tail ...)
- (let ((sock (catch 'system-error
- (lambda ()
- (endpoint->listening-socket head))
- (lambda args
- ;; When opening one socket fails, abort the whole
- ;; process.
- (for-each (match-lambda
- ((_ . socket) (close-port socket)))
- result)
- (apply throw args)))))
- (loop tail
- `((,(endpoint-name head) . ,sock) ,@result)))))))
-
- (let* ((sockets (open-sockets endpoints))
- (ports (match sockets
- (((names . ports) ...)
- ports)))
+ (let* ((ports (open-sockets endpoints))
+ (sockets (map (lambda (endpoint socket)
+ (cons (endpoint-name endpoint) socket))
+ endpoints ports))
(variables (list (string-append "LISTEN_FDS="
(number->string (length sockets)))
(string-append "LISTEN_FDNAMES="
--
2.36.0
