firewall/nftables.ml

open Utils
open Ipaddr

type _ udp = UdpDport : int udp | UdpSport : int udp
type _ tcp = TcpDport : int tcp | TcpSport : int tcp
type _ payload = Udp : 'a udp -> 'a payload | Tcp : 'a tcp -> 'a payload

type _ expr =
  | String : string -> string expr
  | Number : int -> int expr
  | Boolean : bool -> int expr
  | Ipv4 : V4.Prefix.t -> V4.Prefix.t expr
  | Ipv6 : V6.Prefix.t -> V6.Prefix.t expr
  | List : 'a expr list -> 'a expr
  | Set : 'a expr list -> 'a expr
  | Range : 'a expr * 'a expr -> 'a expr
  | Payload : 'a payload -> 'a expr

type (_, _) match_op = Eq : ('a, 'a) match_op | NotEq : ('a, 'a) match_op
type counter = Named of string | Anon of { packets : int; bytes : int }

type verdict =
  | Accept
  | Drop
  | Continue
  | Return
  | Jump of string
  | Goto of string

type _ stmt =
  | Match : {
      left : 'a expr;
      right : 'b expr;
      op : ('a, 'b) match_op;
    }
      -> unit stmt
  | Counter : counter -> unit stmt
  | Verdict : verdict -> unit stmt
  | NoTrack : unit stmt
  | Log : { prefix : string option; group : int option } -> unit stmt

type family = Ip6 | Ip4 | Inet
type table = { family : family; table_name : string }
type chain = { family : family; table : string; chain_name : string }

type rule = {
  family : family;
  table : string;
  chain : string;
  expr : unit stmt list;
}

type add_object = AddTable of table | AddChain of chain | AddRule of rule
type flush_object = FlushRuleset | FlushTable of table | FlushChain of chain
type command = Add of add_object | Flush of flush_object

let string_of_udp : type a. a udp -> string = function
  | UdpSport -> "sport"
  | UdpDport -> "dport"

let string_of_tcp : type a. a tcp -> string = function
  | TcpSport -> "sport"
  | TcpDport -> "dport"

let assoc_one key value = `Assoc [ (key, value) ]

let json_of_payload (type a) (payload : a payload) =
  let protocol, field =
    match payload with
    | Udp udp -> ("udp", string_of_udp udp)
    | Tcp tcp -> ("tcp", string_of_tcp tcp)
  in
  assoc_one "payload"
    (`Assoc [ ("protocol", `String protocol); ("field", `String field) ])

let rec json_of_expr : type a. a expr -> Yojson.Basic.t = function
  | String s -> `String s
  | Number n -> `Int n
  | Boolean b -> `Bool b
  | Ipv4 i ->
      assoc_one "prefix"
        (`Assoc
          [
            ("addr", `String V4.(to_string (Prefix.network i)));
            ("len", `Int (V4.Prefix.bits i));
          ])
  | Ipv6 i ->
      assoc_one "prefix"
        (`Assoc
          [
            ("addr", `String V6.(to_string (Prefix.network i)));
            ("len", `Int (V6.Prefix.bits i));
          ])
  | List l -> `List (List.map json_of_expr l)
  | Set s -> assoc_one "set" (`List (List.map json_of_expr s))
  | Range (a, b) -> assoc_one "range" (`List [ json_of_expr a; json_of_expr b ])
  | Payload p -> json_of_payload p

let string_of_match_op : type a b. (a, b) match_op -> string = function
  | Eq -> "=="
  | NotEq -> "!="

let json_of_counter = function
  | Named n -> assoc_one "counter" (`String n)
  | Anon { packets; bytes } ->
      assoc_one "counter"
        (`Assoc [ ("packets", `Int packets); ("bytes", `Int bytes) ])

let json_of_verdict = function
  | Accept -> assoc_one "accept" `Null
  | Drop -> assoc_one "drop" `Null
  | Continue -> assoc_one "continue" `Null
  | Return -> assoc_one "return" `Null
  | Jump s -> assoc_one "jump" (assoc_one "target" (`String s))
  | Goto s -> assoc_one "goto" (assoc_one "target" (`String s))

let json_of_stmt : type a. a stmt -> Yojson.Basic.t = function
  | Match { left; right; op } ->
      assoc_one "match"
        (`Assoc
          [
            ("left", json_of_expr left);
            ("right", json_of_expr right);
            ("op", `String (string_of_match_op op));
          ])
  | Counter c -> json_of_counter c
  | Verdict v -> json_of_verdict v
  | NoTrack -> assoc_one "notrack" `Null
  | Log { prefix; group } ->
      let elems =
        [
          Option.map (fun p -> ("prefix", `String p)) prefix;
          Option.map (fun g -> ("group", `Int g)) group;
        ]
      in
      assoc_one "log" (`Assoc (deoptionalise elems))

let string_of_family = function Ip6 -> "ip6" | Ip4 -> "ip4" | Inet -> "inet"

let json_of_table { family; table_name } =
  assoc_one "table"
    (`Assoc
      [
        ("family", `String (string_of_family family));
        ("name", `String table_name);
      ])

let json_of_chain { family; table; chain_name } =
  assoc_one "chain"
    (`Assoc
      [
        ("family", `String (string_of_family family));
        ("table", `String table);
        ("name", `String chain_name);
      ])

let json_of_rule { family; table; chain; expr } =
  assoc_one "rule"
    (`Assoc
      [
        ("family", `String (string_of_family family));
        ("table", `String table);
        ("chain", `String chain);
        ("expr", `List (List.map json_of_stmt expr));
      ])

let json_of_add_object = function
  | AddTable t -> json_of_table t
  | AddChain c -> json_of_chain c
  | AddRule r -> json_of_rule r

let json_of_flush_object = function
  | FlushRuleset -> assoc_one "ruleset" `Null
  | FlushTable t -> json_of_table t
  | FlushChain c -> json_of_chain c

let json_of_command = function
  | Add a -> assoc_one "add" (json_of_add_object a)
  | Flush a -> assoc_one "flush" (json_of_flush_object a)

let json_of_nftables n =
  assoc_one "nftables" (`List (List.map json_of_command n))