;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 muradm <mail@muradm.net>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gnu services security)
  #:use-module (gnu packages admin)
  #:use-module (gnu services)
  #:use-module (gnu services configuration)
  #:use-module (gnu services shepherd)
  #:use-module (guix gexp)
  #:use-module (guix packages)
  #:use-module (guix records)
  #:use-module (guix ui)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:export (fail2ban-configuration
            fail2ban-configuration-fields
            fail2ban-jail-configuration
            fail2ban-jail-configuration-fields

            fail2ban-ignore-cache-configuration
            fail2ban-ignore-cache-configuration-fields
            fail2ban-jail-action-configuration
            fail2ban-jail-action-configuration-fields
            fail2ban-jail-filter-configuration
            fail2ban-jail-filter-configuration-fields

            fail2ban-service-type
            fail2ban-jail-service))

(define-configuration/no-serialization fail2ban-ignore-cache-configuration
  (key string "Cache key.")
  (max-count integer "Cache size.")
  (max-time integer "Cache time."))

(define serialize-fail2ban-ignore-cache-configuration
  (match-lambda
    (($ <fail2ban-ignore-cache-configuration> _ key max-count max-time)
     (format #f "key=\"~a\", max-count=~d, max-time=~d"
             key max-count max-time))))

(define-maybe/no-serialization string)

(define-configuration/no-serialization fail2ban-jail-filter-configuration
  (name string "Filter to use.")
  (mode maybe-string "Mode for filter."))

