Format nftables.ml + simplify Ipv6

compile.ml

@@ -20,3 +20,18 @@ let compile_zones zones =
         let compiled = compile_zone acc values in
         (name, compiled) :: acc) sorted []
   | _ -> assert false
+
+let compile_rule zones { src; dest; l4 } =
+  let match_src = match src with
+    | [] -> []
+    | l -> []
+  in
+  let match_dest = match dest with
+    | [] -> []
+    | l -> []
+  in
+  let l4_rules = compile_l4 zones l4 in
+  List.flatten [match_src; match_dest; l4_rules]
+
+let compile_rules zones =
+  List.map (compile_rule zones)

nftables.ml

@@ -1,36 +1,23 @@
 open Utils
 open Ipaddr
 
-type _ udp =
+type _ udp = UdpDport : int udp | UdpSport : int udp
-  | UdpDport : int udp
+type _ tcp = TcpDport : int tcp | TcpSport : int tcp
-  | UdpSport : int udp
+type _ payload = Udp : 'a udp -> 'a payload | Tcp : 'a tcp -> 'a payload
-
-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
+  | Ipv4 : V4.Prefix.t -> V4.Prefix.t expr
-  | Ipv6 : (V6.t * V6.Prefix.t) -> (V6.t * V6.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 =
+type (_, _) match_op = Eq : ('a, 'a) match_op | NotEq : ('a, 'a) match_op
-  | Eq : ('a, 'a) match_op
+type counter = Named of string | Anon of { packets : int; bytes : int }
-  | NotEq : ('a, 'a) match_op
-
-type counter =
-  | Named of string
-  | Anon of { packets: int; bytes: int }
 
 type verdict =
   | Accept
@@ -42,44 +29,30 @@ type verdict =
 
 type _ stmt =
   | Match : {
-      left: 'a expr;
+      left : 'a expr;
-      right: 'b expr; 
+      right : 'b expr;
-      op: ('a, 'b) match_op
+      op : ('a, 'b) match_op;
-    } -> unit stmt
+    }
+      -> unit stmt
   | Counter : counter -> unit stmt
   | Verdict : verdict -> unit stmt
   | NoTrack : unit stmt
-  | Log : {
+  | Log : { prefix : string option; group : int option } -> unit stmt
-      prefix: string option;
-      group: int option
-    } -> unit stmt
 
 type family = Ip6 | Ip4 | Inet
-
+type table = { family : family; table_name : string }
-type table = { family: family; table_name: string }
+type chain = { family : family; table : string; chain_name : string }
-
-type chain = { family: family; table: string; chain_name: string }
 
 type rule = {
-  family: family;
+  family : family;
-  table: string;
+  table : string;
-  chain: string;
+  chain : string;
-  expr: unit stmt list
+  expr : unit stmt list;
 }
 
-type add_object =
+type add_object = AddTable of table | AddChain of chain | AddRule of rule
-  | AddTable of table
+type flush_object = FlushRuleset | FlushTable of table | FlushChain of chain
-  | AddChain of chain
+type command = Add of add_object | Flush of flush_object
-  | 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"
@@ -89,34 +62,38 @@ let string_of_tcp : type a. a tcp -> string = function
   | TcpSport -> "sport"
   | TcpDport -> "dport"
 
-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) =
-  let (protocol, field) = match payload with
+  let protocol, field =
-    | Udp udp -> "udp", string_of_udp udp
+    match payload with
-    | Tcp tcp -> "tcp", string_of_tcp tcp
+    | Udp udp -> ("udp", string_of_udp udp)
+    | Tcp tcp -> ("tcp", string_of_tcp tcp)
   in
-  assoc_one "payload" (`Assoc [
+  assoc_one "payload"
-      ("protocol", `String protocol);
+    (`Assoc [ ("protocol", `String protocol); ("field", `String field) ])
-      ("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 [
+  | Ipv4 i ->
-      ("addr", `String (V4.to_string a));
+      assoc_one "prefix"
-      ("len", `Int (V4.Prefix.bits p))
+        (`Assoc
+          [
+            ("addr", `String V4.(to_string (Prefix.network i)));
+            ("len", `Int (V4.Prefix.bits i));
           ])
-  | Ipv6 (a, p) -> assoc_one "prefix" (`Assoc [
+  | Ipv6 i ->
-      ("addr", `String (V6.to_string a));
+      assoc_one "prefix"
-      ("len", `Int (V6.Prefix.bits p))
+        (`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) ->
+  | Range (a, b) -> assoc_one "range" (`List [ json_of_expr a; json_of_expr 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
@@ -126,10 +103,8 @@ let string_of_match_op : type a b. (a, b) match_op -> string = function
 let json_of_counter = function
   | Named n -> assoc_one "counter" (`String n)
   | Anon { packets; bytes } ->
-    assoc_one "counter" (`Assoc [
+      assoc_one "counter"
-        ("packets", `Int packets);
+        (`Assoc [ ("packets", `Int packets); ("bytes", `Int bytes) ])
-        ("bytes", `Int bytes)
-      ])
 
 let json_of_verdict = function
   | Accept -> assoc_one "accept" `Null
@@ -141,45 +116,52 @@ let json_of_verdict = function
 
 let json_of_stmt : type a. a stmt -> Yojson.Basic.t = function
   | Match { left; right; op } ->
-    assoc_one "match" (`Assoc [
+      assoc_one "match"
+        (`Assoc
+          [
             ("left", json_of_expr left);
             ("right", json_of_expr right);
-        ("op", `String (string_of_match_op op))
+            ("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 = [
+      let elems =
+        [
           Option.map (fun p -> ("prefix", `String p)) prefix;
-      Option.map (fun g -> ("group", `Int g)) group
+          Option.map (fun g -> ("group", `Int g)) group;
-    ] in
+        ]
+      in
       assoc_one "log" (`Assoc (deoptionalise elems))
 
-let string_of_family = function
+let string_of_family = function Ip6 -> "ip6" | Ip4 -> "ip4" | Inet -> "inet"
-  | Ip6 -> "ip6"
-  | Ip4 -> "ip4"
-  | Inet -> "inet"
 
 let json_of_table { family; table_name } =
-  assoc_one "table" (`Assoc [
+  assoc_one "table"
+    (`Assoc
+      [
         ("family", `String (string_of_family family));
-      ("name", `String table_name)
+        ("name", `String table_name);
       ])
 
 let json_of_chain { family; table; chain_name } =
-  assoc_one "chain" (`Assoc [
+  assoc_one "chain"
+    (`Assoc
+      [
         ("family", `String (string_of_family family));
         ("table", `String table);
-      ("name", `String chain_name)
+        ("name", `String chain_name);
       ])
 
 let json_of_rule { family; table; chain; expr } =
-  assoc_one "rule" (`Assoc [
+  assoc_one "rule"
+    (`Assoc
+      [
         ("family", `String (string_of_family family));
         ("table", `String table);
         ("chain", `String chain);
-      ("expr", `List (List.map json_of_stmt expr))
+        ("expr", `List (List.map json_of_stmt expr));
       ])
 
 let json_of_add_object = function