[shepherd] 26/32: service: Add #:max-connections to 'make-inetd-constructor'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 8f99657fb247f1ff028e922f5a116608eec92d55
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Mon Mar 28 20:40:43 2022 +0200

    service: Add #:max-connections to 'make-inetd-constructor'.
    
    * modules/shepherd/service.scm (default-inetd-max-connections): New 
variable.
    (make-inetd-constructor): Add #:max-connections.
    [connection-count]: New variables.
    [handle-child-termination, spawn-child-service]: New procedures.
    Close CONNECTION when CONNECTION-COUNT is greater than MAX-CONNECTIONS.
    * tests/inetd.sh: Test it.
    * doc/shepherd.texi (Service De- and Constructors): Document it.
---
 doc/shepherd.texi            |   8 +++-
 modules/shepherd/service.scm | 100 +++++++++++++++++++++++++++++--------------
 tests/inetd.sh               |  26 ++++++++++-
 3 files changed, 99 insertions(+), 35 deletions(-)

diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 7e9279f..d764970 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1068,6 +1068,7 @@ in charge of listening.
 @deffn {procedure} make-inetd-constructor @var{command} @var{address}
   [#:service-name-stem _] [#:requirements '()] @
   [#:socket-style SOCK_STREAM] [#:listen-backlog 10] @
+  [#:max-connections (default-inetd-max-connections)] @
   [#:user #f] @
   [#:group #f] @
   [#:supplementary-groups '()] @
@@ -1079,8 +1080,11 @@ 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}.
 Upon a client connection, a transient service running @var{command} is
-spawned.  The remaining arguments are as for
-@code{make-forkexec-constructor}.
+spawned.  Only up to @var{max-connections} simultaneous connections are
+accepted; when that threshold is reached, new connections are immediately
+closed.
+
+The remaining arguments are as for @code{make-forkexec-constructor}.
 @end deffn
 
 @deffn {procedure} make-inetd-destructor
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index a389802..e0bc444 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -91,6 +91,7 @@
             read-pid-file
             make-system-constructor
             make-system-destructor
+            default-inetd-max-connections
             make-inetd-constructor
             make-inetd-destructor
 
@@ -1295,6 +1296,11 @@ as argument, where SIGNAL defaults to `SIGTERM'."
                              (number->string (sockaddr:port client))))
         '())))
 
+(define default-inetd-max-connections
+  ;; Default maximum number of simultaneous connections for an inetd-style
+  ;; service.
+  (make-parameter 100))
+
 (define* (make-inetd-constructor command address
                                  #:key
                                  (service-name-stem
@@ -1304,7 +1310,8 @@ as argument, where SIGNAL defaults to `SIGTERM'."
                                  (requirements '())
                                  (socket-style SOCK_STREAM)
                                  (listen-backlog 10)
-                                 ;; TODO: Add #:max-connections.
+                                 (max-connections
+                                  (default-inetd-max-connections))
                                  (user #f)
                                  (group #f)
                                  (supplementary-groups '())
@@ -1318,8 +1325,11 @@ as argument, where SIGNAL defaults to `SIGTERM'."
 object as returned by @code{make-socket-address}, and accepting connections in
 the background; the @var{listen-backlog} argument is passed to @var{accept}.
 Upon a client connection, a transient service running @var{command} is
-spawned.  The remaining arguments are as for
-@code{make-forkexec-constructor}."
+spawned.  Only up to @var{max-connections} simultaneous connections are
+accepted; when that threshold is reached, new connections are immediately
+closed.
+
+The remaining arguments are as for @code{make-forkexec-constructor}."
   (define child-service-name
     (let ((counter 1))
       (lambda ()
@@ -1329,6 +1339,44 @@ spawned.  The remaining arguments are as for
         (set! counter (+ 1 counter))
         name)))
 
+  (define connection-count
+    ;; Number of active connections.
+    0)
+
+  (define (handle-child-termination service status)
+    (set! connection-count (- connection-count 1))
+    (local-output (l10n "~a connection still in use after ~a termination."
+                        "~a connections still in use after ~a termination."
+                        connection-count)
+                  connection-count (canonical-name service))
+    (default-service-termination-handler service status))
+
+  (define (spawn-child-service connection client-address)
+    (let* ((name    (child-service-name))
+           (service (make <service>
+                      #:provides (list name)
+                      #:requires requirements
+                      #:respawn? #f
+                      #:transient? #t
+                      #:start (make-inetd-forkexec-constructor
+                               command connection
+                               #:user user
+                               #:group group
+                               #:supplementary-groups
+                               supplementary-groups
+                               #:directory directory
+                               #:file-creation-mask file-creation-mask
+                               #:create-session? create-session?
+                               #:environment-variables
+                               (append (inetd-variables address
+                                                        client-address)
+                                   environment-variables)
+                               #:resource-limits resource-limits)
+                      #:handle-termination handle-child-termination
+                      #:stop (make-kill-destructor))))
+      (register-services service)
+      (start service)))
+
   (lambda args
     (let ((sock (non-blocking-port
                  (socket (sockaddr:fam address) socket-style 0))))
@@ -1343,35 +1391,23 @@ spawned.  The remaining arguments are as for
          (let loop ()
            (match (accept sock)
              ((connection . client-address)
-              (local-output
-               (l10n "Accepted connection on ~a from ~:[~a~;~*local 
process~].")
-               (socket-address->string address)
-               (= AF_UNIX (sockaddr:fam client-address))
-               (socket-address->string client-address))
-              (letrec* ((name (child-service-name))
-                        (service
-                         (make <service>
-                           #:provides (list name)
-                           #:requires requirements
-                           #:respawn? #f
-                           #:transient? #t
-                           #:start (make-inetd-forkexec-constructor
-                                    command connection
-                                    #:user user
-                                    #:group group
-                                    #:supplementary-groups
-                                    supplementary-groups
-                                    #:directory directory
-                                    #:file-creation-mask file-creation-mask
-                                    #:create-session? create-session?
-                                    #:environment-variables
-                                    (append (inetd-variables address
-                                                             client-address)
-                                        environment-variables)
-                                    #:resource-limits resource-limits)
-                           #:stop (make-kill-destructor))))
-                (register-services service)
-                (start service))))
+              (if (>= connection-count max-connections)
+                  (begin
+                    (local-output
+                     (l10n "Maximum number of ~a clients reached; \
+rejecting connection from ~:[~a~;~*local process~].")
+                     (socket-address->string address)
+                     (= AF_UNIX (sockaddr:fam client-address))
+                     (socket-address->string client-address))
+                    (close-port connection))
+                  (begin
+                    (set! connection-count (+ 1 connection-count))
+                    (local-output
+                     (l10n "Accepted connection on ~a from ~:[~a~;~*local 
process~].")
+                     (socket-address->string address)
+                     (= AF_UNIX (sockaddr:fam client-address))
+                     (socket-address->string client-address))
+                    (spawn-child-service connection client-address)))))
            (loop))))
       sock)))
 
diff --git a/tests/inetd.sh b/tests/inetd.sh
index e31572f..ef18800 100644
--- a/tests/inetd.sh
+++ b/tests/inetd.sh
@@ -50,7 +50,8 @@ cat > "$conf" <<EOF
    #:provides '(test-inetd-unix)
    #:start (make-inetd-constructor %command
                                    (make-socket-address AF_UNIX
-                                                        "$service_socket"))
+                                                        "$service_socket")
+                                   #:max-connections 5)
    #:stop  (make-inetd-destructor)))
 
 (start 'test-inetd)
@@ -112,6 +113,29 @@ $herd stop test-inetd-unix
 ! converse_with_echo_server \
   "(make-socket-address AF_UNIX \"$service_socket\")"
 
+# Check the maximum connection limit.
+$herd start test-inetd-unix
+guile -c "
+  (use-modules (ice-9 rdelim) (ice-9 match))
+  (define address (make-socket-address AF_UNIX \"$service_socket\"))
+  (let loop ((i 10)
+             (sockets '()))
+    (if (zero? i)
+        ;; shepherd should close the extra sockets immediately.
+        (unless (equal? (append (make-list 5 the-eof-object)
+                                (make-list 5 \"hello\"))
+                        (pk 'read (map read-line sockets)))
+          (exit 1))
+        (let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+          (connect sock address)
+          (loop (- i 1) (cons sock sockets)))))"
+
+converse_with_echo_server \
+  "(make-socket-address AF_UNIX \"$service_socket\")"
+
+$herd stop test-inetd-unix
+$herd status
+
 # At this point, shepherd should have INITIAL_FD_COUNT - 1 file descriptors
 # opened.
 test $(file_descriptor_count) -lt $initial_fd_count