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.t * V4.Prefix.t) -> (V4.t * V4.Prefix.t) expr
  | Ipv6 : (V6.t * V6.Prefix.t) -> (V6.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 (a, p) -> assoc_one "prefix" (`Assoc [
      ("addr", `String (V4.to_string a));
      ("len", `Int (V4.Prefix.bits p))
    ])
  | Ipv6 (a, p) -> assoc_one "prefix" (`Assoc [
      ("addr", `String (V6.to_string a));
      ("len", `Int (V6.Prefix.bits p))
    ])
  | 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))