[shepherd] 13/13: service: Add inetd constructor and destructor.

[Ludovic Courtès]

civodul pushed a commit to branch wip-fibers
in repository shepherd.

commit 69ea4bd01f3dde3007d6eaedaf7a9fd3e4c7b7a9
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Mar 25 18:18:26 2022 +0100

    service: Add inetd constructor and destructor.
    
    * modules/shepherd/service.scm (exec-command): Add #:input-port and
    honor it.
    (make-inetd-forkexec-constructor, socket-address->string)
    (inetd-variables, make-inetd-constructor): New procedures.
    * modules/shepherd/support.scm: Use (ice-9 format).
    * tests/inetd.sh: New file.
    * Makefile.am (TESTS): Add it.
    * doc/shepherd.texi (Service De- and Constructors): Update
    'exec-command' documentation and add 'make-inetd-constructor' and
    'make-inetd-destructor'.
---
 Makefile.am                  |   1 +
 doc/shepherd.texi            |  41 +++++++++-
 modules/shepherd/service.scm | 182 +++++++++++++++++++++++++++++++++++++++++--
 modules/shepherd/support.scm |   1 +
 tests/inetd.sh               | 117 ++++++++++++++++++++++++++++
 5 files changed, 335 insertions(+), 7 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 8f28a29..19c0f4c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -230,6 +230,7 @@ TESTS =                                             \
   tests/forking-service.sh                     \
   tests/one-shot.sh                            \
   tests/transient.sh                           \
