[shepherd] 15/16: service: Add systemd constructor and destructor.

[Ludovic Courtès]

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

commit 7c2af35667a39f5dda6116e96c6fc8baf6ba5064
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Mar 27 22:10:50 2022 +0200

    service: Add systemd constructor and destructor.
    
    * modules/shepherd/service.scm (exec-command): Add #:extra-ports and
    honor it.
    (fork+exec-command): Add #:extra-ports and #:listen-pid-variable and
    honor them.
    (<endpoint>): New record type.
    (endpoint, wait-for-readable, make-systemd-constructor)
    (make-systemd-destructor): New procedures.
    * tests/systemd.sh: New file.
    * Makefile.am (TESTS): Add it.
    * doc/shepherd.texi (Service De- and Constructors): Document it.
---
 Makefile.am                  |   1 +
 doc/shepherd.texi            |  69 +++++++++++++++
 modules/shepherd/service.scm | 202 +++++++++++++++++++++++++++++++++++++++++--
 tests/systemd.sh             | 102 ++++++++++++++++++++++
 4 files changed, 365 insertions(+), 9 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 19c0f4c..c98e82b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -231,6 +231,7 @@ TESTS =                                             \
   tests/one-shot.sh                            \
   tests/transient.sh                           \
   tests/inetd.sh                               \
+  tests/systemd.sh                             \
   tests/signals.sh
 
 TEST_EXTENSIONS = .sh
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 649b69e..fbda56b 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -1063,6 +1063,75 @@ spawned.  The remaining arguments are as for
 Return a procedure that terminates an inetd service.
 @end deffn
 
