civodul pushed a commit to branch devel
in repository shepherd.
commit 17aded516b01e51986a5e18da17de24abfa33f7e
Author: Ludovic Courtès <[email protected]>
AuthorDate: Sat Apr 27 21:00:46 2024 +0200
service: Move logging code to (shepherd logger).
* modules/shepherd/service.scm (default-log-history-size)
(%logging-buffer-size, read-line!, line-reader, get-message/choice)
(%service-file-logger, service-file-logger, spawn-service-file-logger)
(service-builtin-logger, spawn-service-file-logger): Move to…
* modules/shepherd/logger.scm: … here. New file.
---
Makefile.am | 1 +
modules/shepherd/logger.scm | 249 +++++++++++++++++++++++++++++++++++++++++++
modules/shepherd/service.scm | 222 ++------------------------------------
3 files changed, 256 insertions(+), 216 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 37804cd..19cbf7a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -41,6 +41,7 @@ servicesubdir = $(guilemoduledir)/shepherd/service
dist_shepherdsub_DATA = \
modules/shepherd/args.scm \
modules/shepherd/colors.scm \
+ modules/shepherd/logger.scm \
modules/shepherd/service.scm \
modules/shepherd/support.scm \
modules/shepherd/comm.scm
diff --git a/modules/shepherd/logger.scm b/modules/shepherd/logger.scm
new file mode 100644
index 0000000..6a70d89
--- /dev/null
+++ b/modules/shepherd/logger.scm
@@ -0,0 +1,249 @@
+;; logger.scm -- Logging service output.
+;; Copyright (C) 2022-2024 Ludovic Courtès <[email protected]>
+;;
+;; This file is part of the GNU Shepherd.
+;;
+;; The GNU Shepherd is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or (at
+;; your option) any later version.
+;;
+;; The GNU Shepherd is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with the GNU Shepherd. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (shepherd logger)
+ #:use-module ((fibers)
+ #:hide (sleep))
+ #:use-module (fibers channels)
+ #:use-module (fibers operations)
+ #:use-module (shepherd comm)
+ #:autoload (shepherd service) (current-service
+ service-control
+ service-running-value
+ service-status)
+ #:use-module (shepherd support)
+ #:use-module (rnrs io ports)
+ #:use-module (ice-9 match)
+ #:export (default-log-history-size
+
+ spawn-service-file-logger
+ spawn-service-builtin-logger))
+
+(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)
+
+(define (read-line! str port)
+ "This is an interruptible version of the 'read-line!' procedure from (ice-9
+rdelim)."
+ ;; As of Guile 3.0.8, (@ (ice-9 rdelim) read-line!) calls
+ ;; '%read-delimited!', which is in C and thus non-interruptible.
+ (define len
+ (string-length str))
+
+ (let loop ((i 0))
+ (and (< i len)
+ (match (read-char port)
+ ((? eof-object? eof)
+ eof)
+ ((or #\newline #\return)
+ i)
+ (chr
+ (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 (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)
+ #o640))
+ (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))
+
+ (when service
+ ;; Associate this logger with SERVICE.
+ (put-message (service-control service)
+ `(register-logger ,channel)))
+
+ (call-with-port output
+ (lambda (output)
+ (let loop ((messages (ring-buffer history-size))
+ (service service))
+ (match (get-message/choice lines channel)
+ ((? eof-object?)
+ (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))
+ (('file reply)
+ (put-message reply file)
+ (loop messages service))
+ (line
+ (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 (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 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 channel file input
+ #:service service
+ #:history-size history-size))
+ (apply throw args)))))
+
+(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))
+
+ (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?)
+ (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))
+ (('file reply)
+ (put-message reply #f) ;not logged to a file
+ (loop pid messages service))
+ (line
+ (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)
+ (simple-format (log-output-port) "~a[~a] "
+ prefix command))
+ (put-string (log-output-port) line)
+ (newline (log-output-port))
+ (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))
diff --git a/modules/shepherd/service.scm b/modules/shepherd/service.scm
index da33d52..1d036ef 100644
--- a/modules/shepherd/service.scm
+++ b/modules/shepherd/service.scm
@@ -38,7 +38,7 @@
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module ((srfi srfi-35) #:hide (make-condition))
- #:use-module (rnrs io ports)
+ #:use-module ((rnrs io ports) #:select (get-string-all))
#:use-module ((ice-9 control) #:select (call/ec))
#:use-module (ice-9 match)
#:use-module (ice-9 format)
@@ -48,6 +48,7 @@
#:use-module (shepherd support)
#:use-module (shepherd comm)
#:use-module (shepherd config)
+ #:use-module (shepherd logger)
#:use-module (shepherd system)
#:export (<service>
service
@@ -74,8 +75,11 @@
service-recent-messages
service-log-file
service-action-list
+ service-control ;internal
+
lookup-service-action
service-defines-action?
+
with-service-registry
lookup-service
service-name-count
@@ -416,7 +420,7 @@ denoting what the service provides."
(raise (condition
(&message (message "invalid service provision list")))))))
-(define (service-control service)
+(define (service-control service) ;internal
"Return the controlling channel of @var{service}."
;; Spawn the controlling fiber lazily, hopefully once Fibers has actually
;; been initialized.
@@ -1463,220 +1467,6 @@ 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)
-
-(define (read-line! str port)
- "This is an interruptible version of the 'read-line!' procedure from (ice-9
-rdelim)."
- ;; As of Guile 3.0.8, (@ (ice-9 rdelim) read-line!) calls
- ;; '%read-delimited!', which is in C and thus non-interruptible.
- (define len
- (string-length str))
-
- (let loop ((i 0))
- (and (< i len)
- (match (read-char port)
- ((? eof-object? eof)
- eof)
- ((or #\newline #\return)
- i)
- (chr
- (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 (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)
- #o640))
- (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))
-
- (when service
- ;; Associate this logger with SERVICE.
- (put-message (service-control service)
- `(register-logger ,channel)))
-
- (call-with-port output
- (lambda (output)
- (let loop ((messages (ring-buffer history-size))
- (service service))
- (match (get-message/choice lines channel)
- ((? eof-object?)
- (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))
- (('file reply)
- (put-message reply file)
- (loop messages service))
- (line
- (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 (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 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 channel file input
- #:service service
- #:history-size history-size))
- (apply throw args)))))
-
-(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))
-
- (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?)
- (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))
- (('file reply)
- (put-message reply #f) ;not logged to a file
- (loop pid messages service))
- (line
- (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)
- (simple-format (log-output-port) "~a[~a] "
- prefix command))
- (put-string (log-output-port) line)
- (newline (log-output-port))
- (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)))
supplementary-groups)))
