;; system-log.scm -- Reading from the "system log" or "syslog".
;; Copyright (C) 2024-2025 Ludovic Courtès <ludo@gnu.org>
;;
;; 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 endpoints)
  #:use-module (shepherd service)
  #:use-module (shepherd support)
  #:autoload   (shepherd config) (%localstatedir)
  #:autoload   (shepherd logger) (default-log-history-size
                                  open-log-file
                                  log-line
                                  rotate-and-reopen-log-file)
  #:autoload   (shepherd comm) (system-log-file
                                define-record-type-serializer)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-71)
  #: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) #: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)
  #:export (system-log-message?
            system-log-message-facility
            system-log-message-priority
            system-log-message-content
            system-log-message-sender

            system-log-priority
            system-log-facility

            read-system-log-message

            kernel-log-file
            default-max-silent-time
            default-message-destination-procedure
            system-log-service))

;; Message sent to the system log (minus its timestamp).
(define-record-type <system-log-message>
  (system-log-message priority+facility content sender)
  system-log-message?
  (priority+facility system-log-message-priority+facility)
  (content           system-log-message-content)
  (sender            system-log-message-sender))  ;#f | socket address

(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))
  (internal/mark  (ash 20 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 the prefix of system log messages.  Example:
  ;;   <29>Jun 22 16:41:30 wpa_supplicant[303]: whatever
  ;; Note: Do not match the actual message (the suffix) because it might
  ;; contain Unicode code points and 'regexp-exec' might be buggy in that
  ;; case: <https://bugs.gnu.org/77392>.
  (make-regexp "<([0-9]+)> ?([[:alpha:]]{3} +[0-9]+ [0-9]+:[0-9]+:[0-9]+ )?"))

(define %default-priority (system-log-priority notice))
(define %default-facility (system-log-facility user))

(define* (parse-system-log-message line #:optional sender)
  "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)
                         line sender))
    (m
     (let* ((facility+priority (string->number (match:substring m 1))))
       (system-log-message facility+priority
                           (match:suffix m) sender)))))

