[shepherd] 04/06: shepherd: PID 1 logs to /dev/log by default, again.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit 48cae48987af17582754fb345a28f95f10a842f6
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Jun 14 23:29:44 2024 +0200

    shepherd: PID 1 logs to /dev/log by default, again.
    
    This had been changed by the previous commit.
    
    * modules/shepherd/comm.scm (call-with-syslog-port): Export.
    (syslog-output-port): Remove.
    * modules/shepherd/logger.scm (service-system-logger)
    (spawn-service-system-logger): New procedures.
    * modules/shepherd.scm (main): Define ‘syslog?’; use it to determine
    when to use the system logger.
---
 modules/shepherd.scm        | 33 ++++++++++++++----------
 modules/shepherd/comm.scm   | 21 +--------------
 modules/shepherd/logger.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 83 insertions(+), 33 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 8746749..346a967 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -36,7 +36,8 @@
   #:use-module (shepherd system)
   #:use-module (shepherd args)
   #:use-module (shepherd comm)
-  #:autoload   (shepherd logger) (spawn-service-file-logger)
+  #:autoload   (shepherd logger) (spawn-service-file-logger
+                                  spawn-service-system-logger)
   #:autoload   (ice-9 binary-ports) (put-u8 get-u8)
   #:autoload   (fibers operations) (choice-operation
                                     perform-operation
@@ -446,18 +447,21 @@ fork in the child process."
     (and socket-file
          (verify-dir (dirname socket-file) #:secure? secure))
 
+    (define syslog?
+      ;; Is shepherd logging to /dev/log?
+      (and (not logfile) (= 1 (getpid))))
+
     ;; Enable logging as first action.
     (parameterize ((log-output-port (cdr log-input+output))
                    (%current-logfile-date-format
-                    (if (and #f     ;TODO: Remove #f when syslog is supported.
-                             (not logfile) (zero? (getuid)))
-                        (format #f "shepherd[~d]: " (getpid))
+                    (if syslog?
+                        ""                        ;for the "built-in" logger
                         default-logfile-date-format))
                    (%current-service-output-port
                     ;; Send output to log and clients.
                     (make-shepherd-output-port
-                     (if (and (zero? (getuid)) (not logfile))
-                         ;; By default we'd write both to /dev/kmsg and to
+                     (if syslog?
+                         ;; By default we'd write both to /dev/log and to
                          ;; stdout.  Redirect stdout to the bitbucket so we
                          ;; don't log twice.
                          (%make-void-port "w")
@@ -498,13 +502,16 @@ 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)
+
+               (if syslog?
+                   (spawn-service-system-logger (car log-input+output)
+                                                #:service root-service)
+                   (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 11d055e..b8564b4 100644
--- a/modules/shepherd/comm.scm
+++ b/modules/shepherd/comm.scm
@@ -52,7 +52,7 @@
             report-command-error
 
             log-output-port
-            syslog-output-port
+            call-with-syslog-port
             make-shepherd-output-port
 
             %current-client-socket
@@ -302,25 +302,6 @@ mechanism."
                             (apply throw args))))
                     (apply throw args)))))))))
 
-(define (syslog-output-port)
-  "Return the output port to write to syslog or /dev/kmsg, whichever is
-available."
-  (make-soft-port
-   (vector
-    (lambda (char)                                ;write char
-      (call-with-syslog-port
-       (lambda (port)
-         (write-char char port))))
-    (lambda (str)                                 ;write string
-      (call-with-syslog-port
-       (lambda (port)
-         (display str port))))
-    (const #t)                                    ;flush
-    #f                                            ;get char
-    (lambda ()                                    ;close
-      (call-with-syslog-port close-port)))
-   "w"))                                          ;output port
-
 ;; We provide our own output mechanism, because we have certain
 ;; special needs; most importantly, we want to send output to herd
 ;; sometimes.
diff --git a/modules/shepherd/logger.scm b/modules/shepherd/logger.scm
index f41091e..68abf5d 100644
--- a/modules/shepherd/logger.scm
+++ b/modules/shepherd/logger.scm
@@ -35,6 +35,7 @@
 
             spawn-service-file-logger
             spawn-service-builtin-logger
+            spawn-service-system-logger
 
             logger-recent-messages
             logger-file
@@ -301,6 +302,67 @@ with @var{service}.  The logger will maintain a ring 
buffer of up to
                                          #:history-size history-size))
     channel))
 
+(define* (service-system-logger channel input
+                                #:key
+                                (service (current-service))
+                                (history-size (default-log-history-size)))
+  "Return a thunk meant to run as a fiber that reads from @var{input}.  Assume
+it's logging for @var{service}."
+  (lambda ()
+    (define lines (make-channel))
+
+    (spawn-fiber (line-reader input lines))
+
+    (when service
+      ;; Associate this logger with SERVICE.
+      (register-service-logger service channel))
+
+    (let loop ((messages (ring-buffer history-size))
+               (service service))
+      (match (get-message/choice lines channel)
+        ((? eof-object?)
+         (close-port input)
+         (when service
+           ;; When connected to a service, keep running until the
+           ;; service sends an explicit 'terminate message.
+           (loop messages service)))
+        ('terminate
+         (unless (port-closed? input)
+           ;; When disconnected from a service, loop until EOF is
+           ;; reached on INPUT.
+           (loop messages #f)))
+        (('recent-messages reply)
+         (put-message reply (ring-buffer->list messages))
+         (loop messages service))
+        (('file reply)
+         (put-message reply #f)                   ;not logged to a file
+         (loop messages service))
+        (('rotate _ reply)                        ;nothing to rotate
+         (put-message reply #f)
+         (loop messages service))
+        (line
+         (let ((now (current-time)))
+           (call-with-syslog-port
+            (lambda (port)
+              (simple-format port "shepherd[~a]: ~a~%"
+                             (getpid) line)))
+           (loop (ring-buffer-insert (cons now line) messages)
+                 service)))))))
+
+(define* (spawn-service-system-logger input
+                                      #:key
+                                      (service (current-service))
+                                      (history-size 
(default-log-history-size)))
+  "Spawn a logger that reads from @var{input}, an input port, and logs to
+@file{/dev/log}, @file{/dev/kmsg}, or @file{/dev/console}; return the logger's
+control channel.  Associate the logger with @var{service}.  The logger will
+maintain a ring buffer of up to @var{history-size} lines in memory."
+  (let ((channel (make-channel)))
+    (spawn-fiber (service-system-logger channel input
+                                        #:service service
+                                        #:history-size history-size))
+    channel))
+
 (define (logger-control-message message)
   "Return a procedure to send @var{message} to the given logger and wait for 
its
 reply."