From 48b38fa992cfe2567c21668ff967cc006dfdc73d Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 13 Jan 2020 09:49:37 +0000 Subject: [PATCH 1/3] Fix Lwt.4.5.0 in the Dockerfile for faster builds Otherwise, it installs Lwt 5 and then has to downgrade it in the next step. --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 3125969..8a9ed27 100644 --- a/Dockerfile +++ b/Dockerfile @@ -9,7 +9,7 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155 # latest versions. RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update -RUN opam depext -i -y mirage.3.7.4 lwt +RUN opam depext -i -y mirage.3.7.4 lwt.4.5.0 RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall From ab3508a9367dcc69bff871521fcad5090c03eb3a Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 13 Jan 2020 09:50:48 +0000 Subject: [PATCH 2/3] Remove unused Clock argument to Uplink --- build-with-docker.sh | 2 +- unikernel.ml | 2 - uplink.ml | 118 +++++++++++++++++++++---------------------- uplink.mli | 16 +++--- 4 files changed, 66 insertions(+), 72 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index d2944fe..5b1bc30 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,5 +5,5 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc" +echo "SHA2 last known: 6f8f0f19ba62bf5312039f2904ea8696584f8ff49443dec098facf261449ebf2" echo "(hashes should match for released versions)" diff --git a/unikernel.ml b/unikernel.ml index 27f772a..6eaca4e 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -8,8 +8,6 @@ let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) module Main (Clock : Mirage_clock.MCLOCK) = struct - module Uplink = Uplink.Make(Clock) - (* Set up networking and listen for incoming packets. *) let network nat qubesDB = (* Read configuration from QubesDB *) diff --git a/uplink.ml b/uplink.ml index 1fde66b..039e6bd 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,66 +9,64 @@ module Eth = Ethernet.Make(Netif) let src = Logs.Src.create "uplink" ~doc:"Network connection to NetVM" module Log = (val Logs.src_log src : Logs.LOG) -module Make(Clock : Mirage_clock.MCLOCK) = struct - module Arp = Arp.Make(Eth)(OS.Time) +module Arp = Arp.Make(Eth)(OS.Time) - type t = { - net : Netif.t; - eth : Eth.t; - arp : Arp.t; - interface : interface; - fragments : Fragments.Cache.t; - } +type t = { + net : Netif.t; + eth : Eth.t; + arp : Arp.t; + interface : interface; + fragments : Fragments.Cache.t; +} - class netvm_iface eth mac ~my_ip ~other_ip : interface = object - val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) - method my_mac = Eth.mac eth - method my_ip = my_ip - method other_ip = other_ip - method writev ethertype fillfn = - FrameQ.send queue (fun () -> - mac >>= fun dst -> - Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error - ) - end - - let listen t get_ts router = - Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> - (* Handle one Ethernet frame from NetVM *) - Eth.input t.eth - ~arpv4:(Arp.input t.arp) - ~ipv4:(fun ip -> - match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with - | exception ex -> - Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) - Cstruct.hexdump_pp frame - ); - Lwt.return_unit - | Error e -> - Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return_unit - | Ok None -> Lwt.return_unit - | Ok (Some packet) -> - Firewall.ipv4_from_netvm router packet - ) - ~ipv6:(fun _ip -> Lwt.return_unit) - frame - ) >|= or_raise "Uplink listen loop" Netif.pp_error - - let interface t = t.interface - - let connect config = - let ip = config.Dao.uplink_our_ip in - Netif.connect "0" >>= fun net -> - Eth.connect net >>= fun eth -> - Arp.connect eth >>= fun arp -> - Arp.add_ip arp ip >>= fun () -> - let netvm_mac = - Arp.query arp config.Dao.uplink_netvm_ip - >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in - let interface = new netvm_iface eth netvm_mac - ~my_ip:ip - ~other_ip:config.Dao.uplink_netvm_ip in - let fragments = Fragments.Cache.create (256 * 1024) in - Lwt.return { net; eth; arp; interface ; fragments } +class netvm_iface eth mac ~my_ip ~other_ip : interface = object + val queue = FrameQ.create (Ipaddr.V4.to_string other_ip) + method my_mac = Eth.mac eth + method my_ip = my_ip + method other_ip = other_ip + method writev ethertype fillfn = + FrameQ.send queue (fun () -> + mac >>= fun dst -> + Eth.write eth dst ethertype fillfn >|= or_raise "Write to uplink" Eth.pp_error + ) end + +let listen t get_ts router = + Netif.listen t.net ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> + (* Handle one Ethernet frame from NetVM *) + Eth.input t.eth + ~arpv4:(Arp.input t.arp) + ~ipv4:(fun ip -> + match Nat_packet.of_ipv4_packet t.fragments ~now:(get_ts ()) ip with + | exception ex -> + Log.err (fun f -> f "Error unmarshalling ethernet frame from uplink: %s@.%a" (Printexc.to_string ex) + Cstruct.hexdump_pp frame + ); + Lwt.return_unit + | Error e -> + Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); + Lwt.return_unit + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> + Firewall.ipv4_from_netvm router packet + ) + ~ipv6:(fun _ip -> Lwt.return_unit) + frame + ) >|= or_raise "Uplink listen loop" Netif.pp_error + +let interface t = t.interface + +let connect config = + let ip = config.Dao.uplink_our_ip in + Netif.connect "0" >>= fun net -> + Eth.connect net >>= fun eth -> + Arp.connect eth >>= fun arp -> + Arp.add_ip arp ip >>= fun () -> + let netvm_mac = + Arp.query arp config.Dao.uplink_netvm_ip + >|= or_raise "Getting MAC of our NetVM" Arp.pp_error in + let interface = new netvm_iface eth netvm_mac + ~my_ip:ip + ~other_ip:config.Dao.uplink_netvm_ip in + let fragments = Fragments.Cache.create (256 * 1024) in + Lwt.return { net; eth; arp; interface ; fragments } diff --git a/uplink.mli b/uplink.mli index 0f494dd..776b1a4 100644 --- a/uplink.mli +++ b/uplink.mli @@ -5,15 +5,13 @@ open Fw_utils -module Make(Clock : Mirage_clock.MCLOCK) : sig - type t +type t - val connect : Dao.network_config -> t Lwt.t - (** Connect to our NetVM (gateway). *) +val connect : Dao.network_config -> t Lwt.t +(** Connect to our NetVM (gateway). *) - val interface : t -> interface - (** The network interface to NetVM. *) +val interface : t -> interface +(** The network interface to NetVM. *) - val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t - (** Handle incoming frames from NetVM. *) -end +val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t +(** Handle incoming frames from NetVM. *) From 8e714c771244d9830036e05ad71c43a43e64d33f Mon Sep 17 00:00:00 2001 From: Thomas Leonard Date: Mon, 13 Jan 2020 10:05:38 +0000 Subject: [PATCH 3/3] Removed unreachable Lwt.catch Spotted by Hannes Mehnert. --- build-with-docker.sh | 2 +- firewall.ml | 42 ++++++++++++++++-------------------------- 2 files changed, 17 insertions(+), 27 deletions(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 5b1bc30..e8e46cd 100755 --- a/build-with-docker.sh +++ b/build-with-docker.sh @@ -5,5 +5,5 @@ 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 qubes_firewall.xen)" -echo "SHA2 last known: 6f8f0f19ba62bf5312039f2904ea8696584f8ff49443dec098facf261449ebf2" +echo "SHA2 last known: 91c5bf44a85339aaf14e4763a29c2b64537f5bc41cd7dc2571af954ec9dd3cad" echo "(hashes should match for released versions)" diff --git a/firewall.ml b/firewall.ml index e80d7a3..96ea516 100644 --- a/firewall.ml +++ b/firewall.ml @@ -12,33 +12,23 @@ module Log = (val Logs.src_log src : Logs.LOG) let transmit_ipv4 packet iface = Lwt.catch (fun () -> - Lwt.catch - (fun () -> - let fragments = ref [] in - iface#writev `IPv4 (fun b -> - match Nat_packet.into_cstruct packet b with - | Error e -> - Log.warn (fun f -> f "Failed to write packet to %a: %a" - Ipaddr.V4.pp iface#other_ip - Nat_packet.pp_error e); - 0 - | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> - Lwt_list.iter_s (fun f -> - let size = Cstruct.len f in - iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) - !fragments) - (fun ex -> - Log.warn (fun f -> f "Failed to write packet to %a: %s" - Ipaddr.V4.pp iface#other_ip - (Printexc.to_string ex)); - Lwt.return_unit - ) - ) + let fragments = ref [] in + iface#writev `IPv4 (fun b -> + match Nat_packet.into_cstruct packet b with + | Error e -> + Log.warn (fun f -> f "Failed to NAT packet to %a: %a" + Ipaddr.V4.pp iface#other_ip + Nat_packet.pp_error e); + 0 + | Ok (n, frags) -> fragments := frags ; n) >>= fun () -> + Lwt_list.iter_s (fun f -> + let size = Cstruct.len f in + iface#writev `IPv4 (fun b -> Cstruct.blit f 0 b 0 size ; size)) + !fragments) (fun ex -> - Log.err (fun f -> f "Exception in transmit_ipv4: %s for:@.%a" - (Printexc.to_string ex) - Nat_packet.pp packet - ); + Log.warn (fun f -> f "Failed to write packet to %a: %s" + Ipaddr.V4.pp iface#other_ip + (Printexc.to_string ex)); Lwt.return_unit )