From b4079ac8619c58354cc25132f7e55556de0645b8 Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Sun, 5 Mar 2017 16:31:04 +0000 Subject: [PATCH] Update to new mirage-nat API --- .travis.yml | 2 +- Dockerfile | 11 ++++---- README.md | 3 ++- build-with-docker.sh | 4 +-- client_net.ml | 11 ++++---- firewall.ml | 61 +++++++++++++++----------------------------- firewall.mli | 4 +-- my_nat.ml | 30 ++++------------------ my_nat.mli | 6 ++--- packet.ml | 2 +- uplink.ml | 25 ++++++++++-------- 11 files changed, 62 insertions(+), 97 deletions(-) diff --git a/.travis.yml b/.travis.yml index e9d1353..6ef81aa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -20,4 +20,4 @@ addons: - time - libxen-dev env: - - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#mirage3" + - OCAML_VERSION=4.04 MIRAGE_BACKEND=xen PINS="mirage-nat:https://github.com/talex5/mirage-nat.git#cleanup" diff --git a/Dockerfile b/Dockerfile index 2182d1e..4c8b436 100644 --- a/Dockerfile +++ b/Dockerfile @@ -2,19 +2,20 @@ # It will probably still work on newer images, though, unless Debian 8 # changes some compiler optimisations (unlikely). #FROM ocaml/opam:debian-8_ocaml-4.03.0 -FROM ocaml/opam@sha256:28efab6a5535a517aa719ba5ac6d2e6fddd4831afaeabf5eee6470717eda9cca +FROM ocaml/opam@sha256:72ebf516fca7a9464db2136f2dcf2a58d09547669b60f3643a8329768febaed6 # Pin last known-good version for reproducible builds. # Remove this line (and the base image pin above) if you want to test with the # latest versions. -RUN cd opam-repository && git reset --hard 0f17b354206c97e729700ce60ddce3789ccb1d52 && opam update +RUN cd opam-repository && git reset --hard 8f4d15eae94dfe6f70a66a7572a21a0c60d9f4f4 && opam update RUN sudo apt-get install -y m4 libxen-dev RUN opam install -y vchan xen-gnt mirage-xen-ocaml mirage-xen-minios io-page mirage-xen mirage -RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum' +RUN opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' +RUN opam pin add -n -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup' RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall -RUN opam config exec -- mirage configure --xen -CMD opam config exec -- mirage configure --xen --no-opam && \ +RUN opam config exec -- mirage configure -t xen && make depend +CMD opam config exec -- mirage configure -t xen && \ opam config exec -- make tar diff --git a/README.md b/README.md index 18b0b7e..7e24e99 100644 --- a/README.md +++ b/README.md @@ -31,7 +31,8 @@ This took about 10 minutes on my laptop (it will be much quicker if you run it a 2. Install mirage, pinning a few unreleased features we need: - opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#mirage3' + opam pin add -n -y tcpip 'https://github.com/talex5/mirage-tcpip.git#fix-length-checks' + opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#cleanup' opam install mirage 3. Build mirage-firewall: diff --git a/build-with-docker.sh b/build-with-docker.sh index d61f13c..f004471 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -4,5 +4,5 @@ echo Building Docker image with dependencies.. docker build -t qubes-mirage-firewall . echo Building Firewall... docker run --rm -i -v `pwd`:/home/opam/qubes-mirage-firewall qubes-mirage-firewall -echo "SHA2 of build: $(sha256sum mir-qubes-firewall.xen)" -echo "SHA2 last known: f0c1a06fc4b02b494c81972dc89419af6cffa73b75839c0e8ee3798d77bf69b3" +echo "SHA2 of build: $(sha256sum qubes_firewall.xen)" +echo "SHA2 last known: 45b82182341237ca9e754636f771ef3f4c93824212d1a76520a8a79bbee18668" diff --git a/client_net.ml b/client_net.ml index 50f22ea..7148011 100644 --- a/client_net.ml +++ b/client_net.ml @@ -45,7 +45,7 @@ let clients : Cleanup.t Dao.VifMap.t ref = ref Dao.VifMap.empty let input_arp ~fixed_arp ~iface request = match Arpv4_packet.Unmarshal.of_cstruct request with | Error e -> - Log.warn (fun f -> f "ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e); + Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arpv4_packet.Unmarshal.pp_error e); Lwt.return () | Ok arp -> match Client_eth.ARP.input fixed_arp arp with @@ -55,13 +55,14 @@ let input_arp ~fixed_arp ~iface request = (** Handle an IPv4 packet from the client. *) let input_ipv4 ~client_ip ~router packet = - match Ipv4_packet.Unmarshal.of_cstruct packet with + match Nat_packet.of_ipv4_packet packet with | Error e -> - Log.warn (fun f -> f "ignored unknown IPv4 message: %s" e); + Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); Lwt.return () - | Ok (ip, payload) -> + | Ok packet -> + let `IPv4 (ip, _) = packet in let src = ip.Ipv4_packet.src in - if src = client_ip then Firewall.ipv4_from_client router (ip, payload) + if src = client_ip then Firewall.ipv4_from_client router packet else ( Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip); diff --git a/firewall.ml b/firewall.ml index 226a56c..350eecf 100644 --- a/firewall.ml +++ b/firewall.ml @@ -10,10 +10,10 @@ module Log = (val Logs.src_log src : Logs.LOG) (* Transmission *) -let transmit (ip, payload) iface = - let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in +let transmit_ipv4 packet iface = + let headers, payload = Nat_packet.make_headers_cstruct packet in Lwt.catch - (fun () -> iface#writev Ethif_wire.IPv4 [packet; payload]) + (fun () -> iface#writev Ethif_wire.IPv4 [headers; payload]) (fun ex -> Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp_hum iface#other_ip @@ -21,42 +21,23 @@ let transmit (ip, payload) iface = Lwt.return () ) -let forward_ipv4 t (ip, packet) = +let forward_ipv4 t packet = + let `IPv4 (ip, _) = packet in match Router.target t ip with - | Some iface -> transmit (ip, packet) iface + | Some iface -> transmit_ipv4 packet iface | None -> return () (* Packet classification *) -let classify_tcp trans = - match Tcp.Tcp_packet.Unmarshal.of_cstruct trans with - | Error e -> - Log.info (fun f -> f "Failed to parse TCP packet: %s" e); - `Unknown - | Ok (tcp, _payload) -> - let sport = tcp.Tcp.Tcp_packet.src_port in - let dport = tcp.Tcp.Tcp_packet.dst_port in - `TCP {sport; dport} - -let classify_udp trans = - match Udp_packet.Unmarshal.of_cstruct trans with - | Error e -> - Log.info (fun f -> f "Failed to parse UDP packet: %s" e); - `Unknown - | Ok (udp, _payload) -> - let sport = udp.Udp_packet.src_port in - let dport = udp.Udp_packet.dst_port in - `UDP {sport; dport} - -let classify t (ip, transport) = +let classify t packet = + let `IPv4 (ip, transport) = packet in let proto = - match ip.Ipv4_packet.proto |> Ipv4_packet.Unmarshal.int_to_protocol with - | Some `ICMP -> `ICMP - | Some `TCP -> classify_tcp transport - | Some `UDP -> classify_udp transport - | None -> `Unknown in + match transport with + | `TCP ({Tcp.Tcp_packet.src_port; dst_port; _}, _) -> `TCP {sport = src_port; dport = dst_port} + | `UDP ({Udp_packet.src_port; dst_port; _}, _) -> `UDP {sport = src_port; dport = dst_port} + in Some { - packet = (ip, transport); + packet; src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src); dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst); proto; @@ -114,8 +95,8 @@ let nat_to t ~host ~port packet = let apply_rules t rules info = let packet = info.packet in match rules info, info.dst with - | `Accept, `Client client_link -> transmit packet client_link - | `Accept, (`External _ | `NetVM) -> transmit packet t.Router.uplink + | `Accept, `Client client_link -> transmit_ipv4 packet client_link + | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, (`Firewall_uplink | `Client_gateway) -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); return () @@ -133,24 +114,24 @@ let handle_low_memory t = `Memory_critical | `Ok -> Lwt.return `Ok -let ipv4_from_client t (ip, payload) = +let ipv4_from_client t packet = handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> (* Check for existing NAT entry for this packet *) - translate t (ip, payload) >>= function + translate t packet >>= function | Some frame -> forward_ipv4 t frame (* Some existing connection or redirect *) | None -> (* No existing NAT entry. Check the firewall rules. *) - match classify t (ip, payload) with + match classify t packet with | None -> return () | Some info -> apply_rules t Rules.from_client info -let ipv4_from_netvm t (ip, payload) = +let ipv4_from_netvm t packet = handle_low_memory t >>= function | `Memory_critical -> return () | `Ok -> - match classify t (ip, payload) with + match classify t packet with | None -> return () | Some info -> match info.src with @@ -158,7 +139,7 @@ let ipv4_from_netvm t (ip, payload) = Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info); return () | `External _ | `NetVM -> - translate t (ip, payload) >>= function + translate t packet >>= function | Some frame -> forward_ipv4 t frame | None -> apply_rules t Rules.from_netvm info diff --git a/firewall.mli b/firewall.mli index 3a88270..3909ee0 100644 --- a/firewall.mli +++ b/firewall.mli @@ -3,9 +3,9 @@ (** Classify IP packets, apply rules and send as appropriate. *) -val ipv4_from_netvm : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t +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). *) -val ipv4_from_client : Router.t -> Ipv4_packet.t * Cstruct.t -> unit Lwt.t +val ipv4_from_client : Router.t -> 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_nat.ml b/my_nat.ml index ec9d0f2..8d81258 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -11,8 +11,6 @@ type action = [ | `Redirect of Ipaddr.t * int ] -type packet = Ipv4_packet.t * Cstruct.t - (* To avoid needing to allocate a new NAT table when we've run out of memory, pre-allocate the new one ahead of time. *) type 'a with_standby = { @@ -35,21 +33,10 @@ let fake_ipv4_eth = let dontcare = Macaddr.broadcast in Fw_utils.eth_header Ethif_wire.IPv4 ~src:dontcare ~dst:dontcare -let translate (Nat ((module Nat), _, table)) (ip, payload) = - (* XXX: change Nat.translate API *) - let packet = Ipv4_packet.Marshal.make_cstruct ~payload ip in - let frame = Cstruct.concat [ - fake_ipv4_eth; - packet; - payload; - ] in - Nat.translate table.current frame >|= function +let translate (Nat ((module Nat), _, table)) packet = + Nat.translate table.current packet >|= function | Mirage_nat.Untranslated -> None - | Mirage_nat.Translated _ -> (* XXX: translate mutates frame *) - let packet = Cstruct.shift frame Ethif_wire.sizeof_ethernet in - match Ipv4_packet.Unmarshal.of_cstruct packet with - | Error e -> Log.err (fun f -> f "Translation failed: %s" e); None - | Ok packet -> Some packet + | Mirage_nat.Translated packet -> Some packet let random_user_port () = 1024 + Random.int (0xffff - 1024) @@ -62,20 +49,13 @@ let reset (Nat ((module Nat), c, table)) = table.next <- next let add_nat_rule_and_translate ((Nat ((module Nat), c, table)) as t) ~xl_host action packet = - let frame = - let (ip, payload) = packet in - Cstruct.concat [ - fake_ipv4_eth; - Ipv4_packet.Marshal.make_cstruct ~payload ip; - payload; - ] in let apply_action xl_port = Lwt.try_bind (fun () -> match action with | `Rewrite -> - Nat.add_nat table.current frame (xl_host, xl_port) + Nat.add_nat table.current packet (xl_host, xl_port) | `Redirect target -> - Nat.add_redirect table.current frame (xl_host, xl_port) target + Nat.add_redirect table.current packet (xl_host, xl_port) target ) (function | Nat.Ok -> Lwt.return (Ok ()) diff --git a/my_nat.mli b/my_nat.mli index cf71dec..ac6e0f9 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -10,10 +10,8 @@ type action = [ | `Redirect of Ipaddr.t * int ] -type packet = Ipv4_packet.t * Cstruct.t - val create : (module Mirage_nat.S with type t = 'a and type config = 'c) -> 'c -> t Lwt.t val reset : t -> unit Lwt.t -val translate : t -> packet -> packet option Lwt.t +val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val add_nat_rule_and_translate : t -> xl_host:Ipaddr.t -> - action -> packet -> (packet, string) result Lwt.t + action -> Nat_packet.t -> (Nat_packet.t, string) result Lwt.t diff --git a/packet.ml b/packet.ml index bea2594..a9fa4e7 100644 --- a/packet.ml +++ b/packet.ml @@ -14,7 +14,7 @@ type host = [ `Client of client_link | `Client_gateway | `Firewall_uplink | `NetVM | `External of Ipaddr.t ] type info = { - packet : Ipv4_packet.t * Cstruct.t; + packet : Nat_packet.t; src : host; dst : host; proto : [ `UDP of ports | `TCP of ports | `ICMP | `Unknown ]; diff --git a/uplink.ml b/uplink.ml index 0dfe79c..ff7e718 100644 --- a/uplink.ml +++ b/uplink.ml @@ -34,17 +34,20 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let listen t router = Netif.listen t.net (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth - ~arpv4:(Arp.input t.arp) - ~ipv4:(fun ip -> - match Ipv4_packet.Unmarshal.of_cstruct ip with - | Error e -> Log.warn (fun f -> f "Bad IPv4 packet from uplink: %s" e); Lwt.return () - | Ok packet -> Firewall.ipv4_from_netvm router packet - ) - ~ipv6:(fun _ip -> return ()) - frame - ) >|= or_raise "Uplink listen loop" Netif.pp_error + (* Handle one Ethernet frame from NetVM *) + Eth.input t.eth + ~arpv4:(Arp.input t.arp) + ~ipv4:(fun ip -> + match Nat_packet.of_ipv4_packet ip with + | Error e -> + Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); + Lwt.return () + | Ok packet -> + Firewall.ipv4_from_netvm router packet + ) + ~ipv6:(fun _ip -> return ()) + frame + ) >|= or_raise "Uplink listen loop" Netif.pp_error let interface t = t.interface