(define serialize-fail2ban-jail-filter-configuration
  (match-lambda
    (($ <fail2ban-jail-filter-configuration> _ name mode)
     (format #f "~a~@[[mode=~a]~]" name (and (not (eq? 'unset mode)) mode)))))

(define (argument? a)
  (and (pair? a)
       (string? (car a))
       (or (string? (cdr a))
           (list-of-strings? (cdr a)))))

(define list-of-arguments? (list-of argument?))

(define-configuration/no-serialization fail2ban-jail-action-configuration
  (name string "Action name.")
  (arguments (list-of-arguments '()) "Action arguments."))

(define list-of-fail2ban-jail-actions?
  (list-of fail2ban-jail-action-configuration?))

(define (serialize-fail2ban-jail-action-configuration-arguments args)
  (let* ((multi-value
          (lambda (v)
            (format #f "~a" (string-join v ","))))
         (any-value
          (lambda (v)
            (if (list? v) (string-append "\"" (multi-value v) "\"") v)))
         (key-value
          (lambda (e)
            (format #f "~a=~a" (car e) (any-value (cdr e))))))
    (format #f "~a" (string-join (map key-value args) ","))))

(define serialize-fail2ban-jail-action-configuration
  (match-lambda
    (($ <fail2ban-jail-action-configuration> _ name arguments)
     (format
      #f "~a~a"
      name
      (if (null? arguments) ""
          (format
           #f "[~a]"
           (serialize-fail2ban-jail-action-configuration-arguments
            arguments)))))))

(define fail2ban-backend->string
  (match-lambda
    ('auto "auto")
    ('pyinotify "pyinotify")
    ('gamin "gamin")
    ('polling "polling")
    ('systemd "systemd")
    (unknown
     (leave
      (G_ "fail2ban: '~a' is not a supported backend~%") unknown))))

(define fail2ban-log-encoding->string
  (match-lambda
    ('auto "auto")
    ('utf-8 "utf-8")
    ('ascii "ascii")
    (unknown
     (leave
      (G_ "fail2ban: '~a' is not a supported log encoding~%") unknown))))

(define (fail2ban-jail-configuration-serialize-field-name name)
  (cond ((symbol? name)
         (fail2ban-jail-configuration-serialize-field-name
          (symbol->string name)))
        ((string-suffix? "?" name)
         (fail2ban-jail-configuration-serialize-field-name
          (string-drop-right name 1)))
        ((string-prefix? "ban-time-" name)
         (fail2ban-jail-configuration-serialize-field-name
          (string-append "bantime." (substring name 9))))
        ((string-contains name "-")
         (fail2ban-jail-configuration-serialize-field-name
          (string-filter (lambda (c) (equal? c #\-)) name)))
        (#t name)))

(define (fail2ban-jail-configuration-serialize-string field-name value)
  #~(string-append
     #$(fail2ban-jail-configuration-serialize-field-name field-name)
     " = " #$value "\n"))

(define (fail2ban-jail-configuration-serialize-integer field-name value)
  (fail2ban-jail-configuration-serialize-string
   field-name (number->string value)))

(define (fail2ban-jail-configuration-serialize-boolean field-name value)
  (fail2ban-jail-configuration-serialize-string
   field-name (if value "true" "false")))

(define (fail2ban-jail-configuration-serialize-backend field-name value)
  (if (eq? 'unset value) ""
      (fail2ban-jail-configuration-serialize-string
       field-name (fail2ban-backend->string value))))

(define (fail2ban-jail-configuration-serialize-fail2ban-ignore-cache-configuration field-name value)
  (fail2ban-jail-configuration-serialize-string
   field-name (serialize-fail2ban-ignore-cache-configuration value)))

(define (fail2ban-jail-configuration-serialize-fail2ban-jail-filter-configuration field-name value)
  (fail2ban-jail-configuration-serialize-string
   field-name (serialize-fail2ban-jail-filter-configuration value)))

(define (fail2ban-jail-configuration-serialize-log-encoding field-name value)
  (if (eq? 'unset value) ""
      (fail2ban-jail-configuration-serialize-string
       field-name (fail2ban-log-encoding->string value))))

(define (fail2ban-jail-configuration-serialize-list-of-strings field-name value)
  (if (null? value) ""
      (fail2ban-jail-configuration-serialize-string
       field-name (string-join value " "))))

(define (fail2ban-jail-configuration-serialize-list-of-fail2ban-jail-actions field-name value)
  (if (null? value) ""
      (fail2ban-jail-configuration-serialize-string
       field-name (string-join
                   (map serialize-fail2ban-jail-action-configuration value) "\n"))))

(define (fail2ban-jail-configuration-serialize-symbol field-name value)
  (fail2ban-jail-configuration-serialize-string field-name (symbol->string value)))

(define (fail2ban-jail-configuration-serialize-extra-content field-name value)
  (if (eq? 'unset value) ""  (string-append "\n" value "\n")))

(define-maybe integer (prefix fail2ban-jail-configuration-))
(define-maybe string (prefix fail2ban-jail-configuration-))
(define-maybe boolean (prefix fail2ban-jail-configuration-))
(define-maybe symbol (prefix fail2ban-jail-configuration-))
(define-maybe fail2ban-ignore-cache-configuration (prefix fail2ban-jail-configuration-))
(define-maybe fail2ban-jail-filter-configuration (prefix fail2ban-jail-configuration-))

(define-configuration fail2ban-jail-configuration
  (name
   string
   "Required name of this jail configuration.")
  (enabled?
   maybe-boolean
   "Either @code{#t} or @code{#f} for @samp{true} and
@samp{false} respectively.")
  (backend
   maybe-symbol
   "Backend to be used to detect changes in the @code{ogpath}."
   fail2ban-jail-configuration-serialize-backend)
  (max-retry
   maybe-integer
   "Is the number of failures before a host get banned
(e.g. @code{(max-retry 5)}).")
  (max-matches
   maybe-integer
   "Is the number of matches stored in ticket (resolvable via
tag @code{<matches>}) in action.")
  (find-time
   maybe-string
   "A host is banned if it has generated @code{max-retry} during the last
@code{find-time} seconds (e.g. @code{(find-time \"10m\")}).")
  (ban-time
   maybe-string
   "Is the number of seconds that a host is banned
(e.g. @code{(ban-time \"10m\")}).")
  (ban-time-increment?
   maybe-boolean
   "Allows to use database for searching of previously banned
ip's to increase a default ban time using special formula.")
  (ban-time-factor
   maybe-string
   "Is a coefficient to calculate exponent growing of the
formula or common multiplier.")
  (ban-time-formula
   maybe-string
   "Used by default to calculate next value of ban time.")
  (ban-time-multipliers
   maybe-string
   "Used to calculate next value of ban time instead of formula.")
  (ban-time-max-time
   maybe-string
   "Is the max number of seconds using the ban time can reach
(doesn't grow further).")
  (ban-time-rnd-time
   maybe-string
   "Is the max number of seconds using for mixing with random time
to prevent ``clever'' botnets calculate exact time IP can be unbanned again.")
  (ban-time-overall-jails?
   maybe-boolean
   "Either @code{#t} or @code{#f} for @samp{true} and @samp{false} respectively.
@itemize
@item @code{true} - specifies the search of IP in the database will be executed cross over all jails
@item @code{false} - only current jail of the ban IP will be searched
@end itemize")
  (ignore-command
   maybe-string
   "External command that will take an tagged arguments to ignore.
Note: while provided, currently unimplemented in the context of @code{guix}.")
  (ignore-self?
   maybe-boolean
   "Specifies whether the local resp. own IP addresses should be ignored.")
  (ignore-ip
   (list-of-strings '())
   "Can be a list of IP addresses, CIDR masks or DNS hosts.  @code{fail2ban}
will not ban a host which matches an address in this list.")
  (ignore-cache
   maybe-fail2ban-ignore-cache-configuration
   "Provide cache parameters for ignore failure check.")
  (filter
   maybe-fail2ban-jail-filter-configuration
   "Defines the filter to use by the jail, using
@code{<fail2ban-jail-filter-configuration>}.
By default jails have names matching their filter name.")
  (log-time-zone
   maybe-string
   "Force the time zone for log lines that don't have one.")
  (log-encoding
   maybe-symbol
   "Specifies the encoding of the log files handled by the jail.
Possible values: @code{'ascii}, @code{'utf-8}, @code{'auto}."
   fail2ban-jail-configuration-serialize-log-encoding)
  (log-path
   (list-of-strings '())
   "File name(s) of the log files to be monitored.")
  (action
   (list-of-fail2ban-jail-actions '())
   "List of @code{<fail2ban-jail-action-configuration>}.")
  (extra-content
   maybe-string
   "Extra content for the jail configuration."
   fail2ban-jail-configuration-serialize-extra-content)
  (prefix fail2ban-jail-configuration-))

(define list-of-fail2ban-jail-configurations?
  (list-of fail2ban-jail-configuration?))

(define (serialize-fail2ban-jail-configuration config)
  #~(string-append
     #$(format #f "[~a]\n" (fail2ban-jail-configuration-name config))
     #$(serialize-configuration
      config fail2ban-jail-configuration-fields)))

(define-configuration/no-serialization fail2ban-configuration
  (fail2ban
   (package fail2ban)
   "The @code{fail2ban} package to use.  It used for both binaries and
as base default configuration that will be extended with
@code{<fail2ban-jail-configuration>}s.")
  (run-directory
   (string "/var/run/fail2ban")
   "State directory for @code{fail2ban} daemon.")
  (jails
   (list-of-fail2ban-jail-configurations '())
   "Instances of @code{<fail2ban-jail-configuration>} collected from
extensions.")
  (extra-jails
   (list-of-fail2ban-jail-configurations '())
   "Instances of @code{<fail2ban-jail-configuration>} provided by user
explicitly.")
  (extra-content
   maybe-string
   "Extra raw content to add at the end of the @file{jail.local} file."))

(define (serialize-fail2ban-configuration config)
  (let* ((jails (fail2ban-configuration-jails config))
         (extra-jails (fail2ban-configuration-extra-jails config))
         (extra-content (fail2ban-configuration-extra-content config)))
    (interpose
     (append (map serialize-fail2ban-jail-configuration
                  (append jails extra-jails))
             (list (if (eq? 'unset extra-content) "" extra-content))))))

(define (make-fail2ban-configuration-package config)
  (let* ((fail2ban (fail2ban-configuration-fail2ban config))
         (jail-local (apply mixed-text-file "jail.local"
                            (serialize-fail2ban-configuration config))))
    (computed-file
     "fail2ban-configuration"
     (with-imported-modules '((guix build utils))
       #~(begin
           (use-modules (guix build utils))
           (let ((out (ungexp output)))
             (mkdir-p (string-append out "/etc/fail2ban"))
             (copy-recursively
              (string-append #$fail2ban "/etc/fail2ban")
              (string-append out "/etc/fail2ban"))
             (symlink
              #$jail-local
              (string-append out "/etc/fail2ban/jail.local"))))))))

(define (fail2ban-shepherd-service config)
  (match-record config <fail2ban-configuration>
    (fail2ban run-directory)
    (let* ((fail2ban-server (file-append fail2ban "/bin/fail2ban-server"))
           (pid-file (in-vicinity run-directory "fail2ban.pid"))
           (socket-file (in-vicinity run-directory "fail2ban.sock"))
           (config-dir (make-fail2ban-configuration-package config))
           (config-dir (file-append config-dir "/etc/fail2ban"))
           (fail2ban-action
            (lambda args
              #~(lambda _
                  (invoke #$fail2ban-server
                          "-c" #$config-dir
                          "-p" #$pid-file
                          "-s" #$socket-file
                          "-b"
                          #$@args)))))

      ;; TODO: Add 'reload' action.
      (list (shepherd-service
             (provision '(fail2ban))
             (documentation "Run the fail2ban daemon.")
             (requirement '(user-processes))
             (modules `((ice-9 match)
                        ,@%default-modules))
             (start (fail2ban-action "start"))
             (stop (fail2ban-action "stop")))))))

(define fail2ban-service-type
  (service-type (name 'fail2ban)
                (extensions
                 (list (service-extension shepherd-root-service-type
                                          fail2ban-shepherd-service)))
                (compose concatenate)
                (extend (lambda (config jails)
                          (fail2ban-configuration
                           (inherit config)
                           (jails
                            (append
                             (fail2ban-configuration-jails config)
                             jails)))))
                (default-value (fail2ban-configuration))
                (description "Run the fail2ban server.")))

(define (fail2ban-jail-service svc-type jail)
  (service-type
   (inherit svc-type)
   (extensions
    (append
     (service-type-extensions svc-type)
     (list (service-extension fail2ban-service-type
                              (lambda _ (list jail))))))))