;;; 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 (guix gexp)
  #:use-module (guix records)
  #:use-module (gnu packages admin)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:export (fail2ban-ignore-cache-configuration
            fail2ban-jail-filter-configuration
            fail2ban-jail-action-configuration
            fail2ban-jail-configuration
            fail2ban-configuration
            fail2ban-service-type
            fail2ban-jail-service))

(define (fail2ban-section->string name)
  (format #f "[~a]" name))

(define fail2ban-backend->string
  (match-lambda
    ('auto "auto")
    ('pyinotify "pyinotify")
    ('gamin "gamin")
    ('polling "polling")
    ('systemd "systemd")
    (unknown (error (format #f "Unknown fail2ban backend: ~a" unknown)))))

(define fail2ban-log-encoding->string
  (match-lambda
    ('auto "auto")
    ('utf-8 "utf-8")
    ('ascii "ascii")
    (unknown (error (format #f "Unknown fail2ban log-encoding: ~a" unknown)))))

(define-record-type* <fail2ban-ignore-cache-configuration>
  fail2ban-ignore-cache-configuration make-fail2ban-ignore-cache-configuration
  fail2ban-ignore-cache-configuration?
  (key                  fail2ban-ignore-cache-configuration-key)
  (max-count            fail2ban-ignore-cache-configuration-max-count)
  (max-time             fail2ban-ignore-cache-configuration-max-time))

(define fail2ban-ignore-cache-configuration->string
  (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-record-type* <fail2ban-jail-filter-configuration>
  fail2ban-jail-filter-configuration make-fail2ban-jail-filter-configuration
  fail2ban-jail-filter-configuration?
  (name                 fail2ban-jail-filter-configuration-name)
  (mode                 fail2ban-jail-filter-configuration-node
    (default *unspecified*)))

(define fail2ban-jail-filter-configuration->string
  (match-lambda
    (($ <fail2ban-jail-filter-configuration> name mode)
     (format #f "~a~a"
             name (if (unspecified? mode) "" (format #f "[mode=~a]" mode))))))

(define-record-type* <fail2ban-jail-action-configuration>
  fail2ban-jail-action-configuration make-fail2ban-jail-action-configuration
  fail2ban-jail-action-configuration?
  (name                  fail2ban-jail-action-configuration-name)
  (arguments             fail2ban-jail-action-configuration-arguments
                         (default '())))

(define (fail2ban-arguments->string args)
  (let* ((multi-value
          (lambda (v)
            (format #f "\"~a\"" (string-join (map object->string v) ","))))
         (any-value
          (lambda (v)
            (if (list? v) (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 fail2ban-jail-action-configuration->string
  (match-lambda
    (($ <fail2ban-jail-action-configuration> name arguments)
     (format #f "~a~a"
             name (if (null? arguments) ""
                      (format #f "[~a]"
                              (fail2ban-arguments->string arguments)))))))

(define-record-type* <fail2ban-jail-configuration>
  fail2ban-jail-configuration make-fail2ban-jail-configuration
  fail2ban-jail-configuration?
  (name                  fail2ban-jail-configuration-name)
  (enabled               fail2ban-jail-configuration-enabled
                         (default *unspecified*))
  (backend               fail2ban-jail-configuration-backend
                         (default *unspecified*))
  (max-retry             fail2ban-jail-configuration-max-retry
                         (default *unspecified*))
  (max-matches           fail2ban-jail-configuration-max-matches
                         (default *unspecified*))
  (find-time             fail2ban-jail-configuration-find-time
                         (default *unspecified*))
  (ban-time              fail2ban-jail-configuration-ban-time
                         (default *unspecified*))
  (ban-time-increment    fail2ban-jail-configuration-ban-time-increment
                         (default *unspecified*))
  (ban-time-factor       fail2ban-jail-configuration-ban-time-factor
                         (default *unspecified*))
  (ban-time-formula      fail2ban-jail-configuration-ban-time-formula
                         (default *unspecified*))
  (ban-time-multipliers  fail2ban-jail-configuration-ban-time-multipliers
                         (default *unspecified*))
  (ban-time-maxtime      fail2ban-jail-configuration-ban-time-maxtime
                         (default *unspecified*))
  (ban-time-rndtime      fail2ban-jail-configuration-ban-time-rndtime
                         (default *unspecified*))
  (ban-time-overalljails fail2ban-jail-configuration-ban-time-overalljails
                         (default *unspecified*))
  (ignore-command        fail2ban-jail-configuration-ignore-command
                         (default *unspecified*))
  (ignore-self           fail2ban-jail-configuration-ignore-self
                         (default *unspecified*))
  (ignore-ip             fail2ban-jail-configuration-ignore-ip
                         (default '()))
  (ignore-cache          fail2ban-jail-configuration-ignore-cache
                         (default *unspecified*))
  (filter                fail2ban-jail-configuration-filter
                         (default *unspecified*))
  (log-time-zone         fail2ban-jail-configuration-log-time-zone
                         (default *unspecified*))
  (log-encoding          fail2ban-jail-configuration-log-encoding
                         (default *unspecified*))
  (log-path              fail2ban-jail-configuration-log-path
                         (default *unspecified*))
  (action                fail2ban-jail-configuration-action
                         (default '())))

(define fail2ban-jail-configuration->string
  (match-lambda
    (($ <fail2ban-jail-configuration> name enabled backend
                                      max-retry max-matches
                                      find-time ban-time
                                      ban-time-increment ban-time-factor
                                      ban-time-formula ban-time-multipliers
                                      ban-time-maxtime ban-time-rndtime
                                      ban-time-overalljails
                                      ignore-command ignore-self
                                      ignore-ip ignore-cache
                                      fltr
                                      log-time-zone log-encoding log-path
                                      action)
     (string-join
      (filter
       (lambda (s) (not (unspecified? s)))
       (list
        (fail2ban-section->string name)
        (unless (unspecified? enabled)
          (format #f "enabled = ~a"
                  (if enabled "true" "false")))
        (unless (unspecified? backend)
          (format #f "backend = ~a"
                  (fail2ban-backend->string backend)))
        (unless (unspecified? max-retry)
          (format #f "maxretry = ~d" max-retry))
        (unless (unspecified? max-matches)
          (format #f "maxmatches = ~d" max-matches))
        (unless (unspecified? find-time)
          (format #f "findtime = ~a" find-time))
        (unless (unspecified? ban-time)
          (format #f "bantime = ~a" ban-time))
        (unless (unspecified? ban-time-increment)
          (format #f "bantime.increment = ~a"
                  (if ban-time-increment "true" "false")))
        (unless (unspecified? ban-time-factor)
          (format #f "bantime.factor = ~a" ban-time-factor))
        (unless (unspecified? ban-time-formula)
          (format #f "bantime.formula = ~a" ban-time-formula))
        (unless (unspecified? ban-time-multipliers)
          (format #f "bantime.multipliers = ~a" ban-time-multipliers))
        (unless (unspecified? ban-time-maxtime)
          (format #f "bantime.maxtime = ~a" ban-time-maxtime))
        (unless (unspecified? ban-time-rndtime)
          (format #f "bantime.rndtime = ~a" ban-time-rndtime))
        (unless (unspecified? ban-time-overalljails)
          (format #f "bantime.overalljails = ~a"
                  (if ban-time-overalljails "true" "false")))
        (unless (unspecified? ignore-command)
          (format #f "ignorecommand = ~a" ignore-command))
        (unless (unspecified? ignore-self)
          (format #f "ignoreself = ~a"
                  (if ignore-self "true" "false")))
        (unless (null? ignore-ip)
          (format #f "ignoreip = ~a" (string-join ignore-ip " ")))
        (unless (unspecified? ignore-cache)
          (format #f "ignorecache = ~a"
                  (fail2ban-ignore-cache-configuration->string
                   ignore-cache)))
        (unless (unspecified? fltr)
          (format #f "filter = ~a"
                  (fail2ban-jail-filter-configuration->string fltr)))
        (unless (unspecified? log-time-zone)
          (format #f "logtimezone = ~a" log-time-zone))
        (unless (unspecified? log-encoding)
          (format #f "logencoding = ~a"
                  (fail2ban-log-encoding->string log-encoding)))
        (unless (unspecified? log-path)
          (format #f "logpath = ~a" log-path))
        (unless (null? action)
          (format #f "action = ~a"
                  (string-join
                   (map fail2ban-jail-action-configuration->string action)
                   "\n")))))
      "\n"))))

(define-record-type* <fail2ban-configuration>
  fail2ban-configuration make-fail2ban-configuration
  fail2ban-configuration?
  (fail2ban              fail2ban-configuration-fail2ban
                         (default fail2ban))
  (run-directory         fail2ban-configuration-run-directory
                         (default "/var/run/fail2ban"))
  (jails                 fail2ban-configuration-jails
                         (default '()))
  (extra-jails           fail2ban-configuration-extra-jails
                         (default '()))
  (extra-content         fail2ban-configuration-extra-content
                         (default "")))

(define (fail2ban-configuration->string config)
  (let* ((jails (fail2ban-configuration-jails config))
         (extra-jails (fail2ban-configuration-extra-jails config))
         (extra-content (fail2ban-configuration-extra-content config)))
    (string-append
     (string-join
      (map fail2ban-jail-configuration->string
           (append jails extra-jails))
      "\n")
     "\n" extra-content "\n")))

(define (make-fail2ban-configuration-package config)
  (let* ((fail2ban (fail2ban-configuration-fail2ban config))
         (jail-local
          (plain-file "jail.local"
                      (fail2ban-configuration->string 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))))))))