From 55b2f191963e28e2f5956f8ab6d495d9f9380d9d Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 16:58:08 +0200 Subject: [PATCH] add optional uplink interface --- config.ml | 24 +++++++++++++++++++++- dao.ml | 28 +++++++++++++++++-------- dao.mli | 4 ++++ firewall.ml | 14 ++++++++++--- my_dns.ml | 2 +- router.ml | 6 +++--- router.mli | 4 ++-- unikernel.ml | 27 ++++++++++++++++++++++-- uplink.ml | 58 ++++++++++++++++++++++++++++++---------------------- uplink.mli | 6 +++--- 10 files changed, 125 insertions(+), 48 deletions(-) diff --git a/config.ml b/config.ml index 314172f..53bf8e3 100644 --- a/config.ml +++ b/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"; diff --git a/dao.ml b/dao.ml index c6ba241..ade9662 100644 --- a/dao.ml +++ b/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 "@[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 "@[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" diff --git a/dao.mli b/dao.mli index df3c23b..780d82c 100644 --- a/dao.mli +++ b/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 diff --git a/firewall.ml b/firewall.ml index 06d32a4..ebe80dd 100644 --- a/firewall.ml +++ b/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 diff --git a/my_dns.ml b/my_dns.ml index 372c29a..33a0ed5 100644 --- a/my_dns.ml +++ b/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 diff --git a/router.ml b/router.ml index fbd7175..a8dc89d 100644 --- a/router.ml +++ b/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 diff --git a/router.mli b/router.mli index e17b7db..532c39e 100644 --- a/router.mli +++ b/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]. *) diff --git a/unikernel.ml b/unikernel.ml index d0e84cc..ce28b72 100644 --- a/unikernel.ml +++ b/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 diff --git a/uplink.ml b/uplink.ml index a7b0350..2f7ea5e 100644 --- a/uplink.ml +++ b/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 diff --git a/uplink.mli b/uplink.mli index f6edaaf..0d35e5e 100644 --- a/uplink.mli +++ b/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