+  tests/inetd.sh                               \
   tests/signals.sh
 
 TEST_EXTENSIONS = .sh
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 67f4c0e..ca00f28 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -971,7 +971,7 @@ procedures.
   [#:user #f] @
   [#:group #f] @
   [#:supplementary-groups '()] @
-  [#:log-file #f] [#:log-port #f] @
+  [#:log-file #f] [#:log-port #f] [#:input-port #f] @
   [#:directory (default-service-directory)] @
   [#:file-creation-mask #f] [#:create-session? #t] @
   [#:resource-limits '()] @
@@ -991,7 +991,7 @@ Run @var{command} as the current process from 
@var{directory}, with
 File descriptors 1 and 2 are kept as is or redirected to
 either @var{log-port} or @var{log-file}
 if it's true, whereas file descriptor 0
-(standard input) points to @file{/dev/null}; all other file descriptors
+(standard input) points to @var{input-port} or @file{/dev/null}; all other 
file descriptors
 are closed prior to yielding control to @var{command}.  When
 @var{create-session?} is true, call @code{setsid} first
 (@pxref{Processes, @code{setsid},, guile, GNU Guile Reference Manual}).
@@ -1025,6 +1025,43 @@ specified the default PID file timeout in seconds, when
 @code{#:pid-file} is used (see above).  It defaults to 5 seconds.
 @end defvr
 
+@cindex on-demand, starting services
+@cindex inetd-style services
+One may also define services meant to be started @emph{on demand}.  In
+that case, shepherd listens for incoming connections on behalf of the
+program that handles them; when it accepts an incoming connection, it
+starts the program to handle them.  The main benefit is that such
+services do not consume resources until they are actually used, and they
+do not slow down startup.
+
+These services are implemented following the protocol of the venerable
+inetd ``super server'' (@pxref{inetd invocation, inetd,, inetutils, GNU
+Inetutils}).  Many network daemons can be invoked in ``inetd mode'';
+this is the case, for instance, of @command{sshd}, the secure shell
+server of the OpenSSH project.
+
+@deffn {procedure} make-inetd-constructor @var{command} @var{address}
+  [#:service-name-stem _] [#:requirements '()] @
+  [#:socket-style SOCK_STREAM] [#:listen-backlog 10] @
+  [#:user #f] @
+  [#:group #f] @
+  [#:supplementary-groups '()] @
+  [#:directory (default-service-directory)] @
+  [#: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}.
+Upon a client connection, a transient service running @var{command} is
+spawned.  The remaining arguments are as for
+@code{make-forkexec-constructor}.
+@end deffn
+
+@deffn {procedure} make-inetd-destructor
+Return a procedure that terminates an inetd service.
+@end deffn
+
 @c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 
 @node Service Examples
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 218e6e0..b66c33c 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -88,6 +88,8 @@
             read-pid-file
             make-system-constructor
             make-system-destructor
+            make-inetd-constructor
+            make-inetd-destructor
 
             check-for-dead-services
             root-service
@@ -845,6 +847,7 @@ FILE."
                        (supplementary-groups '())
                        (log-file #f)
                        (log-port #f)
+                       (input-port #f)
                        (directory (default-service-directory))
                        (file-creation-mask #f)
                        (create-session? #t)
@@ -854,9 +857,9 @@ FILE."
 if it's true, and with ENVIRONMENT-VARIABLES (a list of strings like
 \"PATH=/bin\").  File descriptors 1 and 2 are kept as is or redirected to
 either LOG-PORT or LOG-FILE if it's true, whereas file descriptor 0 (standard
-input) points to /dev/null; all other file descriptors are closed prior to
-yielding control to COMMAND.  When CREATE-SESSION? is true, call 'setsid'
-first.
+input) points to INPUT-PORT or /dev/null; all other file descriptors are
+closed prior to yielding control to COMMAND.  When CREATE-SESSION? is true,
+call 'setsid' first.
 
 Guile's SETRLIMIT procedure is applied on the entries in RESOURCE-LIMITS.  For
 example, a valid value would be '((nproc 10 100) (nofile 4096 4096)).
@@ -882,11 +885,14 @@ false."
      ;; Close all the file descriptors except stdout and stderr.
      (let ((max-fd (max-file-descriptors)))
 
-       ;; Redirect stdin to use /dev/null
+       ;; Redirect stdin.
        (catch-system-error (close-fdes 0))
        ;; Make sure file descriptor zero is used, so we don't end up reusing
        ;; it for something unrelated, which can confuse some packages.
-       (dup2 (open-fdes "/dev/null" O_RDONLY) 0)
+       (dup2 (if input-port
+                 (fileno input-port)
+                 (open-fdes "/dev/null" O_RDONLY))
+             0)
 
        (when (or log-port log-file)
          (catch #t
@@ -1116,6 +1122,172 @@ as argument, where SIGNAL defaults to `SIGTERM'."
   (lambda (ignored . args)
     (not (zero? (status:exit-val (system (apply string-append command)))))))
 
+
+;;;
+;;; Inetd-style services.
+;;;
+
+(define* (make-inetd-forkexec-constructor command connection
+                                          #:key
+                                          (user #f)
+                                          (group #f)
+                                          (supplementary-groups '())
+                                          (directory 
(default-service-directory))
+                                          (file-creation-mask #f)
+                                          (create-session? #t)
+                                          (environment-variables
+                                           (default-environment-variables))
+                                          (resource-limits '()))
+  (lambda ()
+    ;; XXX: This is partly copied from 'make-forkexec-constructor'.
+    ;; Install the SIGCHLD handler if this is the first fork+exec-command call.
+    (unless %sigchld-handler-installed?
+      (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP)
+      (set! %sigchld-handler-installed? #t))
+
+    (with-blocked-signals %precious-signals
+      (let ((pid (primitive-fork)))
+        (if (zero? pid)
+            (begin
+              ;; First restore the default handlers.
+              (for-each (cut sigaction <> SIG_DFL) %precious-signals)
+
+              ;; Unblock any signals that have been blocked by the parent
+              ;; process.
+              (unblock-signals %precious-signals)
+
+              (exec-command command
+                            #:input-port connection
+                            #:log-port connection
+                            #:user user
+                            #:group group
+                            #:supplementary-groups supplementary-groups
+                            #:directory directory
+                            #:file-creation-mask file-creation-mask
+                            #:create-session? create-session?
+                            #:environment-variables
+                            environment-variables
+                            #:resource-limits resource-limits))
+            (begin
+              (close-port connection)
+              pid))))))
+
+(define (socket-address->string address)
+  "Return a human-readable representation of ADDRESS, an object as returned by
+'make-socket-address'."
+  (let ((family (sockaddr:fam address)))
+    (cond ((= AF_INET family)
+           (string-append (inet-ntop AF_INET (sockaddr:addr address))
+                          ":" (number->string (sockaddr:port address))))
+          ((= AF_INET6 family)
+           (string-append "[" (inet-ntop AF_INET (sockaddr:addr address)) "]"
+                          ":" (number->string (sockaddr:port address))))
+          ((= AF_UNIX family)
+           (sockaddr:path address))
+          (else
+           (object->string address)))))
+
+(define (inetd-variables server client)
+  "Return environment variables that inetd would defined for a connection of
+@var{client} to @var{server} (info \"(inetutils) Inetd Environment\")."
+  (let ((family (sockaddr:fam server)))
+    (if (memv family (list AF_INET AF_INET6))
+        (list (string-append "TCPLOCALIP="
+                             (inet-ntop family (sockaddr:addr server)))
+              (string-append "TCPLOCALPORT="
+                             (number->string (sockaddr:port server)))
+              (string-append "TCPREMOTEIP="
+                             (inet-ntop (sockaddr:fam client)
+                                        (sockaddr:addr client)))
+              (string-append "TCPREMOTEPORT"
+                             (number->string (sockaddr:port client))))
+        '())))
+
+(define* (make-inetd-constructor command address
+                                 #:key
+                                 (service-name-stem
+                                  (match command
+                                    ((program . _)
+                                     (basename program))))
+                                 (requirements '())
+                                 (socket-style SOCK_STREAM)
+                                 (listen-backlog 10)
+                                 ;; TODO: Add #:max-connections.
+                                 (user #f)
+                                 (group #f)
+                                 (supplementary-groups '())
+                                 (directory (default-service-directory))
+                                 (file-creation-mask #f)
+                                 (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}.
+Upon a client connection, a transient service running @var{command} is
+spawned.  The remaining arguments are as for
+@code{make-forkexec-constructor}."
+  (define child-service-name
+    (let ((counter 1))
+      (lambda ()
+        (define name
+          (string->symbol
+           (string-append service-name-stem "-" (number->string counter))))
+        (set! counter (+ 1 counter))
+        name)))
+
+  (lambda args
+    (let ((sock (non-blocking-port
+                 (socket (sockaddr:fam address) socket-style 0))))
+      (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+      (when (= AF_UNIX (sockaddr:fam address))
+        (mkdir-p (dirname (sockaddr:path address))))
+      (bind sock address)
+      (listen sock listen-backlog)
+      (spawn-fiber
+       (lambda ()
+         (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))))
+           (loop))))
+      sock)))
+
+(define (make-inetd-destructor)
+  "Return a procedure that terminates an inetd service."
+  (lambda (sock)
+    (close-port sock)
+    #f))
+
 ;; A group of service-names which can be provided (i.e. services
 ;; providing them get started) and unprovided (same for stopping)
 ;; together.  Not comparable with a real runlevel at all, but can be
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 4e27988..94cd4c6 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -23,6 +23,7 @@
 (define-module (shepherd support)
   #:use-module (shepherd config)
   #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
   #:export (buffering-mode
 
             caught-error
diff --git a/tests/inetd.sh b/tests/inetd.sh
new file mode 100644
index 0000000..c65a049
--- /dev/null
+++ b/tests/inetd.sh
@@ -0,0 +1,117 @@
+# GNU Shepherd --- Test transient services.
+# Copyright © 2022 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/>.
+
+shepherd --version
+herd --version
+
+socket="t-socket-$$"
+conf="t-conf-$$"
+log="t-log-$$"
+pid="t-pid-$$"
+service_socket="t-service-socket-$$"
+
+herd="herd -s $socket"
+
+trap "cat $log || true; rm -f %service_socket $socket $conf $log;
+      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+
+PORT=4444                      # port of the echo server
+
+cat > "$conf" <<EOF
+(define %command
+  ;; Simple echo server.
+  '("$SHELL" "-c" "echo hello; read line; echo \$line; echo done"))
+
+(register-services
+ (make <service>
+   #:provides '(test-inetd)
+   #:start (make-inetd-constructor %command
+                                   (make-socket-address AF_INET
+                                                        INADDR_LOOPBACK
+                                                        $PORT))
+   #:stop  (make-inetd-destructor))
+ (make <service>
+   #:provides '(test-inetd-unix)
+   #:start (make-inetd-constructor %command
+                                   (make-socket-address AF_UNIX
+                                                        "$service_socket"))
+   #:stop  (make-inetd-destructor)))
+
+(start 'test-inetd)
+EOF
+
+rm -f "$pid"
+shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &
+
+# Wait till it's ready.
+while ! test -f "$pid" ; do sleep 0.3 ; done
+
+shepherd_pid="`cat $pid`"
+
+file_descriptor_count ()
+{
+    ls -l /proc/$shepherd_pid/fd/[0-9]* | wc -l
+}
+
+initial_fd_count=$(file_descriptor_count)
+
+$herd status test-inetd | grep started
+test $($herd status | grep '\+' | wc -l) -eq 2
+
+converse_with_echo_server ()
+{
+    guile -c "(use-modules (ice-9 match) (ice-9 rdelim))
+      (define address $1)
+      (define sock (socket (sockaddr:fam address) SOCK_STREAM 0))
+      (connect sock address)
+      (match (read-line sock) (\"hello\" #t))
+      (display \"bye\n\" sock)
+      (match (read-line sock) (\"bye\" #t))
+      (match (read-line sock) (\"done\" #t))"
+}
+
+
+for i in $(seq 1 3)
+do
+    test $($herd status | grep '\+' | wc -l) -eq 2
+    converse_with_echo_server \
+       "(make-socket-address AF_INET INADDR_LOOPBACK $PORT)"
+done
+
+$herd stop test-inetd
+! converse_with_echo_server \
+  "(make-socket-address AF_INET INADDR_LOOPBACK $PORT)"
+
+# Now test inetd on a Unix-domain socket.
+
+$herd start test-inetd-unix
+for i in $(seq 1 3)
+do
+    test $($herd status | grep '\+' | wc -l) -eq 2
+    converse_with_echo_server \
+       "(make-socket-address AF_UNIX \"$service_socket\")"
+done
+
+$herd stop test-inetd-unix
+! converse_with_echo_server \
+  "(make-socket-address AF_UNIX \"$service_socket\")"
+
+# At this point, shepherd should have INITIAL_FD_COUNT - 1 file descriptors
+# opened.
+test $(file_descriptor_count) -lt $initial_fd_count