134 lines
4.2 KiB
OCaml
134 lines
4.2 KiB
OCaml
open Ipaddr
|
|
|
|
module Prefix = struct
|
|
type t = Ipv4 of V4.Prefix.t | Ipv6 of V6.Prefix.t | Not of t
|
|
|
|
let rec compare a b =
|
|
match (a, b) with
|
|
| Ipv4 a, Ipv4 b -> V4.Prefix.compare a b
|
|
| Ipv6 a, Ipv6 b -> V6.Prefix.compare a b
|
|
| Ipv6 _, _ -> 1
|
|
| _, Ipv6 _ -> -1
|
|
| Not a, Not b -> -compare a b
|
|
| Not _, _ -> -1
|
|
| _, Not _ -> 1
|
|
|
|
let rec to_ipv4_list negate = function
|
|
| Ipv4 ipv4 -> if negate then [] else [ ipv4 ]
|
|
| Ipv6 _ -> []
|
|
| Not prefix -> to_ipv4_list (not negate) prefix
|
|
|
|
let rec to_ipv6_list negate = function
|
|
| Ipv4 _ -> []
|
|
| Ipv6 ipv6 -> if negate then [] else [ ipv6 ]
|
|
| Not prefix -> to_ipv6_list (not negate) prefix
|
|
end
|
|
|
|
module PrefixSet = struct
|
|
include Stdlib.Set.Make (Prefix)
|
|
|
|
let of_addrs zones =
|
|
let open Config in
|
|
function
|
|
| Addrs.Name name -> (
|
|
match List.assoc_opt name zones with
|
|
| Some set -> set
|
|
| None -> failwith ("zone " ^ name ^ " not found"))
|
|
| Addrs.Ipv4 prefix -> singleton (Prefix.Ipv4 prefix)
|
|
| Addrs.Ipv6 prefix -> singleton (Prefix.Ipv6 prefix)
|
|
|
|
let of_addrs_list zone =
|
|
List.fold_left (fun acc addrs -> union (of_addrs zone addrs) acc) empty
|
|
end
|
|
|
|
module Zones = struct
|
|
open Config.Zone
|
|
|
|
let dependencies zone =
|
|
let rec aux = function
|
|
| Ipv4 _ | Ipv6 _ -> []
|
|
| Name name -> [ name ]
|
|
| List list -> List.flatten (List.map aux list)
|
|
| Not not -> aux not
|
|
in
|
|
List.map (fun (k, v) -> (k, aux v)) zone
|
|
|
|
let rec compile_zone assoc = function
|
|
| Ipv4 ipv4 -> PrefixSet.singleton (Prefix.Ipv4 ipv4)
|
|
| Ipv6 ipv6 -> PrefixSet.singleton (Prefix.Ipv6 ipv6)
|
|
| Name name -> List.assoc name assoc
|
|
| List list ->
|
|
List.fold_left
|
|
(fun acc zone -> PrefixSet.union (compile_zone assoc zone) acc)
|
|
PrefixSet.empty list
|
|
| Not zone ->
|
|
PrefixSet.map (fun p -> Prefix.Not p) (compile_zone assoc zone)
|
|
|
|
let compile zones =
|
|
match Tsort.sort (dependencies zones) with
|
|
| Tsort.Sorted sorted ->
|
|
List.fold_right
|
|
(fun name acc ->
|
|
let zone = List.assoc name zones in
|
|
let compiled = compile_zone acc zone in
|
|
(name, compiled) :: acc)
|
|
sorted []
|
|
| _ -> failwith "cyclic dependency in zones definitions"
|
|
end
|
|
|
|
module Rules = struct
|
|
open Nftables
|
|
open Config.Rule
|
|
|
|
(* Bon, ce module n'est vraiment pas très joli… *)
|
|
|
|
let compile_addrs_list getter expr negate zones addrs_list =
|
|
PrefixSet.fold
|
|
(fun prefix acc -> getter negate prefix @ acc)
|
|
(PrefixSet.of_addrs_list zones addrs_list)
|
|
[]
|
|
|> List.map expr
|
|
|
|
let compile_match_addrs getter expr field zones addrs_list =
|
|
let equal = compile_addrs_list getter expr false zones addrs_list in
|
|
let not_equal = compile_addrs_list getter expr true zones addrs_list in
|
|
let stmts =
|
|
match equal with
|
|
| [] -> []
|
|
| _ -> [ Stmt.Match (Match.Eq, Expr.Payload field, Expr.Set equal) ]
|
|
in
|
|
match not_equal with
|
|
| [] -> stmts
|
|
| _ ->
|
|
Stmt.Match (Match.NotEq, Expr.Payload field, Expr.Set not_equal)
|
|
:: stmts
|
|
|
|
let compile_match_ipv4 field =
|
|
compile_match_addrs Prefix.to_ipv4_list Expr.ipv4 (Payload.Ipv4 field)
|
|
|
|
let compile_match_ipv6 field =
|
|
compile_match_addrs Prefix.to_ipv6_list Expr.ipv6 (Payload.Ipv6 field)
|
|
|
|
let compile_rule zones { src; dest; _ } =
|
|
let ipv4_src = compile_match_ipv4 Payload.Ipv4.Saddr zones src in
|
|
let ipv4_dest = compile_match_ipv4 Payload.Ipv4.Daddr zones dest in
|
|
let ipv6_src = compile_match_ipv6 Payload.Ipv6.Saddr zones src in
|
|
let ipv6_dest = compile_match_ipv6 Payload.Ipv6.Daddr zones dest in
|
|
let verdict = [ Stmt.Verdict Verdict.Accept ] in
|
|
[ ipv4_src @ ipv4_dest @ verdict; ipv6_src @ ipv6_dest @ verdict ]
|
|
|
|
let compile zones rules = List.flatten (List.map (compile_rule zones) rules)
|
|
end
|
|
|
|
let compile config =
|
|
let open Nftables in
|
|
let open Config in
|
|
let zones = Zones.compile config.zones in
|
|
let exprs = Rules.compile zones config.rules in
|
|
let family = Family.Inet in
|
|
let table = "filter" in
|
|
let chain = "forward" in
|
|
let compiled =
|
|
List.map (fun expr -> Command.AddRule { family; table; chain; expr }) exprs
|
|
in
|
|
Command.FlushRuleset :: compiled
|