Subject: [PATCH Shepherd 1/3] service: 'make-inetd-constructor' accepts a list of endpoints.

From: Ludovic Courtès <[email-masked]>
Date: Wed, 18 May 2022 16:06:43 +0200

* 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 <[email-masked]>
 Please send Shepherd bug reports to [email-masked].
 
 * 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