allow to have no netvm defined (will fail on uplink.connect)

client_eth.ml

@@ -10,7 +10,7 @@ module Log = (val Logs.src_log src : Logs.LOG)
 type t = {
   mutable iface_of_ip : client_link IpMap.t;
   changed : unit Lwt_condition.t;   (* Fires when [iface_of_ip] changes. *)
-  client_gw : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
+  my_ip : Ipaddr.V4.t;  (* The IP that clients are given as their default gateway. *)
 }
 
 type host =
@@ -18,11 +18,12 @@ type host =
   | `Firewall
   | `External of Ipaddr.t ]
 
-let create ~client_gw =
+let create config =
   let changed = Lwt_condition.create () in
-  { iface_of_ip = IpMap.empty; client_gw; changed }
+  let my_ip = config.Dao.uplink_our_ip in
+  Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed }
 
-let client_gw t = t.client_gw
+let client_gw t = t.my_ip
 
 let add_client t iface =
   let ip = iface#other_ip in
@@ -52,14 +53,14 @@ let classify t ip =
   match ip with
   | Ipaddr.V6 _ -> `External ip
   | Ipaddr.V4 ip4 ->
-    if ip4 = t.client_gw then `Firewall
+    if ip4 = t.my_ip then `Firewall
     else match lookup t ip4 with
       | Some client_link -> `Client client_link
       | None -> `External ip
 
 let resolve t : host -> Ipaddr.t = function
   | `Client client_link -> Ipaddr.V4 client_link#other_ip
-  | `Firewall -> Ipaddr.V4 t.client_gw
+  | `Firewall -> Ipaddr.V4 t.my_ip
   | `External addr -> addr
 
 module ARP = struct
@@ -69,7 +70,7 @@ module ARP = struct
   }
 
   let lookup t ip =
-    if ip = t.net.client_gw then Some t.client_link#my_mac
+    if ip = t.net.my_ip then Some t.client_link#my_mac
     else if (Ipaddr.V4.to_octets ip).[3] = '\x01' then (
       Log.info (fun f -> f ~header:t.client_link#log_header
                    "Request for %a is invalid, but pretending it's me (see Qubes issue #5022)" Ipaddr.V4.pp ip);

client_eth.mli

@@ -17,7 +17,7 @@ type host =
    disconnected client.
    See: https://github.com/talex5/qubes-mirage-firewall/issues/9#issuecomment-246956850 *)
 
-val create : client_gw:Ipaddr.V4.t -> t
+val create : Dao.network_config -> t Lwt.t
 (** [create ~client_gw] is a network of client machines.
     Qubes will have configured the client machines to use [client_gw] as their default gateway. *)
 

client_net.ml

@@ -80,7 +80,7 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~cl
   Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip));
   ClientEth.connect backend >>= fun eth ->
   let client_mac = Netback.frontend_mac backend in
-  let client_eth = router.Router.client_eth in
+  let client_eth = router.Router.clients in
   let gateway_ip = Client_eth.client_gw client_eth in
   let iface = new client_iface eth ~domid ~gateway_ip ~client_ip client_mac in
   (* update the rules whenever QubesDB notices a change for this IP *)

dao.ml

@@ -136,13 +136,13 @@ exception Missing_key of string
 let try_read_network_config db =
   let get name =
     match DB.KeyMap.find_opt name db with
-    | None -> raise (Missing_key name)
+    | None -> Ipaddr.V4.make 0 0 0 0
-    | Some value -> value in
+    | Some value -> Ipaddr.V4.of_string_exn value in
-  let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in
+  let uplink_our_ip = get "/qubes-ip" in
-  let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in
+  let uplink_netvm_ip = get "/qubes-gateway" in
-  let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in
+  let clients_our_ip = get "/qubes-netvm-gateway" in
-  let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in
+  let dns = get "/qubes-primary-dns" in
-  let dns2 = get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn in
+  let dns2 = get "/qubes-secondary-dns" in
   Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
                         NetVM IP on uplink network: %a@,\
                         Our IP on uplink network:   %a@,\

router.ml

@@ -6,29 +6,29 @@ open Fw_utils
 (* The routing table *)
 
 type t = {
-  client_eth : Client_eth.t;
+  clients : Client_eth.t;
   nat : My_nat.t;
   uplink : interface;
 }
 
-let create ~client_eth ~uplink ~nat =
+let create ~clients ~uplink ~nat =
-  { client_eth; nat; uplink }
+  { clients; nat; uplink }
 
 let target t buf =
   let dst_ip = buf.Ipv4_packet.dst in
-  match Client_eth.lookup t.client_eth dst_ip with
+  match Client_eth.lookup t.clients dst_ip with
   | Some client_link -> Some (client_link :> interface)
   | None -> Some t.uplink
 
-let add_client t = Client_eth.add_client t.client_eth
+let add_client t = Client_eth.add_client t.clients
-let remove_client t = Client_eth.remove_client t.client_eth
+let remove_client t = Client_eth.remove_client t.clients
 
 let classify t ip =
   if ip = Ipaddr.V4 t.uplink#my_ip then `Firewall
   else if ip = Ipaddr.V4 t.uplink#other_ip then `NetVM
-  else (Client_eth.classify t.client_eth ip :> Packet.host)
+  else (Client_eth.classify t.clients ip :> Packet.host)
 
 let resolve t = function
   | `Firewall -> Ipaddr.V4 t.uplink#my_ip
   | `NetVM -> Ipaddr.V4 t.uplink#other_ip
-  | #Client_eth.host as host -> Client_eth.resolve t.client_eth host
+  | #Client_eth.host as host -> Client_eth.resolve t.clients host

router.mli

@@ -6,13 +6,13 @@
 open Fw_utils
 
 type t = private {
-  client_eth : Client_eth.t;
+  clients : Client_eth.t;
   nat : My_nat.t;
   uplink : interface;
 }
 
 val create :
-  client_eth:Client_eth.t ->
+  clients:Client_eth.t ->
   uplink:interface ->
   nat:My_nat.t ->
   t

unikernel.ml

@@ -52,11 +52,10 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
 
     Uplink.connect config >>= fun uplink ->
     (* Set up client-side networking *)
-    let client_eth = Client_eth.create
+    Client_eth.create config >>= fun clients ->
-      ~client_gw:config.Dao.clients_our_ip in
     (* Set up routing between networks and hosts *)
     let router = Router.create
-      ~client_eth
+      ~clients
       ~uplink:(Uplink.interface uplink)
       ~nat
     in