(define-module (battering services opensnitch)
  #:use-module (guix gexp)
  #:use-module (guix records)
  #:use-module (guix modules)
  #:use-module (gnu services)
  #:use-module (gnu services shepherd)
  #:use-module (gnu services configuration)
  #:use-module (gnu packages guile)
  #:use-module (battering packages opensnitch)
  #:use-module (srfi srfi-171)

  #:export (opensnitch-configuration
            opensnitch-rule
            opensnitch-service-type))

;; Turns lisp-case into dot.case
(define (dot-field-name field-name)
  (string-join
   (string-tokenize (format #f "~a" field-name)
                    char-set:letter)
   "."))

(define methods-list '(ftrace audit ebpf proc))
(define actions-list '(allow deny reject))
(define durations-list '(once until-restart forever))
(define (method? val)
  (memq val methods-list))
(define (action? val)
  (memq val actions-list))
(define (duration? val)
  (memq val durations-list))

(define (port? val)
  (or (integer? val)
      ((list-of integer?) val)))

(define-maybe string)
(define-maybe gexp)
(define-maybe file-like)
(define-maybe port)
(define-maybe path)

(define-configuration/no-serialization opensnitch-rule
  (name
   (string)
   "Name of the rule")
  (description
   (string "")
   "Description of the rule")
  (action
   (action 'allow)
   "Action to execute on the rule.")
  (nolog?
   (boolean #f)
   "Should connections with this rule be ignored from logging?")
  (priority-rule?
   (boolean #f)
   "Should this rule have priority over others?")
  (regexp-fields
   (list '("dest.port"))
   "Opensnich fields with regular expressions.")
  (case-sensitive?
   (boolean #f)
   "Are fields case-sensitive")
  (file-path
   maybe-file-like
   "Command-line of the process")
  (command-line
   maybe-gexp
   "Path of the process")
  (dest-host
   maybe-string
   "Destination host")
  (dest-ip
   maybe-string
   "Destination IP")
  (dest-network
   maybe-string
   "Destination network")
  (dest-port
   maybe-port
   "Destination port")
  (dest-iface
   maybe-string
   "Outside interface")
  (protocol
   maybe-string
   "Protocol")
  (user
   maybe-string
   "User ID")
  (hosts-file
   maybe-string
   "List of domains")
  (hosts-regex?
   maybe-string
   "List of domains is a list of regexes?"))

(define (serialize-opensnitch-rule rule)
  (match-record rule
      <opensnitch-rule>
      (name
       description
       action
       nolog? priority-rule? case-sensitive?
       regexp-fields
       file-path command-line
       dest-host dest-ip dest-network dest-port dest-iface
       protocol user hosts-file hosts-regex?)

    (define (parse-port port)
      (if (maybe-value-set? port)
          (if (integer? port)
              (format #f "~a" port)
              (format #f "^(~a)$"
                      (string-join
                       (map number->string port)
                       "|")))
          port))

    (with-extensions (list guile-json-4)
      (with-imported-modules (source-module-closure
                              '((json builder)))
        #~(begin
            (use-modules (json builder)
                         (srfi srfi-1))

            ;; Uuuuurgh ugly hack.
            (define %unset-marker% '%unset-marker%)

            (define (serialize-single-operand operand)
              (let* ((name (car operand))
                     (data (cdr operand))
                     (type (if (find
                                (lambda (s) (string= name s))
                                '#$regexp-fields)
                               "regexp"
                               "simple")))
                (if (not (eq? data %unset-marker%))
                    `((operand . ,name)
                      (data . ,data)
                      (type . ,type)
                      (sensitive . #$case-sensitive?))
                    #f)))

            (define serialized-fields
              (filter-map
               serialize-single-operand
               `(("process.path" . ,#$file-path)
                 ("process.command" . ,#$command-line)
                 ("dest.host" . ,#$dest-host)
                 ("dest.ip" . ,#$dest-ip)
                 ("dest.network" . ,#$dest-network)
                 ("dest.port" . ,#$(parse-port dest-port))
                 ("iface.out" . ,#$dest-iface)
                 ("protocol" . ,#$protocol)
                 ("user.id" . ,#$user)
                 (#$(if hosts-regex?
                        "lists.domain_regexp"
                        "lists.domain") . ,#$hosts-file))))

            (begin
              (scm->json
               `((name . #$name)
                 (description . #$description)
                 (action . #$action)
                 ;; These rules will be read-only in the store and always present at
                 ;; boot, so "on restart" would be functionally the same as "always", and
                 ;; "once" would be nonsensical.  Plus, Opensnich wouldn't be able to
                 ;; delete them.
                 (duration . "always")
                 (precedence . #$priority-rule?)
                 (enabled . #t)
                 (nolog . #$nolog?)
                 (operator
                  ,@(if (= (length serialized-fields) 1)
                        (car serialized-fields)
                        `((sensitive . #$case-sensitive?)
                          (list . #(,@serialized-fields))
                          (operand . "list")
                          (data . "")
                          (type . "list"))))))))))))

;; Turns lisp-case into PascalCase
(define (pascal-field-name field-name)
  (apply
   string-append
   (map string-capitalize (string-tokenize
                           (format #f "~a" field-name)
                           char-set:letter))))

(define (serialize-field field-name val)
  `(,(pascal-field-name field-name) . ,val))

(define serialize-boolean serialize-field)

(define (serialize-integer field-name val)
  (let ((serialized (serialize-field field-name val)))
    (if (eq? field-name 'workers)
        `("Stats" ,serialized)
        serialized)))

(define (serialize-string field-name val)
  (let ((serialized (serialize-field field-name val)))
    (if (eq? field-name 'address)
        `("Server" ,serialized
          ;; LogFile should always be stdout because logging will be managed
          ;; by Shepherd
          ("LogFile" . "/dev/stdout"))
        serialized)))

(define serialize-method serialize-field)
(define serialize-action serialize-field)
(define (serialize-duration field-name val)
  (serialize-field
   field-name
   (string-join (string-split (format #f "~a" val) #\-))))

(define (serialize-opensnitch-configuration config fields)
  "Return a G-expression that contains a json representation the values
corresponding to the FIELDS of CONFIG."
  (with-extensions (list guile-json-4)
    (with-imported-modules (source-module-closure '((json builder)))
      #~(begin
          (use-modules (json builder))
          (scm->json
           '#$(list-transduce (base-transducer config) rcons fields)
           #:pretty #t)))))

(define list-of-opensnitch-rules?
  (list-of opensnitch-rule?))

(define-configuration opensnitch-configuration
  (opensnitchd
   (file-like opensnitchd)
   "Opensnitchd package to use.")
  (rules
   (list-of-opensnitch-rules '())
   "List of rules to add in /etc/opensnitchd/rules."
   (serializer empty-serializer))
  (address
   (string "unix:///tmp/osui.sock")
   "Opensnitch UI socket path.")
  (workers
   (integer 6)
   "Number of workers started by the daemon.")
  (log-utc?
   (boolean #t)
   "Use UTC timestamps in event logging?")
  (log-micro?
   (boolean #f)
   "Include microseconds in event timestamps?")
  (log-level
   (integer 2)
   "Daemon log level.")
  (process-monitor-method
   (method 'proc)
   "Process monitor method to use.")
  (default-action
    (action 'allow)
    "Default action to take when the UI isn't connected.")
  (default-duration
    (duration 'once)
    "Duration of the rules created automatically.")
  (intercept-unknown?
   (boolean #f)
   "Intercept unknown network connections?"))

(define (opensnitch-activation config)
  "Create the opensnitch rules and configuration according to CONFIG."
  (match-record config <opensnitch-configuration> (opensnitchd rules)
    (with-extensions (list guile-json-4)
      (with-imported-modules '((guix build utils))
        #~(begin
            (use-modules (guix build utils)
                         (ice-9 ftw))
            (when (not (file-exists? "/etc/opensnitchd"))
              (mkdir-p "/etc/opensnitchd/rules/")
              (copy-file #$(file-append opensnitchd "/etc/system-fw.json")
                         "/etc/opensnitchd/system-fw.json"))

            ;; Not the most elegant of solutions. I'd be happy to find
            ;; something more Guix-y, or even Guix-ish.
            (nftw "/etc/opensnitchd/rules"
                  (lambda (filename s flag b l)
                    (when (eq? flag 'symlink)
                      (delete-file filename))
                    #t)
                  'physical)

            #$@(map
                (lambda (rule)
                  (let ((rule-name
                         (string-append (opensnitch-rule-name rule) ".json")))
                    #~(symlink
                       #$(computed-file
                          rule-name
                          #~(with-output-to-file #$output
                              (lambda _
                                #$(serialize-opensnitch-rule rule))))
                       #$(string-append "/etc/opensnitchd/rules/" rule-name))))
                rules))))))

(define (opensnitch-shepherd-service config)
  "Return a <shepherd-service> for opensnitch with CONFIG."
  (let ((default-config
          (computed-file
           "opensnitchd-config.json"
           #~(with-output-to-file #$output
               (lambda _
                 #$(serialize-opensnitch-configuration
                    config
                    opensnitch-configuration-fields))))))
    (list (shepherd-service
           (documentation "Opensnitchd daemon.")
           (requirement '(syslogd loopback))
           (provision '(opensnitch))
           (start
            #~(make-forkexec-constructor
               (list #$(file-append opensnitchd "/bin/opensnitchd")
                     ;; Live reload breaks with custom rules.
                     "-no-live-reload" "-config-file" #$default-config)))
           (stop #~(make-kill-destructor))))))

(define opensnitch-service-type
  (service-type
   (name 'opensnitch)
   (description "Run the Opensnitch application firewall daemon.")
   (extensions
    (list
     (service-extension shepherd-root-service-type
                        opensnitch-shepherd-service)
     (service-extension activation-service-type
                        opensnitch-activation)
     (service-extension profile-service-type
                        (lambda (config)
                          `(,(opensnitch-configuration-opensnitchd config))))))
   (compose identity)
   (default-value (opensnitch-configuration))))