[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 04/04: service: Associate loggers with services; keep buffer
|
From: |
Ludovic Courtès |
|
Subject: |
[shepherd] 04/04: service: Associate loggers with services; keep buffer of logged lines. |
|
Date: |
Sun, 3 Dec 2023 17:50:51 -0500 (EST) |
civodul pushed a commit to branch wip-logging
in repository shepherd.
commit 0be5cf861845510fb36506727968c575419f00a7
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
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 request.
(spawn-service-builtin-logger): New procedure.
(fork+exec-command): Use ‘spawn-service-builtin-logger’ and
‘spawn-service-file-logger’.
---
modules/shepherd/service.scm | 173 ++++++++++++++++++++++++++++++++++---------
1 file changed, 139 insertions(+), 34 deletions(-)
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index 0fe7675..d678370 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -431,7 +431,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))
@@ -604,9 +605,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))))
@@ -623,10 +627,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))))
@@ -644,6 +650,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)
@@ -1362,6 +1383,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)
@@ -1405,7 +1430,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)
@@ -1416,54 +1451,109 @@ 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)))
+ (match (get-message/choice lines channel)
((? eof-object?)
- (close-port output))
+ (close-port output)
+ (when service
+ ;; When connected to a service, keep running until the
+ ;; service sends an explicit 'terminate message.
+ (loop messages)))
+ ('terminate
+ (close-port input))
+ (('recent-messages reply)
+ (put-message reply (ring-buffer->list messages))
+ (loop messages))
(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))))))))))
+ (loop (ring-buffer-insert (cons now line)
+ messages)))))))))))
-(define* (service-file-logger file input
- #:key (service (current-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)))
+ (match (get-message/choice lines channel)
((? eof-object?)
- #t)
+ (when service
+ ;; When connected to a service, keep running until the
+ ;; service sends an explicit 'terminate message.
+ (loop pid messages)))
+ ('terminate
+ (close-port input))
+ (('recent-messages reply)
+ (put-message reply (ring-buffer->list messages))
+ (loop pid messages))
(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)
@@ -1471,7 +1561,23 @@ 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))))))))
+
+(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)))
@@ -1677,13 +1783,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