[shepherd] 09/13: service: 'make-forkexec-constructor' spawns a logging fiber.

[Ludovic Courtès]

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

commit 2cf3eb0ae9909f08c631d75717b9cd8af1f87b73
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Mar 23 16:57:32 2022 +0100

    service: 'make-forkexec-constructor' spawns a logging fiber.
    
    * modules/shepherd/service.scm (service-file-logger)
    (service-builtin-logger): New procedures.
    (exec-command): Add #:log-port and honor it.
    (fork+exec-command): Add #:log-encoding.  Call 'pipe' before
    'primitive-fork' and pass #:log-port to 'exec-command'.  Call
    'spawn-fiber' for logging.
    * tests/logging.sh: New file.
    * doc/shepherd.texi (Service De- and Constructors): Adjust accordingly.
    * Makefile.am (TESTS): Add it.
---
 Makefile.am                  |   1 +
 doc/shepherd.texi            |   6 ++-
 modules/shepherd/service.scm | 126 +++++++++++++++++++++++++++++++++----------
 tests/logging.sh             |  94 ++++++++++++++++++++++++++++++++
 4 files changed, 197 insertions(+), 30 deletions(-)

diff --git a/Makefile.am b/Makefile.am
index 408c68e..1564156 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -224,6 +224,7 @@ TESTS =                                             \
   tests/misbehaved-client.sh                   \
   tests/no-home.sh                             \
   tests/pid-file.sh                            \
+  tests/logging.sh                             \
   tests/file-creation-mask.sh                  \
   tests/status-sexp.sh                         \
   tests/forking-service.sh                     \
