qubes-mirage-firewall/firewall.ml
2015-12-31 09:56:58 +00:00

177 lines
6.0 KiB
OCaml

(* Copyright (C) 2015, Thomas Leonard <thomas.leonard@unikernel.com>
See the README file for details. *)
open Utils
open Packet
let src = Logs.Src.create "firewall" ~doc:"Packet handler"
module Log = (val Logs.src_log src : Logs.LOG)
(* Transmission *)
let transmit ~frame iface =
let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in
iface#writev [packet]
let forward_ipv4 t frame =
let packet = Cstruct.shift frame Wire_structs.sizeof_ethernet in
match Router.target t packet with
| Some iface -> iface#writev [packet]
| None -> return ()
(* Packet classification *)
let ports transport =
let sport, dport = Nat_rewrite.ports_of_transport transport in
{ sport; dport }
let classify t frame =
match Nat_rewrite.layers frame with
| None ->
Log.warn "Failed to parse frame" Logs.unit;
None
| Some (_eth, ip, transport) ->
let src, dst = Nat_rewrite.addresses_of_ip ip in
let proto =
match Nat_rewrite.proto_of_ip ip with
| 1 -> `ICMP
| 6 -> `TCP (ports transport)
| 17 -> `UDP (ports transport)
| _ -> `Unknown in
Some {
frame;
src = Router.classify t src;
dst = Router.classify t dst;
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 =
match Nat_rewrite.translate t.Router.nat frame with
| None -> None
| Some frame -> Some (fixup_checksums frame |> Cstruct.concat)
let random_user_port () =
1024 + Random.int (0xffff - 1024)
let rec add_nat_rule_and_transmit t frame fn fmt logf =
let xl_port = random_user_port () in
match fn xl_port with
| Nat_rewrite.Overlap -> add_nat_rule_and_transmit t frame fn fmt logf (* Try a different port *)
| Nat_rewrite.Unparseable ->
Log.warn "Failed to add NAT rule: Unparseable" Logs.unit;
return ()
| Nat_rewrite.Ok _ ->
Log.info fmt (logf xl_port);
match translate t frame with
| Some frame -> forward_ipv4 t frame
| None ->
Log.warn "No NAT entry, even after adding one!" Logs.unit;
return ()
(* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *)
let add_nat_and_forward_ipv4 t frame =
add_nat_rule_and_transmit t frame
(Nat_rewrite.make_nat_entry t.Router.nat frame t.Router.my_uplink_ip)
"added NAT entry: %s:%d -> firewall:%d -> %d:%s"
(fun xl_port f ->
match Nat_rewrite.layers frame with
| None -> assert false
| Some (_eth, ip, transport) ->
let src, dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst)
)
(* Add a NAT rule to redirect this conversation to NetVM instead of us. *)
let redirect_to_netvm t ~frame ~port =
let gw = Ipaddr.V4 t.Router.default_gateway#other_ip in
add_nat_rule_and_transmit t frame
(fun xl_port ->
Nat_rewrite.make_redirect_entry t.Router.nat frame (t.Router.my_uplink_ip, xl_port) (gw, port)
)
"added NAT redirect %s:%d -> %d:firewall:%d -> %d:NetVM"
(fun xl_port f ->
match Nat_rewrite.layers frame with
| None -> assert false
| Some (_eth, ip, transport) ->
let src, _dst = Nat_rewrite.addresses_of_ip ip in
let sport, dport = Nat_rewrite.ports_of_transport transport in
f (Ipaddr.to_string src) sport dport xl_port port
)
(* Handle incoming packets *)
let ipv4_from_client t frame =
match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *)
Log.warn "Memory low - dropping packet" Logs.unit;
return ()
| `Ok ->
(* Check for existing NAT entry for this packet *)
match translate t frame with
| Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *)
| None ->
(* No existing NAT entry. Check the firewall rules. *)
match classify t frame with
| None -> return ()
| 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 %a" (fun f -> f pp_packet info);
return ()
| `Accept, (`Firewall_uplink | `Client_gateway) ->
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) %a" (fun f -> f reason pp_packet info);
return ()
let ipv4_from_netvm t frame =
match Memory_pressure.status () with
| `Memory_critical -> (* TODO: should happen before copying and async *)
Log.warn "Memory low - dropping packet" Logs.unit;
return ()
| `Ok ->
match classify t frame with
| 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! %a" (fun f -> f pp_packet info);
return ()
| `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) %a" (fun f -> f reason pp_packet info);
return ()