Log packet details when dropping

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
+let classify t ip =
-  | Ipaddr.V6 _ -> `External
+  match ip with
-  | Ipaddr.V4 ip ->
+  | Ipaddr.V6 _ -> `External ip
-  if ip === t.client_gw then `Client_gateway
+  | Ipaddr.V4 ip4 ->
-  else match lookup t ip with
+  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 when Ipaddr.V4.Prefix.mem ip4 t.prefix -> `Unknown_client ip
-  | None -> `External
+  | None -> `External ip
 
 module ARP = struct
   type arp = {

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
 

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

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, `External _ -> add_nat_and_forward_ipv4 t frame
-  | `Accept, `Unknown_client ->
+  | `Accept, `Unknown_client _ ->
-      Log.warn "Dropping packet to unknown client" Logs.unit;
+      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 ->
+  | `Client _ | `Unknown_client _ | `Firewall_uplink | `Client_gateway ->
-    Log.warn "Frame from NetVM has internal source IP address!" Logs.unit;
+    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 ()

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;

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. *)