From 848a4269c4d11d6f1e34afaa79daa3bfad03cf1d Mon Sep 17 00:00:00 2001 From: Jeltz Date: Mon, 29 Aug 2022 07:01:56 +0200 Subject: [PATCH] Initial commit --- .gitignore | 1 + dune | 3 + dune-project | 1 + firewall.ml | 25 +++++++ nftables.ml | 189 +++++++++++++++++++++++++++++++++++++++++++++++++++ utils.ml | 4 ++ 6 files changed, 223 insertions(+) create mode 100644 .gitignore create mode 100644 dune create mode 100644 dune-project create mode 100644 firewall.ml create mode 100644 nftables.ml create mode 100644 utils.ml diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..a485625 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/_build diff --git a/dune b/dune new file mode 100644 index 0000000..e610902 --- /dev/null +++ b/dune @@ -0,0 +1,3 @@ +(executable + (name firewall) + (libraries yojson)) diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..d58d45f --- /dev/null +++ b/dune-project @@ -0,0 +1 @@ +(lang dune 3.4) diff --git a/firewall.ml b/firewall.ml new file mode 100644 index 0000000..e7c1a7b --- /dev/null +++ b/firewall.ml @@ -0,0 +1,25 @@ +open Nftables + +let nftables = [ + Flush FlushRuleset; + Add (AddRule { + family = Inet; + table = "filter"; + chain = "forward"; + expr = + [ + Log { prefix = Some "test"; group = None }; + Match { + left = Payload (Udp UdpSport); + right = Set [Number 53]; + op = NotEq }; + Verdict Accept + ] + }) +] + +let json = json_of_nftables nftables + +let () = + print_string (Yojson.Basic.to_string json); + print_newline () diff --git a/nftables.ml b/nftables.ml new file mode 100644 index 0000000..f8fec87 --- /dev/null +++ b/nftables.ml @@ -0,0 +1,189 @@ +open Utils + +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 + | 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 + | 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)) diff --git a/utils.ml b/utils.ml new file mode 100644 index 0000000..12a4eb2 --- /dev/null +++ b/utils.ml @@ -0,0 +1,4 @@ +let rec deoptionalise = function + | (Some x) :: xs -> x :: deoptionalise xs + | None :: xs -> deoptionalise xs + | [] -> []