battering: services: Add support for rules in config.

* battering/services/opensnitch.scm
(opensnitchd-rule): New record.
(opensnitchd-service-type)[rules]: New field.

1 files changed, 206 insertions, 25 deletions

diff --git a/battering/services/opensnitch.scm b/battering/services/opensnitch.scm
index 2e31d0e..d5e7e3b 100644
--- a/battering/services/opensnitch.scm
+++ b/battering/services/opensnitch.scm
@@ -10,9 +10,172 @@
   #:use-module (srfi srfi-171)
 
   #:export (opensnitch-configuration
-            serialize-json-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 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?")
+  (precedence?
+   (boolean #f)
+   "Should this rule have priority over others?")
+  (regexp-fields
+   (list '("dest.port"))
+   "Opensnich fields with regular expressions.")
+  (sensitive?
+   (boolean #f)
+   "Are fields case-sensitive")
+  (process-path
+   maybe-file-like
+   "Command-line of the process")
+  (process-command
+   maybe-file-like
+   "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? precedence? sensitive?
+       regexp-fields
+       process-path process-command
+       dest-host dest-ip dest-network dest-port dest-iface
+       protocol user hosts-file hosts-regex?)
+
+    (define (parse-port port)
+      (if (not (eq? %unset-value port))
+          (if (integer? port)
+              (format #f "~a" port)
+              (format #f "^(~a)$"
+                      (string-join
+                       (map number->string port)
+                       "|")))
+          %unset-value))
+
+    (with-extensions (list guile-json-4)
+      (with-imported-modules (source-module-closure '((json builder)))
+        #~(begin
+            (use-modules (json builder)
+                         (srfi srfi-1))
+
+            (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-value))
+                    `((operand . ,name)
+                      (data . ,data)
+                      (type . ,type)
+                      (sensitive . #$sensitive?))
+                    #f)))
+
+            (define serialized-fields
+              (filter-map
+               serialize-single-operand
+               '(("process.path" . #$process-path)
+                 ("process.command" . #$process-command)
+                 ("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 . #$precedence?)
+                 (enabled . #t)
+                 (nolog . #$nolog?)
+                 (operator
+                  ,@(if (= (length serialized-fields) 1)
+                        (car serialized-fields)
+                        `((sensitive . #$sensitive?)
+                          (list . #(,@serialized-fields))
+                          (operand . "list")
+                          (data . "")
+                          (type . "list"))))))))))))
+
 ;; Turns lisp-case into PascalCase
 (define (pascal-field-name field-name)
   (apply
@@ -41,16 +204,6 @@
           ("LogFile" . "/dev/stdout"))
         serialized)))
 
-(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 serialize-method serialize-field)
 (define serialize-action serialize-field)
 (define (serialize-duration field-name val)
@@ -58,7 +211,7 @@
    field-name
    (string-join (string-split (format #f "~a" val) #\-))))
 
-(define (serialize-json-configuration config fields)
+(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)
@@ -69,10 +222,17 @@ corresponding to the FIELDS of CONFIG."
            '#$(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.")
@@ -99,21 +259,42 @@ corresponding to the FIELDS of CONFIG."
     "Duration of the rules created automatically.")
   (intercept-unknown?
    (boolean #f)
-   "Intercept unknown network connections?")
-  (rules
-   (list '())
-   "List of rules to add in /etc/opensnitchd/rules."))
+   "Intercept unknown network connections?"))
 
 (define (opensnitch-activation config)
   "Create the opensnitch rules and configuration according to CONFIG."
-  (match-record config <opensnitch-configuration> (opensnitchd)
-    (with-imported-modules '((guix build utils))
-      #~(begin
-          (use-modules (guix build utils))
-          (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"))))))
+  (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."
@@ -122,7 +303,7 @@ corresponding to the FIELDS of CONFIG."
            "opensnitchd-config.json"
            #~(with-output-to-file #$output
                (lambda _
-                 #$(serialize-json-configuration
+                 #$(serialize-opensnitch-configuration
                     config
                     opensnitch-configuration-fields))))))
     (list (shepherd-service