civodul pushed a commit to branch wip-syslogd
in repository shepherd.
commit 714cfc3f47ec6fc1fa471ed04a2a6754d8c8c50b
Author: Ludovic Courtès <[email protected]>
AuthorDate: Wed Jul 17 16:45:25 2024 +0200
squash! Move from SOCK_STREAM to SOCK_DGRAM.
---
modules/shepherd/service/system-log.scm | 163 +++++++++++++++-----------------
tests/services/system-log.sh | 6 +-
2 files changed, 82 insertions(+), 87 deletions(-)
diff --git a/modules/shepherd/service/system-log.scm
b/modules/shepherd/service/system-log.scm
index f9e1be0..1a672af 100644
--- a/modules/shepherd/service/system-log.scm
+++ b/modules/shepherd/service/system-log.scm
@@ -28,8 +28,11 @@
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
#:autoload (ice-9 rdelim) (read-line)
+ #:autoload (ice-9 iconv) (bytevector->string)
#:use-module (ice-9 vlist)
- #:use-module (rnrs io ports)
+ #:use-module ((rnrs io ports) #:hide (bytevector->string))
+ #:use-module (rnrs bytevectors)
+ #:autoload (rnrs bytevectors gnu) (bytevector-slice)
#:use-module (fibers operations)
#:use-module (fibers channels)
#:autoload (fibers io-wakeup) (wait-until-port-readable-operation)
@@ -123,80 +126,37 @@
(define %default-priority (system-log-priority notice))
(define %default-facility (system-log-facility user))
+(define (parse-system-log-message line)
+ "Parse @var{line} and return a @code{<system-log-message>} record
+representing it."
+ (match (false-if-exception (regexp-exec %system-log-message-rx line))
+ (#f
+ (system-log-message (logior %default-facility %default-priority)
+ #f #f line))
+ (m
+ (let* ((facility+priority (string->number (match:substring m 1)))
+ (process+pid (match:substring m 3))
+ (process pid (match (regexp-exec %process+pid-rx
+ process+pid)
+ (#f (values process+pid #f))
+ (m (values (match:substring m 1)
+ (string->number
+ (match:substring m 2)))))))
+ (system-log-message facility+priority
+ process pid
+ (match:substring m 4))))))
+
(define (read-system-log-message port)
+ "Read a system log message from @var{port}. Return the end-of-file object
+or a <system-log-message> object."
(match (read-line port)
- ((? eof-object? eof)
- eof)
- (line
- (match (false-if-exception (regexp-exec %system-log-message-rx line))
- (#f
- (system-log-message (logior %default-facility %default-priority)
- #f #f line))
- (m
- (let* ((facility+priority (string->number (match:substring m 1)))
- (process+pid (match:substring m 3))
- (process pid (match (regexp-exec %process+pid-rx
- process+pid)
- (#f (values process+pid #f))
- (m (values (match:substring m 1)
- (string->number
- (match:substring m 2)))))))
- (system-log-message facility+priority
- process pid
- (match:substring m 4))))))))
-
-(define (read-client-log client dispatcher)
- (let loop ()
- (match (read-system-log-message client)
- ((? eof-object?)
- #t)
- (#f
- (loop))
- (message
- (put-message dispatcher message)
- (loop)))))
-
-(define (spawn-child-service client parent id dispatcher)
- "Register and start a new service that reads messages from @var{client}, a
-socket, passing them to @var{dispatcher} for actual logging. @var{parent} and
-@var{id} are used to generate the service's name."
- (letrec* ((name (string->symbol
- (string-append (symbol->string parent) "-client-"
- (number->string id))))
- (child (service
- (list name)
- #:transient? #t
- #:respawn? #f
- #:requirement (list parent)
- #:start (lambda ()
- (spawn-fiber
- (lambda ()
- (read-client-log client dispatcher)))
- client)
- #:stop (lambda (client)
- (close-port client)
- #f))))
- (register-services (list child))
- (start-service child)))
-
-(define (accept/get-message socket channel)
- "Wait for connections on @var{socket} and for messages on @var{channel}.
-Return either the return value of the @code{accept} procedure, for incoming
-connections, or the message received on @var{channel} wrapped in a list whose
-first element is @code{'message}."
- (perform-operation
- (choice-operation
- (wrap-operation (wait-until-port-readable-operation socket)
- (lambda ()
- (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC))))
- (wrap-operation (get-operation channel)
- (lambda (message)
- (list 'message message))))))
+ ((? eof-object? eof) eof)
+ (line (parse-system-log-message line))))
(define* (open-socket file #:key (backlog 512))
- "Open a socket listening on @var{file} and return it."
+ "Open a datagram socket listening on @var{file} and return it."
(let ((socket (socket AF_UNIX
- (logior SOCK_STREAM SOCK_NONBLOCK SOCK_CLOEXEC)
+ (logior SOCK_DGRAM SOCK_NONBLOCK SOCK_CLOEXEC)
0)))
(catch 'system-error
(lambda ()
@@ -207,24 +167,56 @@ first element is @code{'message}."
(false-if-exception (delete-file file))
(bind socket AF_UNIX file))
(apply throw args))))
- (listen socket backlog)
socket))
-(define (run-system-log channel name socket dispatcher)
- "Run the system log, where @var{name} is its service name. Listen for
-connections on @var{socket} and for control messages on @var{channel}. Send
-incoming system log messages to @var{dispatcher}."
- (let loop ((id 0))
- (match (accept/get-message socket channel)
- (('message ('terminate reply))
+(define (wait-for-input-or-message socket channel)
+ "Wait for input on @var{socket} or messages on @var{channel}. Return
+@var{socket} when input is available or the message received on @var{channel}."
+ (perform-operation
+ (choice-operation
+ (wrap-operation (wait-until-port-readable-operation socket)
+ (const socket))
+ (get-operation channel))))
+
+(define (maybe-utf8->string bv)
+ "Attempt to decode BV as UTF-8 string and return it. Gracefully handle the
+case where BV does not contain only valid UTF-8."
+ (catch 'decoding-error
+ (lambda ()
+ (utf8->string bv))
+ (lambda _
+ ;; Fall back to something that should be safe.
+ (bytevector->string bv "ISO-8859-1" 'substitute))))
+
+(define (run-system-log channel socket dispatcher)
+ "Return the system log, getting instructions on @var{channel}, receiving
+messages to be logged on @var{socket} and passing them to @var{dispatcher}."
+ (define (input-marker? x)
+ (eq? x socket))
+
+ (define buffer
+ (make-bytevector 1024))
+
+ (let loop ()
+ (match (wait-for-input-or-message socket channel)
+ ((? input-marker?)
+ (match (recvfrom! socket buffer)
+ ((0 . _)
+ #t)
+ ((bytes . sender)
+ (let ((bytes (if (= (char->integer #\newline)
+ (bytevector-u8-ref buffer (- bytes 1)))
+ (- bytes 1)
+ bytes)))
+ (put-message dispatcher
+ (parse-system-log-message
+ (maybe-utf8->string
+ (bytevector-slice buffer 0 bytes)))))))
+ (loop))
+ (('terminate reply)
(local-output (l10n "Terminating system log service."))
(close-port socket)
- (put-message dispatcher `(terminate ,reply)))
- ((port . client)
- (local-output (l10n "New system log connection from ~s.")
- client)
- (spawn-child-service port name id dispatcher)
- (loop (+ 1 id))))))
+ (put-message dispatcher `(terminate ,reply))))))
(define (log-dispatcher channel log-file)
"Dispatch system log messages received on @var{channel} to log files. Call
@@ -307,8 +299,7 @@ to write to."
(dispatcher (spawn-log-dispatcher log-file)))
(spawn-fiber
(lambda ()
- (run-system-log channel (car provision)
- socket dispatcher)))
+ (run-system-log channel socket dispatcher)))
socket))
#:stop (lambda (socket)
(let ((reply (make-channel)))
diff --git a/tests/services/system-log.sh b/tests/services/system-log.sh
index 7f388e1..074f949 100644
--- a/tests/services/system-log.sh
+++ b/tests/services/system-log.sh
@@ -66,7 +66,7 @@ cat > "$logger" <<EOF
!#
(display "starting logger\n")
-(let ((sock (socket AF_UNIX SOCK_STREAM 0)))
+(let ((sock (socket AF_UNIX SOCK_DGRAM 0)))
(connect sock AF_UNIX "$syslog_socket")
(display "<86> Jun 29 10:45:54 sudo: pam_unix(sudo:session): session opened
for user root\n" sock)
(display "<85>Jul 14 12:32:50 sudo: pam_unix(sudo:auth): authentication
failure; logname= uid=1000\n" sock)
@@ -107,6 +107,10 @@ grep "ntpd\[427\]: new interface" "$syslog_debug_file"
grep "elogind\[286\]: Power key pressed short" "$syslog_file"
grep "NetworkManager\[319\]: .*sleep" "$syslog_file"
+test $(wc -l < "$syslog_auth_file") -eq 3
+test $(wc -l < "$syslog_debug_file") -eq 1
+test $(wc -l < "$syslog_file") -eq 2
+
for file in "$syslog_file" "$syslog_auth_file" "$syslog_debug_file"
do
cat "$file"
