[shepherd] 01/06: service: Move line-by-line log reading to a separate fiber.

[Ludovic Courtès]

civodul pushed a commit to branch devel
in repository shepherd.

commit ebe5bf088605d1a2e085878536ff677a4f689aa5
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Wed Nov 29 18:47:25 2023 +0100

    service: Move line-by-line log reading to a separate fiber.
    
    * modules/shepherd/service.scm (line-reader): New procedure.
    (%service-file-logger, service-builtin-logger): Use it.
---
 modules/shepherd/service.scm | 56 ++++++++++++++++++++++++++++----------------
 1 file changed, 36 insertions(+), 20 deletions(-)

diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index f1dd563..63c501d 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -1380,32 +1380,49 @@ rdelim)."
             (string-set! str i chr)
             (loop (+ i 1)))))))
 
+(define (line-reader port channel)
+  "Return a thunk that reads from @var{port} line by line and send each line to
+@var{channel}.  When EOF is reached, close @var{port} and send the EOF object
+on @var{channel}."
+  (lambda ()
+    (define line
+      (make-string %logging-buffer-size))
+
+    (let loop ()
+      (match (read-line! line port)
+        ((? eof-object? eof)
+         (close-port port)
+         (put-message channel eof))
+        (#f                                       ;filled all of LINE
+         (put-message channel (string-copy line))
+         (loop))
+        (count
+         (put-message channel (string-take line count))
+         (loop))))))
+
 (define (%service-file-logger file input)
   "Like 'service-file-logger', but doesn't handle the case in which FILE does
 not exist."
   (let* ((fd     (open-fdes file (logior O_CREAT O_WRONLY O_APPEND O_CLOEXEC)
                             #o640))
-         (output (fdopen fd "al")))
+         (output (fdopen fd "al"))
+         (lines  (make-channel)))
     (set-port-encoding! output "UTF-8")
     (set-port-conversion-strategy! output 'substitute)
     (lambda ()
+      (spawn-fiber (line-reader input lines))
       (call-with-port output
         (lambda (output)
-          (define line
-            (make-string %logging-buffer-size))
-
           (let loop ()
-            (match (read-line! line input)
+            (match (get-message lines)
               ((? eof-object?)
-               (close-port input)
                (close-port output))
-              (count
+              (line
                (let ((prefix (strftime default-logfile-date-format
-                                       (localtime (current-time))))
-                     (count  (or count (string-length line))))
+                                       (localtime (current-time)))))
                  ;; Avoid (ice-9 format) to reduce heap allocations.
                  (put-string output prefix)
-                 (put-string output line 0 count)
+                 (put-string output line)
                  (newline output)
                  (loop))))))))))
 
@@ -1423,26 +1440,25 @@ FILE."
           (apply throw args)))))
 
 (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'."
+  "Return a thunk meant to run as a fiber that reads from @var{input} and logs 
to
+@code{log-output-port}."
   (lambda ()
-    (define line
-      (make-string %logging-buffer-size))
+    (define lines (make-channel))
 
+    (spawn-fiber (line-reader input lines))
     (let loop ()
-      (match (read-line! line input)
+      (match (get-message lines)
         ((? eof-object?)
-         (close-port input))
-        (count
+         #t)
+        (line
          (let ((prefix (strftime (%current-logfile-date-format)
-                                 (localtime (current-time))))
-               (count  (or count (string-length line))))
+                                 (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.
            (simple-format (log-output-port) "~a[~a] "
                           prefix command)
-           (put-string (log-output-port) line 0 count)
+           (put-string (log-output-port) line)
            (newline (log-output-port)))
          (loop))))))