Create modules in nftables.ml
This commit is contained in:
parent
6e26862f40
commit
aaba2f32ae
GPG key ID:
800882B66C0C3326
1 changed files with 202 additions and 178 deletions
380
nftables.ml
380
nftables.ml
|
|
@ -1,195 +1,219 @@
|
||||||
open Utils
|
open Utils
|
||||||
open Ipaddr
|
open Ipaddr
|
||||||
|
|
||||||
type _ udp = UdpDport : int udp | UdpSport : int udp
|
|
||||||
type _ tcp = TcpDport : int tcp | TcpSport : int tcp
|
|
||||||
type _ ipv4 = Ipv4Saddr : V4.Prefix.t ipv4 | Ipv4Daddr : V4.Prefix.t ipv4
|
|
||||||
type _ ipv6 = Ipv6Saddr : V6.Prefix.t ipv6 | Ipv6Daddr : V6.Prefix.t ipv6
|
|
||||||
|
|
||||||
type _ payload =
|
|
||||||
| Udp : 'a udp -> 'a payload
|
|
||||||
| Tcp : 'a tcp -> 'a payload
|
|
||||||
| Ipv4 : 'a ipv4 -> 'a payload
|
|
||||||
| Ipv6 : 'a ipv6 -> '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 : (('a, 'b) match_op * 'a expr * 'b expr) -> unit stmt
|
|
||||||
| Counter : counter -> unit stmt
|
|
||||||
| Verdict : verdict -> unit stmt
|
|
||||||
| NoTrack : unit stmt
|
|
||||||
| Log : { prefix : string option; group : int option } -> unit stmt
|
|
||||||
|
|
||||||
type family = FamilyIpv6 | FamilyIpv4 | FamilyInet
|
|
||||||
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 command =
|
|
||||||
| FlushRuleset
|
|
||||||
| AddTable of table
|
|
||||||
| FlushTable of table
|
|
||||||
| AddChain of chain
|
|
||||||
| FlushChain of chain
|
|
||||||
| AddRule of rule
|
|
||||||
|
|
||||||
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 string_of_ipv4 : type a. a ipv4 -> string = function
|
|
||||||
| Ipv4Saddr -> "saddr"
|
|
||||||
| Ipv4Daddr -> "daddr"
|
|
||||||
|
|
||||||
let string_of_ipv6 : type a. a ipv6 -> string = function
|
|
||||||
| Ipv6Saddr -> "saddr"
|
|
||||||
| Ipv6Daddr -> "daddr"
|
|
||||||
|
|
||||||
let assoc_one key value = `Assoc [ (key, value) ]
|
let assoc_one key value = `Assoc [ (key, value) ]
|
||||||
|
|
||||||
let json_of_payload (type a) (payload : a payload) =
|
module Payload = struct
|
||||||
let protocol, field =
|
module Udp = struct
|
||||||
match payload with
|
type _ t = Sport : int t | Dport : int t
|
||||||
| Ipv4 ipv4 -> ("ip", string_of_ipv4 ipv4)
|
|
||||||
| Ipv6 ipv6 -> ("ip6", string_of_ipv6 ipv6)
|
|
||||||
| 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
|
let to_string : type a. a t -> string = function
|
||||||
| String s -> `String s
|
| Sport -> "sport"
|
||||||
| Number n -> `Int n
|
| Dport -> "dport"
|
||||||
| Boolean b -> `Bool b
|
end
|
||||||
| Ipv4 i ->
|
|
||||||
assoc_one "prefix"
|
module Tcp = struct
|
||||||
(`Assoc
|
type _ t = Sport : int t | Dport : int t
|
||||||
|
|
||||||
|
let to_string : type a. a t -> string = function
|
||||||
|
| Sport -> "sport"
|
||||||
|
| Dport -> "dport"
|
||||||
|
end
|
||||||
|
|
||||||
|
module Ipv4 = struct
|
||||||
|
type _ t = Saddr : V4.Prefix.t t | Daddr : V4.Prefix.t t
|
||||||
|
|
||||||
|
let to_string : type a. a t -> string = function
|
||||||
|
| Saddr -> "saddr"
|
||||||
|
| Daddr -> "saddr"
|
||||||
|
end
|
||||||
|
|
||||||
|
module Ipv6 = struct
|
||||||
|
type _ t = Saddr : V6.Prefix.t t | Daddr : V6.Prefix.t t
|
||||||
|
|
||||||
|
let to_string : type a. a t -> string = function
|
||||||
|
| Saddr -> "saddr"
|
||||||
|
| Daddr -> "saddr"
|
||||||
|
end
|
||||||
|
|
||||||
|
type _ t =
|
||||||
|
| Udp : 'a Udp.t -> 'a t
|
||||||
|
| Tcp : 'a Tcp.t -> 'a t
|
||||||
|
| Ipv4 : 'a Ipv4.t -> 'a t
|
||||||
|
| Ipv6 : 'a Ipv6.t -> 'a t
|
||||||
|
|
||||||
|
let to_json (type a) (payload : a t) =
|
||||||
|
let protocol, field =
|
||||||
|
match payload with
|
||||||
|
| Udp udp -> ("udp", Udp.to_string udp)
|
||||||
|
| Tcp tcp -> ("tcp", Tcp.to_string tcp)
|
||||||
|
| Ipv4 ipv4 -> ("ip", Ipv4.to_string ipv4)
|
||||||
|
| Ipv6 ipv6 -> ("ip6", Ipv6.to_string ipv6)
|
||||||
|
in
|
||||||
|
assoc_one "payload"
|
||||||
|
(`Assoc [ ("protocol", `String protocol); ("field", `String field) ])
|
||||||
|
end
|
||||||
|
|
||||||
|
module Expr = struct
|
||||||
|
type _ t =
|
||||||
|
| String : string -> string t
|
||||||
|
| Number : int -> int t
|
||||||
|
| Boolean : bool -> int t
|
||||||
|
| Ipv4 : V4.Prefix.t -> V4.Prefix.t t
|
||||||
|
| Ipv6 : V6.Prefix.t -> V6.Prefix.t t
|
||||||
|
| List : 'a t list -> 'a t
|
||||||
|
| Set : 'a t list -> 'a t
|
||||||
|
| Range : 'a t * 'a t -> 'a t
|
||||||
|
| Payload : 'a Payload.t -> 'a t
|
||||||
|
|
||||||
|
let rec to_json : type a. a t -> Yojson.Basic.t = function
|
||||||
|
| String str -> `String str
|
||||||
|
| Number num -> `Int num
|
||||||
|
| Boolean bool -> `Bool bool
|
||||||
|
| Ipv4 ipv4 ->
|
||||||
|
let network = V4.(to_string (Prefix.network ipv4)) in
|
||||||
|
let len = V4.Prefix.bits ipv4 in
|
||||||
|
assoc_one "prefix"
|
||||||
|
(`Assoc [ ("addr", `String network); ("len", `Int len) ])
|
||||||
|
| Ipv6 ipv6 ->
|
||||||
|
let network = V6.(to_string (Prefix.network ipv6)) in
|
||||||
|
let len = V6.Prefix.bits ipv6 in
|
||||||
|
assoc_one "prefix"
|
||||||
|
(`Assoc [ ("addr", `String network); ("len", `Int len) ])
|
||||||
|
| List list -> `List (List.map to_json list)
|
||||||
|
| Set set -> assoc_one "set" (`List (List.map to_json set))
|
||||||
|
| Range (a, b) -> assoc_one "range" (`List [ to_json a; to_json b ])
|
||||||
|
| Payload payload -> Payload.to_json payload
|
||||||
|
end
|
||||||
|
|
||||||
|
module Match = struct
|
||||||
|
type (_, _) t = Eq : ('a, 'a) t | NotEq : ('a, 'a) t
|
||||||
|
|
||||||
|
let to_string : type a b. (a, b) t -> string = function
|
||||||
|
| Eq -> "=="
|
||||||
|
| NotEq -> "!="
|
||||||
|
|
||||||
|
let to_json (type a b) (op : (a, b) t) = `String (to_string op)
|
||||||
|
end
|
||||||
|
|
||||||
|
module Counter = struct
|
||||||
|
type t =
|
||||||
|
| NamedCounter of string
|
||||||
|
| AnonCounter of { packets : int; bytes : int }
|
||||||
|
|
||||||
|
let to_json = function
|
||||||
|
| NamedCounter n -> assoc_one "counter" (`String n)
|
||||||
|
| AnonCounter { packets; bytes } ->
|
||||||
|
assoc_one "counter"
|
||||||
|
(`Assoc [ ("packets", `Int packets); ("bytes", `Int bytes) ])
|
||||||
|
end
|
||||||
|
|
||||||
|
module Verdict = struct
|
||||||
|
type t = Accept | Drop | Continue | Return | Jump of string | Goto of string
|
||||||
|
|
||||||
|
let to_json = 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))
|
||||||
|
end
|
||||||
|
|
||||||
|
module Stmt = struct
|
||||||
|
type _ t =
|
||||||
|
| Match : (('a, 'b) Match.t * 'a Expr.t * 'b Expr.t) -> unit t
|
||||||
|
| Counter : Counter.t -> unit t
|
||||||
|
| Verdict : Verdict.t -> unit t
|
||||||
|
| NoTrack : unit t
|
||||||
|
| Log : { prefix : string option; group : int option } -> unit t
|
||||||
|
|
||||||
|
let to_json : type a. a t -> Yojson.Basic.t = function
|
||||||
|
| Match (op, left, right) ->
|
||||||
|
assoc_one "match"
|
||||||
|
(`Assoc
|
||||||
|
[
|
||||||
|
("left", Expr.to_json left);
|
||||||
|
("right", Expr.to_json right);
|
||||||
|
("op", Match.to_json op);
|
||||||
|
])
|
||||||
|
| Counter counter -> Counter.to_json counter
|
||||||
|
| Verdict verdict -> Verdict.to_json verdict
|
||||||
|
| NoTrack -> assoc_one "notrack" `Null
|
||||||
|
| Log { prefix; group } ->
|
||||||
|
let elems =
|
||||||
[
|
[
|
||||||
("addr", `String V4.(to_string (Prefix.network i)));
|
Option.map (fun p -> ("prefix", `String p)) prefix;
|
||||||
("len", `Int (V4.Prefix.bits i));
|
Option.map (fun g -> ("group", `Int g)) group;
|
||||||
])
|
]
|
||||||
| Ipv6 i ->
|
in
|
||||||
assoc_one "prefix"
|
assoc_one "log" (`Assoc (deoptionalise elems))
|
||||||
(`Assoc
|
end
|
||||||
[
|
|
||||||
("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
|
module Family = struct
|
||||||
| Eq -> "=="
|
type t = Ipv4 | Ipv6 | Inet
|
||||||
| NotEq -> "!="
|
|
||||||
|
|
||||||
let json_of_counter = function
|
let to_string = function Ipv4 -> "ip" | Ipv6 -> "ip6" | Inet -> "inet"
|
||||||
| Named n -> assoc_one "counter" (`String n)
|
let to_json f = `String (to_string f)
|
||||||
| Anon { packets; bytes } ->
|
end
|
||||||
assoc_one "counter"
|
|
||||||
(`Assoc [ ("packets", `Int packets); ("bytes", `Int bytes) ])
|
|
||||||
|
|
||||||
let json_of_verdict = function
|
module Table = struct
|
||||||
| Accept -> assoc_one "accept" `Null
|
type t = { family : Family.t; name : string }
|
||||||
| 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
|
let to_json { family; name } =
|
||||||
| Match (op, left, right) ->
|
assoc_one "table"
|
||||||
assoc_one "match"
|
(`Assoc [ ("family", Family.to_json family); ("name", `String name) ])
|
||||||
(`Assoc
|
end
|
||||||
[
|
|
||||||
("left", json_of_expr left);
|
module Chain = struct
|
||||||
("right", json_of_expr right);
|
type t = { family : Family.t; table : string; name : string }
|
||||||
("op", `String (string_of_match_op op));
|
|
||||||
])
|
let to_json { family; table; name } =
|
||||||
| Counter c -> json_of_counter c
|
assoc_one "chain"
|
||||||
| Verdict v -> json_of_verdict v
|
(`Assoc
|
||||||
| NoTrack -> assoc_one "notrack" `Null
|
|
||||||
| Log { prefix; group } ->
|
|
||||||
let elems =
|
|
||||||
[
|
[
|
||||||
Option.map (fun p -> ("prefix", `String p)) prefix;
|
("family", Family.to_json family);
|
||||||
Option.map (fun g -> ("group", `Int g)) group;
|
("table", `String table);
|
||||||
]
|
("name", `String name);
|
||||||
in
|
])
|
||||||
assoc_one "log" (`Assoc (deoptionalise elems))
|
end
|
||||||
|
|
||||||
let string_of_family = function
|
module Rule = struct
|
||||||
| FamilyIpv4 -> "ip"
|
type t = {
|
||||||
| FamilyIpv6 -> "ip6"
|
family : Family.t;
|
||||||
| FamilyInet -> "inet"
|
table : string;
|
||||||
|
chain : string;
|
||||||
|
expr : unit Stmt.t list;
|
||||||
|
}
|
||||||
|
|
||||||
let json_of_table { family; table_name } =
|
let to_json { family; table; chain; expr } =
|
||||||
assoc_one "table"
|
assoc_one "rule"
|
||||||
(`Assoc
|
(`Assoc
|
||||||
[
|
[
|
||||||
("family", `String (string_of_family family));
|
("family", Family.to_json family);
|
||||||
("name", `String table_name);
|
("table", `String table);
|
||||||
])
|
("chain", `String chain);
|
||||||
|
("expr", `List (List.map Stmt.to_json expr));
|
||||||
|
])
|
||||||
|
end
|
||||||
|
|
||||||
let json_of_chain { family; table; chain_name } =
|
module Command = struct
|
||||||
assoc_one "chain"
|
type t =
|
||||||
(`Assoc
|
| FlushRuleset
|
||||||
[
|
| AddTable of Table.t
|
||||||
("family", `String (string_of_family family));
|
| FlushTable of Table.t
|
||||||
("table", `String table);
|
| AddChain of Chain.t
|
||||||
("name", `String chain_name);
|
| FlushChain of Chain.t
|
||||||
])
|
| AddRule of Rule.t
|
||||||
|
|
||||||
let json_of_rule { family; table; chain; expr } =
|
let to_json = function
|
||||||
assoc_one "rule"
|
| FlushRuleset -> assoc_one "flush" (assoc_one "ruleset" `Null)
|
||||||
(`Assoc
|
| AddTable table -> assoc_one "add" (Table.to_json table)
|
||||||
[
|
| FlushTable table -> assoc_one "flush" (Table.to_json table)
|
||||||
("family", `String (string_of_family family));
|
| AddChain chain -> assoc_one "add" (Chain.to_json chain)
|
||||||
("table", `String table);
|
| FlushChain chain -> assoc_one "flush" (Chain.to_json chain)
|
||||||
("chain", `String chain);
|
| AddRule rule -> assoc_one "add" (Rule.to_json rule)
|
||||||
("expr", `List (List.map json_of_stmt expr));
|
end
|
||||||
])
|
|
||||||
|
|
||||||
let json_of_command = function
|
let to_json commands =
|
||||||
| FlushRuleset -> assoc_one "flush" (assoc_one "ruleset" `Null)
|
assoc_one "nftables" (`List (List.map Command.to_json commands))
|
||||||
| AddTable t -> assoc_one "add" (json_of_table t)
|
|
||||||
| FlushTable t -> assoc_one "flush" (json_of_table t)
|
|
||||||
| AddChain c -> assoc_one "add" (json_of_chain c)
|
|
||||||
| FlushChain c -> assoc_one "flush" (json_of_chain c)
|
|
||||||
| AddRule r -> assoc_one "add" (json_of_rule r)
|
|
||||||
|
|
||||||
let json_of_nftables n =
|
|
||||||
assoc_one "nftables" (`List (List.map json_of_command n))
|
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue