diff --git a/client_eth.ml b/client_eth.ml index 8808032..87965c2 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -31,14 +31,15 @@ let remove_client t iface = let lookup t ip = IpMap.find ip t.iface_of_ip -let classify t = function - | Ipaddr.V6 _ -> `External - | Ipaddr.V4 ip -> - if ip === t.client_gw then `Client_gateway - else match lookup t ip with +let classify t ip = + match ip with + | Ipaddr.V6 _ -> `External ip + | Ipaddr.V4 ip4 -> + if ip4 === t.client_gw then `Client_gateway + else match lookup t ip4 with | Some client_link -> `Client client_link - | None when Ipaddr.V4.Prefix.mem ip t.prefix -> `Unknown_client - | None -> `External + | None when Ipaddr.V4.Prefix.mem ip4 t.prefix -> `Unknown_client ip + | None -> `External ip module ARP = struct type arp = { diff --git a/client_eth.mli b/client_eth.mli index 2808dad..83bad9a 100644 --- a/client_eth.mli +++ b/client_eth.mli @@ -19,7 +19,7 @@ val remove_client : t -> client_link -> unit val prefix : t -> Ipaddr.V4.Prefix.t val classify : t -> Ipaddr.t -> - [ `Client of client_link | `Unknown_client | `Client_gateway | `External ] + [ `Client of client_link | `Unknown_client of Ipaddr.t | `Client_gateway | `External of Ipaddr.t ] val lookup : t -> Ipaddr.V4.t -> client_link option diff --git a/dao.ml b/dao.ml index 4635ccf..972d2e9 100644 --- a/dao.ml +++ b/dao.ml @@ -48,6 +48,7 @@ type network_config = { clients_our_ip : Ipaddr.V4.t; (* The IP address of our interface to our client VMs (their gateway) *) } +(* TODO: /qubes-secondary-dns *) let read_network_config qubesDB = let get name = match DB.read qubesDB name with diff --git a/firewall.ml b/firewall.ml index 6f60b9b..15bd3f4 100644 --- a/firewall.ml +++ b/firewall.ml @@ -45,6 +45,28 @@ let classify t frame = proto; } +let pp_ports fmt {sport; dport} = + Format.fprintf fmt "sport=%d dport=%d" sport dport + +let pp_host fmt = function + | `Client c -> Ipaddr.V4.pp_hum fmt (c#other_ip) + | `Unknown_client ip -> Format.fprintf fmt "unknown-client(%a)" Ipaddr.pp_hum ip + | `External ip -> Format.fprintf fmt "external(%a)" Ipaddr.pp_hum ip + | `Firewall_uplink -> Format.pp_print_string fmt "firewall(uplink)" + | `Client_gateway -> Format.pp_print_string fmt "firewall(client-gw)" + +let pp_proto fmt = function + | `UDP ports -> Format.fprintf fmt "UDP(%a)" pp_ports ports + | `TCP ports -> Format.fprintf fmt "TCP(%a)" pp_ports ports + | `ICMP -> Format.pp_print_string fmt "ICMP" + | `Unknown -> Format.pp_print_string fmt "UnknownProtocol" + +let pp_packet fmt {src; dst; proto; frame = _} = + Format.fprintf fmt "[src=%a dst=%a proto=%a]" + pp_host src + pp_host dst + pp_proto proto + (* NAT *) let translate t frame = @@ -119,16 +141,16 @@ let ipv4_from_client t frame = | Some info -> match Rules.from_client info, info.dst with | `Accept, `Client client_link -> transmit ~frame client_link - | `Accept, `External -> add_nat_and_forward_ipv4 t frame - | `Accept, `Unknown_client -> - Log.warn "Dropping packet to unknown client" Logs.unit; + | `Accept, `External _ -> add_nat_and_forward_ipv4 t frame + | `Accept, `Unknown_client _ -> + Log.warn "Dropping packet to unknown client %a" (fun f -> f pp_packet info); return () | `Accept, (`Firewall_uplink | `Client_gateway) -> - Log.warn "Bad rule: firewall can't accept packets" Logs.unit; + Log.warn "Bad rule: firewall can't accept packets %a" (fun f -> f pp_packet info); return () | `Redirect_to_netvm port, _ -> redirect_to_netvm t ~frame ~port | `Drop reason, _ -> - Log.info "Dropped packet (%s)" (fun f -> f reason); + Log.info "Dropped packet (%s) %a" (fun f -> f reason pp_packet info); return () let ipv4_from_netvm t frame = @@ -141,14 +163,14 @@ let ipv4_from_netvm t frame = | None -> return () | Some info -> match info.src with - | `Client _ | `Unknown_client | `Firewall_uplink | `Client_gateway -> - Log.warn "Frame from NetVM has internal source IP address!" Logs.unit; + | `Client _ | `Unknown_client _ | `Firewall_uplink | `Client_gateway -> + Log.warn "Frame from NetVM has internal source IP address! %a" (fun f -> f pp_packet info); return () - | `External -> + | `External _ -> match translate t frame with | Some frame -> forward_ipv4 t frame | None -> match Rules.from_netvm info with | `Drop reason -> - Log.info "Dropped packet (%s)" (fun f -> f reason); + Log.info "Dropped packet (%s) %a" (fun f -> f reason pp_packet info); return () diff --git a/packet.ml b/packet.ml index 15db616..e088f3a 100644 --- a/packet.ml +++ b/packet.ml @@ -11,7 +11,7 @@ type ports = { } type host = - [ `Client of client_link | `Unknown_client | `Client_gateway | `Firewall_uplink | `External ] + [ `Client of client_link | `Unknown_client of Ipaddr.t | `Client_gateway | `Firewall_uplink | `External of Ipaddr.t ] type info = { frame : Cstruct.t; diff --git a/rules.ml b/rules.ml index eb15011..35dc35e 100644 --- a/rules.ml +++ b/rules.ml @@ -11,11 +11,11 @@ open Packet (** Decide what to do with a packet from a client VM. Note: If the packet matched an existing NAT rule then this isn't called. *) let from_client = function - | { dst = `External } -> `Accept + | { dst = `External _ } -> `Accept | { dst = `Client_gateway; proto = `UDP { dport = 53 } } -> `Redirect_to_netvm 53 | { dst = (`Client_gateway | `Firewall_uplink) } -> `Drop "packet addressed to firewall itself" | { dst = `Client _ } -> `Drop "prevent communication between client VMs" - | { dst = `Unknown_client } -> `Drop "target client not running" + | { dst = `Unknown_client _ } -> `Drop "target client not running" (** Decide what to do with a packet received from the outside world. Note: If the packet matched an existing NAT rule then this isn't called. *)