[shepherd] 04/08: Move endpoints to (shepherd endpoints).

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit b89d5d37d02dfebb6d42a422994c5d262e6511d1
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Tue Jul 30 18:40:01 2024 +0200

    Move endpoints to (shepherd endpoints).
    
    * modules/shepherd/service.scm (<endpoint>, endpoint->sexp)
    (default-bind-attempts, endpoint, bind/retry-if-in-use)
    (endpoint->listening-socket, open-sockets, IN6ADDR_LOOPBACK)
    (IN6ADDR_ANY): Move to…
    * modules/shepherd/endpoints.scm: … here.  New file.
    * Makefile.am (dist_shepherdsub_DATA): Add it.
    * doc/shepherd.texi (Service De- and Constructors): Mention the module
    name.
---
 Makefile.am                    |   1 +
 doc/shepherd.texi              |   3 +-
 modules/shepherd/endpoints.scm | 194 +++++++++++++++++++++++++++++++++++++++++
 modules/shepherd/service.scm   | 177 +++----------------------------------
 4 files changed, 209 insertions(+), 166 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 87a3010..af941e5 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -41,6 +41,7 @@ servicesubdir = $(guilemoduledir)/shepherd/service
 dist_shepherdsub_DATA =                                \
   modules/shepherd/args.scm                    \
   modules/shepherd/colors.scm                  \
+  modules/shepherd/endpoints.scm               \
   modules/shepherd/logger.scm                  \
   modules/shepherd/service.scm                 \
   modules/shepherd/support.scm                 \
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 84b895b..b7bca3f 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1284,7 +1284,8 @@ in charge of listening.
 @cindex endpoints, for inetd services
 @cindex endpoints, for systemd services
 Listening endpoints for such services are described as records built
