mirror of
https://github.com/mirage/qubes-mirage-firewall.git
synced 2025-04-15 21:13:07 -04:00
updates to recent mirage-nat changes
This commit is contained in:
Hannes Mehnert
parent
06b9a88331
commit
8187096bfa
52
firewall.ml
52
firewall.ml
@ -47,7 +47,7 @@ let translate t packet =
|
||||
let add_nat_and_forward_ipv4 t packet =
|
||||
let open Router in
|
||||
let xl_host = t.uplink#my_ip in
|
||||
My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet >>= function
|
||||
match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet with
|
||||
| Ok packet -> forward_ipv4 t packet
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet);
|
||||
@ -60,7 +60,7 @@ let nat_to t ~host ~port packet =
|
||||
| Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit
|
||||
| Ipaddr.V4 target ->
|
||||
let xl_host = t.uplink#my_ip in
|
||||
My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet >>= function
|
||||
match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet with
|
||||
| Ok packet -> forward_ipv4 t packet
|
||||
| Error e ->
|
||||
Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet);
|
||||
@ -88,34 +88,34 @@ let ipv4_from_client resolver dns_servers t ~src packet =
|
||||
| `Memory_critical -> Lwt.return_unit
|
||||
| `Ok ->
|
||||
(* Check for existing NAT entry for this packet *)
|
||||
translate t packet >>= function
|
||||
| Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
|
||||
| None ->
|
||||
(* No existing NAT entry. Check the firewall rules. *)
|
||||
let `IPv4 (ip, _transport) = packet in
|
||||
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||
match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
|
||||
| None -> Lwt.return_unit
|
||||
| Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet
|
||||
match translate t packet with
|
||||
| Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
|
||||
| None ->
|
||||
(* No existing NAT entry. Check the firewall rules. *)
|
||||
let `IPv4 (ip, _transport) = packet in
|
||||
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||
match of_mirage_nat_packet ~src:(`Client src) ~dst packet with
|
||||
| None -> Lwt.return_unit
|
||||
| Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet
|
||||
|
||||
let ipv4_from_netvm t packet =
|
||||
match Memory_pressure.status () with
|
||||
| `Memory_critical -> Lwt.return_unit
|
||||
| `Ok ->
|
||||
let `IPv4 (ip, _transport) = packet in
|
||||
let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
|
||||
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
||||
| None -> Lwt.return_unit
|
||||
| Some _ ->
|
||||
match src with
|
||||
| `Client _ | `Firewall ->
|
||||
Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet);
|
||||
Lwt.return_unit
|
||||
| `External _ | `NetVM as src ->
|
||||
translate t packet >>= function
|
||||
| Some frame -> forward_ipv4 t frame
|
||||
| None ->
|
||||
let `IPv4 (ip, _transport) = packet in
|
||||
let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in
|
||||
let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in
|
||||
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
||||
| None -> Lwt.return_unit
|
||||
| Some packet -> apply_rules t Rules.from_netvm ~dst packet
|
||||
| Some _ ->
|
||||
match src with
|
||||
| `Client _ | `Firewall ->
|
||||
Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet);
|
||||
Lwt.return_unit
|
||||
| `External _ | `NetVM as src ->
|
||||
match translate t packet with
|
||||
| Some frame -> forward_ipv4 t frame
|
||||
| None ->
|
||||
match Packet.of_mirage_nat_packet ~src ~dst packet with
|
||||
| None -> Lwt.return_unit
|
||||
| Some packet -> apply_rules t Rules.from_netvm ~dst packet
|
||||
|
||||
33
my_nat.ml
33
my_nat.ml
@ -34,11 +34,11 @@ type t = {
|
||||
let create ~max_entries =
|
||||
let tcp_size = 7 * max_entries / 8 in
|
||||
let udp_size = max_entries - tcp_size in
|
||||
Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table ->
|
||||
let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in
|
||||
{ table }
|
||||
|
||||
let translate t packet =
|
||||
Nat.translate t.table packet >|= function
|
||||
match Nat.translate t.table packet with
|
||||
| Error (`Untranslated | `TTL_exceeded as e) ->
|
||||
Log.debug (fun f -> f "Failed to NAT %a: %a"
|
||||
Nat_packet.pp packet
|
||||
@ -64,15 +64,6 @@ let remove_connections t ports ip =
|
||||
ports.nat_icmp := Ports.diff !(ports.nat_icmp) (Ports.of_list freed_ports.Mirage_nat.icmp)
|
||||
|
||||
let add_nat_rule_and_translate t ports ~xl_host action packet =
|
||||
let apply_action xl_port =
|
||||
Lwt.catch (fun () ->
|
||||
Nat.add t.table packet (xl_host, xl_port) action
|
||||
)
|
||||
(function
|
||||
| Out_of_memory -> Lwt.return (Error `Out_of_memory)
|
||||
| x -> Lwt.fail x
|
||||
)
|
||||
in
|
||||
let rec aux ~retries =
|
||||
let nat_ports, dns_ports =
|
||||
match packet with
|
||||
@ -81,29 +72,21 @@ let add_nat_rule_and_translate t ports ~xl_host action packet =
|
||||
| `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty
|
||||
in
|
||||
let xl_port = pick_free_port ~nat_ports ~dns_ports in
|
||||
apply_action xl_port >>= function
|
||||
| Error `Out_of_memory ->
|
||||
(* Because hash tables resize in big steps, this can happen even if we have a fair
|
||||
chunk of free memory. *)
|
||||
Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table...");
|
||||
reset t ports >>= fun () ->
|
||||
aux ~retries:(retries - 1)
|
||||
| Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries")
|
||||
match Nat.add t.table packet xl_host (fun () -> xl_port) action with
|
||||
| Error `Overlap when retries < 0 -> Error "Too many retries"
|
||||
| Error `Overlap ->
|
||||
if retries = 0 then (
|
||||
Log.warn (fun f -> f "Failed to find a free port; resetting NAT table");
|
||||
reset t ports >>= fun () ->
|
||||
reset t ports;
|
||||
aux ~retries:(retries - 1)
|
||||
) else (
|
||||
aux ~retries:(retries - 1)
|
||||
)
|
||||
| Error `Cannot_NAT ->
|
||||
Lwt.return (Error "Cannot NAT this packet")
|
||||
Error "Cannot NAT this packet"
|
||||
| Ok () ->
|
||||
Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table);
|
||||
translate t packet >|= function
|
||||
| None -> Error "No NAT entry, even after adding one!"
|
||||
| Some packet ->
|
||||
Ok packet
|
||||
Option.to_result ~none:"No NAT entry, even after adding one!"
|
||||
(translate t packet)
|
||||
in
|
||||
aux ~retries:100
|
||||
|
||||
@ -19,9 +19,9 @@ type action = [
|
||||
| `Redirect of Mirage_nat.endpoint
|
||||
]
|
||||
|
||||
val create : max_entries:int -> t Lwt.t
|
||||
val reset : t -> ports -> unit Lwt.t
|
||||
val create : max_entries:int -> t
|
||||
val reset : t -> ports -> unit
|
||||
val remove_connections : t -> ports -> Ipaddr.V4.t -> unit
|
||||
val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t
|
||||
val translate : t -> Nat_packet.t -> Nat_packet.t option
|
||||
val add_nat_rule_and_translate : t -> ports ->
|
||||
xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t
|
||||
xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result
|
||||
|
||||
@ -45,7 +45,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
|
||||
Lwt.return_unit in
|
||||
(* Set up networking *)
|
||||
let max_entries = Key_gen.nat_table_size () in
|
||||
My_nat.create ~max_entries >>= fun nat ->
|
||||
let nat = My_nat.create ~max_entries in
|
||||
|
||||
(* Read network configuration from QubesDB *)
|
||||
Dao.read_network_config qubesDB >>= fun config ->
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user