[shepherd] 03/06: shepherd: Use a file logger for the ‘root’ service.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit a2825cf0d08e73a60bfdcca390118e205c3ff462
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Jun 12 21:59:35 2024 +0200

    shepherd: Use a file logger for the ‘root’ service.
    
    * modules/shepherd.scm (main)[log-flags]: Remove.
    [log-input+output]: New variable.
    Set ‘log-output-port’ to its cdr.
    Add call to ‘spawn-service-file-logger’.
    * modules/shepherd/comm.scm (make-shepherd-output-port): Remove
    ‘prefix’ such that the date is no longer written to ‘log-output-port’.
    * modules/shepherd/support.scm (system-default-log-file): New procedure.
    * tests/status-sexp.sh (define_reset_timestamps): Rename to…
    (define_canonicalize): … this, and add ‘remove-messages’ and
    ‘canonicalize-service-sexp’.  Adjust users.
    (root_service_sexp): Change value of ‘log-file’ property.
    * tests/services/log-rotation.sh: Ensure $log is rotated.
---
 modules/shepherd.scm           | 34 +++++++++++++++++++++-------------
 modules/shepherd/comm.scm      |  8 ++------
 modules/shepherd/support.scm   |  7 +++++++
 tests/services/log-rotation.sh |  7 +++++--
 tests/status-sexp.sh           | 29 +++++++++++++++++++++--------
 5 files changed, 56 insertions(+), 29 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 490cf65..8746749 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -36,6 +36,7 @@
   #:use-module (shepherd system)
   #:use-module (shepherd args)
   #:use-module (shepherd comm)
+  #:autoload   (shepherd logger) (spawn-service-file-logger)
   #:autoload   (ice-9 binary-ports) (put-u8 get-u8)
   #:autoload   (fibers operations) (choice-operation
                                     perform-operation
@@ -364,9 +365,16 @@ fork in the child process."
     ;; the signal thread.
     (maybe-signal-port %precious-signals))
 