-using the @code{endpoint} procedure:
+using the @code{endpoint} procedure provided by the @code{(shepherd
+endpoints)} module:
 
 @deffn {Procedure} endpoint @var{address} [#:name "unknown"] @
   [#:style SOCK_STREAM] [#:backlog 128] @
diff --git a/modules/shepherd/endpoints.scm b/modules/shepherd/endpoints.scm
new file mode 100644
index 0000000..01ccdda
--- /dev/null
+++ b/modules/shepherd/endpoints.scm
@@ -0,0 +1,194 @@
+;; endpoints.scm -- Network connection endpoints.
+;; Copyright (C) 2023-2024 Ludovic Courtès <ludo@gnu.org>
+;;
+;; This file is part of the GNU Shepherd.
+;;
+;; The GNU Shepherd is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or (at
+;; your option) any later version.
+;;
+;; The GNU Shepherd is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with the GNU Shepherd.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (shepherd endpoints)
+  #:use-module (srfi srfi-9)
+  #:use-module (ice-9 match)
+  #:use-module (shepherd support)
+  #:use-module (shepherd system)
+  #:export (endpoint
+            endpoint?
+            endpoint-name
+            endpoint-address
+            endpoint-style
+            endpoint-backlog
+            endpoint-socket-owner
+            endpoint-socket-group
+            endpoint-socket-directory-permissions
+            endpoint-bind-attempts
+            endpoint->sexp
+            default-bind-attempts
+            bind/retry-if-in-use
+            open-sockets))
+
+;;; Commentary:
+;;;
+;;; This module defines "server endpoints", an abstraction representing
+;;; server-side endpoints to listen on, along with a procedure to open a set
+;;; of endpoints and obtain the corresponding listening sockets.
+;;;
+;;; Code:
+
+;; Endpoint of a systemd-style or inetd-style service.
+(define-record-type <endpoint>
+  (make-endpoint name address style backlog owner group permissions
+                 bind-attempts)
+  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
+  (bind-attempts endpoint-bind-attempts))              ;integer
+
+(define (endpoint->sexp endpoint)
+  `(endpoint (version 0)
+             (name ,(endpoint-name endpoint))
+             (address ,(endpoint-address endpoint))
+             (style ,(endpoint-style endpoint))
+             (backlog ,(endpoint-backlog endpoint))
+             (owner ,(endpoint-socket-owner endpoint))
+             (group ,(endpoint-socket-group endpoint))
+             (permissions ,(endpoint-socket-directory-permissions endpoint))
+             (bind-attempts ,(endpoint-bind-attempts endpoint))))
+
+(define default-bind-attempts
+  ;; Default number of 'bind' attempts upon EADDRINUSE.
+  (make-parameter 5))
+
+(define* (endpoint address
+                   #:key (name "unknown") (style SOCK_STREAM)
+                   (backlog 128)
+                   (socket-owner (getuid)) (socket-group (getgid))
+                   (socket-directory-permissions #o755)
+                   (bind-attempts (default-bind-attempts)))
+  "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_INET6}, the endpoint is
+@emph{IPv6-only}.  Thus, if you want a service available both on IPv4 and
+IPv6, you need two endpoints.
+
+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.
+
+Upon @samp{EADDRINUSE} (``Address already in use''), up to @var{bind-attempts}
+attempts will be made to @code{bind} on @var{address}, one every second."
+  (make-endpoint name address style backlog
+                 socket-owner socket-group
+                 socket-directory-permissions
+                 bind-attempts))
+
+(define* (bind/retry-if-in-use sock address
+                               #:key (max-attempts (default-bind-attempts)))
+  "Bind @var{sock} to @var{address}.  Retry up to @var{max-attempts} times upon
+EADDRINUSE."
+  (let loop ((attempts 1))
+    (catch 'system-error
+      (lambda ()
+        (bind sock address))
+      (lambda args
+        (if (and (= EADDRINUSE (system-error-errno args))
+                 (< attempts max-attempts))
+            (begin
+              (local-output
+               (l10n "Address ~a is in use; \
+retrying to bind it in one second.")
+               (socket-address->string address))
+              (sleep 1)
+              (loop (+ attempts 1)))
+            (apply throw args))))))
+
+(define (endpoint->listening-socket endpoint)
+  "Return a listening socket for ENDPOINT."
+  (match endpoint
+    (($ <endpoint> name address style backlog
+                   owner group permissions bind-attempts)
+     ;; Make listening sockets SOCK_CLOEXEC: inetd-style services don't pass
+     ;; them to the child process, and systemd-style do pass them but call
+     ;; 'dup2' right before 'exec', thereby clearing this property.
+     (let* ((sock    (socket (sockaddr:fam address)
+                             (logior SOCK_NONBLOCK SOCK_CLOEXEC style)
+                             0))
+            (owner   (if (integer? owner)
+                         owner
+                         (passwd:uid (getpwnam owner))))
+            (group   (if (integer? group)
+                         group
+                         (group:gid (getgrnam group)))))
+       (when (= AF_INET6 (sockaddr:fam address))
+         ;; Interpret AF_INET6 endpoints as IPv6-only.  This is contrary to
+         ;; the Linux defaults where listening on an IPv6 address also listens
+         ;; on its IPv4 counterpart.
+         (ipv6-only sock))
+       (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))))
+
+       ;; SO_REUSEADDR appears to be undefined for AF_UNIX sockets; on
+       ;; GNU/Hurd, attempting to set it raises ENOPROTOOPT.
+       (unless (= AF_UNIX (sockaddr:fam address))
+         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1))
+
+       (bind/retry-if-in-use sock address
+                             #:max-attempts bind-attempts)
+       (listen sock backlog)
+
+       (when (= AF_UNIX (sockaddr:fam address))
+         (chown (sockaddr:path address) owner group)
+         (chmod (sockaddr:path address) #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)))))))
+
+(define-syntax-rule (define-as-needed name value)
+  (unless (defined? 'name)
+    (module-define! (current-module) 'name value)
+    (module-export! (current-module) '(name))))
+
+;; These values are not defined as of Guile 3.0.8.  Provide them as a
+;; convenience.
+(define-as-needed IN6ADDR_LOOPBACK 1)
+(define-as-needed IN6ADDR_ANY 0)
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 8c9d1c6..bc8852d 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -48,6 +48,18 @@
   #:use-module (shepherd config)
   #:use-module (shepherd logger)
   #:use-module (shepherd system)
+  #:use-module (shepherd endpoints)
+  #:re-export (endpoint                           ;compatibility with 0.10.x
+               endpoint?
+               endpoint-name
+               endpoint-address
+               endpoint-style
+               endpoint-backlog
+               endpoint-socket-owner
+               endpoint-socket-group
+               endpoint-socket-directory-permissions
+               endpoint-bind-attempts
+               default-bind-attempts)
   #:export (service
             service?
             service-provision
@@ -132,17 +144,6 @@
             process-id
             process-command
 
-            endpoint
-            endpoint?
-            endpoint-name
-            endpoint-address
-            endpoint-style
-            endpoint-backlog
-            endpoint-socket-owner
-            endpoint-socket-group
-            endpoint-socket-directory-permissions
-            endpoint-bind-attempts
-            default-bind-attempts
             make-systemd-constructor
             make-systemd-destructor
 
@@ -1771,160 +1772,6 @@ waiting for the shell to terminate."
                  (spawn-shell-command (string-concatenate 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
-                 bind-attempts)
-  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
-  (bind-attempts endpoint-bind-attempts))              ;integer
-
-(define (endpoint->sexp endpoint)
-  `(endpoint (version 0)
-             (name ,(endpoint-name endpoint))
-             (address ,(endpoint-address endpoint))
-             (style ,(endpoint-style endpoint))
-             (backlog ,(endpoint-backlog endpoint))
-             (owner ,(endpoint-socket-owner endpoint))
-             (group ,(endpoint-socket-group endpoint))
-             (permissions ,(endpoint-socket-directory-permissions endpoint))
-             (bind-attempts ,(endpoint-bind-attempts endpoint))))
-
-(define default-bind-attempts
-  ;; Default number of 'bind' attempts upon EADDRINUSE.
-  (make-parameter 5))
-
-(define* (endpoint address
-                   #:key (name "unknown") (style SOCK_STREAM)
-                   (backlog 128)
-                   (socket-owner (getuid)) (socket-group (getgid))
-                   (socket-directory-permissions #o755)
-                   (bind-attempts (default-bind-attempts)))
-  "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_INET6}, the endpoint is
-@emph{IPv6-only}.  Thus, if you want a service available both on IPv4 and
-IPv6, you need two endpoints.
-
-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.
-
-Upon @samp{EADDRINUSE} (``Address already in use''), up to @var{bind-attempts}
-attempts will be made to @code{bind} on @var{address}, one every second."
-  (make-endpoint name address style backlog
-                 socket-owner socket-group
-                 socket-directory-permissions
-                 bind-attempts))
-
-(define* (bind/retry-if-in-use sock address
-                               #:key (max-attempts (default-bind-attempts)))
-  "Bind @var{sock} to @var{address}.  Retry up to @var{max-attempts} times upon
-EADDRINUSE."
-  (let loop ((attempts 1))
-    (catch 'system-error
-      (lambda ()
-        (bind sock address))
-      (lambda args
-        (if (and (= EADDRINUSE (system-error-errno args))
-                 (< attempts max-attempts))
-            (begin
-              (local-output
-               (l10n "Address ~a is in use; \
-retrying to bind it in one second.")
-               (socket-address->string address))
-              (sleep 1)
-              (loop (+ attempts 1)))
-            (apply throw args))))))
-
-(define (endpoint->listening-socket endpoint)
-  "Return a listening socket for ENDPOINT."
-  (match endpoint
-    (($ <endpoint> name address style backlog
-                   owner group permissions bind-attempts)
-     ;; Make listening sockets SOCK_CLOEXEC: inetd-style services don't pass
-     ;; them to the child process, and systemd-style do pass them but call
-     ;; 'dup2' right before 'exec', thereby clearing this property.
-     (let* ((sock    (socket (sockaddr:fam address)
-                             (logior SOCK_NONBLOCK SOCK_CLOEXEC style)
-                             0))
-            (owner   (if (integer? owner)
-                         owner
-                         (passwd:uid (getpwnam owner))))
-            (group   (if (integer? group)
-                         group
-                         (group:gid (getgrnam group)))))
-       (when (= AF_INET6 (sockaddr:fam address))
-         ;; Interpret AF_INET6 endpoints as IPv6-only.  This is contrary to
-         ;; the Linux defaults where listening on an IPv6 address also listens
-         ;; on its IPv4 counterpart.
-         (ipv6-only sock))
-       (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))))
-
-       ;; SO_REUSEADDR appears to be undefined for AF_UNIX sockets; on
-       ;; GNU/Hurd, attempting to set it raises ENOPROTOOPT.
-       (unless (= AF_UNIX (sockaddr:fam address))
-         (setsockopt sock SOL_SOCKET SO_REUSEADDR 1))
-
-       (bind/retry-if-in-use sock address
-                             #:max-attempts bind-attempts)
-       (listen sock backlog)
-
-       (when (= AF_UNIX (sockaddr:fam address))
-         (chown (sockaddr:path address) owner group)
-         (chmod (sockaddr:path address) #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)))))))
-
-(define-syntax-rule (define-as-needed name value)
-  (unless (defined? 'name)
-    (module-define! (current-module) 'name value)
-    (module-export! (current-module) '(name))))
-
-;; These values are not defined as of Guile 3.0.8.  Provide them as a
-;; convenience.
-(define-as-needed IN6ADDR_LOOPBACK 1)
-(define-as-needed IN6ADDR_ANY 0)
-
-
 ;;;
 ;;; Inetd-style services.
 ;;;