[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 04/06: service: Associate loggers with services; keep buffer
From: |
Ludovic Courtès |
Subject: |
[shepherd] 04/06: service: Associate loggers with services; keep buffer of logged lines. |
Date: |
Sun, 17 Dec 2023 17:06:22 -0500 (EST) |
civodul pushed a commit to branch devel
in repository shepherd.
commit 67b61146f832bfecad27991743dd688023f40d60
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Dec 2 19:05:10 2023 +0100
service: Associate loggers with services; keep buffer of logged lines.
* modules/shepherd/service.scm (service-controller): Thread ‘logger’.
Handle 'register-logger and 'recent-messages requests.
(default-log-history-size): New variable.
(get-message/choice): New procedure.
(%service-file-logger): Add ‘channel’ and #:history-size parameters.
Make ‘service’ a keyword parameter. Send 'register-logger message to
SERVICE. Thread ‘messages’ through the loop. Handle 'recent-messages
and 'terminate requests.
(service-file-logger): Add ‘channel’ and #:history-size parameters and
honor them.
(spawn-service-file-logger): New procedure.
(service-builtin-logger): Add ‘channel’ and #:history-size.
Send 'register-logger to SERVICE. Thread ‘messages’ through the loop.
Handle 'recent-messages and 'terminate requests.
(spawn-service-builtin-logger): New procedure.
(fork+exec-command): Use ‘spawn-service-builtin-logger’ and
‘spawn-service-file-logger’.
---
modules/shepherd/service.scm | 187 +++++++++++++++++++++++++++++++++++--------
1 file changed, 152 insertions(+), 35 deletions(-)
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 9c95303..2cc5405 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -435,7 +435,8 @@ denoting what the service provides."
(failures ;list of timestamps
(ring-buffer %max-recorded-startup-failures))
(respawns '()) ;list of timestamps
- (replacement #f))
+ (replacement #f)
+ (logger #f)) ;channel of the logger
(define (update-status-changes status)
;; Add STATUS to CHANGES, the ring buffer of status changes.
(ring-buffer-insert (cons status (current-time)) changes))
@@ -608,9 +609,12 @@ denoting what the service provides."
(local-output (l10n "Service ~a is now stopped.")
(service-canonical-name service))
(signal-condition! condition)
+ (when logger
+ (put-message logger 'terminate))
+
(loop (status 'stopped)
(changes (update-status-changes 'stopped))
- (value #f) (condition #f)
+ (value #f) (condition #f) (logger #f)
(respawns '())
(failures (ring-buffer %max-recorded-startup-failures))))
@@ -627,10 +631,12 @@ denoting what the service provides."
(lambda ()
(false-if-exception
((service-termination-handler service)
- service value exit-status))))
+ service value exit-status))
+ (when logger
+ (put-message logger 'terminate))))
(loop (status 'stopped)
(changes (update-status-changes 'stopped))
- (value #f) (condition #f)))))
+ (value #f) (condition #f) (logger #f)))))
('record-respawn-time ;no reply
(loop (respawns (cons (current-time) respawns))))
@@ -648,6 +654,21 @@ denoting what the service provides."
(('replacement reply)
(put-message reply replacement)
(loop))
+ (('register-logger new-logger) ;no reply
+ (when logger
+ ;; Shouldn't happen.
+ (local-output
+ (l10n "Adding controller to ~a, which already has one!")
+ (service-canonical-name service))
+ (put-message logger 'terminate))
+ (loop (logger new-logger)))
+ (('recent-messages reply)
+ ;; Forward the request to LOGGER if it exists, return the empty list
+ ;; otherwise.
+ (if logger
+ (put-message logger `(recent-messages ,reply))
+ (put-message reply '()))
+ (loop))
('terminate ;no reply
(if (eq? status 'stopped)
@@ -1366,6 +1387,10 @@ daemon writing FILE is running in a separate PID
namespace."
(try-again)
(apply throw args)))))))
+(define default-log-history-size
+ ;; Number of lines of service log kept in memory by default.
+ (make-parameter 20))
+
(define %logging-buffer-size
;; Size of the buffer for each line read by logging fibers.
512)
@@ -1409,7 +1434,17 @@ on @var{channel}."
(put-message channel (string-take line count))
(loop))))))
-(define (%service-file-logger file input service)
+(define (get-message/choice channel1 channel2)
+ "Wait for messages on both @var{channel1} and @var{channel2}, and return the
+first message received."
+ (perform-operation (choice-operation
+ (get-operation channel1)
+ (get-operation channel2))))
+
+(define* (%service-file-logger channel file input
+ #:key
+ (service (current-service))
+ (history-size (default-log-history-size)))
"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)
@@ -1420,54 +1455,120 @@ not exist."
(set-port-conversion-strategy! output 'substitute)
(lambda ()
(spawn-fiber (line-reader input lines))
+
+ (when service
+ ;; Associate this logger with SERVICE.
+ (put-message (service-control service)
+ `(register-logger ,channel)))
+
(call-with-port output
(lambda (output)
- (let loop ()
- (match (get-message lines)
+ (let loop ((messages (ring-buffer history-size))
+ (service service))
+ (match (get-message/choice lines channel)
((? eof-object?)
- (close-port output))
+ (close-port output)
+ (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))
(line
- (let ((prefix (strftime default-logfile-date-format
- (localtime (current-time)))))
+ (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 line)
(newline output)
- (loop))))))))))
-
-(define* (service-file-logger file input
- #:key (service (current-service)))
+ (loop (ring-buffer-insert (cons now line)
+ messages)
+ service))))))))))
+
+(define* (service-file-logger channel file 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} and logs
it
to @var{file}. Assume it's logging for @var{service}."
(catch 'system-error
(lambda ()
- (%service-file-logger file input service))
+ (%service-file-logger channel file input
+ #:service service
+ #:history-size history-size))
(lambda args
(if (= ENOENT (system-error-errno args))
(begin
(mkdir-p (dirname file))
- (%service-file-logger file input service))
+ (%service-file-logger channel file input
+ #:service service
+ #:history-size history-size))
(apply throw args)))))
-(define* (service-builtin-logger command input
- #:key (service (current-service)))
+(define* (spawn-service-file-logger file input
+ #:key
+ (service (current-service))
+ (history-size (default-log-history-size)))
+ "Spawn a logger that reads from @var{input}, an input port, and writes a log
+with timestamps to @var{file}; 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-file-logger channel file input
+ #:service service
+ #:history-size history-size))
+ channel))
+
+(define* (service-builtin-logger channel command 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} and logs
to
@code{log-output-port}. Assume it's logging for @var{service}."
(lambda ()
(define lines (make-channel))
(spawn-fiber (line-reader input lines))
- (let loop ((pid #f))
- (match (get-message lines)
+
+ (when service
+ ;; Associate this logger with SERVICE.
+ (put-message (service-control service)
+ `(register-logger ,channel)))
+
+ (let loop ((pid #f)
+ (messages (ring-buffer history-size))
+ (service service))
+ (match (get-message/choice lines channel)
((? eof-object?)
- #t)
+ (close-port input)
+ (when service
+ ;; When connected to a service, keep running until the
+ ;; service sends an explicit 'terminate message.
+ (loop pid messages service)))
+ ('terminate
+ (unless (port-closed? input)
+ ;; When disconnected from a service, loop until EOF is
+ ;; reached on INPUT.
+ (loop pid messages #f)))
+ (('recent-messages reply)
+ (put-message reply (ring-buffer->list messages))
+ (loop pid messages service))
(line
- (let ((pid (or pid
- (and service
- (eq? 'running (service-status service))
- (service-running-value service))))
- (prefix (strftime (%current-logfile-date-format)
- (localtime (current-time)))))
+ (let* ((pid (or pid
+ (and service
+ (eq? 'running (service-status service))
+ (service-running-value service))))
+ (now (current-time))
+ (prefix (strftime (%current-logfile-date-format)
+ (localtime now))))
(if (integer? pid)
(simple-format (log-output-port) "~a~a[~a] "
prefix command pid)
@@ -1475,7 +1576,24 @@ to @var{file}. Assume it's logging for @var{service}."
prefix command))
(put-string (log-output-port) line)
(newline (log-output-port))
- (loop pid)))))))
+ (loop pid
+ (ring-buffer-insert (cons now line)
+ messages)
+ service)))))))
+
+(define* (spawn-service-builtin-logger command input
+ #:key
+ (service (current-service))
+ (history-size
(default-log-history-size)))
+ "Spawn a logger that reads from @var{input}, an input port, marked as coming
+from @var{command}; 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-builtin-logger channel command input
+ #:service service
+ #:history-size history-size))
+ channel))
(define (format-supplementary-groups supplementary-groups)
(list->vector (map (lambda (group) (group:gid (getgr group)))
@@ -1681,13 +1799,12 @@ environment variable used for systemd-style \"socket
activation\"."
;; <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)))
+ (if log-file
+ (spawn-service-file-logger log-file log-input)
+ (spawn-service-builtin-logger (match command
+ ((command . _)
+ (basename command)))
+ log-input))
pid)))))))
(define* (make-forkexec-constructor command
- [shepherd] branch devel created (now 4978a5a), Ludovic Courtès, 2023/12/17
- [shepherd] 02/06: service: Thread the current service to actions., Ludovic Courtès, 2023/12/17
- [shepherd] 03/06: service: Built-in logger logs the PID of the service., Ludovic Courtès, 2023/12/17
- [shepherd] 04/06: service: Associate loggers with services; keep buffer of logged lines.,
Ludovic Courtès <=
- [shepherd] 01/06: service: Move line-by-line log reading to a separate fiber., Ludovic Courtès, 2023/12/17
- [shepherd] 05/06: service: Communicate recently-logged messages to clients., Ludovic Courtès, 2023/12/17
- [shepherd] 06/06: herd: ‘status’ displays recently-logged messages., Ludovic Courtès, 2023/12/17