+@cindex systemd-style services
+@cindex on-demand, starting services
+@cindex socket activation, starting services
+@cindex starting services, via socket activation
+The last type is @dfn{systemd-style services}.  Like inetd-style
+services, those are started on demand when an incoming connection
+arrives, but using the protocol devised by the systemd service manager
+and referred to as
+@uref{https://www.freedesktop.org/software/systemd/man/daemon.html#Socket-Based%20Activation,
+@dfn{socket activation}}.  The main difference with inetd-style services
+is that shepherd hands over the listening socket(s) to the daemon; the
+daemon is then responsible for accepting incoming connections.  A
+handful of environment variables are set in the daemon's execution
+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]
+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}.
+@end deffn
+
+The constructor and destructor for systemd-style daemons are described
+below.
+
+@deffn {procedure} make-systemd-destructor @var{command} @var{endpoints} @
+  [#: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 starts @var{command}, a program and list of
+argument, as a systemd-style service listening on @var{endpoints}, a list of
+@code{<endpoint>} objects.
+
+@var{command} is started on demand on the first connection attempt on one of
+@var{endpoints}.  It is passed the listening sockets for @var{endpoints} in
+file descriptors 3 and above; as such, it is equivalent to an @code{Accept=no}
+@uref{https://www.freedesktop.org/software/systemd/man/systemd.socket.html,systemd
+socket unit}.  The following environment variables are set in its environment:
+
+@table @env
+@item LISTEN_PID
+It is set to the PID of the newly spawned process.
+
+@item LISTEN_FDS
+It contains the number of sockets available starting from file descriptor
+3---i.e., the length of @var{endpoints}.
+
+@item LISTEN_FDNAMES
+The colon-separated list of endpoint names.
+@end table
+
+This must be paired with @code{make-systemd-destructor}.
+@end deffn
+
+@deffn {procedure} make-systemd-destructor
+Return a procedure that terminates a systemd-style service as created by
+@code{make-systemd-constructor}.
+@end deffn
+
 @c @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
 
 @node Service Examples
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 4831c90..aa12461 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -25,7 +25,7 @@
 
 (define-module (shepherd service)
   #:use-module (fibers)
-  #:use-module ((fibers scheduler) #:select (yield-current-task))
+  #:use-module (fibers scheduler)
   #:use-module (oop goops)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
@@ -36,6 +36,7 @@
   #:use-module ((ice-9 control) #:select (call/ec))
   #:use-module (ice-9 match)
   #:use-module (ice-9 format)
+  #:autoload   (ice-9 ports internal) (port-read-wait-fd)
   #:autoload   (ice-9 rdelim) (read-line)
   #:autoload   (ice-9 pretty-print) (truncated-print)
   #:use-module (shepherd support)
@@ -91,6 +92,15 @@
             make-inetd-constructor
             make-inetd-destructor
 
+            endpoint
+            endpoint?
+            endpoint-name
+            endpoint-address
+            endpoint-style
+            endpoint-backlog
+            make-systemd-constructor
+            make-systemd-destructor
+
             check-for-dead-services
             root-service
             make-actions
@@ -854,6 +864,7 @@ FILE."
                        (log-file #f)
                        (log-port #f)
                        (input-port #f)
+                       (extra-ports '())
                        (directory (default-service-directory))
                        (file-creation-mask #f)
                        (create-session? #t)
@@ -863,9 +874,11 @@ 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 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.
+input) points to INPUT-PORT or /dev/null.
+
+EXTRA-PORTS are made available starting from file descriptor 3 onwards; 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)).
@@ -911,7 +924,18 @@ false."
                                   #o640)
                        (fileno log-port))
                    1)
-             (dup2 1 2))
+             (dup2 1 2)
+
+             ;; Make EXTRA-PORTS available starting from file descriptor 3.
+             (let loop ((fd    3)
+                        (ports extra-ports))
+               (match ports
+                 (() #t)
+                 ((port rest ...)
+                  (catch-system-error (close-fdes fd))
+                  (dup2 (fileno port) fd)
+                  (loop (+ 1 fd) rest)))))
+
            (lambda (key . args)
              (when log-file
                (format (current-error-port)
@@ -950,7 +974,7 @@ false."
      ;; finalization thread since we will close its pipe, leading to
      ;; "error in the finalization thread: Bad file descriptor".
      (without-automatic-finalization
-      (let loop ((i 3))
+      (let loop ((i (+ 3 (length extra-ports))))
         (when (< i max-fd)
           (catch-system-error (close-fdes i))
           (loop (+ i 1))))
@@ -975,14 +999,18 @@ false."
                             (supplementary-groups '())
                             (log-file #f)
                             (log-encoding "UTF-8")
+                            (extra-ports '())
                             (directory (default-service-directory))
                             (file-creation-mask #f)
                             (create-session? #t)
                             (environment-variables
                              (default-environment-variables))
+                            (listen-pid-variable? #f)
                             (resource-limits '()))
-  "Spawn a process that executed COMMAND as per 'exec-command', and return
-its PID."
+  "Spawn a process that executes @var{command} as per @code{exec-command}, and
+return its PID.  When @var{listen-pid-variable?} is true, augment
+@var{environment-variables} with a definition of the @env{LISTEN_PID}
+environment variable used for systemd-style \"socket activation\"."
   ;; Install the SIGCHLD handler if this is the first fork+exec-command call.
   (unless %sigchld-handler-installed?
     (sigaction SIGCHLD handle-SIGCHLD SA_NOCLDSTOP)
@@ -1011,10 +1039,16 @@ its PID."
                              #:group group
                              #:supplementary-groups supplementary-groups
                              #:log-port log-output
+                             #:extra-ports extra-ports
                              #:directory directory
                              #:file-creation-mask file-creation-mask
                              #:create-session? create-session?
-                             #:environment-variables environment-variables
+                             #:environment-variables
+                             (if listen-pid-variable?
+                                 (cons (string-append "LISTEN_PID="
+                                                      (number->string 
(getpid)))
+                                       environment-variables)
+                                 environment-variables)
                              #:resource-limits resource-limits))
              (let ((log-input (non-blocking-port log-input)))
                (close-port log-output)
@@ -1295,6 +1329,155 @@ spawned.  The remaining arguments are as for
     (close-port sock)
     #f))
 
+
+;;;
+;;; systemd-style services.
+;;;
+
+;; Endpoint of a systemd-style service.
+(define-record-type <endpoint>
+  (make-endpoint name address style backlog)
+  endpoint?
+  (name    endpoint-name)                         ;string
+  (address endpoint-address)                      ;socket address
+  (style   endpoint-style)                        ;SOCK_STREAM, etc.
+  (backlog endpoint-backlog))                     ;integer
+
+(define* (endpoint address
+                   #:key (name "unknown") (style SOCK_STREAM)
+                   (backlog 128))
+  "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}."
+  (make-endpoint name address style backlog))
+
+(define (wait-for-readable ports)
+  "Suspend the current task until one of @var{ports} is available for
+reading."
+  (suspend-current-task
+   (lambda (sched k)
+     (for-each (lambda (port)
+                 (schedule-task-when-fd-readable sched
+                                                 (port-read-wait-fd port)
+                                                 k))
+               ports))))
+
+(define* (make-systemd-constructor command endpoints
+                                   #:key
+                                   (user #f)
+                                   (group #f)
+                                   (supplementary-groups '())
+                                   (log-file #f)
+                                   (directory (default-service-directory))
+                                   (file-creation-mask #f)
+                                   (create-session? #t)
+                                   (environment-variables
+                                    (default-environment-variables))
+                                   (resource-limits '()))
+  "Return a procedure that starts @var{command}, a program and list of
+argument, as a systemd-style service listening on @var{endpoints}, a list of
+@code{<endpoint>} objects.
+
+@var{command} is started on demand on the first connection attempt on one of
+@var{endpoints}.  It is passed the listening sockets for @var{endpoints} in
+file descriptors 3 and above; as such, it is equivalent to an @code{Accept=no}
+@uref{https://www.freedesktop.org/software/systemd/man/systemd.socket.html,systemd
+socket unit}.  The following environment variables are set in its environment:
+
+@table @env
+@item LISTEN_PID
+It is set to the PID of the newly spawned process.
+
+@item LISTEN_FDS
+It contains the number of sockets available starting from file descriptor
+3---i.e., the length of @var{endpoints}.
+
+@item LISTEN_FDNAMES
+The colon-separated list of endpoint names.
+@end table
+
+This must be paired with @code{make-systemd-destructor}."
+  (lambda args
+    (define (endpoint->listening-socket endpoint)
+      ;; Return a listening socket for ENDPOINT.
+      (let* ((address (endpoint-address endpoint))
+             (style   (endpoint-style endpoint))
+             (backlog (endpoint-backlog endpoint))
+             (sock    (non-blocking-port
+                       (socket (sockaddr:fam address) style 0))))
+        (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+        (when (= AF_UNIX (sockaddr:fam address))
+          (mkdir-p (dirname (sockaddr:path address)))
+          (catch-system-error (delete-file (sockaddr:path address))))
+        (bind sock address)
+        (listen sock backlog)
+        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)))
+           (variables (list (string-append "LISTEN_FDS="
+                                           (number->string (length sockets)))
+                            (string-append "LISTEN_FDNAMES="
+                                           (string-join
+                                            (map endpoint-name endpoints)))))
+           (running   sockets))
+      (spawn-fiber
+       (lambda ()
+         (wait-for-readable ports)
+         (local-output (l10n "Spawning systemd-style service ~a.")
+                       (match command
+                         ((program . _) program)))
+         (let ((pid (fork+exec-command command
+                                       #:extra-ports ports
+                                       #:user user
+                                       #:group group
+                                       #:supplementary-groups
+                                       supplementary-groups
+                                       #:log-file log-file
+                                       #:directory directory
+                                       #:file-creation-mask file-creation-mask
+                                       #:create-session? create-session?
+                                       #:environment-variables
+                                       (append variables environment-variables)
+                                       #:listen-pid-variable? #t
+                                       #:resource-limits resource-limits)))
+           (set! running pid)
+           (for-each close-port ports))))
+      (lambda () running))))
+
+(define (make-systemd-destructor)
+  "Return a procedure that terminates a systemd-style service as created by
+@code{make-systemd-constructor}."
+  (let ((destroy (make-kill-destructor)))
+    (match-lambda
+      ((? integer? pid)
+       (destroy pid))
+      (((_ . (? port? socks)) ...)
+       (for-each close-port socks)))))
+
+
 ;; 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
@@ -1308,6 +1491,7 @@ spawned.  The remaining arguments are as for
             #f)
     ADDITIONS ...))
 
+
 
 
 ;;; Registered services.
diff --git a/tests/systemd.sh b/tests/systemd.sh
new file mode 100644
index 0000000..17e1813
--- /dev/null
+++ b/tests/systemd.sh
@@ -0,0 +1,102 @@
+# 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
+
+cat > "$conf" <<EOF
+(define %command
+  ;; Simple echo server.
+  (quasiquote ("guile" "-c"
+    ,(object->string
+      '(begin
+         (use-modules (ice-9 match) (ice-9 rdelim))
+
+         (display "starting\n")
+         (unless (= (string->number (getenv "LISTEN_PID")) (getpid))
+           (error "wrong pid!" (getenv "LISTEN_PID")))
+         (unless (= (string->number (getenv "LISTEN_FDS")) 1)
+           (error "wrong LISTEN_FDS!" (getenv "LISTEN_FDS")))
+         (let ((sock (fdopen 3 "r+0")))
+           (match (accept sock)
+             ((connection . peer)
+              (format #t "accepting connection from ~s~%" peer)
+              (display "hello\n" connection)
+              (display (read-line connection) connection)
+              (newline connection)
+              (display "done\n" connection)
+              (display "exiting!\n")
+              (close-port connection)
+              (close-port sock)))))))))
+
+(define %endpoints
+  (list (endpoint (make-socket-address AF_UNIX "$service_socket"))))
+
+(register-services
+ (make <service>
+   #:provides '(test-systemd-unix)
+   #:start (make-systemd-constructor %command %endpoints)
+   #:stop  (make-systemd-destructor)
+   #:respawn? #t))
+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`"
+
+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))"
+}
+
+
+$herd start test-systemd-unix
+$herd status test-systemd-unix | grep started
+test $($herd status | grep '\+' | wc -l) -eq 2
+
+for i in $(seq 1 3)
+do
+    converse_with_echo_server \
+       "(make-socket-address AF_UNIX \"$service_socket\")"
+done
+
+$herd stop test-systemd-unix
+! converse_with_echo_server \
+  "(make-socket-address AF_UNIX \"$service_socket\")"