From abb508000ea7af121705d4922022ee607803cb92 Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 6 Oct 2022 18:06:02 +0200 Subject: [PATCH 1/8] remove memory management code not needed anymore --- client_net.ml | 5 +---- firewall.ml | 12 ++---------- frameQ.ml | 32 -------------------------------- frameQ.mli | 15 --------------- memory_pressure.ml | 1 - uplink.ml | 7 ++----- 6 files changed, 5 insertions(+), 67 deletions(-) delete mode 100644 frameQ.ml delete mode 100644 frameQ.mli diff --git a/client_net.ml b/client_net.ml index 84a1401..15a659e 100644 --- a/client_net.ml +++ b/client_net.ml @@ -29,7 +29,6 @@ let writev eth dst proto fillfn = class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in object - val queue = FrameQ.create (Ipaddr.V4.to_string client_ip) val mutable rules = [] method get_rules = rules method set_rules new_db = rules <- Dao.read_rules new_db client_ip @@ -38,9 +37,7 @@ class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = method my_ip = gateway_ip method other_ip = client_ip method writev proto fillfn = - FrameQ.send queue (fun () -> - writev eth client_mac proto fillfn - ) + writev eth client_mac proto fillfn method log_header = log_header end diff --git a/firewall.ml b/firewall.ml index 44e6c9b..52eb208 100644 --- a/firewall.ml +++ b/firewall.ml @@ -83,16 +83,8 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); Lwt.return_unit -let handle_low_memory t = - match Memory_pressure.status () with - | `Memory_critical -> (* TODO: should happen before copying and async *) - Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); - My_nat.reset t.Router.nat t.Router.ports >|= fun () -> - `Memory_critical - | `Ok -> Lwt.return `Ok - let ipv4_from_client resolver dns_servers t ~src packet = - handle_low_memory t >>= function + match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit | `Ok -> (* Check for existing NAT entry for this packet *) @@ -107,7 +99,7 @@ let ipv4_from_client resolver dns_servers t ~src packet = | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet let ipv4_from_netvm t packet = - handle_low_memory t >>= function + match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit | `Ok -> let `IPv4 (ip, _transport) = packet in diff --git a/frameQ.ml b/frameQ.ml deleted file mode 100644 index 390ac7a..0000000 --- a/frameQ.ml +++ /dev/null @@ -1,32 +0,0 @@ -(* Copyright (C) 2016, Thomas Leonard - See the README file for details. *) - -let src = Logs.Src.create "frameQ" ~doc:"Interface output queue" -module Log = (val Logs.src_log src : Logs.LOG) - -type t = { - name : string; - mutable items : int; -} - -let create name = { name; items = 0 } - -(* Note: the queue is only used if we already filled the transmit buffer. *) -let max_qlen = 10 - -let send q fn = - if q.items = max_qlen then ( - Log.warn (fun f -> f "Maximum queue length exceeded for %s: dropping frame" q.name); - Lwt.return_unit - ) else ( - let sent = fn () in - if Lwt.state sent = Lwt.Sleep then ( - q.items <- q.items + 1; - Log.info (fun f -> f "Queue length for %s: incr to %d" q.name q.items); - Lwt.on_termination sent (fun () -> - q.items <- q.items - 1; - Log.info (fun f -> f "Queue length for %s: decr to %d" q.name q.items); - ) - ); - sent - ) diff --git a/frameQ.mli b/frameQ.mli deleted file mode 100644 index f11e1ae..0000000 --- a/frameQ.mli +++ /dev/null @@ -1,15 +0,0 @@ -(* Copyright (C) 2016, Thomas Leonard - See the README file for details. *) - -(** Keep track of the queue length for output buffers. *) - -type t - -val create : string -> t -(** [create name] is a new empty queue. [name] is used in log messages. *) - -val send : t -> (unit -> unit Lwt.t) -> unit Lwt.t -(** [send t fn] checks that the queue isn't overloaded and calls [fn ()] if it's OK. - The item is considered to be queued until the result of [fn] has resolved. - In the case of mirage-net-xen's [writev], this happens when the frame has been - added to the ring (not when it is consumed), which is fine for us. *) diff --git a/memory_pressure.ml b/memory_pressure.ml index 3b14f4b..b867573 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -54,7 +54,6 @@ let print_mem_usage = let init () = Gc.full_major (); let stats = Xen_os.Memory.quick_stat () in - print_mem_usage ; report_mem_usage stats let status () = diff --git a/uplink.ml b/uplink.ml index 1e5d30e..40695ed 100644 --- a/uplink.ml +++ b/uplink.ml @@ -25,15 +25,12 @@ module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_tim } class netvm_iface eth mac ~my_ip ~other_ip : interface = object - val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) method my_mac = Eth.mac eth method my_ip = my_ip method other_ip = other_ip method writev ethertype fillfn = - FrameQ.send queue (fun () -> - mac >>= fun dst -> - Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error - ) + mac >>= fun dst -> + Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error end let send_dns_client_query t ~src_port ~dst ~dst_port buf = From eb4d0fc37195c80619b13c139aeefc5a84e74211 Mon Sep 17 00:00:00 2001 From: palainp Date: Thu, 6 Oct 2022 18:06:18 +0200 Subject: [PATCH 2/8] update documentation --- README.md | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/README.md b/README.md index 8b4b1a9..a24f6cd 100644 --- a/README.md +++ b/README.md @@ -70,8 +70,8 @@ Run this command in dom0 to create a `mirage-firewall` VM using the `mirage-fire qvm-create \ --property kernel=mirage-firewall \ --property kernelopts='' \ - --property memory=64 \ - --property maxmem=64 \ + --property memory=32 \ + --property maxmem=32 \ --property netvm=sys-net \ --property provides_network=True \ --property vcpus=1 \ @@ -137,7 +137,7 @@ The boot process: For development, use the [test-mirage][] scripts to deploy the unikernel (`qubes-firewall.xen`) from your development AppVM. This takes a little more setting up the first time, but will be much quicker after that. e.g. - $ test-mirage qubes_firewall.xen mirage-firewall + $ test-mirage dist/qubes-firewall.xen mirage-firewall Waiting for 'Ready'... OK Uploading 'dist/qubes-firewall.xen' (7454880 bytes) to "mirage-test" Waiting for 'Booting'... OK @@ -148,25 +148,25 @@ This takes a little more setting up the first time, but will be much quicker aft \__ \ ( | | ( | ) | ____/\___/ _|\___/____/ Solo5: Bindings version v0.7.3 - Solo5: Memory map: 64 MB addressable: + Solo5: Memory map: 32 MB addressable: Solo5: reserved @ (0x0 - 0xfffff) - Solo5: text @ (0x100000 - 0x31bfff) - Solo5: rodata @ (0x31c000 - 0x386fff) - Solo5: data @ (0x387000 - 0x544fff) - Solo5: heap >= 0x545000 < stack < 0x4000000 + Solo5: text @ (0x100000 - 0x319fff) + Solo5: rodata @ (0x31a000 - 0x384fff) + Solo5: data @ (0x385000 - 0x53ffff) + Solo5: heap >= 0x540000 < stack < 0x2000000 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] waiting for client... - 2022-08-13 14:55:38 -00:00: INF [qubes.gui] waiting for client... 2022-08-13 14:55:38 -00:00: INF [qubes.db] connecting to server... 2022-08-13 14:55:38 -00:00: INF [qubes.db] connected 2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-ip" = "10.137.0.20" 2022-08-13 14:55:38 -00:00: INF [qubes.db] got update: "/mapped-ip/10.137.0.20/visible-gateway" = "10.137.0.23" - 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, other end wants to use protocol version 3, continuing with version 2 + 2022-08-13 14:55:38 -00:00: INF [qubes.rexec] client connected, using protocol version 3 2022-08-13 14:55:38 -00:00: INF [unikernel] QubesDB and qrexec agents connected in 0.041 s 2022-08-13 14:55:38 -00:00: INF [dao] Got network configuration from QubesDB: NetVM IP on uplink network: 10.137.0.4 Our IP on uplink network: 10.137.0.23 Our IP on client networks: 10.137.0.23 DNS resolver: 10.139.1.1 + DNS secondary resolver: 10.139.1.2 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] connect 0 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] create: id=0 domid=1 2022-08-13 14:55:38 -00:00: INF [net-xen frontend] sg:true gso_tcpv4:true rx_copy:true rx_flip:false smart_poll:false @@ -176,7 +176,7 @@ This takes a little more setting up the first time, but will be much quicker aft 2022-08-13 14:55:38 -00:00: INF [ARP] Sending gratuitous ARP for 10.137.0.23 (00:16:3e:5e:6c:00) 2022-08-13 14:55:38 -00:00: INF [udp] UDP layer connected on 10.137.0.23 2022-08-13 14:55:38 -00:00: INF [dao] Watching backend/vif - 2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 52MiB / 59MiB (87.55 %) + 2022-08-13 14:55:38 -00:00: INF [memory_pressure] Writing meminfo: free 20MiB / 27MiB (72.68 %) # Testing if the firewall works From 06b9a883314e974378cbe88ffb3680a4cec5b714 Mon Sep 17 00:00:00 2001 From: palainp Date: Sun, 9 Oct 2022 12:38:44 +0200 Subject: [PATCH 3/8] remove unneeded logs: be silent if the GC is enough --- memory_pressure.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/memory_pressure.ml b/memory_pressure.ml index b867573..629ecda 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -63,7 +63,8 @@ let status () = Gc.full_major (); Xen_os.Memory.trim (); let stats = Xen_os.Memory.quick_stat () in - report_mem_usage stats; - if fraction_free stats < 0.6 then `Memory_critical - else `Ok + if fraction_free stats < 0.6 then begin + report_mem_usage stats; + `Memory_critical + end else `Ok ) From 8187096bfa030eac410669681f21f7b207e7eb06 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 7 Oct 2022 18:49:03 +0200 Subject: [PATCH 4/8] updates to recent mirage-nat changes --- firewall.ml | 52 ++++++++++++++++++++++++++-------------------------- my_nat.ml | 33 ++++++++------------------------- my_nat.mli | 8 ++++---- unikernel.ml | 2 +- 4 files changed, 39 insertions(+), 56 deletions(-) diff --git a/firewall.ml b/firewall.ml index 52eb208..aab9b21 100644 --- a/firewall.ml +++ b/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 diff --git a/my_nat.ml b/my_nat.ml index 2652ff5..1f1bd32 100644 --- a/my_nat.ml +++ b/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 diff --git a/my_nat.mli b/my_nat.mli index 2ee21e0..488aae1 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -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 diff --git a/unikernel.ml b/unikernel.ml index 02cb5a3..65f7b3a 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -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 -> From f2d3faf1da0a12a535df5505964f70115d70a851 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Fri, 7 Oct 2022 20:54:49 +0200 Subject: [PATCH 5/8] revise port management this needs mirage-nat at hannesm#fixes --- client_net.ml | 2 +- firewall.ml | 4 +-- my_dns.ml | 4 +-- my_nat.ml | 92 ++++++++++++++++++++------------------------------- my_nat.mli | 18 ++++------ ports.ml | 16 --------- router.ml | 5 +-- router.mli | 1 - uplink.ml | 2 +- 9 files changed, 49 insertions(+), 95 deletions(-) delete mode 100644 ports.ml diff --git a/client_net.ml b/client_net.ml index 15a659e..b9b74fe 100644 --- a/client_net.ml +++ b/client_net.ml @@ -98,7 +98,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~cl (Ipaddr.V4.to_string client_ip) Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.Router.nat router.Router.ports client_ip; + My_nat.remove_connections router.Router.nat client_ip; end); update new_db new_rules in diff --git a/firewall.ml b/firewall.ml index aab9b21..06d32a4 100644 --- a/firewall.ml +++ b/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 - match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host `NAT packet with + match My_nat.add_nat_rule_and_translate t.nat ~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 - match My_nat.add_nat_rule_and_translate t.nat t.ports ~xl_host (`Redirect (target, port)) packet with + match My_nat.add_nat_rule_and_translate t.nat ~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); diff --git a/my_dns.ml b/my_dns.ml index 01ce370..8cb169d 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -35,12 +35,12 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let open My_nat in let dst, dst_port = ctx.nameserver in let router, send_udp, answer = ctx.stack in - let src_port = Ports.pick_free_port ~consult:router.ports.nat_udp router.ports.dns_udp in + let src_port = My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53 in with_timeout ctx.timeout_ns ((send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function | Ok () -> (Lwt_mvar.take answer >|= fun (_, dns_response) -> Ok dns_response) | Error _ as e -> Lwt.return e) >|= fun result -> - router.ports.dns_udp := Ports.remove src_port !(router.ports.dns_udp); + router.nat.udp_dns <- List.filter (fun p -> p <> src_port) router.nat.udp_dns; result let close _ = Lwt.return_unit diff --git a/my_nat.ml b/my_nat.ml index 1f1bd32..2591483 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,31 +11,38 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -type ports = { - nat_tcp : Ports.t ref; - nat_udp : Ports.t ref; - nat_icmp : Ports.t ref; - dns_udp : Ports.t ref; -} - -let empty_ports () = - let nat_tcp = ref Ports.empty in - let nat_udp = ref Ports.empty in - let nat_icmp = ref Ports.empty in - let dns_udp = ref Ports.empty in - { nat_tcp ; nat_udp ; nat_icmp ; dns_udp } - module Nat = Mirage_nat_lru type t = { table : Nat.t; + mutable udp_dns : int list; } let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in - { table } + { table ; udp_dns = [] } + +let pick_free_port t proto = + let rec go () = + let p = 1024 + Random.int (0xffff - 1024) in + match proto with + | `Udp when List.mem p t.udp_dns -> go () + | _ -> p + in + go () + +let free_udp_port t ~src ~dst ~dst_port = + let rec go () = + let src_port = pick_free_port t `Udp in + if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin + t.udp_dns <- src_port :: t.udp_dns; + src_port + end else + go () + in + go () let translate t packet = match Nat.translate t.table packet with @@ -47,46 +54,19 @@ let translate t packet = None | Ok packet -> Some packet -let pick_free_port ~nat_ports ~dns_ports = - Ports.pick_free_port ~consult:dns_ports nat_ports +let remove_connections t ip = + ignore (Nat.remove_connections t.table ip) -(* just clears the nat ports, dns ports stay as is *) -let reset t ports = - ports.nat_tcp := Ports.empty; - ports.nat_udp := Ports.empty; - ports.nat_icmp := Ports.empty; - Nat.reset t.table - -let remove_connections t ports ip = - let freed_ports = Nat.remove_connections t.table ip in - ports.nat_tcp := Ports.diff !(ports.nat_tcp) (Ports.of_list freed_ports.Mirage_nat.tcp); - ports.nat_udp := Ports.diff !(ports.nat_udp) (Ports.of_list freed_ports.Mirage_nat.udp); - 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 rec aux ~retries = - let nat_ports, dns_ports = - match packet with - | `IPv4 (_, `TCP _) -> ports.nat_tcp, ref Ports.empty - | `IPv4 (_, `UDP _) -> ports.nat_udp, ports.dns_udp - | `IPv4 (_, `ICMP _) -> ports.nat_icmp, ref Ports.empty - in - let xl_port = pick_free_port ~nat_ports ~dns_ports in - 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; - aux ~retries:(retries - 1) - ) else ( - aux ~retries:(retries - 1) - ) - | Error `Cannot_NAT -> - Error "Cannot NAT this packet" - | Ok () -> - Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); - Option.to_result ~none:"No NAT entry, even after adding one!" - (translate t packet) +let add_nat_rule_and_translate t ~xl_host action packet = + let proto = match packet with + | `IPv4 (_, `TCP _) -> `Tcp + | `IPv4 (_, `UDP _) -> `Udp + | `IPv4 (_, `ICMP _) -> `Icmp in - aux ~retries:100 + match Nat.add t.table packet xl_host (fun () -> pick_free_port t proto) action with + | Error `Overlap -> Error "Too many retries" + | Error `Cannot_NAT -> Error "Cannot NAT this packet" + | Ok () -> + Log.debug (fun f -> f "Updated NAT table: %a" Nat.pp_summary t.table); + Option.to_result ~none:"No NAT entry, even after adding one!" + (translate t packet) diff --git a/my_nat.mli b/my_nat.mli index 488aae1..1a9c1e7 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -3,25 +3,19 @@ (* Abstract over NAT interface (todo: remove this) *) -type ports = private { - nat_tcp : Ports.t ref; - nat_udp : Ports.t ref; - nat_icmp : Ports.t ref; - dns_udp : Ports.t ref; +type t = { + table : Mirage_nat_lru.t; + mutable udp_dns : int list; } -val empty_ports : unit -> ports - -type t - type action = [ | `NAT | `Redirect of Mirage_nat.endpoint ] +val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> int val create : max_entries:int -> t -val reset : t -> ports -> unit -val remove_connections : t -> ports -> Ipaddr.V4.t -> unit +val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option -val add_nat_rule_and_translate : t -> ports -> +val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result diff --git a/ports.ml b/ports.ml deleted file mode 100644 index 59d3205..0000000 --- a/ports.ml +++ /dev/null @@ -1,16 +0,0 @@ -module Set = Set.Make(struct - type t = int - let compare a b = compare a b -end) - -include Set - -let rec pick_free_port ?(retries = 10) ~consult add_to = - let p = 1024 + Random.int (0xffff - 1024) in - if (mem p !consult || mem p !add_to) && retries <> 0 - then pick_free_port ~retries:(retries - 1) ~consult add_to - else - begin - add_to := add p !add_to; - p - end diff --git a/router.ml b/router.ml index b91da74..4d7ed90 100644 --- a/router.ml +++ b/router.ml @@ -9,13 +9,10 @@ type t = { client_eth : Client_eth.t; nat : My_nat.t; uplink : interface; - (* NOTE: do not try to make this pure, it relies on mvars / side effects *) - ports : My_nat.ports; } let create ~client_eth ~uplink ~nat = - let ports = My_nat.empty_ports () in - { client_eth; nat; uplink; ports } + { client_eth; nat; uplink } let target t buf = let dst_ip = buf.Ipv4_packet.dst in diff --git a/router.mli b/router.mli index 610bddd..34fa86b 100644 --- a/router.mli +++ b/router.mli @@ -9,7 +9,6 @@ type t = private { client_eth : Client_eth.t; nat : My_nat.t; uplink : interface; - ports : My_nat.ports; } val create : diff --git a/uplink.ml b/uplink.ml index 40695ed..8ff4c10 100644 --- a/uplink.ml +++ b/uplink.ml @@ -44,7 +44,7 @@ end Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); match ip_packet with - | `UDP (header, packet) when Ports.mem header.dst_port !(router.Router.ports.My_nat.dns_udp) -> + | `UDP (header, packet) when List.mem header.dst_port router.Router.nat.My_nat.udp_dns -> Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); Lwt_mvar.put dns_responses (header, packet) | _ -> From 93b92c041bc3a9d243f9e1f674980868f5f56d07 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 8 Oct 2022 10:50:29 +0200 Subject: [PATCH 6/8] Adapt to mirage-nat changes: allow pick_free_port to fail reserve a special udp port for dns (as last resort) --- my_dns.ml | 6 ++++-- my_nat.ml | 43 ++++++++++++++++++++++++++++++++----------- my_nat.mli | 9 ++++----- uplink.ml | 2 +- 4 files changed, 41 insertions(+), 19 deletions(-) diff --git a/my_dns.ml b/my_dns.ml index 8cb169d..80f5ab0 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -35,12 +35,14 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let open My_nat in let dst, dst_port = ctx.nameserver in let router, send_udp, answer = ctx.stack in - let src_port = My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53 in + let src_port, evict = + My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53 + in with_timeout ctx.timeout_ns ((send_udp ~src_port ~dst ~dst_port buf >|= Rresult.R.open_error_msg) >>= function | Ok () -> (Lwt_mvar.take answer >|= fun (_, dns_response) -> Ok dns_response) | Error _ as e -> Lwt.return e) >|= fun result -> - router.nat.udp_dns <- List.filter (fun p -> p <> src_port) router.nat.udp_dns; + evict (); result let close _ = Lwt.return_unit diff --git a/my_nat.ml b/my_nat.ml index 2591483..209a562 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -13,37 +13,58 @@ type action = [ module Nat = Mirage_nat_lru +module S = + Set.Make(struct type t = int let compare (a : int) (b : int) = compare a b end) + type t = { table : Nat.t; - mutable udp_dns : int list; + mutable udp_dns : S.t; + last_resort_port : int } +let pick_port () = + 1024 + Random.int (0xffff - 1024) + let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in let table = Nat.empty ~tcp_size ~udp_size ~icmp_size:100 in - { table ; udp_dns = [] } + let last_resort_port = pick_port () in + { table ; udp_dns = S.empty ; last_resort_port } let pick_free_port t proto = - let rec go () = - let p = 1024 + Random.int (0xffff - 1024) in - match proto with - | `Udp when List.mem p t.udp_dns -> go () - | _ -> p + let rec go retries = + if retries = 0 then + None + else + let p = 1024 + Random.int (0xffff - 1024) in + match proto with + | `Udp when S.mem p t.udp_dns || p = t.last_resort_port -> + go (retries - 1) + | _ -> Some p in - go () + go 10 let free_udp_port t ~src ~dst ~dst_port = let rec go () = - let src_port = pick_free_port t `Udp in + let src_port = + Option.value ~default:t.last_resort_port (pick_free_port t `Udp) + in if Nat.is_port_free t.table `Udp ~src ~dst ~src_port ~dst_port then begin - t.udp_dns <- src_port :: t.udp_dns; - src_port + let remove = + if src_port <> t.last_resort_port then begin + t.udp_dns <- S.add src_port t.udp_dns; + (fun () -> t.udp_dns <- S.remove src_port t.udp_dns) + end else Fun.id + in + src_port, remove end else go () in go () +let dns_port t port = S.mem port t.udp_dns || port = t.last_resort_port + let translate t packet = match Nat.translate t.table packet with | Error (`Untranslated | `TTL_exceeded as e) -> diff --git a/my_nat.mli b/my_nat.mli index 1a9c1e7..eab1a34 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -3,17 +3,16 @@ (* Abstract over NAT interface (todo: remove this) *) -type t = { - table : Mirage_nat_lru.t; - mutable udp_dns : int list; -} +type t type action = [ | `NAT | `Redirect of Mirage_nat.endpoint ] -val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> int +val free_udp_port : t -> src:Ipaddr.V4.t -> dst:Ipaddr.V4.t -> dst_port:int -> + int * (unit -> unit) +val dns_port : t -> int -> bool val create : max_entries:int -> t val remove_connections : t -> Ipaddr.V4.t -> unit val translate : t -> Nat_packet.t -> Nat_packet.t option diff --git a/uplink.ml b/uplink.ml index 8ff4c10..b74d1df 100644 --- a/uplink.ml +++ b/uplink.ml @@ -44,7 +44,7 @@ end Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); match ip_packet with - | `UDP (header, packet) when List.mem header.dst_port router.Router.nat.My_nat.udp_dns -> + | `UDP (header, packet) when My_nat.dns_port router.Router.nat header.dst_port -> Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); Lwt_mvar.put dns_responses (header, packet) | _ -> From c66d6a8727a6f263bdddd68d3715f2a53973cfb6 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 11 Oct 2022 13:34:55 +0200 Subject: [PATCH 7/8] raise lower bound of mirage-nat to 3.0.0, bump opam-repo commit --- Dockerfile | 2 +- config.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index cf6a662..62637b6 100644 --- a/Dockerfile +++ b/Dockerfile @@ -11,7 +11,7 @@ RUN sudo ln -sf /usr/bin/opam-2.1 /usr/bin/opam # Pin last known-good version for reproducible builds. # Remove this line (and the base image pin above) if you want to test with the # latest versions. -RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 632ef7fd6add02a7789f896751c51b408dca0373 && opam update +RUN cd /home/opam/opam-repository && git fetch origin master && git reset --hard 0f451c34c56458ee18495a98eb35d7dcb14f519a && opam update RUN opam install -y mirage opam-monorepo RUN mkdir /home/opam/qubes-mirage-firewall diff --git a/config.ml b/config.ml index d33bf23..8f187ae 100644 --- a/config.ml +++ b/config.ml @@ -28,7 +28,7 @@ let main = package "mirage-net-xen"; package "ipaddr" ~min:"5.2.0"; package "mirage-qubes" ~min:"0.9.1"; - package "mirage-nat" ~min:"2.2.1"; + package "mirage-nat" ~min:"3.0.0"; package "mirage-logs"; package "mirage-xen" ~min:"8.0.0"; package ~min:"6.1.0" "dns-client"; From b958c106904c92b09142347f7b6c2052e4ab8c80 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Tue, 11 Oct 2022 13:55:36 +0200 Subject: [PATCH 8/8] build-with-docker: update sha --- build-with-docker.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 0b6e016..cc00274 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall . echo Building Firewall... docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: d0ec19d5b392509955edccf100852bcc9c0e05bf31f1ec25c9cc9c9e74c3b7bf" +echo "SHA2 last known: 73488b0c54d6c43d662ddf58916b6d472430894f6394c6bdb8a879723abcc06f" echo "(hashes should match for released versions)"