[shepherd] 07/08: system-log: Use ‘log-line’ from (shepherd logger).

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit de31c3074e02288f9686d462d693687ff1a27231
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Aug 9 22:33:53 2024 +0200

    system-log: Use ‘log-line’ from (shepherd logger).
    
    * modules/shepherd/logger.scm (log-line): Export.
    * modules/shepherd/service/system-log.scm (%kernel-prefix): New
    variable, formerly in ‘log-dispatcher’.
    (system-log-message->string): New procedure.
    (%heartbeat-message): Pass to ‘system-log-message->string’.
    (log-dispatcher)[kernel-prefix, log-line]: Remove.
    Use ‘system-log-message->string’ together with ‘log-line’ from (shepherd
    logger).
---
 modules/shepherd/logger.scm             |  2 ++
 modules/shepherd/service/system-log.scm | 61 ++++++++++++++++-----------------
 2 files changed, 31 insertions(+), 32 deletions(-)

diff --git a/modules/shepherd/logger.scm b/modules/shepherd/logger.scm
index bb756f5..c82a959 100644
--- a/modules/shepherd/logger.scm
+++ b/modules/shepherd/logger.scm
@@ -41,6 +41,8 @@
             logger-files
             rotate-log-file
 
+            ;; Internal helpers.
+            log-line
             open-log-file
             rotate-and-reopen-log-file))
 
diff --git a/modules/shepherd/service/system-log.scm 
b/modules/shepherd/service/system-log.scm
index 51d4af7..6c5794e 100644
--- a/modules/shepherd/service/system-log.scm
+++ b/modules/shepherd/service/system-log.scm
@@ -23,6 +23,7 @@
   #:use-module (shepherd support)
   #:autoload   (shepherd config) (%localstatedir)
   #:autoload   (shepherd logger) (open-log-file
+                                  log-line
                                   rotate-and-reopen-log-file)
   #:autoload   (shepherd comm) (system-log-file)
   #:use-module (srfi srfi-1)
@@ -147,6 +148,26 @@ or @code{#f}) as its sender."
     ((? eof-object? eof) eof)
     (line (parse-system-log-message line sender))))
 
+(define %kernel-prefix
+  ;; Prefix from messages coming from the "kernel" facility.
+  (if (string-contains %host-type "linux")
+      "linux: "
+      "vmunix: "))                              ;old style
+
+(define (system-log-message->string message)
+  "Return a string representing @var{message}, a system log message, as it
+will be printed."
+  (string-append (or (and=> (system-log-message-sender message)
+                            (lambda (address)
+                              (string-append (socket-address->string address)
+                                             " ")))
+                     "localhost ")
+                 (if (= (system-log-message-facility message)
+                        (system-log-facility kernel))
+                     %kernel-prefix
+                     "")
+                 (system-log-message-content message)))
+
 (define (wait-for-input-or-message ports channel)
   "Wait for input on @var{ports}, a list of input ports, or for messages on
 @var{channel}.  Return one of the elements of @var{ports} when input is
@@ -225,40 +246,15 @@ and passing them to @var{dispatcher}."
 
 (define %heartbeat-message
   ;; Message logged when nothing was logged for a while.
-  (system-log-message (logior (system-log-facility internal/mark)
-                              (system-log-priority info))
-                      "-- MARK --" #f))
+  (system-log-message->string
+   (system-log-message (logior (system-log-facility internal/mark)
+                               (system-log-priority info))
+                       "-- MARK --" #f)))
 
 (define* (log-dispatcher channel message-destination #:key max-silent-time)
   "Dispatch system log messages received on @var{channel} to log files.  Call
 @var{message-destination} for each system log message to determine the
 destination file(s)."
-  (define kernel-prefix
-    ;; Prefix from messages coming from the "kernel" facility.
-    (if (string-contains %host-type "linux")
-        "linux: "
-        "vmunix: "))                              ;old style
-
-  (define (log-line message output)
-    ;; Write MESSAGE to OUTPUT and return its timestamp.
-    (let* ((now (current-time))
-           (prefix (strftime default-logfile-date-format
-                             (localtime now))))
-      ;; Avoid (ice-9 format) to reduce heap allocations.
-      (put-string output prefix)
-      (put-string output
-                  (or (and=> (system-log-message-sender message)
-                             (lambda (address)
-                               (string-append (socket-address->string address)
-                                              " ")))
-                      "localhost "))
-      (when (= (system-log-message-facility message)
-               (system-log-facility kernel))
-        (put-string output kernel-prefix))
-      (put-string output (system-log-message-content message))
-      (newline output)
-      now))
-
   (define default-message-destination
     (default-message-destination-procedure))
 
@@ -275,14 +271,15 @@ destination file(s)."
                            #:warning
                            (l10n "Uncaught exception \
 in message destination procedure: "))
-                          (default-message-destination message))))
+                          (default-message-destination message)))
+               (line (system-log-message->string message)))
            (loop (fold (lambda (file ports)
                          (match (vhash-assoc file ports)
                            (#f
                             (catch 'system-error
                               (lambda ()
                                 (let ((port (open-log-file file)))
-                                  (log-line message port)
+                                  (log-line line port)
                                   (vhash-cons file port ports)))
                               (lambda args
                                 (local-output
@@ -290,7 +287,7 @@ in message destination procedure: "))
                                  file (strerror (system-error-errno args)))
                                 ports)))
                            ((_ . port)
-                            (log-line message port)
+                            (log-line line port)
                             ports)))
                        ports
                        files))))