diff --git a/doc/shepherd.texi b/doc/shepherd.texi
index 589ece0..3d1894f 100644
--- a/doc/shepherd.texi
+++ b/doc/shepherd.texi
@@ -960,7 +960,7 @@ procedures.
   [#:user #f] @
   [#:group #f] @
   [#:supplementary-groups '()] @
-  [#:log-file #f] @
+  [#:log-file #f] [#:log-port #f] @
   [#:directory (default-service-directory)] @
   [#:file-creation-mask #f] [#:create-session? #t] @
   [#:resource-limits '()] @
@@ -969,6 +969,7 @@ procedures.
   [#:user #f] @
   [#:group #f] @
   [#:supplementary-groups '()] @
+  [#:log-file #f] [#:log-encoding "UTF-8"] @
   [#:directory (default-service-directory)] @
   [#:file-creation-mask #f] [#:create-session? #t] @
   [#:resource-limits '()] @
@@ -976,7 +977,8 @@ procedures.
 Run @var{command} as the current process from @var{directory}, with
 @var{file-creation-mask} if it's true, with @var{rlimits}, and with
 @var{environment-variables} (a list of strings like @code{"PATH=/bin"}.)
-File descriptors 1 and 2 are kept as is or redirected to @var{log-file}
+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
 are closed prior to yielding control to @var{command}.  When
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 71e06b8..1ccb18d 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -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 rdelim) (read-line)
   #:autoload   (ice-9 pretty-print) (truncated-print)
   #:use-module (shepherd support)
   #:use-module (shepherd comm)
@@ -783,6 +784,45 @@ daemon writing FILE is running in a separate PID 
namespace."
               (try-again)
               (apply throw args)))))))
 
+(define (service-file-logger file input)
+  "Return a thunk meant to run as a fiber that reads from INPUT and logs it to
+FILE."
+  (let* ((fd     (open-fdes file (logior O_CREAT O_WRONLY O_APPEND) #o640))
+         (output (fdopen fd "al")))
+    (set-port-encoding! output "UTF-8")
+    (set-port-conversion-strategy! output 'substitute)
+    (lambda ()
+      (call-with-port output
+        (lambda (output)
+          (let loop ()
+            (match (read-line input)
+              ((? eof-object?)
+               (close-port input)
+               (close-port output))
+              (line
+               (let ((prefix (strftime (%current-logfile-date-format)
+                                       (localtime (current-time)))))
+                 (format output "~a~a~%" prefix line)
+                 (loop))))))))))
+
+(define (service-builtin-logger command input)
+  "Return a thunk meant to run as a fiber that reads from INPUT and logs to
+'log-output-port'."
+  (lambda ()
+    (let loop ()
+      (match (read-line input)
+        ((? eof-object?)
+         (close-port input))
+        (line
+         (let ((prefix (strftime (%current-logfile-date-format)
+                                 (localtime (current-time)))))
+           ;; TODO: Print the PID of COMMAND.  The actual PID is potentially
+           ;; not known until after 'read-pid-file' has completed, so it would
+           ;; need to be communicated.
+           (format (log-output-port) "~a[~a] ~a~%"
+                   prefix command line))
+         (loop))))))
+
 (define (format-supplementary-groups supplementary-groups)
   (list->vector (map (lambda (group) (group:gid (getgr group)))
                      supplementary-groups)))
@@ -793,6 +833,7 @@ daemon writing FILE is running in a separate PID namespace."
                        (group #f)
                        (supplementary-groups '())
                        (log-file #f)
+                       (log-port #f)
                        (directory (default-service-directory))
                        (file-creation-mask #f)
                        (create-session? #t)
@@ -801,9 +842,10 @@ daemon writing FILE is running in a separate PID 
namespace."
   "Run COMMAND as the current process from DIRECTORY, with FILE-CREATION-MASK
 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
-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.
+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.
 
 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)).
@@ -835,17 +877,22 @@ false."
        ;; it for something unrelated, which can confuse some packages.
        (dup2 (open-fdes "/dev/null" O_RDONLY) 0)
 
-       (when log-file
+       (when (or log-port log-file)
          (catch #t
            (lambda ()
              ;; Redirect stout and stderr to use LOG-FILE.
              (catch-system-error (close-fdes 1))
              (catch-system-error (close-fdes 2))
-             (dup2 (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND) 
#o640) 1)
+             (dup2 (if log-file
+                       (open-fdes log-file (logior O_CREAT O_WRONLY O_APPEND)
+                                  #o640)
+                       (fileno log-port))
+                   1)
              (dup2 1 2))
            (lambda (key . args)
-             (format (current-error-port)
-                     "failed to open log-file ~s:~%" log-file)
+             (when log-file
+               (format (current-error-port)
+                       "failed to open log-file ~s:~%" log-file))
              (print-exception (current-error-port) #f key args)
              (primitive-exit 1))))
 
@@ -904,6 +951,7 @@ false."
                             (group #f)
                             (supplementary-groups '())
                             (log-file #f)
+                            (log-encoding "UTF-8")
                             (directory (default-service-directory))
                             (file-creation-mask #f)
                             (create-session? #t)
@@ -922,27 +970,49 @@ its PID."
   ;; handler, which stops shepherd, is called.  To avoid this, block signals
   ;; so that the child process never executes those handlers.
   (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
-                          #: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 environment-variables
-                          #:resource-limits resource-limits))
-          pid))))
+    (match (pipe)
+      ((log-input . log-output)
+       (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)
+
+               (close-port log-input)
+               (exec-command command
+                             #:user user
+                             #:group group
+                             #:supplementary-groups supplementary-groups
+                             #:log-port log-output
+                             #:directory directory
+                             #:file-creation-mask file-creation-mask
+                             #:create-session? create-session?
+                             #:environment-variables environment-variables
+                             #:resource-limits resource-limits))
+             (let ((log-input (non-blocking-port log-input)))
+               (close-port log-output)
+
+               (when log-encoding
+                 (set-port-encoding! log-input log-encoding))
+
+               ;; Do not crash when LOG-INPUT contains data that does not
+               ;; conform LOG-ENCODING.  XXX: The 'escape strategy would be
+               ;; nicer but it's not implemented in (ice-9 suspendable-ports):
+               ;; <https://issues.guix.gnu.org/54538>.
+               (set-port-conversion-strategy! log-input 'substitute)
+
+               (spawn-fiber
+                (if log-file
+                    (service-file-logger log-file log-input)
+                    (service-builtin-logger (match command
+                                              ((command . _)
+                                               (basename command)))
+                                            log-input)))
+               pid)))))))
 
 (define* (make-forkexec-constructor command
                                     #:key
diff --git a/tests/logging.sh b/tests/logging.sh
new file mode 100644
index 0000000..edac963
--- /dev/null
+++ b/tests/logging.sh
@@ -0,0 +1,94 @@
+# GNU Shepherd --- Test the logging capabilities of 
'make-forkexec-constructor'.
+# 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_script="t-service-script-$$"
+service_pid="t-service-pid-$$"
+service_log="t-service-log-$$"
+
+herd="herd -s $socket"
+
+trap "cat $log || true; rm -f $socket $conf $service_pid $service_log 
$service_script $log;
+      test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+cat > "$service_script" <<EOF
+echo STARTING
+echo \$\$ > "$PWD/$service_pid"
+echo STARTED
+echo café anyone?
+printf "latin1 garbage: \347a alors !\n"
+exec sleep 600
+EOF
+
+cat > "$conf"<<EOF
+(use-modules (ice-9 match))
+
+(define %command
+  '("$SHELL" "$service_script"))
+
+(register-services
+ (make <service>
+   ;; Service with built-in logging.
+   #:provides '(test-builtin-logging)
+   #:start (make-forkexec-constructor %command
+                                      #:pid-file "$PWD/$service_pid")
+   #:stop  (make-kill-destructor)
+   #:respawn? #f)
+
+ (make <service>
+   ;; Service with built-in logging.
+   #:provides '(test-file-logging)
+   #:start (make-forkexec-constructor %command
+                                      #:log-file "$PWD/$service_log"
+                                      #:pid-file "$PWD/$service_pid")
+   #:stop  (make-kill-destructor)
+   #:respawn? #f))
+
+;; Start it upfront to make sure the logging fiber works.
+(start 'test-file-logging)
+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`"
+
+cat "$service_log"
+$herd status test-file-logging | grep started
+for message in "STARTING" "STARTED" "café" "latin1 garbage: .* alors"
+do
+    grep -E '2[0-9]{3}-[0-9]{2}-[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2} 
'"$message" "$service_log"
+done
+
+rm -f "$service_pid"
+$herd start test-builtin-logging
+for message in "STARTING" "STARTED" "café" "latin1 garbage: .* alors"
+do
+    grep -E '2[0-9]{3}-[0-9]{2}-[0-9]{2} [0-9]{2}:[0-9]{2}:[0-9]{2} 
.*'"$message" "$log"
+done
+
+$herd stop root