From 764e95e5be9d49c3ff0617a1b1417a34dee4647c Mon Sep 17 00:00:00 2001 From: palainp Date: Wed, 5 Jul 2023 11:56:19 +0200 Subject: [PATCH] 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