civodul pushed a commit to branch wip-syslogd
in repository shepherd.
commit cda04452e6651057ea1e438e3c099b996c2dd10e
Author: Ludovic Courtès <[email protected]>
AuthorDate: Sat Jun 29 23:55:47 2024 +0200
DRAFT syslog service
DRAFT: Missing doc and system test.
* modules/shepherd/service/system-log.scm,
tests/services/system-log-internal.scm,
tests/services/system-log.sh: New files.
* Makefile.am (dist_servicesub_DATA): Add them.
(TESTS): Add it.
* modules/shepherd/logger.scm (open-log-file): Export.
---
Makefile.am | 5 +-
modules/shepherd/logger.scm | 4 +-
modules/shepherd/service/system-log.scm | 319 ++++++++++++++++++++++++++++++++
tests/services/system-log-internal.scm | 70 +++++++
tests/services/system-log.sh | 135 ++++++++++++++
5 files changed, 531 insertions(+), 2 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 87a3010..e8fee47 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -52,6 +52,7 @@ dist_servicesub_DATA = \
modules/shepherd/service/log-rotation.scm \
modules/shepherd/service/monitoring.scm \
modules/shepherd/service/repl.scm \
+ modules/shepherd/service/system-log.scm \
modules/shepherd/service/timer.scm
shepherdgosubdir = $(guileobjectdir)/shepherd
@@ -287,7 +288,9 @@ TESTS = \
tests/services/timer.sh \
tests/services/timer-events.scm \
tests/services/log-rotation.sh \
- tests/services/log-rotation-internal.scm
+ tests/services/log-rotation-internal.scm \
+ tests/services/system-log.sh \
+ tests/services/system-log-internal.scm
TEST_EXTENSIONS = .sh .scm
EXTRA_DIST += $(TESTS)
diff --git a/modules/shepherd/logger.scm b/modules/shepherd/logger.scm
index 68abf5d..c0f7a11 100644
--- a/modules/shepherd/logger.scm
+++ b/modules/shepherd/logger.scm
@@ -39,7 +39,9 @@
logger-recent-messages
logger-file
- rotate-log-file))
+ rotate-log-file
+
+ open-log-file))
(define default-log-history-size
;; Number of lines of service log kept in memory by default.
diff --git a/modules/shepherd/service/system-log.scm
b/modules/shepherd/service/system-log.scm
new file mode 100644
index 0000000..f9e1be0
--- /dev/null
+++ b/modules/shepherd/service/system-log.scm
@@ -0,0 +1,319 @@
+;; system-log.scm -- Reading from the "system log" or "syslog".
+;; Copyright (C) 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 service system-log)
+ #:use-module (fibers)
+ #:use-module (shepherd service)
+ #:use-module (shepherd support)
+ #:autoload (shepherd config) (%localstatedir)
+ #:autoload (shepherd logger) (open-log-file)
+ #:autoload (shepherd comm) (system-log-file)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-71)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:autoload (ice-9 rdelim) (read-line)
+ #:use-module (ice-9 vlist)
+ #:use-module (rnrs io ports)
+ #:use-module (fibers operations)
+ #:use-module (fibers channels)
+ #:autoload (fibers io-wakeup) (wait-until-port-readable-operation)
+ #:export (system-log-message?
+ system-log-message-facility
+ system-log-message-priority
+ system-log-message-pid
+ system-log-message-sender
+ system-log-message-content
+
+ system-log-priority
+ system-log-facility
+
+ read-system-log-message
+
+ system-log-service))
+
+;; Message sent to the system log (minus its timestamp).
+(define-record-type <system-log-message>
+ (system-log-message priority+facility sender pid content)
+ system-log-message?
+ (priority+facility system-log-message-priority+facility)
+ (sender system-log-message-sender)
+ (pid system-log-message-pid)
+ (content system-log-message-content))
+
+(define-syntax define-enumerate-type
+ (syntax-rules ()
+ ((_ name->int (name id) ...)
+ (define-syntax name->int
+ (syntax-rules (name ...)
+ ((_ name) id) ...)))))
+
+;; From glibc's <syslog.h>.
+
+(define-enumerate-type system-log-priority
+ (emergency 0)
+ (alert 1)
+ (critical 2)
+ (error 3)
+ (warning 4)
+ (notice 5)
+ (info 6)
+ (debug 7))
+
+(define-enumerate-type system-log-facility
+ (kernel 0)
+ (user (ash 1 3))
+ (mail (ash 2 3))
+ (daemon (ash 3 3))
+ (authorization (ash 4 3))
+ (syslogd (ash 5 3))
+ (lpr (ash 6 3))
+ (news (ash 7 3))
+ (uucp (ash 8 3))
+ (cron (ash 9 3))
+ (authorization/private (ash 10 3))
+ (ftp (ash 11 3))
+ (local0 (ash 12 3))
+ (local1 (ash 13 3))
+ (local2 (ash 14 3))
+ (local3 (ash 15 3))
+ (local4 (ash 16 3))
+ (local5 (ash 17 3))
+ (local6 (ash 18 3))
+ (local7 (ash 19 3)))
+
+(define %system-log-facility-mask #x03f8)
+(define %system-log-priority-mask #x0007)
+
+(define (system-log-message-facility message)
+ "Return the facility @var{message} originates from."
+ (logand (system-log-message-priority+facility message)
+ %system-log-facility-mask))
+
+(define (system-log-message-priority message)
+ "Return the priority of @var{message}."
+ (logand (system-log-message-priority+facility message)
+ %system-log-priority-mask))
+
+(define %system-log-message-rx
+ ;; Regexp matching system log messages. Example:
+ ;; <29>Jun 22 16:41:30 wpa_supplicant[303]: whatever
+ (make-regexp "<([0-9]+)> ?([[:alpha:]]{3} [0-9]+ [0-9]+:[0-9]+:[0-9]+ )?\
+([[:graph:]]+): (.*)"))
+
+(define %process+pid-rx
+ ;; Regexp matching "process[123]".
+ (make-regexp "([[:graph:]]+)\\[([[:digit:]]+)\\]"))
+
+(define %default-priority (system-log-priority notice))
+(define %default-facility (system-log-facility user))
+
+(define (read-system-log-message port)
+ (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))))))
+
+(define* (open-socket file #:key (backlog 512))
+ "Open a socket listening on @var{file} and return it."
+ (let ((socket (socket AF_UNIX
+ (logior SOCK_STREAM SOCK_NONBLOCK SOCK_CLOEXEC)
+ 0)))
+ (catch 'system-error
+ (lambda ()
+ (bind socket AF_UNIX file))
+ (lambda args
+ (if (= (system-error-errno args) EADDRINUSE)
+ (begin
+ (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))
+ (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))))))
+
+(define (log-dispatcher channel log-file)
+ "Dispatch system log messages received on @var{channel} to log files. Call
+@var{log-file} for each system log message to determine the destination file
+name."
+ (define (log-line message output)
+ ;; Write MESSAGE to OUTPUT and return its timestamp.
+ (let* ((now (current-time))
+ (prefix (strftime default-logfile-date-format
+ (localtime now))))
+ ;; Avoid (ice-9 format) to reduce heap allocations.
+ (put-string output prefix)
+ (when (system-log-message-sender message)
+ (if (system-log-message-pid message)
+ (simple-format output "~a[~a]: "
+ (system-log-message-sender message)
+ (system-log-message-pid message))
+ (simple-format output "~a: "
+ (system-log-message-sender message))))
+ (put-string output (system-log-message-content message))
+ (newline output)
+ now))
+
+ (define default-log-file
+ (default-log-file-procedure))
+
+ (lambda ()
+ (let loop ((ports vlist-null))
+ (match (get-message channel)
+ ((? system-log-message? message)
+ (let ((file (or (false-if-exception (log-file message))
+ (default-log-file message))))
+ (match (vhash-assoc file ports)
+ (#f
+ (let ((port (open-log-file file)))
+ (log-line message port)
+ (loop (vhash-cons file port ports))))
+ ((_ . port)
+ (log-line message port)
+ (loop ports)))))
+ (('terminate reply)
+ (local-output (l10n "Closing ~a system log ports.")
+ (vlist-length ports))
+ (vhash-fold (lambda (file port _)
+ (close-port port)
+ #t)
+ #t
+ ports)
+ (put-message reply #t))))))
+
+(define (spawn-log-dispatcher log-file)
+ "Spawn the log dispatcher, responsible for writing system log messages to
+the file returned by @var{log-file} for each message."
+ (let ((channel (make-channel)))
+ (spawn-fiber (log-dispatcher channel log-file))
+ channel))
+
+(define (default-log-file-procedure)
+ (if (zero? (getuid))
+ (const (in-vicinity %localstatedir "log/syslog"))
+ (const (in-vicinity %user-log-dir "syslog"))))
+
+(define* (system-log-service #:optional (file (system-log-file))
+ #:key
+ (provision '(system-log syslogd))
+ (requirement '())
+ (log-file (default-log-file-procedure)))
+ "Return the system log service (@dfn{syslogd}) with the given
+@var{provision} and @var{requirement} (lists of symbols). The service accepts
+connections on @var{file}, a Unix-domain socket. Log messages are passed to
+@var{log-file}, a one-argument procedure that must return the name of the file
+to write to."
+ (define channel
+ (make-channel))
+
+ (service provision
+ #:requirement requirement
+ #:start (lambda ()
+ (let ((socket (open-socket file))
+ (dispatcher (spawn-log-dispatcher log-file)))
+ (spawn-fiber
+ (lambda ()
+ (run-system-log channel (car provision)
+ socket dispatcher)))
+ socket))
+ #:stop (lambda (socket)
+ (let ((reply (make-channel)))
+ (close-port socket)
+ (put-message channel `(terminate ,reply))
+ (get-message reply) ;wait for complete shutdown
+ #f))
+ #:respawn? #f))
diff --git a/tests/services/system-log-internal.scm
b/tests/services/system-log-internal.scm
new file mode 100644
index 0000000..2520f65
--- /dev/null
+++ b/tests/services/system-log-internal.scm
@@ -0,0 +1,70 @@
+;; GNU Shepherd --- Test the system log service.
+;; Copyright © 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 (test-system-log-internal)
+ #:use-module (shepherd service system-log)
+ #:use-module (srfi srfi-64))
+
+(test-begin "system-log-internal")
+
+(test-equal "read-system-log-message, with PID"
+ (list (system-log-facility daemon)
+ (system-log-priority notice)
+ "wpa_supplicant" 303
+ "wlp0s20f0u2: CTRL-EVENT-BEACON-LOSS")
+ (call-with-input-string "<29>Jun 22 16:41:31 wpa_supplicant[303]: \
+wlp0s20f0u2: CTRL-EVENT-BEACON-LOSS"
+ (lambda (port)
+ (let ((message (read-system-log-message port)))
+ (list (system-log-message-facility message)
+ (system-log-message-priority message)
+ (system-log-message-sender message)
+ (system-log-message-pid message)
+ (system-log-message-content message))))))
+
+(test-equal "read-system-log-message, without PID"
+ (list (system-log-facility authorization/private)
+ (system-log-priority notice)
+ "sudo" #f
+ "ludo : TTY=pts/0 ; PWD=/home/ludo ; USER=root ; COMMAND=xyz")
+ (call-with-input-string "<85>Jun 29 10:45:55 \
+sudo: ludo : TTY=pts/0 ; PWD=/home/ludo ; USER=root ; COMMAND=xyz"
+ (lambda (port)
+ (let ((message (read-system-log-message port)))
+ (list (system-log-message-facility message)
+ (system-log-message-priority message)
+ (system-log-message-sender message)
+ (system-log-message-pid message)
+ (system-log-message-content message))))))
+
+(test-equal "read-system-log-message, raw"
+ (list (system-log-facility user)
+ (system-log-priority notice)
+ #f #f
+ "shepherd[1]: Stopping service tor...")
+ ;; This message lacks the usual syslog header.
+ (call-with-input-string "shepherd[1]: Stopping service tor...\n"
+ (lambda (port)
+ (let ((message (read-system-log-message port)))
+ (list (system-log-message-facility message)
+ (system-log-message-priority message)
+ (system-log-message-sender message)
+ (system-log-message-pid message)
+ (system-log-message-content message))))))
+
+(test-end)
diff --git a/tests/services/system-log.sh b/tests/services/system-log.sh
new file mode 100644
index 0000000..7f388e1
--- /dev/null
+++ b/tests/services/system-log.sh
@@ -0,0 +1,135 @@
+# GNU Shepherd --- Test system logging service (syslog).
+# Copyright © 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/>.
+
+shepherd --version
+herd --version
+
+socket="t-socket-$$"
+conf="t-conf-$$"
+log="t-log-$$"
+pid="t-pid-$$"
+logger="$PWD/t-syslog-logger-$$.scm"
+syslog_file="$PWD/t-syslog-$$"
+syslog_auth_file="$PWD/t-syslog-auth-$$"
+syslog_debug_file="$PWD/t-syslog-debug-$$"
+syslog_socket="$PWD/t-syslog-socket-$$"
+
+herd="herd -s $socket"
+
+trap "cat $log || true;
+ rm -f $socket $conf $log $logger $syslog_socket;
+ rm -f $syslog_file $syslog_auth_file $syslog_debug_file;
+ test -f $pid && kill \`cat $pid\` || true; rm -f $pid" EXIT
+
+cat > "$conf" <<EOF
+(use-modules (shepherd service system-log))
+
+(define (log-file message)
+ (pk 'log-file->
+ (cond ((= (system-log-message-facility message)
+ (system-log-facility authorization/private))
+ "$syslog_auth_file")
+ ((= (system-log-message-priority message)
+ (system-log-priority debug))
+ "$syslog_debug_file")
+ (else
+ "$syslog_file"))))
+
+(register-services
+ (list (system-log-service "$syslog_socket"
+ #:log-file log-file)
+ (service
+ '(logger)
+ #:requirement '(syslogd)
+ #:start (make-forkexec-constructor '("$logger"))
+ #:stop (make-kill-destructor)
+ #:respawn? #f)))
+EOF
+
+cat > "$logger" <<EOF
+#!$GUILE --no-auto-compile
+!#
+
+(display "starting logger\n")
+(let ((sock (socket AF_UNIX SOCK_STREAM 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)
+ (display "<81>Jul 14 12:33:01 sudo: ludo : 3 incorrect password attempts ;
TTY=pts/34\n" sock)
+ (display "<31>Jul 14 12:18:28 ntpd[427]: new interface(s) found: waking up
resolver\n" sock)
+ (display "<38>Jul 14 12:47:33 elogind[286]: Power key pressed short.\n" sock)
+ (display "<30>Jul 14 12:47:33 NetworkManager[319]: <info> [1720954053.6685]
manager: sleep: sleep requested\n" sock))
+EOF
+
+chmod +x "$logger"
+
+file_descriptor_count ()
+{
+ ls -l /proc/"$(cat $pid)"/fd/[0-9]* | wc -l
+}
+
+rm -f "$pid"
+shepherd -I -s "$socket" -c "$conf" -l "$log" --pid="$pid" &
+
+# Wait till it's ready.
+while ! test -f "$pid" ; do sleep 0.3 ; done
+
+# Trigger startup of the finalizer thread, which creates a couple of pipes.
+# That way, those extra file descriptors won't influence the comparison with
+# INITIAL_FD_COUNT done at the end.
+$herd eval root '(gc)'
+
+initial_fd_count=$(file_descriptor_count)
+
+$herd start logger
+until $herd status logger | grep stopped; do sleep 0.3; done
+
+grep "starting logger" "$log"
+grep "sudo:.* session opened" "$syslog_auth_file"
+grep "sudo:.* authentication failure" "$syslog_auth_file"
+grep "3 incorrect password attempts" "$syslog_auth_file"
+grep "ntpd\[427\]: new interface" "$syslog_debug_file"
+grep "elogind\[286\]: Power key pressed short" "$syslog_file"
+grep "NetworkManager\[319\]: .*sleep" "$syslog_file"
+
+for file in "$syslog_file" "$syslog_auth_file" "$syslog_debug_file"
+do
+ cat "$file"
+done
+
+$herd stop system-log
+$herd eval root '(gc)'
+
+if test -d "/proc/$$/fd" # GNU/Hurd lacks /proc/*/fd.
+then
+ # At this point, shepherd should be back to INITIAL_FD_COUNT.
+ ls -l "/proc/$(cat $pid)/fd"
+ test $(file_descriptor_count) -le $initial_fd_count
+fi
+
+# Remove the logs, start it again, and ensure it's working.
+rm -f "$syslog_file" "$syslog_auth_file" "$syslog_debug_file"
+$herd enable logger
+$herd start logger
+until $herd status logger | grep stopped; do sleep 0.3; done
+for file in "$syslog_file" "$syslog_auth_file" "$syslog_debug_file"
+do
+ test -f "$file"
+done
+
+$herd stop root
