add optional uplink interface

config.ml

@@ -13,9 +13,31 @@ let table_size =
   let key = Key.Arg.opt ~stage:`Both Key.Arg.int 5_000 info in
   Key.create "nat_table_size" key
 
+let ipv4 =
+  let doc = Key.Arg.info ~doc:"Manual IP setting." ["ipv4"] in
+  Key.(create "ipv4" Arg.(opt string "0.0.0.0" doc))
+
+let ipv4_gw =
+  let doc = Key.Arg.info ~doc:"Manual Gateway IP setting." ["ipv4-gw"] in
+  Key.(create "ipv4_gw" Arg.(opt string "0.0.0.0" doc))
+
+let ipv4_dns =
+  let doc = Key.Arg.info ~doc:"Manual DNS IP setting." ["ipv4-dns"] in
+  Key.(create "ipv4_dns" Arg.(opt string "10.139.0.1" doc))
+
+let ipv4_dns2 =
+  let doc = Key.Arg.info ~doc:"Manual Second DNS IP setting." ["ipv4-dns2"] in
+  Key.(create "ipv4_dns2" Arg.(opt string "10.139.0.2" doc))
+
 let main =
   foreign
-    ~keys:[Key.v table_size]
+    ~keys:[
+      Key.v table_size;
+      Key.v ipv4;
+      Key.v ipv4_gw;
+      Key.v ipv4_dns;
+      Key.v ipv4_dns2;
+    ]
     ~packages:[
       package "vchan" ~min:"4.0.2";
       package "cstruct";

dao.ml

@@ -140,15 +140,6 @@ let try_read_network_config db =
   let netvm_ip = get "/qubes-gateway" in (* - default gateway IP (only when VM has netvm set); VM should add host route to this address directly via eth0 (or whatever default interface name is) *)
   let dns = get "/qubes-primary-dns" 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 client networks:  %a@,\
-                        DNS primary resolver:       %a@,\
-                        DNS secondary resolver:     %a@]"
-               Ipaddr.V4.pp netvm_ip
-               Ipaddr.V4.pp our_ip
-               Ipaddr.V4.pp dns
-               Ipaddr.V4.pp dns2);
   { netvm_ip ; our_ip ; dns ; dns2 }
 
 let read_network_config qubesDB =
@@ -160,4 +151,23 @@ let read_network_config qubesDB =
   in
   aux (DB.bindings qubesDB)
 
+let print_network_config config =
+  Log.info (fun f -> f "@[<v2>Got network configuration from QubesDB:@,\
+                        NetVM IP on uplink network: %a@,\
+                        Our IP on client networks:  %a@,\
+                        DNS primary resolver:       %a@,\
+                        DNS secondary resolver:     %a@]"
+               Ipaddr.V4.pp config.netvm_ip
+               Ipaddr.V4.pp config.our_ip
+               Ipaddr.V4.pp config.dns
+               Ipaddr.V4.pp config.dns2)
+
+let update_network_config config update_config =
+  let zero_ip = Ipaddr.V4.make 0 0 0 0 in
+  let netvm_ip = if config.netvm_ip = zero_ip then update_config.netvm_ip else config.netvm_ip in
+  let our_ip = if config.our_ip = zero_ip then update_config.our_ip else config.our_ip in
+  let dns = if config.dns = zero_ip then update_config.dns else config.dns in
+  let dns2 = if config.dns2 = zero_ip then update_config.dns2 else config.dns2 in
+  Lwt.return { netvm_ip ; our_ip ; dns ; dns2 }
+
 let set_iptables_error db = Qubes.DB.write db "/qubes-iptables-error"

dao.mli

@@ -37,4 +37,8 @@ val read_rules : string Qubes.DB.KeyMap.t -> Ipaddr.V4.t -> Pf_qubes.Parse_qubes
 (** [read_rules bindings ip] extracts firewall rule information for [ip] from [bindings].
     If any rules fail to parse, it will return only one rule denying all traffic. *)
 
+val update_network_config : network_config -> network_config -> network_config Lwt.t
+
+val print_network_config : network_config -> unit
+
 val set_iptables_error : Qubes.DB.t -> string -> unit Lwt.t

firewall.ml

@@ -46,7 +46,7 @@ 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 open Router in
-  let xl_host = t.uplink#my_ip in
+  let xl_host = t.config.our_ip in
   match My_nat.add_nat_rule_and_translate t.nat ~xl_host `NAT packet with
   | Ok packet -> forward_ipv4 t packet
   | Error e ->
