From 0ef60ae76789ea3b8144b744d0e14a35512a381d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Fri, 10 Mar 2017 16:09:36 +0000 Subject: [PATCH] Update to new mirage-nat API --- firewall.ml | 20 +++++++++++--------- my_nat.ml | 45 ++++++++++++++++++++++++++------------------- my_nat.mli | 8 ++++---- unikernel.ml | 4 ++-- 4 files changed, 43 insertions(+), 34 deletions(-) diff --git a/firewall.ml b/firewall.ml index 341f103..f0d29ef 100644 --- a/firewall.ml +++ b/firewall.ml @@ -84,8 +84,8 @@ let translate t packet = (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) let add_nat_and_forward_ipv4 t packet = - let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `Rewrite packet >>= function + let xl_host = t.Router.uplink#my_ip in + My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host `NAT packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s" e); @@ -93,13 +93,15 @@ let add_nat_and_forward_ipv4 t packet = (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) let nat_to t ~host ~port packet = - let target = Router.resolve t host in - let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in - My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function - | Ok packet -> forward_ipv4 t packet - | Error e -> - Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e); - Lwt.return () + match Router.resolve t host with + | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return () + | Ipaddr.V4 target -> + let xl_host = t.Router.uplink#my_ip in + My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function + | Ok packet -> forward_ipv4 t packet + | Error e -> + Log.warn (fun f -> f "Failed to add NAT redirect rule: %s" e); + Lwt.return () (* Handle incoming packets *) diff --git a/my_nat.ml b/my_nat.ml index 6cdcae1..be9b57b 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -7,35 +7,42 @@ let src = Logs.Src.create "my-nat" ~doc:"NAT shim" module Log = (val Logs.src_log src : Logs.LOG) type action = [ - | `Rewrite - | `Redirect of Ipaddr.t * int + | `NAT + | `Redirect of Mirage_nat.endpoint ] -type t = Nat : (module Mirage_nat.S with type t = 't) * 't -> t +module Nat = Mirage_nat_hashtable -let create (type t) (nat:(module Mirage_nat.S with type t = t)) (table:t) = - let (module Nat : Mirage_nat.S with type t = t) = nat in - Nat (nat, table) +type t = { + table : Nat.t; + get_time : unit -> Mirage_nat.time; +} -let translate (Nat ((module Nat), table)) packet = - Nat.translate table packet >|= function - | Error `Untranslated -> None +let create ~get_time = + Nat.empty () >|= fun table -> + { get_time; table } + +let translate t packet = + Nat.translate t.table packet >|= function + | Error (`Untranslated | `TTL_exceeded as e) -> + Log.debug (fun f -> f "Failed to NAT %a: %a" + Nat_packet.pp packet + Mirage_nat.pp_error e + ); + None | Ok packet -> Some packet let random_user_port () = 1024 + Random.int (0xffff - 1024) -let reset (Nat ((module Nat), table)) = - Nat.reset table +let reset t = + Nat.reset t.table -let add_nat_rule_and_translate ((Nat ((module Nat), table)) as t) ~xl_host action packet = +let add_nat_rule_and_translate t ~xl_host action packet = + let now = t.get_time () in let apply_action xl_port = Lwt.catch (fun () -> - match action with - | `Rewrite -> - Nat.add_nat table packet (xl_host, xl_port) - | `Redirect target -> - Nat.add_redirect table packet (xl_host, xl_port) target + Nat.add t.table ~now packet (xl_host, xl_port) action ) (function | Out_of_memory -> Lwt.return (Error `Out_of_memory) @@ -49,13 +56,13 @@ let add_nat_rule_and_translate ((Nat ((module Nat), table)) as t) ~xl_host actio (* 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..."); - Nat.reset table >>= fun () -> + Nat.reset t.table >>= fun () -> aux ~retries:(retries - 1) | Error `Overlap when retries < 0 -> Lwt.return (Error "Too many retries") | Error `Overlap -> if retries = 0 then ( Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); - Nat.reset table >>= fun () -> + Nat.reset t.table >>= fun () -> aux ~retries:(retries - 1) ) else ( aux ~retries:(retries - 1) diff --git a/my_nat.mli b/my_nat.mli index 7ff5b88..6761b73 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -6,12 +6,12 @@ type t type action = [ - | `Rewrite - | `Redirect of Ipaddr.t * int + | `NAT + | `Redirect of Mirage_nat.endpoint ] -val create : (module Mirage_nat.S with type t = 'a) -> 'a -> t +val create : get_time:(unit -> Mirage_nat.time) -> t Lwt.t val reset : t -> unit Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t -val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t -> +val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t diff --git a/unikernel.ml b/unikernel.ml index f0368a7..5cf69f9 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -9,7 +9,6 @@ module Log = (val Logs.src_log src : Logs.LOG) module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct module Uplink = Uplink.Make(Clock) - module Nat = Mirage_nat_hashtable.Make(Clock)(OS.Time) (* Set up networking and listen for incoming packets. *) let network ~clock nat qubesDB = @@ -72,7 +71,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> return () in (* Set up networking *) - Nat.empty clock >|= My_nat.create (module Nat) >>= fun nat -> + let get_time () = Clock.elapsed_ns clock in + My_nat.create ~get_time >>= fun nat -> let net_listener = network ~clock nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init ();