qubes-mirage-firewall/client_eth.ml
Thomas Leonard 672c82c43c Combine Client_gateway and Firewall_uplink
Before, we used Client_gateway for the IP address of the firewall on the
client network and Firewall_uplink for its address on the uplink
network. However, Qubes 4 uses the same IP address for both, so we can't
separate these any longer, and there doesn't seem to be any advantage to
keeping them separate anyway.
2019-05-16 19:30:51 +01:00

132 lines
4.6 KiB
OCaml

(* Copyright (C) 2016, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Fw_utils
open Lwt.Infix
let src = Logs.Src.create "client_eth" ~doc:"Ethernet networks for NetVM clients"
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. *)
}
type host =
[ `Client of client_link
| `Firewall
| `External of Ipaddr.t ]
let create ~client_gw =
let changed = Lwt_condition.create () in
{ iface_of_ip = IpMap.empty; client_gw; changed }
let client_gw t = t.client_gw
let add_client t iface =
let ip = iface#other_ip in
let rec aux () =
match IpMap.find ip t.iface_of_ip with
| Some old ->
(* Wait for old client to disappear before adding one with the same IP address.
Otherwise, its [remove_client] call will remove the new client instead. *)
Log.info (fun f -> f ~header:iface#log_header "Waiting for old client %s to go away before accepting new one" old#log_header);
Lwt_condition.wait t.changed >>= aux
| None ->
t.iface_of_ip <- t.iface_of_ip |> IpMap.add ip iface;
Lwt_condition.broadcast t.changed ();
Lwt.return_unit
in
aux ()
let remove_client t iface =
let ip = iface#other_ip in
assert (IpMap.mem ip t.iface_of_ip);
t.iface_of_ip <- t.iface_of_ip |> IpMap.remove ip;
Lwt_condition.broadcast t.changed ()
let lookup t ip = IpMap.find ip t.iface_of_ip
let classify t ip =
match ip with
| Ipaddr.V6 _ -> `External ip
| Ipaddr.V4 ip4 ->
if ip4 = t.client_gw 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
| `External addr -> addr
module ARP = struct
type arp = {
net : t;
client_link : client_link;
}
let lookup t ip =
if ip = t.net.client_gw then Some t.client_link#my_mac
else if (Ipaddr.V4.to_bytes 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);
Some t.client_link#my_mac
) else None
(* We're now treating client networks as point-to-point links,
so we no longer respond on behalf of other clients. *)
(*
else match IpMap.find ip t.net.iface_of_ip with
| Some client_iface -> Some client_iface#other_mac
| None -> None
*)
let create ~net client_link = {net; client_link}
let input_query t arp =
let req_ipv4 = arp.Arp_packet.target_ip in
let pf (f : ?header:string -> ?tags:_ -> _) fmt =
f ~header:t.client_link#log_header ("who-has %a? " ^^ fmt) Ipaddr.V4.pp req_ipv4
in
if req_ipv4 = t.client_link#other_ip then (
Log.info (fun f -> pf f "ignoring request for client's own IP");
None
) else match lookup t req_ipv4 with
| None ->
Log.info (fun f -> pf f "unknown address; not responding");
None
| Some req_mac ->
Log.info (fun f -> pf f "responding with %a" Macaddr.pp req_mac);
Some { Arp_packet.
operation = Arp_packet.Reply;
(* The Target Hardware Address and IP are copied from the request *)
target_ip = arp.Arp_packet.source_ip;
target_mac = arp.Arp_packet.source_mac;
source_ip = req_ipv4;
source_mac = req_mac;
}
let input_gratuitous t arp =
let source_ip = arp.Arp_packet.source_ip in
let source_mac = arp.Arp_packet.source_mac in
let header = t.client_link#log_header in
match lookup t source_ip with
| Some real_mac when Macaddr.compare source_mac real_mac = 0 ->
Log.info (fun f -> f ~header "client suggests updating %s -> %s (as expected)"
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac));
| Some other_mac ->
Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (should be %s)"
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac) (Macaddr.to_string other_mac));
| None ->
Log.warn (fun f -> f ~header "client suggests incorrect update %s -> %s (unexpected IP)"
(Ipaddr.V4.to_string source_ip) (Macaddr.to_string source_mac))
let input t arp =
let op = arp.Arp_packet.operation in
match op with
| Arp_packet.Request -> input_query t arp
| Arp_packet.Reply -> input_gratuitous t arp; None
end