(define* (read-system-log-message port #:optional sender)
  "Read a system log message from @var{port}.  Return the end-of-file object
or a <system-log-message> object, with @var{sender} (either a socket address
or @code{#f}) as its sender."
  (match (read-line port)
    ((? eof-object? eof) eof)
    (line (parse-system-log-message line sender))))

(define %kernel-prefix
  ;; Prefix from messages coming from the "kernel" facility.
  (if (string-contains %host-type "linux")
      "linux: "
      "vmunix: "))                              ;old style

(define (system-log-message->string message)
  "Return a string representing @var{message}, a system log message, as it
will be printed."
  (string-append (or (and=> (system-log-message-sender message)
                            (lambda (address)
                              ;; On the Hurd, accept(2) returns a socket
                              ;; address with the empty string for incoming
                              ;; AF_UNIX connections.  Ignore it.
                              (and (not (= AF_UNIX (sockaddr:fam address)))
                                   (string-append (socket-address->string address)
                                                  " "))))
                     "localhost ")
                 (if (= (system-log-message-facility message)
                        (system-log-facility kernel))
                     %kernel-prefix
                     "")
                 (system-log-message-content message)))

(define (wait-for-input-or-message ports channel)
  "Wait for input on @var{ports}, a list of input ports, or for messages on
@var{channel}.  Return one of the elements of @var{ports} when input is
available or the message received on @var{channel}."
  (perform-operation
   (apply choice-operation
          (get-operation channel)
          (map (lambda (port)
                 (wrap-operation (wait-until-port-readable-operation port)
                                 (const port)))
               ports))))

(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 (socket? port)
  "Return true if @var{port} is backed by a socket."
  (catch 'system-error
    (lambda ()
      (getsockname port))
    (const #f)))

(define (run-system-log channel ports dispatcher)
  "Return the system log, getting instructions on @var{channel}, receiving
messages to be logged on @var{ports}, a list of sockets or other file ports,
and passing them to @var{dispatcher}."
  (define buffer
    (make-bytevector 1024))

  (define (log-bytes buffer 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))
                    sender))))

  (define socket-port?
    ;; Since 'socket?' incurs one syscall per port, do it only once.  Since
    ;; there are usually more sockets than non-socket ports, keep the list of
    ;; of non-socket ports.
    (let ((non-socket (remove socket? ports)))
      (lambda (obj)
        ;; Return true if OBJ is a port and is backed by a socket.
        (and (input-port? obj)
             (not (memq obj non-socket))))))

  (let loop ((ports ports))
    (match (wait-for-input-or-message ports channel)
      ((? socket-port? socket)                    ;socket such as /dev/log
       (match (recvfrom! socket buffer)
         ((0 . _) #t)
         ((bytes . sender) (log-bytes buffer bytes sender)))
       (loop ports))
      ((? input-port? port)                      ;regular file like /proc/kmsg
       (match (read-line port)
         ((? eof-object?)
          (local-output (l10n "Closing system log input file ~s on end-of-file.")
                        (or (port-filename port) (fileno port)))
          (close-port port)
          (loop (delq port ports)))
         (line
          (put-message dispatcher (parse-system-log-message line))
          (loop ports))))
      (('terminate reply)
       ;; Close all of PORTS.  DISPATCHER itself is registered as a logger and
       ;; thus shut down separately, by the service itself.
       (local-output (l10n "Terminating system log service."))
       (for-each close-port ports)
       (put-message reply #t)))))

(define %heartbeat-message
  ;; Message logged when nothing was logged for a while.
  (system-log-message->string
   (system-log-message (logior (system-log-facility internal/mark)
                               (system-log-priority info))
                       "-- MARK --" #f)))

(define* (log-dispatcher channel message-destination
                         #:key
                         max-silent-time
                         (history-size (default-log-history-size))
                         (date-format default-logfile-date-format))
  "Dispatch system log messages received on @var{channel} to log files.  Call
@var{message-destination} for each system log message to determine the
destination file(s)."
  (define default-message-destination
    (default-message-destination-procedure))

  (lambda ()
    (let loop ((ports vlist-null)
               (messages (ring-buffer history-size)))
      (match (if max-silent-time
                 (get-message* channel max-silent-time 'timeout)
                 (get-message channel))
        ((? system-log-message? message)
         ;; Write MESSAGE to the target file(s).
         ;; TODO: Support sending to a remote syslog.
         (let ((files (or (false-if-exception
                           (message-destination message)
                           #:warning
                           (l10n "Uncaught exception \
in message destination procedure: "))
                          (default-message-destination message)))
               (now (current-time))
               (line (system-log-message->string message)))
           (loop (fold (lambda (file ports)
                         (match (vhash-assoc file ports)
                           (#f
                            (catch 'system-error
                              (lambda ()
                                (let ((port (open-log-file file)))
                                  (log-line line port now
                                            #:date-format date-format)
                                  (vhash-cons file port ports)))
                              (lambda args
                                (local-output
                                 (l10n "Failed to open log file '~a': ~a")
                                 file (strerror (system-error-errno args)))
                                ports)))
                           ((_ . port)
                            (log-line line port now
                                      #:date-format date-format)
                            ports)))
                       ports
                       files)
                 (ring-buffer-insert (cons now line) messages))))
        ('timeout
         ;; Write a mark to all the files indiscriminately.
         (vhash-fold (lambda (file port _)
                       (log-line %heartbeat-message port
                                 #:date-format date-format))
                     #t
                     ports)
         (loop ports messages))
        (('recent-messages reply)
         (put-message reply (ring-buffer->list messages))
         (loop ports messages))
        (('files reply)
         (put-message reply (vhash-fold (lambda (file _ lst)
                                          (cons file lst))
                                        '()
                                        ports))
         (loop ports messages))
        (('rotate file rotated-file reply)
         (match (vhash-assoc file ports)
           (#f
            (local-output (l10n "Ignoring request to rotate unknown \
system log file '~a'.")
                          file)
            (put-message reply #f)
            (loop ports messages))
           ((_ . port)
            (let ((port (rotate-and-reopen-log-file port file
                                                    rotated-file)))
              (put-message reply (port? port))
              (if (port? port)
                  (loop (vhash-cons file port (vhash-delete file ports))
                        messages)
                  (loop ports messages))))))
        (('set-process-id pid)                    ;ignore
         (loop ports messages))
        ('terminate
         (local-output (l10n "Closing ~a system log port."
                             "Closing ~a system log ports."
                             (vlist-length ports))
                       (vlist-length ports))
         (vhash-fold (lambda (file port _)
                       (close-port port)
                       #t)
                     #t
                     ports))))))

(define* (spawn-log-dispatcher message-destination
                               #:key
                               max-silent-time
                               (history-size (default-log-history-size))
                               (date-format default-logfile-date-format))
  "Spawn the log dispatcher, responsible for writing system log messages to
the file(s) returned by @var{message-destination} for each message.  Keep up
to @var{history-size} messages in a ring buffer."
  (let ((channel (make-channel)))
    (spawn-fiber (log-dispatcher channel message-destination
                                 #:max-silent-time max-silent-time
                                 #:history-size history-size
                                 #:date-format date-format))
    channel))

(define (default-message-destination-procedure)
  "Return a procedure that, given a system log message, returns a ``good''
default destination to log it to."
  (if (zero? (getuid))
      (lambda (message)
        `(,@(if (member (system-log-message-facility message)
                        (list (system-log-facility mail)
                              (system-log-facility authorization/private)))
                '()
                (list (in-vicinity %localstatedir "log/messages")
                      "/dev/tty12"))
          ,@(if (member (system-log-message-priority message)
                        (list (system-log-priority emergency)
                              (system-log-priority alert)))
                '("/dev/console")
                '())
          ,@(if (= (system-log-message-priority message)
                   (system-log-priority debug))
                (list (in-vicinity %localstatedir "log/debug"))
                '())
          ,@(if (member (system-log-message-facility message)
                        (list (system-log-facility authorization)
                              (system-log-facility authorization/private)))
                (list (in-vicinity %localstatedir "log/secure"))
                '())))
      (const (list (in-vicinity %user-log-dir "syslog")))))

(define %default-kernel-log-file
  (cond ((string-contains %host-type "linux")     ;Linux
         "/proc/kmsg")
        ((string-suffix? "-gnu" %host-type)
         "/dev/klog")                             ;GNU/Hurd
        (else
         #f)))

(define kernel-log-file
  ;; File to read to get kernel messages.
  (make-parameter %default-kernel-log-file))

(define default-max-silent-time
  ;; Maximum number of seconds during which syslogd should remain silent.
  (make-parameter (* 20 60)))

;; Running system log.
(define-record-type <system-log>
  (system-log channel ports dispatcher endpoints kernel-log-file)
  system-log?
  (channel    system-log-channel)
  (ports      system-log-ports)
  (dispatcher system-log-dispatcher)

  ;; The following fields are informational.
  (endpoints  system-log-endpoints)               ;list of <endpoint>
  (kernel-log-file system-log-kernel-log-file))   ;#f | file name

(define (print-system-log log port)
  (simple-format port "#<system-log ~a>"
                 (number->string (object-address log) 16)))

(set-record-type-printer! <system-log> print-system-log)

(define-record-type-serializer (system-log->sexp (system-log <system-log>))
  `(system-log (version 0)
               (endpoints
                ,(map endpoint->sexp (system-log-endpoints system-log)))
               (kernel-log-file ,(system-log-kernel-log-file system-log))
               (sockets ,(filter-map (lambda (port)
                                       (and (not (port-closed? port))
                                            (file-port? port)
                                            (fileno port)))
                                     (system-log-ports system-log)))))

(define (file->endpoint file)
  "Return a endpoint for Unix-domain socket @var{file}."
  (endpoint (make-socket-address AF_UNIX file)
            #:name "Unix-domain system log endpoint"
            #:style SOCK_DGRAM))

(define* (system-log-service #:optional
                             (sources
                              (list (file->endpoint (system-log-file))))
                             #:key
                             (provision '(system-log syslogd))
                             (requirement '())
                             (kernel-log-file (and (zero? (getuid))
                                                   (kernel-log-file)))
                             (message-destination
                              (default-message-destination-procedure))
                             (history-size (default-log-history-size))
                             (max-silent-time (default-max-silent-time))
                             (date-format default-logfile-date-format))
  "Return the system log service (@dfn{syslogd}) with the given
@var{provision} and @var{requirement} (lists of symbols).  The service accepts
connections on @var{sources}, a list of @code{<endpoint>} objects; optionally
it also reads messages from @code{#:kernel-log-file}, which defaults to
@file{/proc/kmsg} (Linux) or @file{/dev/klog} (the Hurd) when running as root.

Log messages are passed to @var{message-destination}, a one-argument procedure
that must return the list of files to write it to.  Write a mark to log files
when no message has been logged for more than @var{max-silent-time} seconds
(this feature is disabled by setting @var{max-silent-time} to @code{#f}).
Timestamps in log files are formatted according to @var{date-format}, a format
string for @code{strftime}, including delimiting space---e.g., @code{\"%c \"}
for a format identical to that of traditional syslogd implementations.

Keep up to @var{history-size} messages in memory for the purposes of allowing
users to view recent messages without opening various files."
  (define (maybe-kernel-log-port)
    (catch 'system-error
      (lambda ()
        (open kernel-log-file
              (logior O_RDONLY O_NONBLOCK O_CLOEXEC)))
      (lambda args
        ;; If KERNEL-LOG-FILE cannot be opened, dismiss it instead of failing
        ;; to start since that could prevent many system services from
        ;; starting (useful for example in Linux containers where /proc/kmsg
        ;; is not accessible).
        (local-output (l10n "Dismissing kernel log '~a': ~a.")
                      kernel-log-file
                      (strerror (system-error-errno args)))
        #f)))

  (define this-system-log
    (service provision
             #:requirement requirement
             #:start (lambda ()
                       (let* ((channel (make-channel))
                              (klog (and kernel-log-file
                                         (maybe-kernel-log-port)))
                              (ports (append (open-sockets sources)
                                             (if klog (list klog) '())))
                              (dispatcher (spawn-log-dispatcher message-destination
                                                                #:max-silent-time
                                                                max-silent-time
                                                                #:history-size
                                                                history-size
                                                                #:date-format
                                                                date-format)))
                         (register-service-logger this-system-log dispatcher)
                         (spawn-fiber
                          (lambda ()
                            (run-system-log channel ports dispatcher)))
                         (system-log channel ports dispatcher
                                     sources (and klog kernel-log-file))))
             #:stop (lambda (system-log)
                      (let ((reply (make-channel)))
                        (put-message (system-log-channel system-log)
                                     `(terminate ,reply))
                        (get-message reply)         ;wait for complete shutdown
                        #f))
             #:respawn? #f
             #:documentation (l10n "Listen for syslogd-style messages from
applications, by default on /dev/log, and log them to files.")))

  this-system-log)