@@ -59,7 +59,7 @@ let nat_to t ~host ~port packet =
   match resolve t host with
   | 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
+    let xl_host = t.config.our_ip in
     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 ->
@@ -71,7 +71,15 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot
   rules annotated_packet >>= fun action ->
   match action, dst with
   | `Accept, `Client client_link -> transmit_ipv4 packet client_link
-  | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink
+  | `Accept, (`External _ | `NetVM) -> 
+    begin match t.Router.uplink with
+    | Some uplink -> transmit_ipv4 packet uplink
+    | None -> begin match Client_eth.lookup t.clients t.config.netvm_ip with
+      | Some iface -> transmit_ipv4 packet iface
+      | None -> Log.warn (fun f -> f "No output interface for %a : drop" Nat_packet.pp packet);
+        Lwt.return_unit
+      end
+    end
   | `Accept, `Firewall ->
       Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet);
       Lwt.return_unit

my_dns.ml

@@ -52,7 +52,7 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_
     let dst, dst_port = ctx.nameserver in
     let router, send_udp, _ = ctx.stack in
     let src_port, evict =
-      My_nat.free_udp_port router.nat ~src:router.uplink#my_ip ~dst ~dst_port:53
+      My_nat.free_udp_port router.nat ~src:router.config.our_ip ~dst ~dst_port:53
     in
     let id = Cstruct.BE.get_uint16 buf 0 in
     with_timeout ctx.timeout_ns

router.ml

@@ -9,17 +9,17 @@ type t = {
   config : Dao.network_config;
   clients : Client_eth.t;
   nat : My_nat.t;
-  uplink : interface;
+  uplink : interface option;
 }
 
-let create ~config ~clients ~uplink ~nat =
+let create ~config ~clients ~nat ?uplink =
   { config; clients; nat; uplink }
 
 let target t buf =
   let dst_ip = buf.Ipv4_packet.dst in
   match Client_eth.lookup t.clients dst_ip with
   | Some client_link -> Some (client_link :> interface)
-  | None -> Some t.uplink
+  | None -> t.uplink
 
 let add_client t = Client_eth.add_client t.clients
 let remove_client t = Client_eth.remove_client t.clients

router.mli

@@ -9,14 +9,14 @@ type t = private {
   config : Dao.network_config;
   clients : Client_eth.t;
   nat : My_nat.t;
-  uplink : interface;
+  uplink : interface option;
 }
 
 val create :
   config : Dao.network_config ->
   clients : Client_eth.t ->
-  uplink : interface ->
   nat : My_nat.t ->
+  ?uplink : interface ->
   t
 (** [create ~client_eth ~uplink ~nat] is a new routing table
     that routes packets outside of [client_eth] via [uplink]. *)

unikernel.ml

@@ -49,16 +49,39 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim
 
     (* Read network configuration from QubesDB *)
     Dao.read_network_config qubesDB >>= fun config ->
+    (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *)
 
-    Uplink.connect config >>= fun uplink ->
     (* Set up client-side networking *)
     Client_eth.create config >>= fun clients ->
+
+    let connect_if_netvm = 
+      if config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0) then (
+        Uplink.connect config >>= fun uplink ->
+        Lwt.return (config, Some uplink)
+      ) else (
+      (* If we have no netvm IP address we must not try to Uplink.connect and we can update the config
+         with command option (if any) *)
+        let netvm_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4_gw ()) in
+        let our_ip = Ipaddr.V4.of_string_exn (Key_gen.ipv4 ()) in
+        let dns = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns ()) in
+        let dns2 = Ipaddr.V4.of_string_exn (Key_gen.ipv4_dns2 ()) in
+        let default_config:Dao.network_config = {netvm_ip; our_ip; dns; dns2} in
+        Dao.update_network_config config default_config >>= fun config ->
+        Lwt.return (config, None)
+      )
+    in
+    connect_if_netvm >>= fun (config, uplink) ->
+
+    (* We now must have a valid netvm IP address or crash *)
+    Dao.print_network_config config ;
+    assert(config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0));
+
     (* Set up routing between networks and hosts *)
     let router = Router.create
       ~config
       ~clients
-      ~uplink:(Uplink.interface uplink)
       ~nat
+      ?uplink:(Uplink.interface uplink)
     in
 
     let send_dns_query = Uplink.send_dns_client_query uplink in

uplink.ml

@@ -34,9 +34,13 @@ class netvm_iface eth mac ~my_ip ~other_ip : interface = object
 end
 
   let send_dns_client_query t ~src_port ~dst ~dst_port buf =
-    U.write ~src_port ~dst ~dst_port t.udp buf >|= function
-    | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
-    | Ok () -> Ok ()
+    match t with
+    | None ->
+      Log.err (fun f -> f "No uplink interface"); Lwt.return (Error (`Msg "failure"))
+    | Some t ->
+      U.write ~src_port ~dst ~dst_port t.udp buf >|= function
+      | Error s -> Log.err (fun f -> f "error sending udp packet: %a" U.pp_error s); Error (`Msg "failure")
+      | Ok () -> Ok ()
 
   let listen t get_ts dns_responses router =
     let handle_packet ip_header ip_packet =
@@ -50,28 +54,34 @@ end
       | _ ->
         Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet))
     in
-    Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame ->
-        (* Handle one Ethernet frame from NetVM *)
-        Eth.input t.eth
-        ~arpv4:(Arp.input t.arp)
-        ~ipv4:(fun ip ->
-            let cache, r =
-              Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip
-            in
-            t.fragments <- cache;
-            match r with
-              | Error e ->
-                Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
-                Lwt.return ()
-              | Ok None -> Lwt.return_unit
-              | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
-            )
-        ~ipv6:(fun _ip -> Lwt.return_unit)
-        frame
-    ) >|= or_raise "Uplink listen loop" Netif.pp_error
+    begin match t with
+    | None -> Lwt.return_unit
+    | Some t ->
+      Netif.listen t.net ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame ->
+          (* Handle one Ethernet frame from NetVM *)
+          Eth.input t.eth
+          ~arpv4:(Arp.input t.arp)
+          ~ipv4:(fun ip ->
+              let cache, r =
+                Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip
+              in
+              t.fragments <- cache;
+              match r with
+                | Error e ->
+                  Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e);
+                  Lwt.return ()
+                | Ok None -> Lwt.return_unit
+                | Ok (Some (`IPv4 (header, packet))) -> handle_packet header packet
+              )
+          ~ipv6:(fun _ip -> Lwt.return_unit)
+          frame
+      ) >|= or_raise "Uplink listen loop" Netif.pp_error
+   end
 
-
-let interface t = t.interface
+let interface t =
+  match t with
+  | None -> None
+  | Some t -> Some t.interface
 
 let connect config =
   let my_ip = config.Dao.our_ip in

uplink.mli

@@ -11,11 +11,11 @@ module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time
   val connect : Dao.network_config -> t Lwt.t
   (** Connect to our NetVM (gateway). *)
 
-  val interface : t -> interface
+  val interface : t option -> interface option
   (** The network interface to NetVM. *)
 
-  val listen : t -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
+  val listen : t option -> (unit -> int64) -> (Udp_packet.t * Cstruct.t) Lwt_mvar.t -> Router.t -> unit Lwt.t
   (** Handle incoming frames from NetVM. *)
 
-  val send_dns_client_query: t -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t
+  val send_dns_client_query: t option -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t
 end