From 9cabe7e303aa0eaafb72303bc8bbaa7df34e8d7d Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 13:59:03 +0200 Subject: [PATCH 01/12] allow to have no netvm defined (will fail on uplink.connect) --- client_eth.ml | 15 ++++++++------- client_eth.mli | 2 +- client_net.ml | 2 +- dao.ml | 14 +++++++------- router.ml | 16 ++++++++-------- router.mli | 4 ++-- unikernel.ml | 5 ++--- 7 files changed, 29 insertions(+), 29 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index 10c84d1..45337b2 100644 --- a/client_eth.ml +++ b/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); diff --git a/client_eth.mli b/client_eth.mli index 2bbb672..02ccee9 100644 --- a/client_eth.mli +++ b/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. *) diff --git a/client_net.ml b/client_net.ml index b9b74fe..6e46327 100644 --- a/client_net.ml +++ b/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 *) diff --git a/dao.ml b/dao.ml index 1c3785e..d5bfffa 100644 --- a/dao.ml +++ b/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) - | Some value -> value in - let uplink_our_ip = get "/qubes-ip" |> Ipaddr.V4.of_string_exn in - let uplink_netvm_ip = get "/qubes-gateway" |> Ipaddr.V4.of_string_exn in - let clients_our_ip = get "/qubes-netvm-gateway" |> Ipaddr.V4.of_string_exn in - let dns = get "/qubes-primary-dns" |> Ipaddr.V4.of_string_exn in - let dns2 = get "/qubes-secondary-dns" |> Ipaddr.V4.of_string_exn in + | None -> Ipaddr.V4.make 0 0 0 0 + | Some value -> Ipaddr.V4.of_string_exn value in + let uplink_our_ip = get "/qubes-ip" in + let uplink_netvm_ip = get "/qubes-gateway" in + let clients_our_ip = get "/qubes-netvm-gateway" in + 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 uplink network: %a@,\ diff --git a/router.ml b/router.ml index 4d7ed90..1e18005 100644 --- a/router.ml +++ b/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 = - { client_eth; nat; uplink } +let create ~clients ~uplink ~nat = + { 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 remove_client t = Client_eth.remove_client t.client_eth +let add_client t = Client_eth.add_client t.clients +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 diff --git a/router.mli b/router.mli index 34fa86b..515277e 100644 --- a/router.mli +++ b/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 diff --git a/unikernel.ml b/unikernel.ml index 65f7b3a..c065f94 100644 --- a/unikernel.ml +++ b/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_gw:config.Dao.clients_our_ip in + Client_eth.create config >>= fun clients -> (* Set up routing between networks and hosts *) let router = Router.create - ~client_eth + ~clients ~uplink:(Uplink.interface uplink) ~nat in From 5a0711bb2db3e39456c50b11f8b98f5424c4da45 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 15:31:30 +0200 Subject: [PATCH 02/12] in Qubes doc client_our_ip is always netvm_our_ip --- client_eth.ml | 2 +- dao.ml | 19 +++++++------------ dao.mli | 6 ++---- uplink.ml | 6 +++--- 4 files changed, 13 insertions(+), 20 deletions(-) diff --git a/client_eth.ml b/client_eth.ml index 45337b2..de41f70 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -20,7 +20,7 @@ type host = let create config = let changed = Lwt_condition.create () in - let my_ip = config.Dao.uplink_our_ip in + let my_ip = config.Dao.our_ip in Lwt.return { iface_of_ip = IpMap.empty; my_ip; changed } let client_gw t = t.my_ip diff --git a/dao.ml b/dao.ml index d5bfffa..c6ba241 100644 --- a/dao.ml +++ b/dao.ml @@ -123,10 +123,8 @@ let watch_clients fn = ) type network_config = { - uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) - - clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } @@ -138,23 +136,20 @@ let try_read_network_config db = match DB.KeyMap.find_opt name db with | None -> Ipaddr.V4.make 0 0 0 0 | Some value -> Ipaddr.V4.of_string_exn value in - let uplink_our_ip = get "/qubes-ip" in - let uplink_netvm_ip = get "/qubes-gateway" in - let clients_our_ip = get "/qubes-netvm-gateway" in + let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *) + 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 uplink network: %a@,\ Our IP on client networks: %a@,\ DNS primary resolver: %a@,\ DNS secondary resolver: %a@]" - Ipaddr.V4.pp uplink_netvm_ip - Ipaddr.V4.pp uplink_our_ip - Ipaddr.V4.pp clients_our_ip + Ipaddr.V4.pp netvm_ip + Ipaddr.V4.pp our_ip Ipaddr.V4.pp dns Ipaddr.V4.pp dns2); - { uplink_netvm_ip; uplink_our_ip; clients_our_ip ; dns ; dns2 } + { netvm_ip ; our_ip ; dns ; dns2 } let read_network_config qubesDB = let rec aux bindings = diff --git a/dao.mli b/dao.mli index 2b3d97a..df3c23b 100644 --- a/dao.mli +++ b/dao.mli @@ -20,10 +20,8 @@ val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t in XenStore, and again each time XenStore updates. *) type network_config = { - uplink_netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) - uplink_our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) - - clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) + netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) + our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; dns2 : Ipaddr.V4.t; } diff --git a/uplink.ml b/uplink.ml index b74d1df..a7b0350 100644 --- a/uplink.ml +++ b/uplink.ml @@ -74,8 +74,8 @@ end let interface t = t.interface let connect config = - let my_ip = config.Dao.uplink_our_ip in - let gateway = config.Dao.uplink_netvm_ip in + let my_ip = config.Dao.our_ip in + let gateway = config.Dao.netvm_ip in Netif.connect "0" >>= fun net -> Eth.connect net >>= fun eth -> Arp.connect eth >>= fun arp -> @@ -88,7 +88,7 @@ let connect config = >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in let interface = new netvm_iface eth netvm_mac ~my_ip - ~other_ip:config.Dao.uplink_netvm_ip in + ~other_ip:config.Dao.netvm_ip in let fragments = Fragments.Cache.empty (256 * 1024) in Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp } end From de9a1dbd1c7bc9a82762c38b50d8cddd715a3566 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 15:33:41 +0200 Subject: [PATCH 03/12] add the network_config to the router --- router.ml | 13 +++++++------ router.mli | 8 +++++--- unikernel.ml | 1 + 3 files changed, 13 insertions(+), 9 deletions(-) diff --git a/router.ml b/router.ml index 1e18005..fbd7175 100644 --- a/router.ml +++ b/router.ml @@ -6,13 +6,14 @@ open Fw_utils (* The routing table *) type t = { + config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; uplink : interface; } -let create ~clients ~uplink ~nat = - { clients; nat; uplink } +let create ~config ~clients ~uplink ~nat = + { config; clients; nat; uplink } let target t buf = let dst_ip = buf.Ipv4_packet.dst in @@ -24,11 +25,11 @@ let add_client t = Client_eth.add_client t.clients 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 + if ip = Ipaddr.V4 t.config.our_ip then `Firewall + else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM 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 + | `Firewall -> Ipaddr.V4 t.config.our_ip + | `NetVM -> Ipaddr.V4 t.config.netvm_ip | #Client_eth.host as host -> Client_eth.resolve t.clients host diff --git a/router.mli b/router.mli index 515277e..e17b7db 100644 --- a/router.mli +++ b/router.mli @@ -6,15 +6,17 @@ open Fw_utils type t = private { + config : Dao.network_config; clients : Client_eth.t; nat : My_nat.t; uplink : interface; } val create : - clients:Client_eth.t -> - uplink:interface -> - nat:My_nat.t -> + config : Dao.network_config -> + clients : Client_eth.t -> + uplink : interface -> + nat : My_nat.t -> 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 c065f94..d0e84cc 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -55,6 +55,7 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Client_eth.create config >>= fun clients -> (* Set up routing between networks and hosts *) let router = Router.create + ~config ~clients ~uplink:(Uplink.interface uplink) ~nat From 55b2f191963e28e2f5956f8ab6d495d9f9380d9d Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 16:58:08 +0200 Subject: [PATCH 04/12] 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 From fe99021dc05cf43bcaef2db23b1463d5686312f6 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 17:06:17 +0200 Subject: [PATCH 05/12] add minimal README information about using mirage-firewall without netvm --- README.md | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/README.md b/README.md index a24f6cd..0dc963d 100644 --- a/README.md +++ b/README.md @@ -109,6 +109,17 @@ https://www.qubes-os.org/doc/software-update-dom0/ says: > there are no significant security implications in this choice. By default, > this role is assigned to the firewallvm. +### Configure firewall with OpenBSD-like netvm + +OpenBSD is currently unable to be used as netvm, so if you want to use a BSD as your sys-net VM, you'll need to set its netvm to qubes-mirage-firewall (see https://github.com/mirage/qubes-mirage-firewall/issues/146 for more information). +That means you'll have `AppVMs -> qubes-mirage-firewall <- OpenBSD` with the arrow standing for the netvm property setting. + +In that case you'll have to tell qubes-mirage-firewall which AppVM client should be used as uplink: +``` +qvm-prefs --set mirage-firewall -- kernelopts '--ipv4=X.X.X.X --ipv4-gw=Y.Y.Y.Y' +``` +with `X.X.X.X` the IP address for mirage-firewall and `Y.Y.Y.Y` the IP address of your OpenBSD HVM. + ### Components This diagram show the main components (each box corresponds to a source `.ml` file with the same name): From e5349c22a7f3c6e7db678098b2aaf7abe0de7c83 Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 17:13:56 +0200 Subject: [PATCH 06/12] do not stop the unikernel if netvm is None --- unikernel.ml | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index ce28b72..708fe53 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -17,10 +17,13 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) - Lwt.choose [ - Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router; - Uplink.listen uplink Clock.elapsed_ns dns_responses router - ] + match uplink with + | None -> Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router + | _ -> + Lwt.choose [ + Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router; + Uplink.listen uplink Clock.elapsed_ns dns_responses router + ] (* Main unikernel entry point (called from auto-generated main.ml). *) let start _random _clock _time = From e99e80b1508248c1c122a1962b5d0753a23fd6fa Mon Sep 17 00:00:00 2001 From: palainp Date: Fri, 30 Jun 2023 17:57:08 +0200 Subject: [PATCH 07/12] only set clients when we have a correct netvm IP address --- unikernel.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 708fe53..227e75a 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -54,9 +54,6 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Dao.read_network_config qubesDB >>= fun config -> (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *) - (* 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 -> @@ -79,6 +76,9 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Dao.print_network_config config ; assert(config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0)); + (* Set up client-side networking *) + Client_eth.create config >>= fun clients -> + (* Set up routing between networks and hosts *) let router = Router.create ~config From 7f5729a12d5b0ab0a3d0f995b22d9ad69ff37f7f Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 10:46:55 +0200 Subject: [PATCH 08/12] prevent usage of both command line options and netvm property --- unikernel.ml | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 227e75a..fe602e2 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -54,27 +54,33 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim Dao.read_network_config qubesDB >>= fun config -> (* config.netvm_ip might be 0.0.0.0 if there's no netvm provided via Qubes *) + let zero_ip = (Ipaddr.V4.make 0 0 0 0) in + let connect_if_netvm = - if config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0) then ( + 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 + + if config.netvm_ip <> zero_ip then ( + if (netvm_ip <> zero_ip || our_ip <> zero_ip) then begin + Log.err (fun f -> f "You must not specify --ipv4 or --ipv4-gw when using the netvm property: discard command line options") + end ; 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 *) + (* We now must have a valid netvm IP address and our IP address or crash *) Dao.print_network_config config ; - assert(config.netvm_ip <> (Ipaddr.V4.make 0 0 0 0)); + assert(config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); (* Set up client-side networking *) Client_eth.create config >>= fun clients -> From ee2409dc6134bc8ce15dd923b756ef467786efdb Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 11:56:14 +0200 Subject: [PATCH 09/12] fallback to the command line specified uplink interface if no netvm interface --- firewall.ml | 37 ++++++++++++++++++++++--------------- router.ml | 11 ++++++++++- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/firewall.ml b/firewall.ml index ebe80dd..3bf0e6f 100644 --- a/firewall.ml +++ b/firewall.ml @@ -91,21 +91,6 @@ let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annot Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); Lwt.return_unit -let ipv4_from_client resolver dns_servers t ~src packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> - (* Check for existing NAT entry for this packet *) - match translate t packet with - | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> - (* No existing NAT entry. Check the firewall rules. *) - let `IPv4 (ip, _transport) = packet in - let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match of_mirage_nat_packet ~src:(`Client src) ~dst packet with - | None -> Lwt.return_unit - | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet - let ipv4_from_netvm t packet = match Memory_pressure.status () with | `Memory_critical -> Lwt.return_unit @@ -127,3 +112,25 @@ let ipv4_from_netvm t packet = match Packet.of_mirage_nat_packet ~src ~dst packet with | None -> Lwt.return_unit | Some packet -> apply_rules t Rules.from_netvm ~dst packet + +let ipv4_from_client resolver dns_servers t ~src packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> + (* Check for existing NAT entry for this packet *) + match translate t packet with + | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> + (* No existing NAT entry. Check the firewall rules. *) + let `IPv4 (ip, _transport) = packet in + match Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) with + | `Client _ | `Firewall -> ( + let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match of_mirage_nat_packet ~src:(`Client src) ~dst packet with + | None -> Lwt.return_unit + | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet + ) + | `NetVM -> ipv4_from_netvm t packet + | `External _ -> + Log.warn (fun f -> f "Frame from Inside has external source IP address! %a" Nat_packet.pp packet); + Lwt.return_unit diff --git a/router.ml b/router.ml index a8dc89d..3ca586a 100644 --- a/router.ml +++ b/router.ml @@ -4,6 +4,8 @@ open Fw_utils (* The routing table *) +let src = Logs.Src.create "router" ~doc:"Packet router" +module Log = (val Logs.src_log src : Logs.LOG) type t = { config : Dao.network_config; @@ -19,7 +21,14 @@ 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 -> t.uplink + | None -> begin match t.uplink with + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some uplink -> Some (uplink :> interface) + | None -> None + ) + | uplink -> uplink + end let add_client t = Client_eth.add_client t.clients let remove_client t = Client_eth.remove_client t.clients From 95812a7458018c03fc3552d9ef0c38639974676b Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 16:49:07 +0200 Subject: [PATCH 10/12] fix default DNS addresses --- config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/config.ml b/config.ml index 53bf8e3..e3eb2ad 100644 --- a/config.ml +++ b/config.ml @@ -23,11 +23,11 @@ let ipv4_gw = 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)) + Key.(create "ipv4_dns" Arg.(opt string "10.139.1.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)) + Key.(create "ipv4_dns2" Arg.(opt string "10.139.1.2" doc)) let main = foreign From e055f810c7744f761184cf852f72ff817ec5a5d2 Mon Sep 17 00:00:00 2001 From: palainp Date: Sat, 1 Jul 2023 17:26:34 +0200 Subject: [PATCH 11/12] update hashsum --- build-with-docker.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 7cd77a6..65f6867 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,5 +5,5 @@ docker build -t qubes-mirage-firewall . echo Building Firewall... docker run --rm -i -v `pwd`:/tmp/orb-build qubes-mirage-firewall echo "SHA2 of build: $(sha256sum ./dist/qubes-firewall.xen)" -echo "SHA2 last known: 55a2f823d66473c7d0be66a93289d48b6557f18c9257c6f98aa5a4583663d3c2" +echo "SHA2 last known: 1f621d3bde2cf2905b5ad333f7dbde9ef99479251118e1a1da9b4da15957a87d" echo "(hashes should match for released versions)" From 764e95e5be9d49c3ff0617a1b1417a34dee4647c Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 5 Jul 2023 11:56:19 +0200 Subject: [PATCH 12/12] WIP: - merge router+uplink+client_net+firewall into a single dispatcher file - watch qubesDB for netvm update - dynamic netvm should works - without netvm (but command line options) forward packet to a client, and warn the user if the "netvm" is not connected - apply ocamlformat --- client_net.ml | 167 --------------- client_net.mli | 12 -- dao.ml | 13 +- dao.mli | 3 +- dispatcher.ml | 550 +++++++++++++++++++++++++++++++++++++++++++++++++ firewall.ml | 136 ------------ firewall.mli | 13 -- my_dns.ml | 4 +- router.ml | 44 ---- router.mli | 33 --- unikernel.ml | 68 +++--- uplink.ml | 104 ---------- uplink.mli | 21 -- 13 files changed, 585 insertions(+), 583 deletions(-) delete mode 100644 client_net.ml delete mode 100644 client_net.mli create mode 100644 dispatcher.ml delete mode 100644 firewall.ml delete mode 100644 firewall.mli delete mode 100644 router.ml delete mode 100644 router.mli delete mode 100644 uplink.ml delete mode 100644 uplink.mli diff --git a/client_net.ml b/client_net.ml deleted file mode 100644 index 6e46327..0000000 --- a/client_net.ml +++ /dev/null @@ -1,167 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Lwt.Infix -open Fw_utils - -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Xen_os.Xs)) -module ClientEth = Ethernet.Make(Netback) - -let src = Logs.Src.create "client_net" ~doc:"Client networking" -module Log = (val Logs.src_log src : Logs.LOG) - -let writev eth dst proto fillfn = - Lwt.catch - (fun () -> - ClientEth.write eth dst proto fillfn >|= function - | Ok () -> () - | Error e -> - Log.err (fun f -> f "error trying to send to client: @[%a@]" - ClientEth.pp_error e); - ) - (fun ex -> - (* Usually Netback_shutdown, because the client disconnected *) - Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]" - (Printexc.to_string ex)); - Lwt.return_unit - ) - -class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = - let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in - object - val mutable rules = [] - method get_rules = rules - method set_rules new_db = rules <- Dao.read_rules new_db client_ip - method my_mac = ClientEth.mac eth - method other_mac = client_mac - method my_ip = gateway_ip - method other_ip = client_ip - method writev proto fillfn = - writev eth client_mac proto fillfn - method log_header = log_header - end - -let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty - -(** Handle an ARP message from the client. *) -let input_arp ~fixed_arp ~iface request = - match Arp_packet.decode request with - | Error e -> - Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); - Lwt.return_unit - | Ok arp -> - match Client_eth.ARP.input fixed_arp arp with - | None -> Lwt.return_unit - | Some response -> - iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size) - -(** Handle an IPv4 packet from the client. *) -let input_ipv4 get_ts cache ~iface ~router dns_client dns_servers packet = - let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in - cache := cache'; - match r with - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | Ok (Some packet) -> - let `IPv4 (ip, _) = packet in - let src = ip.Ipv4_packet.src in - if src = iface#other_ip then Firewall.ipv4_from_client dns_client dns_servers router ~src:iface packet - else ( - Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" - Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); - Lwt.return_unit - ) - -(** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) -let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB = - Netback.make ~domid ~device_id >>= fun backend -> - 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.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 *) - let qubesdb_updater = - Lwt.catch - (fun () -> - let rec update current_db current_rules = - Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db >>= fun new_db -> - iface#set_rules new_db; - let new_rules = iface#get_rules in - (if current_rules = new_rules then - Log.debug (fun m -> m "Rules did not change for %s" (Ipaddr.V4.to_string client_ip)) - else begin - Log.debug (fun m -> m "New firewall rules for %s@.%a" - (Ipaddr.V4.to_string client_ip) - Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) new_rules); - (* empty NAT table if rules are updated: they might deny old connections *) - My_nat.remove_connections router.Router.nat client_ip; - end); - update new_db new_rules - in - update Qubes.DB.KeyMap.empty []) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); - Router.add_client router iface >>= fun () -> - Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); - let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in - let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in - let listener = - Lwt.catch - (fun () -> - Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet (fun frame -> - match Ethernet.Packet.of_cstruct frame with - | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit - | Ok (eth, payload) -> - match eth.Ethernet.Packet.ethertype with - | `ARP -> input_arp ~fixed_arp ~iface payload - | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router dns_client dns_servers payload - | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) - ) - >|= or_raise "Listen on client interface" Netback.pp_error) - (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) - in - Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); - Lwt.pick [ qubesdb_updater ; listener ] - -(** A new client VM has been found in XenStore. Find its interface and connect to it. *) -let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = - let cleanup_tasks = Cleanup.create () in - Log.info (fun f -> f "add client vif %a with IP %a" - Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); - Lwt.async (fun () -> - Lwt.catch (fun () -> - add_vif get_ts vif dns_client dns_servers ~client_ip ~router ~cleanup_tasks qubesDB - ) - (fun ex -> - Log.warn (fun f -> f "Error with client %a: %s" - Dao.ClientVif.pp vif (Printexc.to_string ex)); - Lwt.return_unit - ) - ); - cleanup_tasks - -(** Watch XenStore for notifications of new clients. *) -let listen get_ts dns_client dns_servers qubesDB router = - Dao.watch_clients (fun new_set -> - (* Check for removed clients *) - !clients |> Dao.VifMap.iter (fun key cleanup -> - if not (Dao.VifMap.mem key new_set) then ( - clients := !clients |> Dao.VifMap.remove key; - Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); - Cleanup.cleanup cleanup - ) - ); - (* Check for added clients *) - new_set |> Dao.VifMap.iter (fun key ip_addr -> - if not (Dao.VifMap.mem key !clients) then ( - let cleanup = add_client get_ts dns_client dns_servers ~router key ip_addr qubesDB in - Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); - clients := !clients |> Dao.VifMap.add key cleanup - ) - ) - ) diff --git a/client_net.mli b/client_net.mli deleted file mode 100644 index e6254a6..0000000 --- a/client_net.mli +++ /dev/null @@ -1,12 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** Handling client VMs. *) - -val listen : (unit -> int64) -> - ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) -> - Ipaddr.V4.t list -> Qubes.DB.t -> Router.t -> 'a Lwt.t -(** [listen get_timestamp resolver dns_servers db router] is a thread that watches for clients being added to and - removed from XenStore. Clients are connected to the client network and - packets are sent via [router]. We ensure the source IP address is correct - before routing a packet. *) diff --git a/dao.ml b/dao.ml index ade9662..5c81543 100644 --- a/dao.ml +++ b/dao.ml @@ -123,6 +123,7 @@ let watch_clients fn = ) type network_config = { + from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; @@ -134,13 +135,13 @@ exception Missing_key of string let try_read_network_config db = let get name = match DB.KeyMap.find_opt name db with - | None -> Ipaddr.V4.make 0 0 0 0 + | None -> raise (Missing_key name) | Some value -> Ipaddr.V4.of_string_exn value in let our_ip = get "/qubes-ip" in (* - IP address for this VM (only when VM has netvm set) *) 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 - { netvm_ip ; our_ip ; dns ; dns2 } + { from_cmdline=false; netvm_ip ; our_ip ; dns ; dns2 } let read_network_config qubesDB = let rec aux bindings = @@ -162,12 +163,4 @@ let print_network_config config = 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 780d82c..bff4cbf 100644 --- a/dao.mli +++ b/dao.mli @@ -20,6 +20,7 @@ val watch_clients : (Ipaddr.V4.t VifMap.t -> unit) -> 'a Lwt.t in XenStore, and again each time XenStore updates. *) type network_config = { + from_cmdline : bool; (* Specify if we have network configuration from command line or from qubesDB*) netvm_ip : Ipaddr.V4.t; (* The IP address of NetVM (our gateway) *) our_ip : Ipaddr.V4.t; (* The IP address of our interface to NetVM *) dns : Ipaddr.V4.t; @@ -37,8 +38,6 @@ 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/dispatcher.ml b/dispatcher.ml new file mode 100644 index 0000000..19f829a --- /dev/null +++ b/dispatcher.ml @@ -0,0 +1,550 @@ +open Lwt.Infix +open Fw_utils +module Netback = Netchannel.Backend.Make (Netchannel.Xenstore.Make (Xen_os.Xs)) +module ClientEth = Ethernet.Make (Netback) +module UplinkEth = Ethernet.Make (Netif) + +let src = Logs.Src.create "dispatcher" ~doc:"Networking dispatch" + +module Log = (val Logs.src_log src : Logs.LOG) + +module Make + (R : Mirage_random.S) + (Clock : Mirage_clock.MCLOCK) + (Time : Mirage_time.S) = +struct + module Arp = Arp.Make (UplinkEth) (Time) + module I = Static_ipv4.Make (R) (Clock) (UplinkEth) (Arp) + module U = Udp.Make (I) (R) + + let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty + + class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link + = + let log_header = Fmt.str "dom%d:%a" domid Ipaddr.V4.pp client_ip in + object + val mutable rules = [] + method get_rules = rules + method set_rules new_db = rules <- Dao.read_rules new_db client_ip + method my_mac = ClientEth.mac eth + method other_mac = client_mac + method my_ip = gateway_ip + method other_ip = client_ip + + method writev proto fillfn = + Lwt.catch + (fun () -> + ClientEth.write eth client_mac proto fillfn >|= function + | Ok () -> () + | Error e -> + Log.err (fun f -> + f "error trying to send to client: @[%a@]" + ClientEth.pp_error e)) + (fun ex -> + (* Usually Netback_shutdown, because the client disconnected *) + Log.err (fun f -> + f "uncaught exception trying to send to client: @[%s@]" + (Printexc.to_string ex)); + Lwt.return_unit) + + method log_header = log_header + end + + class netvm_iface eth mac ~my_ip ~other_ip : interface = + object + method my_mac = UplinkEth.mac eth + method my_ip = my_ip + method other_ip = other_ip + + method writev ethertype fillfn = + mac >>= fun dst -> + UplinkEth.write eth dst ethertype fillfn + >|= or_raise "Write to uplink" UplinkEth.pp_error + end + + type uplink = { + net : Netif.t; + eth : UplinkEth.t; + arp : Arp.t; + interface : interface; + mutable fragments : Fragments.Cache.t; + ip : I.t; + udp : U.t; + } + + type t = { + uplink_wait_config : unit Lwt_condition.t; + mutable config : Dao.network_config; + clients : Client_eth.t; + nat : My_nat.t; + mutable uplink : uplink option; + } + + let create ~config ~clients ~nat ?uplink = + { + uplink_wait_config = Lwt_condition.create (); + config; + clients; + nat; + uplink; + } + + let update t ~config ?uplink = + t.config <- config; + t.uplink <- uplink; + Lwt.return_unit + + 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 -> ( (* if dest is not a client, transfer it to our uplink *) + match t.uplink with + | None -> ( + match Client_eth.lookup t.clients t.config.netvm_ip with + | Some uplink -> + Some (uplink :> interface) + | None -> + Log.err (fun f -> f "We have a command line configuration %a but it's currently not connected to us (please check its netvm property)...%!" Ipaddr.V4.pp t.config.netvm_ip); + None) + | Some uplink -> Some uplink.interface) + + let add_client t = Client_eth.add_client t.clients + let remove_client t = Client_eth.remove_client t.clients + + let classify t ip = + if ip = Ipaddr.V4 t.config.our_ip then `Firewall + else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM + else (Client_eth.classify t.clients ip :> Packet.host) + + let resolve t = function + | `Firewall -> Ipaddr.V4 t.config.our_ip + | `NetVM -> Ipaddr.V4 t.config.netvm_ip + | #Client_eth.host as host -> Client_eth.resolve t.clients host + + (* Transmission *) + + let transmit_ipv4 packet iface = + Lwt.catch + (fun () -> + let fragments = ref [] in + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> + f "Failed to write packet to %a: %a" Ipaddr.V4.pp + iface#other_ip Nat_packet.pp_error e); + 0 + | Ok (n, frags) -> + fragments := frags; + n) + >>= fun () -> + Lwt_list.iter_s + (fun f -> + let size = Cstruct.length f in + iface#writev `IPv4 (fun b -> + Cstruct.blit f 0 b 0 size; + size)) + !fragments) + (fun ex -> + Log.warn (fun f -> + f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); + Lwt.return_unit) + + let forward_ipv4 t packet = + let (`IPv4 (ip, _)) = packet in + match target t ip with + | Some iface -> transmit_ipv4 packet iface + | None -> Lwt.return_unit + + (* NAT *) + + let translate t packet = My_nat.translate t.nat 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 = 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 -> + Log.warn (fun f -> + f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); + Lwt.return_unit + + (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) + 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.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 -> + Log.warn (fun f -> + f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp + packet); + Lwt.return_unit) + + let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst + (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = + let packet = Packet.to_mirage_nat_packet annotated_packet in + rules annotated_packet >>= fun action -> + match (action, dst) with + | `Accept, `Client client_link -> transmit_ipv4 packet client_link + | `Accept, (`External _ | `NetVM) -> ( + match t.uplink with + | Some uplink -> transmit_ipv4 packet uplink.interface + | None -> ( + 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)) + | `Accept, `Firewall -> + Log.warn (fun f -> + f "Bad rule: firewall can't accept packets %a" Nat_packet.pp packet); + Lwt.return_unit + | `NAT, _ -> + Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet); + add_nat_and_forward_ipv4 t packet + | `NAT_to (host, port), _ -> nat_to t packet ~host ~port + | `Drop reason, _ -> + Log.debug (fun f -> + f "Dropped packet (%s) %a" reason Nat_packet.pp packet); + Lwt.return_unit + + let ipv4_from_netvm t packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + let (`IPv4 (ip, _transport)) = packet in + let src = classify t (Ipaddr.V4 ip.Ipv4_packet.src) in + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some _ -> ( + match src with + | `Client _ | `Firewall -> + Log.warn (fun f -> + f "Frame from NetVM has internal source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit + | (`External _ | `NetVM) as src -> ( + match translate t packet with + | Some frame -> forward_ipv4 t frame + | None -> ( + match Packet.of_mirage_nat_packet ~src ~dst packet with + | None -> Lwt.return_unit + | Some packet -> apply_rules t Rules.from_netvm ~dst packet) + ))) + + let ipv4_from_client resolver dns_servers t ~src packet = + match Memory_pressure.status () with + | `Memory_critical -> Lwt.return_unit + | `Ok -> ( + (* Check for existing NAT entry for this packet *) + match translate t packet with + | Some frame -> + forward_ipv4 t frame (* Some existing connection or redirect *) + | None -> ( + (* No existing NAT entry. Check the firewall rules. *) + let (`IPv4 (ip, _transport)) = packet in + match classify t (Ipaddr.V4 ip.Ipv4_packet.src) with + | `Client _ | `Firewall -> ( + let dst = classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in + match + Packet.of_mirage_nat_packet ~src:(`Client src) ~dst packet + with + | None -> Lwt.return_unit + | Some firewall_packet -> + apply_rules t + (Rules.from_client resolver dns_servers) + ~dst firewall_packet) + | `NetVM -> ipv4_from_netvm t packet + | `External _ -> + Log.warn (fun f -> + f "Frame from Inside has external source IP address! %a" + Nat_packet.pp packet); + Lwt.return_unit)) + + (** Handle an ARP message from the client. *) + let client_handle_arp ~fixed_arp ~iface request = + match Arp_packet.decode request with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); + Lwt.return_unit + | Ok arp -> ( + match Client_eth.ARP.input fixed_arp arp with + | None -> Lwt.return_unit + | Some response -> + iface#writev `ARP (fun b -> + Arp_packet.encode_into response b; + Arp_packet.size)) + + (** Handle an IPv4 packet from the client. *) + let client_handle_ipv4 get_ts cache ~iface ~router dns_client dns_servers + packet = + let cache', r = Nat_packet.of_ipv4_packet !cache ~now:(get_ts ()) packet in + cache := cache'; + match r with + | Error e -> + Log.warn (fun f -> + f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); + Lwt.return_unit + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> + let (`IPv4 (ip, _)) = packet in + let src = ip.Ipv4_packet.src in + if src = iface#other_ip then + ipv4_from_client dns_client dns_servers router ~src:iface packet + else ( + Log.warn (fun f -> + f "Incorrect source IP %a in IP packet from %a (dropping)" + Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); + Lwt.return_unit) + + (** Connect to a new client's interface and listen for incoming frames and firewall rule changes. *) + let add_vif get_ts { Dao.ClientVif.domid; device_id } dns_client dns_servers + ~client_ip ~router ~cleanup_tasks qubesDB = + Netback.make ~domid ~device_id >>= fun backend -> + 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.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 *) + let qubesdb_updater = + Lwt.catch + (fun () -> + let rec update current_db current_rules = + Qubes.DB.got_new_commit qubesDB (Dao.db_root client_ip) current_db + >>= fun new_db -> + iface#set_rules new_db; + let new_rules = iface#get_rules in + if current_rules = new_rules then + Log.info (fun m -> + m "Rules did not change for %s" + (Ipaddr.V4.to_string client_ip)) + else ( + Log.info (fun m -> + m "New firewall rules for %s@.%a" + (Ipaddr.V4.to_string client_ip) + Fmt.(list ~sep:(any "@.") Pf_qubes.Parse_qubes.pp_rule) + new_rules); + (* empty NAT table if rules are updated: they might deny old connections *) + My_nat.remove_connections router.nat client_ip); + update new_db new_rules + in + update Qubes.DB.KeyMap.empty []) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel qubesdb_updater); + add_client router iface >>= fun () -> + Cleanup.on_cleanup cleanup_tasks (fun () -> remove_client router iface); + let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in + let fragment_cache = ref (Fragments.Cache.empty (256 * 1024)) in + let listener = + Lwt.catch + (fun () -> + Netback.listen backend ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + match Ethernet.Packet.of_cstruct frame with + | Error err -> + Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); + Lwt.return_unit + | Ok (eth, payload) -> ( + match eth.Ethernet.Packet.ethertype with + | `ARP -> client_handle_arp ~fixed_arp ~iface payload + | `IPv4 -> + client_handle_ipv4 get_ts fragment_cache ~iface ~router + dns_client dns_servers payload + | `IPv6 -> Lwt.return_unit (* TODO: oh no! *))) + >|= or_raise "Listen on client interface" Netback.pp_error) + (function Lwt.Canceled -> Lwt.return_unit | e -> Lwt.fail e) + in + Cleanup.on_cleanup cleanup_tasks (fun () -> Lwt.cancel listener); + Lwt.pick [ qubesdb_updater; listener ] + + (** A new client VM has been found in XenStore. Find its interface and connect to it. *) + let add_client get_ts dns_client dns_servers ~router vif client_ip qubesDB = + let cleanup_tasks = Cleanup.create () in + Log.info (fun f -> + f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp + client_ip); + Lwt.async (fun () -> + Lwt.catch + (fun () -> + add_vif get_ts vif dns_client dns_servers ~client_ip ~router + ~cleanup_tasks qubesDB) + (fun ex -> + Log.warn (fun f -> + f "Error with client %a: %s" Dao.ClientVif.pp vif + (Printexc.to_string ex)); + Lwt.return_unit)); + cleanup_tasks + + (** Watch XenStore for notifications of new clients. *) + let wait_clients get_ts dns_client dns_servers qubesDB router = + Dao.watch_clients (fun new_set -> + (* Check for removed clients *) + !clients + |> Dao.VifMap.iter (fun key cleanup -> + if not (Dao.VifMap.mem key new_set) then ( + clients := !clients |> Dao.VifMap.remove key; + Log.info (fun f -> f "client %a has gone" Dao.ClientVif.pp key); + Cleanup.cleanup cleanup)); + (* Check for added clients *) + new_set + |> Dao.VifMap.iter (fun key ip_addr -> + if not (Dao.VifMap.mem key !clients) then ( + let cleanup = + add_client get_ts dns_client dns_servers ~router key ip_addr + qubesDB + in + Log.debug (fun f -> f "client %a arrived" Dao.ClientVif.pp key); + clients := !clients |> Dao.VifMap.add key cleanup))) + + let send_dns_client_query t ~src_port ~dst ~dst_port buf = + 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 ()) + + (** Wait for packet from our uplink (we must have an uplink here...). *) + let rec uplink_listen get_ts dns_responses router = + let handle_packet ip_header ip_packet = + let open Udp_packet in + Log.debug (fun f -> + f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp + ip_header.Ipv4_packet.src); + match ip_packet with + | `UDP (header, packet) when My_nat.dns_port router.nat header.dst_port -> + Log.debug (fun f -> + f + "found a DNS packet whose dst_port (%d) was in the list of \ + dns_client ports" + header.dst_port); + Lwt_mvar.put dns_responses (header, packet) + | _ -> ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) + in + match router.uplink with + | None -> + Lwt_condition.wait router.uplink_wait_config >>= fun () -> + uplink_listen get_ts dns_responses router + | Some uplink -> + let listen = + Netif.listen uplink.net ~header_size:Ethernet.Packet.sizeof_ethernet + (fun frame -> + (* Handle one Ethernet frame from NetVM *) + UplinkEth.input uplink.eth ~arpv4:(Arp.input uplink.arp) + ~ipv4:(fun ip -> + let cache, r = + Nat_packet.of_ipv4_packet uplink.fragments ~now:(get_ts ()) + ip + in + uplink.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 + in + let reconnect_uplink = + Lwt_condition.wait router.uplink_wait_config >>= fun () -> + uplink_listen get_ts dns_responses router + in + Lwt.pick [ listen; reconnect_uplink ] + + (** Connect to our uplink backend (we must have an uplink here...). *) + let connect config = + let my_ip = config.Dao.our_ip in + let gateway = config.Dao.netvm_ip in + Netif.connect "0" >>= fun net -> + UplinkEth.connect net >>= fun eth -> + Arp.connect eth >>= fun arp -> + Arp.add_ip arp my_ip >>= fun () -> + let cidr = Ipaddr.V4.Prefix.make 0 my_ip in + I.connect ~cidr ~gateway eth arp >>= fun ip -> + U.connect ip >>= fun udp -> + let netvm_mac = + Arp.query arp gateway >|= or_raise "Getting MAC of our NetVM" Arp.pp_error + in + let interface = + new netvm_iface eth netvm_mac ~my_ip ~other_ip:config.Dao.netvm_ip + in + let fragments = Fragments.Cache.empty (256 * 1024) in + Lwt.return { net; eth; arp; interface; fragments; ip; udp } + + (** Wait Xenstore for our uplink changes (we must have an uplink here...). *) + let uplink_wait_update qubesDB router = + let rec aux current_db = + let netvm = "/qubes-gateway" in + Log.info (fun f -> f "Waiting for netvm changes from %S...%!" netvm); + Qubes.DB.after qubesDB current_db >>= fun new_db -> + (match (router.uplink, Qubes.DB.KeyMap.find_opt netvm new_db) with + | Some uplink, Some netvm + when not + (String.equal netvm + (Ipaddr.V4.to_string uplink.interface#other_ip)) -> + Log.info (fun f -> + f "Our netvm IP has changed, before it was %s, now it's: %s%!" + (Ipaddr.V4.to_string uplink.interface#other_ip) + netvm); + Netif.disconnect uplink.net; + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + Time.sleep_ns (Duration.of_sec 1) >>= fun () -> + (* We need to wait for uplink_listen callback to be killed off *) + connect config >>= fun uplink -> + update router ~config ?uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_wait_config (); + Lwt.return_unit + | None, Some _ -> + (* a new interface is attributed to qubes-mirage-firewall *) + Log.info (fun f -> f "Going from netvm not connected to %s%!" netvm); + Dao.read_network_config qubesDB >>= fun config -> + Dao.print_network_config config; + connect config >>= fun uplink -> + update router ~config ?uplink:(Some uplink) >>= fun () -> + Lwt_condition.broadcast router.uplink_wait_config (); + Lwt.return_unit + | Some uplink, None -> + (* qubes-mirage-firewall now have netvm set to none: this is currently not supported... *) + Log.info (fun f -> + f "TODO: Our netvm disapeared, troubles are coming!%!"); + Netif.disconnect uplink.net; + Dao.read_network_config qubesDB >>= fun config -> + update router ~config ?uplink:None + | Some _, Some _ (* The new netvm IP is unchanged (it's our old netvm IP) *) + | None, None -> + Log.info (fun f -> + f "QubesDB has changed but not the situation of our netvm!%!"); + Lwt.return_unit) + >>= fun () -> aux new_db + in + aux Qubes.DB.KeyMap.empty +end diff --git a/firewall.ml b/firewall.ml deleted file mode 100644 index 3bf0e6f..0000000 --- a/firewall.ml +++ /dev/null @@ -1,136 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Packet -open Lwt.Infix - -let src = Logs.Src.create "firewall" ~doc:"Packet handler" -module Log = (val Logs.src_log src : Logs.LOG) - -(* Transmission *) - -let transmit_ipv4 packet iface = - Lwt.catch - (fun () -> - let fragments = ref [] in - iface#writev `IPv4 (fun b -> - match Nat_packet.into_cstruct packet b with - | Error e -> - Log.warn (fun f -> f "Failed to write packet to %a: %a" - Ipaddr.V4.pp iface#other_ip - Nat_packet.pp_error e); - 0 - | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> - Lwt_list.iter_s (fun f -> - let size = Cstruct.length f in - iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) - !fragments) - (fun ex -> - Log.warn (fun f -> f "Failed to write packet to %a: %s" - Ipaddr.V4.pp iface#other_ip - (Printexc.to_string ex)); - Lwt.return_unit - ) - -let forward_ipv4 t packet = - let `IPv4 (ip, _) = packet in - match Router.target t ip with - | Some iface -> transmit_ipv4 packet iface - | None -> Lwt.return_unit - -(* NAT *) - -let translate t packet = - My_nat.translate t.Router.nat 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.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 -> - Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e Nat_packet.pp packet); - Lwt.return_unit - -(* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) -let nat_to t ~host ~port packet = - let open Router in - 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.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 -> - Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e Nat_packet.pp packet); - Lwt.return_unit - -let apply_rules t (rules : ('a, 'b) Packet.t -> Packet.action Lwt.t) ~dst (annotated_packet : ('a, 'b) Packet.t) : unit Lwt.t = - let packet = to_mirage_nat_packet annotated_packet in - rules annotated_packet >>= fun action -> - match action, dst with - | `Accept, `Client client_link -> transmit_ipv4 packet client_link - | `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 - | `NAT, _ -> - Log.debug (fun f -> f "adding NAT rule for %a" Nat_packet.pp packet); - add_nat_and_forward_ipv4 t packet - | `NAT_to (host, port), _ -> nat_to t packet ~host ~port - | `Drop reason, _ -> - Log.debug (fun f -> f "Dropped packet (%s) %a" reason Nat_packet.pp packet); - Lwt.return_unit - -let ipv4_from_netvm t packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> - let `IPv4 (ip, _transport) = packet in - let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in - let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some _ -> - match src with - | `Client _ | `Firewall -> - Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" Nat_packet.pp packet); - Lwt.return_unit - | `External _ | `NetVM as src -> - match translate t packet with - | Some frame -> forward_ipv4 t frame - | None -> - match Packet.of_mirage_nat_packet ~src ~dst packet with - | None -> Lwt.return_unit - | Some packet -> apply_rules t Rules.from_netvm ~dst packet - -let ipv4_from_client resolver dns_servers t ~src packet = - match Memory_pressure.status () with - | `Memory_critical -> Lwt.return_unit - | `Ok -> - (* Check for existing NAT entry for this packet *) - match translate t packet with - | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) - | None -> - (* No existing NAT entry. Check the firewall rules. *) - let `IPv4 (ip, _transport) = packet in - match Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) with - | `Client _ | `Firewall -> ( - let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in - match of_mirage_nat_packet ~src:(`Client src) ~dst packet with - | None -> Lwt.return_unit - | Some firewall_packet -> apply_rules t (Rules.from_client resolver dns_servers) ~dst firewall_packet - ) - | `NetVM -> ipv4_from_netvm t packet - | `External _ -> - Log.warn (fun f -> f "Frame from Inside has external source IP address! %a" Nat_packet.pp packet); - Lwt.return_unit diff --git a/firewall.mli b/firewall.mli deleted file mode 100644 index c26cfbe..0000000 --- a/firewall.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** Classify IP packets, apply rules and send as appropriate. *) - -val ipv4_from_netvm : Router.t -> Nat_packet.t -> unit Lwt.t -(** Handle a packet from the outside world (this module will validate the source IP). *) - -(* TODO the function type is a workaround, rework the module dependencies / functors to get rid of it *) -val ipv4_from_client : ([ `host ] Domain_name.t -> (int32 * Ipaddr.V4.Set.t, [> `Msg of string ]) result Lwt.t) -> - Ipaddr.V4.t list -> Router.t -> src:Fw_utils.client_link -> Nat_packet.t -> unit Lwt.t -(** Handle a packet from a client. Caller must check the source IP matches the client's - before calling this. *) diff --git a/my_dns.ml b/my_dns.ml index 33a0ed5..849aa8d 100644 --- a/my_dns.ml +++ b/my_dns.ml @@ -3,7 +3,8 @@ open Lwt.Infix module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct type +'a io = 'a Lwt.t type io_addr = Ipaddr.V4.t * int - type stack = Router.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t + module Dispatcher = Dispatcher.Make(R)(C)(Time) + type stack = Dispatcher.t * (src_port:int -> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [ `Msg of string ]) result Lwt.t) * (Udp_packet.t * Cstruct.t) Lwt_mvar.t module IM = Map.Make(Int) @@ -48,7 +49,6 @@ module Transport (R : Mirage_random.S) (C : Mirage_clock.MCLOCK) (Time : Mirage_ let connect (t : t) = Lwt.return (Ok (t.protocol, t)) let send_recv (ctx : context) buf : (Cstruct.t, [> `Msg of string ]) result Lwt.t = - let open Router in let dst, dst_port = ctx.nameserver in let router, send_udp, _ = ctx.stack in let src_port, evict = diff --git a/router.ml b/router.ml deleted file mode 100644 index 3ca586a..0000000 --- a/router.ml +++ /dev/null @@ -1,44 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Fw_utils - -(* The routing table *) -let src = Logs.Src.create "router" ~doc:"Packet router" -module Log = (val Logs.src_log src : Logs.LOG) - -type t = { - config : Dao.network_config; - clients : Client_eth.t; - nat : My_nat.t; - uplink : interface option; -} - -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 -> begin match t.uplink with - | None -> ( - match Client_eth.lookup t.clients t.config.netvm_ip with - | Some uplink -> Some (uplink :> interface) - | None -> None - ) - | uplink -> uplink - end - -let add_client t = Client_eth.add_client t.clients -let remove_client t = Client_eth.remove_client t.clients - -let classify t ip = - if ip = Ipaddr.V4 t.config.our_ip then `Firewall - else if ip = Ipaddr.V4 t.config.netvm_ip then `NetVM - else (Client_eth.classify t.clients ip :> Packet.host) - -let resolve t = function - | `Firewall -> Ipaddr.V4 t.config.our_ip - | `NetVM -> Ipaddr.V4 t.config.netvm_ip - | #Client_eth.host as host -> Client_eth.resolve t.clients host diff --git a/router.mli b/router.mli deleted file mode 100644 index 532c39e..0000000 --- a/router.mli +++ /dev/null @@ -1,33 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** Routing packets to the right network interface. *) - -open Fw_utils - -type t = private { - config : Dao.network_config; - clients : Client_eth.t; - nat : My_nat.t; - uplink : interface option; -} - -val create : - config : Dao.network_config -> - clients : Client_eth.t -> - 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]. *) - -val target : t -> Ipv4_packet.t -> interface option -(** [target t packet] is the interface to which [packet] should be routed. *) - -val add_client : t -> client_link -> unit Lwt.t -(** [add_client t iface] adds a rule for routing packets addressed to [iface]. *) - -val remove_client : t -> client_link -> unit - -val classify : t -> Ipaddr.t -> Packet.host -val resolve : t -> Packet.host -> Ipaddr.t diff --git a/unikernel.ml b/unikernel.ml index fe602e2..ef02620 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -8,22 +8,20 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) = struct - module Uplink = Uplink.Make(R)(Clock)(Time) + module Dispatcher = Dispatcher.Make(R)(Clock)(Time) module Dns_transport = My_dns.Transport(R)(Clock)(Time) module Dns_client = Dns_client.Make(Dns_transport) (* Set up networking and listen for incoming packets. *) - let network dns_client dns_responses dns_servers uplink qubesDB router = + let network dns_client dns_responses dns_servers qubesDB router = (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Handle packets from both networks *) - match uplink with - | None -> Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router - | _ -> - Lwt.choose [ - Client_net.listen Clock.elapsed_ns dns_client dns_servers qubesDB router; - Uplink.listen uplink Clock.elapsed_ns dns_responses router - ] + Lwt.choose [ + Dispatcher.wait_clients Clock.elapsed_ns dns_client dns_servers qubesDB router ; + Dispatcher.uplink_wait_update qubesDB router ; + Dispatcher.uplink_listen Clock.elapsed_ns dns_responses router + ] (* Main unikernel entry point (called from auto-generated main.ml). *) let start _random _clock _time = @@ -50,56 +48,48 @@ module Main (R : Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_tim let max_entries = Key_gen.nat_table_size () in let nat = My_nat.create ~max_entries in - (* 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 *) - + 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 zero_ip = (Ipaddr.V4.make 0 0 0 0) in - - let connect_if_netvm = - 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 - - if config.netvm_ip <> zero_ip then ( - if (netvm_ip <> zero_ip || our_ip <> zero_ip) then begin - Log.err (fun f -> f "You must not specify --ipv4 or --ipv4-gw when using the netvm property: discard command line options") - end ; - 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) *) - Dao.update_network_config config default_config >>= fun config -> - Lwt.return (config, None) - ) + + let network_config = + if (netvm_ip = zero_ip && our_ip = zero_ip) then (* Read network configuration from QubesDB *) + Dao.read_network_config qubesDB >>= fun config -> + if config.netvm_ip = zero_ip || config.our_ip = zero_ip then + Log.info (fun f -> f "We currently have no netvm nor command line for setting it up, aborting..."); + assert (config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); + Lwt.return config + else begin + let config:Dao.network_config = {from_cmdline=true; netvm_ip; our_ip; dns; dns2} in + Lwt.return config + end in - connect_if_netvm >>= fun (config, uplink) -> + network_config >>= fun config -> (* We now must have a valid netvm IP address and our IP address or crash *) Dao.print_network_config config ; - assert(config.netvm_ip <> zero_ip && config.our_ip <> zero_ip); (* Set up client-side networking *) Client_eth.create config >>= fun clients -> (* Set up routing between networks and hosts *) - let router = Router.create + let router = Dispatcher.create ~config ~clients ~nat - ?uplink:(Uplink.interface uplink) + ?uplink:None in - let send_dns_query = Uplink.send_dns_client_query uplink in + let send_dns_query = Dispatcher.send_dns_client_query None in let dns_mvar = Lwt_mvar.create_empty () in let nameservers = `Udp, [ config.Dao.dns, 53 ; config.Dao.dns2, 53 ] in let dns_client = Dns_client.create ~nameservers (router, send_dns_query, dns_mvar) in let dns_servers = [ config.Dao.dns ; config.Dao.dns2 ] in - let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers uplink qubesDB router in + let net_listener = network (Dns_client.getaddrinfo dns_client Dns.Rr_map.A) dns_mvar dns_servers qubesDB router in (* Report memory usage to XenStore *) Memory_pressure.init (); diff --git a/uplink.ml b/uplink.ml deleted file mode 100644 index 2f7ea5e..0000000 --- a/uplink.ml +++ /dev/null @@ -1,104 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -open Lwt.Infix -open Fw_utils - -module Eth = Ethernet.Make(Netif) - -let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" -module Log = (val Logs.src_log src : Logs.LOG) - -module Make (R:Mirage_random.S) (Clock : Mirage_clock.MCLOCK) (Time : Mirage_time.S) = struct - module Arp = Arp.Make(Eth)(Time) - module I = Static_ipv4.Make(R)(Clock)(Eth)(Arp) - module U = Udp.Make(I)(R) - - type t = { - net : Netif.t; - eth : Eth.t; - arp : Arp.t; - interface : interface; - mutable fragments : Fragments.Cache.t; - ip : I.t; - udp: U.t; - } - -class netvm_iface eth mac ~my_ip ~other_ip : interface = object - method my_mac = Eth.mac eth - method my_ip = my_ip - method other_ip = other_ip - method writev ethertype fillfn = - mac >>= fun dst -> - Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error -end - - let send_dns_client_query t ~src_port ~dst ~dst_port buf = - 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 = - let open Udp_packet in - - Log.debug (fun f -> f "received ipv4 packet from %a on uplink" Ipaddr.V4.pp ip_header.Ipv4_packet.src); - match ip_packet with - | `UDP (header, packet) when My_nat.dns_port router.Router.nat header.dst_port -> - Log.debug (fun f -> f "found a DNS packet whose dst_port (%d) was in the list of dns_client ports" header.dst_port); - Lwt_mvar.put dns_responses (header, packet) - | _ -> - Firewall.ipv4_from_netvm router (`IPv4 (ip_header, ip_packet)) - in - 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 = - match t with - | None -> None - | Some t -> Some t.interface - -let connect config = - let my_ip = config.Dao.our_ip in - let gateway = config.Dao.netvm_ip in - Netif.connect "0" >>= fun net -> - Eth.connect net >>= fun eth -> - Arp.connect eth >>= fun arp -> - Arp.add_ip arp my_ip >>= fun () -> - let cidr = Ipaddr.V4.Prefix.make 0 my_ip in - I.connect ~cidr ~gateway eth arp >>= fun ip -> - U.connect ip >>= fun udp -> - let netvm_mac = - Arp.query arp gateway - >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in - let interface = new netvm_iface eth netvm_mac - ~my_ip - ~other_ip:config.Dao.netvm_ip in - let fragments = Fragments.Cache.empty (256 * 1024) in - Lwt.return { net; eth; arp; interface ; fragments ; ip ; udp } -end diff --git a/uplink.mli b/uplink.mli deleted file mode 100644 index 0d35e5e..0000000 --- a/uplink.mli +++ /dev/null @@ -1,21 +0,0 @@ -(* Copyright (C) 2015, Thomas Leonard - See the README file for details. *) - -(** The link from us to NetVM (and, through that, to the outside world). *) - -open Fw_utils - -module Make (R: Mirage_random.S)(Clock : Mirage_clock.MCLOCK)(Time : Mirage_time.S) : sig - type t - - val connect : Dao.network_config -> t Lwt.t - (** Connect to our NetVM (gateway). *) - - val interface : t option -> interface option - (** The network interface to NetVM. *) - - 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 option -> src_port:int-> dst:Ipaddr.V4.t -> dst_port:int -> Cstruct.t -> (unit, [`Msg of string]) result Lwt.t -end