;; log-rotation.scm -- Rotating service log files.
;; 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 log-rotation)
  #:use-module (shepherd support)
  #:use-module (shepherd logger)
  #:autoload   (shepherd service timer) (calendar-event
                                         make-timer-constructor
                                         make-timer-destructor
                                         timer-trigger-action)
  #:autoload   (shepherd service) (service
                                   service-logger
                                   service-log-files
                                   service-canonical-name
                                   for-each-service
                                   action)
  #:autoload   (shepherd system) (%gzip-program %zstd-program)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-71)
  #:autoload   (ice-9 ftw) (scandir)
  #:use-module (ice-9 match)
  #:export (rotate-past-logs

            %default-rotation-size-threshold
            %default-log-expiry
            %default-log-compression
            log-rotation-service))

(define %compression-extensions
  ;; Compressed file extensions.
  '("gz" "bz2" "lz" "lzma" "xz" "zst"))

(define (file-extension file)
  "Return the extension of @var{file} or @code{#f} if there is none."
  (let ((dot (string-rindex file #\.)))
    (and dot (string-drop file (+ 1 dot)))))

(define (compressed-file? file)
  "Return true if @var{file} denotes a compressed file."
  (->bool (member (file-extension file) %compression-extensions)))

(define (next-rotated-file-name reference file)
  "Return the file name @var{file} should be renamed to and its rotation
number (an integer).  Return #f and #f if @var{file} is not rotated from the
@var{reference} file."
  (define (next-file base n compression)
    (let ((base (string-join base ".")))
      (if (and (string=? base (basename reference))
               (>= n 0)
               (or (not compression)
                   (member compression %compression-extensions)))
          (values (string-append (dirname file) "/" base
                                 "." (number->string (+ 1 n))
                                 (if compression
                                     (string-append "." compression)
                                     ""))
                  n)
          (values #f #f))))

  (match (string-split (basename file) #\.)
    ((base ... (= string->number (? integer? n)) compression)
     (next-file base n compression))
    ((base ... (= string->number (? integer? n)))
     (next-file base n #f))
    (_
     (values #f #f))))

(define* (rotate-past-logs log-file
                           #:optional (rotate rename-file))
  "Rotate previously-rotated archives of @var{log-file}--e.g.,
@code{\"/var/log/ntpd.log\"}--by calling @var{rotate} with the old and new
file names."
  (define directory
    (dirname log-file))

  (define (file->rotation file)
    (let* ((file (in-vicinity directory file))
           (next level (next-rotated-file-name log-file file)))
      (and next level
           (list level file next))))

  (let* ((candidates (scandir directory
                              (let ((base (basename log-file)))
                                (lambda (file)
                                  (and (not (string=? base file))
                                       (string-prefix? base file))))))
         (logs (filter-map file->rotation candidates)))
    ;; Rotate logs starting from the highest level.
    (for-each (match-lambda
                ((level file next)
                 (rotate file next)))
              (sort logs
                    (match-lambda*
                      (((level1 . _) (level2 . _))
                       (< level2 level1)))))))

(define %default-rotation-size-threshold
  ;; Default size in bytes below which log files are not considered for
  ;; rotation.
  (make-parameter 8192))

(define %default-log-compression
  ;; Default log file compression method.
  (make-parameter 'gzip))

(define (compress-file method file)
  "Compress @var{file} in place according to @var{method}, which can be either
a symbol denoting a supported compression method, or a procedure that gets
called with @var{file}."
  ;; Note: Delegate compression to a separate process rather than use an
  ;; in-process compression library to reduce risks of memory corruption or
  ;; leaks and to reduce the attack surface.
  (match method
    ('gzip (system* %gzip-program "-9" file))
    ('zstd (system* %zstd-program "-9" "--rm" file))
    ('none #f)
    ((? procedure? proc) (proc file))
    (_  #f)))

(define* (rotate-file file
                      #:key
                      rotate-current
                      (rotate rename-file)
                      (compression (%default-log-compression))
                      (rotation-size-threshold
                       (%default-rotation-size-threshold)))
  "Rotate @var{file}, a log file, by first rotating past log files with
@var{rotate} and then rotating @var{file} itself by calling
@code{rotate-current} and then compressing it according to @var{compression}."
  (match (stat file #f)
    (#f
     (local-output (l10n "Log file '~a' is inaccessible; not rotating.")
                   file))
    (stat
     (cond ((not (eq? 'regular (stat:type stat)))
            ;; Do not rotate /dev/tty12, directories, or anything like that.
            (local-output
             (l10n "Not rotating '~a', which is not a regular file.")
             file))
           ((> (stat:size stat) rotation-size-threshold)
            ;; First rotate past logs, to free "FILE.1".
            (rotate-past-logs file rotate)
            ;; Then rename FILE to "FILE.1".
            (let* ((next (string-append file ".1"))
                   (rotated? (rotate-current file next)))
              (when rotated?
                (unless (compressed-file? file)
                  (compress-file compression next))
                (local-output (l10n "Rotated '~a'.") file))))
           (else
            (local-output
             (l10n "Not rotating '~a', which is below the ~a B threshold.")
             file rotation-size-threshold))))))

(define* (rotate-logs logger #:optional (rotate rename-file)
                      #:key
                      (compression (%default-log-compression))
                      (rotation-size-threshold
                       (%default-rotation-size-threshold)))
  "Rotate the log file associated with @var{logger}, if any, along with any
previously-archived log files.  Compress the log file of @var{logger}
according to @var{method}.  Call @var{rotate} with the old a new file name for
each rotation.  If the size of the log file is below
@var{rotation-size-threshold}, do not rotate it."
  (for-each (lambda (file)
              (rotate-file file
                           #:rotate rotate
                           #:rotate-current (lambda (file next)
                                              (rotate-log-file logger file next))
                           #:compression compression
                           #:rotation-size-threshold rotation-size-threshold))
            (logger-files logger)))

(define* (rotate-service-logs #:optional (rotate rename-file)
                              #:key
                              (compression (%default-log-compression))
                              (rotation-size-threshold
                               (%default-rotation-size-threshold)))
  "Rotate the log files of all the currently running services."
  (for-each-service (lambda (service)
                      (match (service-logger service)
                        (#f #f)
                        (logger (rotate-logs logger rotate
                                             #:compression compression
                                             #:rotation-size-threshold
                                             rotation-size-threshold))))))

(define* (rotate-external-log file
                              #:optional (rotate rename-file)
                              #:key
                              (compression (%default-log-compression))
                              (rotation-size-threshold
                               (%default-rotation-size-threshold)))
  "Rotate @var{files}, a list of \"external\" log files--i.e., log files not
passed as @code{#:log-file} to any service."
  (rotate-file file
               #:rotate rotate
               #:rotate-current (lambda (file next)
                                  ;; Rotate FILE, which is the log currently
                                  ;; being written to.  This operation is not
                                  ;; atomic.
                                  (copy-file file next)
                                  (truncate-file file 0)
                                  #t)
               #:compression compression
               #:rotation-size-threshold rotation-size-threshold))

(define %default-calendar-event
  ;; Default calendar event when log rotation is triggered.
  (calendar-event #:minutes '(0)
                  #:hours '(22)
                  #:days-of-week '(sunday)))

(define %default-log-expiry
  ;; Default duration in seconds after which log files are deleted.
  (make-parameter (* 3 30 24 3600)))

(define* (log-rotation-service #:optional
                               (event %default-calendar-event)
                               #:key
                               (provision '(log-rotation))
                               (requirement '())
                               (external-log-files '())
                               (compression (%default-log-compression))
                               (expiry (%default-log-expiry))
                               (rotation-size-threshold
                                (%default-rotation-size-threshold)))
  "Return a timed service that rotates service logs along with
@var{external-log-files} (a list of file names such as
@file{/var/log/nginx/access.log} corresponding to ``external'' log files not
passed as @code{#:log-file} to any service) on every occurrence of
@var{event}, a calendar event.

Compress log files according to @var{method}, which can be one of
@code{'gzip}, @code{'zstd}, @code{'none}, or a one-argument procedure that
is passed the file name.  Log files smaller than @var{rotation-size-threshold}
are not rotated; copies older than @var{expiry} seconds are deleted.

Last, @var{provision} and @var{requirement} are lists of symbols specifying
what the service provides and requires, respectively.  Specifying
@var{requirement} is useful to ensure, for example, that log rotation runs
only if the service that mounts the file system that hosts log files is up."
  (define (rotate old new)
    (let ((stat (stat old))
          (now (current-time)))
      (if (<= (- now (stat:mtime stat)) expiry)
          (rename-file old new)
          (begin
            (local-output (l10n "Deleting old log file '~a'.") old)
            (delete-file old)))))

  (define rotation
    (lambda ()
      (rotate-service-logs rotate
                           #:compression compression
                           #:rotation-size-threshold
                           rotation-size-threshold)
      (for-each (lambda (file)
                  (rotate-external-log file
                                       rotate
                                       #:compression compression
                                       #:rotation-size-threshold
                                       rotation-size-threshold))
                external-log-files)))

  (define files-action
    (action 'files
            (lambda _
              (for-each-service (lambda (service)
                                  (define name
                                    (service-canonical-name service))
                                  (for-each (lambda (file)
                                              (format #t "~a\t~a~%"
                                                      file name))
                                            (service-log-files service))))
              (for-each (lambda (file)
                          ;; TRANSLATORS: "External" here refers to "external
                          ;; log files".
                          (format #t (l10n "~a\t(external)~%")
                                  file))
                        external-log-files))
            (l10n "List the log files subject to rotation.")))

  (service provision
           #:start (make-timer-constructor event rotation)
           #:stop (make-timer-destructor)
           #:actions (list timer-trigger-action files-action)
           #:documentation
           (l10n "Periodically rotate the log files of services.")))
