;; logger.scm -- Logging service output.
;; Copyright (C) 2022-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 logger)
  #:use-module ((fibers)
                #:hide (sleep))
  #:use-module (fibers channels)
  #:use-module (fibers operations)
  #:use-module (shepherd comm)
  #:autoload   (shepherd service) (current-service
                                   process?
                                   process-id
                                   register-service-logger
                                   service-canonical-name
                                   service-running-value
                                   service-status)
  #:use-module (shepherd support)
  #:use-module (ice-9 textual-ports)
  #:use-module (ice-9 match)
  #:export (default-log-history-size

            spawn-service-file-logger
            spawn-service-builtin-logger
            spawn-service-system-logger

            logger-recent-messages
            logger-files
            rotate-log-file

            ;; Internal helpers.
            log-line
            open-log-file
            rotate-and-reopen-log-file))

(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)
            (if (zero? i) eof i))
           ((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))

    (setvbuf port 'block (* 2 %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* (log-line line output #:optional (now (current-time))
                   #:key (date-format default-logfile-date-format))
  "Attempt to write @var{line} to @var{output} with @var{now} as its timestamp,
formatting according to @var{date-format}, catching @code{'system-error}
exceptions.  Return @var{now}."
  (let ((prefix (strftime date-format (localtime now))))
    ;; Swallow errors such as ENOSPC: the show must go on, even if logs cannot
    ;; be written to disk.
    (catch-system-error
     ;; Avoid (ice-9 format) to reduce heap allocations.
     (put-string output prefix)
     (put-string output line)
     (newline output))
    now))

(define* (open-log-file file #:optional (mode #o640))
  "Open @var{file} as a log file, close-on-exec, in append mode, with UTF-8
encoding, etc."
  (let* ((fd     (open-fdes file (logior O_CREAT O_WRONLY O_APPEND O_CLOEXEC)
                            mode))
         (output (fdopen fd "al")))
    (set-port-encoding! output "UTF-8")
    (set-port-conversion-strategy! output 'substitute)
    output))

(define* (rotate-and-reopen-log-file output file rotated-file
                                     #:optional (mode #o640))
  "Rotate @var{file}, currently or previously opened as port @var{output}, to
@var{rotated-file}; close @var{output} and reopen @var{file} with @var{mode}
and return the resulting output port.  If rotation or reopening fails, return
@code{#f}."
  (local-output (l10n "Rotating '~a' to '~a'.")
                file rotated-file)

  (let ((output (if (port-closed? output)
                    (open-log-file file mode)
                    output)))
    (newline output)
    (log-line (l10n "Rotating log.") output)
    (close-port output))

  (let ((output (catch 'system-error
                  (lambda ()
                    (rename-file file rotated-file)
                    (open-log-file file mode))
                  (lambda args
                    args))))
    (or (and (port? output) output)
        (begin
          (local-output (l10n "Failed to rotate '~a' to '~a': ~a.")
                        file rotated-file
                        (strerror (system-error-errno output)))
          #f))))

(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."
  (define lines
    (make-channel))

  (define output
    (open-log-file file))

  (lambda ()
    (spawn-fiber (line-reader input lines))

    (when service
      ;; Associate this logger with SERVICE.
      (register-service-logger service channel))

    (let log ((output output)
              (messages (ring-buffer history-size))
              (service service))
      (call-with-port output
        (lambda (output)
          (let loop ((messages messages)
                     (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))
              (('files reply)
               (put-message reply (list file))
               (loop messages service))
              (('rotate requested-file rotated-file reply)
               (if (string=? requested-file file)
                   (let ((output (rotate-and-reopen-log-file output file
                                                             rotated-file)))
                     (put-message reply (port? output))
                     (if (port? output)
                         (log output messages service)
                         (loop messages service)))
                   (begin
                     (local-output (l10n "Ignoring request to \
rotate '~a' (log file is '~a').")
                                   requested-file file)
                     (put-message reply #f)
                     (loop messages service))))
              (('set-process-id pid)              ;ignore
               (loop messages service))
              (line
               (let ((now (log-line line 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}."
  ;; Keep FILE as an absolute file name.  This is necessary for instance so
  ;; that the 'log-rotation' service passes the right file name to 'gzip' &
  ;; co., and so that the file name showed in 'herd status SVC' is absolute.
  (let ((file (if (string-prefix? "/" file)
                  file
                  (in-vicinity (getcwd) file))))
    (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)))
    (catch 'system-error
      (lambda ()
        (spawn-fiber (service-file-logger channel file input
                                          #:service service
                                          #:history-size history-size))
        channel)
      (lambda args
        (local-output (l10n "Failed to open log file '~a' for ~a: ~a.")
                      file
                      (or (and=> service service-canonical-name)
                          (l10n "<unknown service>"))
                      (strerror (system-error-errno args)))
        (apply throw args)))))

(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.
      (register-service-logger service 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))
        (('files reply)
         (put-message reply '())                  ;not logged to a file
         (loop pid messages service))
        (('rotate _ _ reply)                      ;nothing to rotate
         (put-message reply #f)
         (loop pid messages service))
        (('set-process-id new-pid)
         (loop new-pid messages service))
        (line
         (let* ((now (current-time))
                ;; Note: 'simple-format' is not suspendable, hence 'put-string'.
                (line* (if (integer? pid)
                           (simple-format #f "~a[~a] ~a~%" command pid line)
                           (simple-format #f "[~a] ~a~%" command line))))
           (put-string (log-output-port) line*)
           (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* (service-system-logger channel 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}.  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.
      (register-service-logger service channel))

    (let loop ((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 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))
        (('files reply)
         (put-message reply '())                  ;not logged to a file
         (loop messages service))
        (('rotate _ _ reply)                      ;nothing to rotate
         (put-message reply #f)
         (loop messages service))
        (('set-process-id pid)                    ;ignore
         (loop messages service))
        (line
         (let ((now (current-time)))
           (call-with-syslog-port
            (lambda (port)
              ;; Note: 'simple-format' is not suspendable, hence 'put-string'.
              (let ((str (simple-format #f "shepherd[~a]: ~a~%"
                                        (getpid) line)))
                (put-string port str))))
           (loop (ring-buffer-insert (cons now line) messages)
                 service)))))))

(define* (spawn-service-system-logger input
                                      #:key
                                      (service (current-service))
                                      (history-size (default-log-history-size)))
  "Spawn a logger that reads from @var{input}, an input port, and logs to
@file{/dev/log}, @file{/dev/kmsg}, or @file{/dev/console}; 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-system-logger channel input
                                        #:service service
                                        #:history-size history-size))
    channel))

(define (logger-control-message message)
  "Return a procedure to send @var{message} to the given logger and wait for its
reply."
  (lambda (logger)
    (let ((reply (make-channel)))
      (put-message logger (list message reply))
      (get-message reply))))

(define logger-recent-messages
  ;; Return the list of timestamp/string for recently logged messages.
  (logger-control-message 'recent-messages))

(define logger-files
  ;; Return the file names the log is written to, possibly the empty list.
  (logger-control-message 'files))

(define (rotate-log-file logger file rotated-file)
  "Ask @var{logger} to atomically rename its log file @var{file} to
@var{rotated-file} and to re-open it with the same name as before.  Return
@code{#f} on failure--e.g., ENOSPC or @var{logger} is not file-backed."
  (let ((reply (make-channel)))
    (put-message logger `(rotate ,file ,rotated-file ,reply))
    (get-message reply)))