-  (define log-flags
-    ;; Flags for 'open' when opening the log file.
-    (logior O_CREAT O_APPEND O_WRONLY O_CLOEXEC))
+  (define log-input+output
+    ;; Pipe used to send output to the logger of the 'root' service.
+    (match (pipe2 (logior O_NONBLOCK O_CLOEXEC))
+      ((input . output)
+       (let ((init! (lambda (port)
+                      (set-port-encoding! port "UTF-8")
+                      (set-port-conversion-strategy! port 'substitute))))
+         (init! input)
+         (init! output)
+         (cons input output)))))
 
   (initialize-cli)
 
@@ -439,17 +447,10 @@ fork in the child process."
          (verify-dir (dirname socket-file) #:secure? secure))
 
     ;; Enable logging as first action.
-    (parameterize ((log-output-port
-                    (cond (logfile
-                           (buffering (open logfile log-flags)
-                                      'line))
-                          ((zero? (getuid))
-                           (syslog-output-port))
-                          (else
-                           (buffering (open (user-default-log-file) log-flags)
-                                      'line))))
+    (parameterize ((log-output-port (cdr log-input+output))
                    (%current-logfile-date-format
-                    (if (and (not logfile) (zero? (getuid)))
+                    (if (and #f     ;TODO: Remove #f when syslog is supported.
+                             (not logfile) (zero? (getuid)))
                         (format #f "shepherd[~d]: " (getpid))
                         default-logfile-date-format))
                    (%current-service-output-port
@@ -497,6 +498,13 @@ fork in the child process."
                ;; Register and start the 'root' service.
                (register-services (list root-service))
                (start-service root-service)
+               ;; TODO: Restore logging to syslog for PID 1.
+               (spawn-service-file-logger (or logfile
+                                              (if (= 1 (getpid))
+                                                  (system-default-log-file)
+                                                  (user-default-log-file)))
+                                          (car log-input+output)
+                                          #:service root-service)
 
                ;; Replace the default 'system*' binding with one that
                ;; cooperates instead of blocking on 'waitpid'.  Replace
diff --git a/modules/shepherd/comm.scm b/modules/shepherd/comm.scm
index 665124e..11d055e 100644
--- a/modules/shepherd/comm.scm
+++ b/modules/shepherd/comm.scm
@@ -1,5 +1,5 @@
 ;; comm.scm -- Communication between processes and general output.
-;; Copyright (C) 2013, 2014, 2016, 2018, 2019, 2022, 2023 Ludovic Courtès 
<ludo@gnu.org>
+;; Copyright (C) 2013-2014, 2016, 2018-2019, 2022-2024 Ludovic Courtès 
<ludo@gnu.org>
 ;; Copyright (C) 2002, 2003 Wolfgang Jährling <wolfgang@pro-linux.de>
 ;; Copyright (C) 2018 Danny Milosavljevic <dannym@scratchpost.org>
 ;;
@@ -348,10 +348,6 @@ available."
         (if (not (string-index str #\newline))
             (set! buffer (cons str buffer))
             (let ((str (string-concatenate-reverse (cons str buffer))))
-              (define prefix
-                (strftime (%current-logfile-date-format)
-                          (localtime (current-time))))
-
               ;; Note: We want to render as many newlinew as present in STR,
               ;; so neither 'string-split' nor 'string-tokenize' helps.
               (let loop ((str str))
@@ -360,7 +356,7 @@ available."
                   (unless (string-null? str)
                     ;; Make exactly one 'display' call per line to make sure we
                     ;; don't create several entries for each line.
-                    (display (string-append prefix line) (log-output-port))
+                    (display line (log-output-port))
                     (when index
                       (loop (string-drop str (+ index 1)))))))
 
diff --git a/modules/shepherd/support.scm b/modules/shepherd/support.scm
index 65b6ed0..4f9574f 100644
--- a/modules/shepherd/support.scm
+++ b/modules/shepherd/support.scm
@@ -59,6 +59,7 @@
 
             user-homedir
             user-default-log-file
+            system-default-log-file
             default-logfile-date-format
             default-config-file
             default-socket-dir
@@ -433,6 +434,12 @@ TARGET should be a string representing a filepath + name."
   (mkdir-p %user-log-dir #o700)
   (string-append %user-log-dir "/shepherd.log"))
 
+(define (system-default-log-file)
+  "Return the file name of the log file of PID 1."
+  (let ((log-directory (in-vicinity %localstatedir "log")))
+    (mkdir-p log-directory #o700)
+    (in-vicinity log-directory "shepherd.log")))
+
 (define default-logfile-date-format
   ;; 'strftime' format string to prefix each entry in the log.
   "%Y-%m-%d %H:%M:%S ")
diff --git a/tests/services/log-rotation.sh b/tests/services/log-rotation.sh
index 62f2b7b..9b0da4e 100644
--- a/tests/services/log-rotation.sh
+++ b/tests/services/log-rotation.sh
@@ -29,7 +29,7 @@ external_log="$PWD/t-service-extlog-$$"
 
 herd="herd -s $socket"
 
-trap "cat $log || true; rm -f $socket $conf $log $service_log1* $service_log2* 
$external_log*;
+trap "cat $log || true; rm -f $socket $conf $log* $service_log1* 
$service_log2* $external_log*;
       test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
 
 cat > "$conf" <<EOF
@@ -70,7 +70,7 @@ $herd start log-rotation
 
 sleep 0.5
 
-for file in "$service_log1" "$service_log2" "$external_log"
+for file in "$service_log1" "$service_log2" "$external_log" "$log"
 do
     $herd files log-rotation | grep "$file"
 done
@@ -88,6 +88,8 @@ test -f "$service_log1"
 test -f "$service_log1.1.gz"
 test -f "$service_log2.1.gz" && false
 test -f "$service_log2"
+test -f "$log"
+test -f "$log.1.gz"
 
 until test -f "$external_log.1.gz"; do sleep 0.5; done
 gunzip < "$external_log.1.gz" | grep "external log file"
@@ -99,6 +101,7 @@ $herd trigger log-rotation
 
 until test -f "$service_log1.2.gz"; do sleep 0.5; done
 until test -f "$service_log1.1.gz"; do sleep 0.5; done
+until test -f "$log.2.gz"; do sleep 0.5; done
 test -f "$service_log1"
 test -f "$service_log2.1.gz" && false
 
diff --git a/tests/status-sexp.sh b/tests/status-sexp.sh
index d8359f2..3e0a14b 100644
--- a/tests/status-sexp.sh
+++ b/tests/status-sexp.sh
@@ -84,12 +84,12 @@ root_service_sexp="
       (respawn-delay 0.1)
       (exit-statuses ())
       (recent-messages ())
-      (log-file #f)
+      (log-file \"$PWD/$log\")
       (pending-replacement? #f))"
 
 # Define a helper procedure that resets timestamps in the 'status-changes'
 # property to make it easier to compare them.
-define_reset_timestamps="
+define_canonicalize="
 (define (reset-timestamps service)
   (match service
     (('service version properties ...)
@@ -103,18 +103,31 @@ define_reset_timestamps="
                                alist)))
                    (prop prop))
                  properties)))))
+
+(define (remove-messages service)
+  (match service
+    (('service version properties ...)
+     (cons* 'service version
+            (map (match-lambda
+                   (('recent-messages _)
+                    '(recent-messages ()))
+                   (prop prop))
+                 properties)))))
+
+(define canonicalize-service-sexp
+  (compose reset-timestamps remove-messages))
 "
 
 "$GUILE" -c "
 (use-modules (shepherd comm) (srfi srfi-1) (ice-9 match))
 
-$define_reset_timestamps
+$define_canonicalize
 
 (exit
  (match $fetch_status
    (('reply _ ('result (services)) ('error #f) ('messages ()))
     (lset= equal?
-           (pk 'ACTUAL (map reset-timestamps services))
+           (pk 'ACTUAL (map canonicalize-service-sexp services))
            '($root_service_sexp
              (service (version 0)
                (provides (foo)) (requires ())
@@ -150,7 +163,7 @@ $define_reset_timestamps
 "$GUILE" -c "
 (use-modules (shepherd comm) (srfi srfi-1) (ice-9 match))
 
-$define_reset_timestamps
+$define_canonicalize
 
 (define (start name)
   ;; Start service NAME.
@@ -161,7 +174,7 @@ $define_reset_timestamps
 (exit
  (match (start 'bar)
    (('reply _ ('result service) ('error #f) ('messages (_)))
-    (equal? (reset-timestamps service)
+    (equal? (canonicalize-service-sexp service)
             '(service (version 0)
                (provides (bar)) (requires (foo))
                (respawn? #f) (docstring \"Bar!\")
@@ -199,14 +212,14 @@ $herd unload root all
 "$GUILE" -c "
 (use-modules (shepherd comm) (ice-9 match))
 
-$define_reset_timestamps
+$define_canonicalize
 
 (exit
   (equal? (match $fetch_status
             (('reply version ('result ((service))) rest ...)
              (cons* 'reply version
                      (list 'result
-                            (list (list (reset-timestamps service))))
+                            (list (list (canonicalize-service-sexp service))))
                      rest)))
           '(reply
             (version 0)