Update to new mirage-nat API

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 *)
 

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)

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

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 ();