From c66ee54a9fe24e1ffb05261e3b7cef3d9883ffc9 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 14:34:25 +0100 Subject: [PATCH 1/6] revert bc7706cc97531aaf1f4dd0291a26c2307f32d647, mirage-xen since 5.0.0 reverted the split of OS into Os_xen --- client_net.ml | 2 +- config.ml | 2 +- dao.ml | 8 ++++---- memory_pressure.ml | 10 +++++----- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/client_net.ml b/client_net.ml index df436be..68fe6d3 100644 --- a/client_net.ml +++ b/client_net.ml @@ -4,7 +4,7 @@ open Lwt.Infix open Fw_utils -module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(Os_xen.Xs)) +module Netback = Netchannel.Backend.Make(Netchannel.Xenstore.Make(OS.Xs)) module ClientEth = Ethernet.Make(Netback) let src = Logs.Src.create "client_net" ~doc:"Client networking" diff --git a/config.ml b/config.ml index 55d8c42..ae4f8f4 100644 --- a/config.ml +++ b/config.ml @@ -33,7 +33,7 @@ let main = package "mirage-qubes"; package "mirage-nat" ~min:"1.2.0"; package "mirage-logs"; - package "mirage-xen" ~min:"4.0.0"; + package "mirage-xen" ~min:"5.0.0"; ] "Unikernel.Main" (mclock @-> job) diff --git a/dao.ml b/dao.ml index 55d901e..a68cc64 100644 --- a/dao.ml +++ b/dao.ml @@ -30,7 +30,7 @@ module VifMap = struct end let directory ~handle dir = - Os_xen.Xs.directory handle dir >|= function + OS.Xs.directory handle dir >|= function | [""] -> [] (* XenStore client bug *) | items -> items @@ -46,7 +46,7 @@ let vifs ~handle domid = | Some device_id -> let vif = { ClientVif.domid; device_id } in Lwt.try_bind - (fun () -> Os_xen.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) + (fun () -> OS.Xs.read handle (Printf.sprintf "%s/%d/ip" path device_id)) (fun client_ip -> let client_ip = Ipaddr.V4.of_string_exn client_ip in Lwt.return (Some (vif, client_ip)) @@ -61,10 +61,10 @@ let vifs ~handle domid = ) let watch_clients fn = - Os_xen.Xs.make () >>= fun xs -> + OS.Xs.make () >>= fun xs -> let backend_vifs = "backend/vif" in Log.info (fun f -> f "Watching %s" backend_vifs); - Os_xen.Xs.wait xs (fun handle -> + OS.Xs.wait xs (fun handle -> begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function diff --git a/memory_pressure.ml b/memory_pressure.ml index 92271da..ed5b7e5 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -6,7 +6,7 @@ open Lwt let src = Logs.Src.create "memory_pressure" ~doc:"Memory pressure monitor" module Log = (val Logs.src_log src : Logs.LOG) -let total_pages = Os_xen.MM.Heap_pages.total () +let total_pages = OS.MM.Heap_pages.total () let pagesize_kb = Io_page.page_size / 1024 let meminfo ~used = @@ -23,7 +23,7 @@ let meminfo ~used = let report_mem_usage used = Lwt.async (fun () -> - let open Os_xen in + let open OS in Xs.make () >>= fun xs -> Xs.immediate xs (fun h -> Xs.write h "memory/meminfo" (meminfo ~used) @@ -32,16 +32,16 @@ let report_mem_usage used = let init () = Gc.full_major (); - let used = Os_xen.MM.Heap_pages.used () in + let used = OS.MM.Heap_pages.used () in report_mem_usage used let status () = - let used = Os_xen.MM.Heap_pages.used () |> float_of_int in + let used = OS.MM.Heap_pages.used () |> float_of_int in let frac = used /. float_of_int total_pages in if frac < 0.9 then `Ok else ( Gc.full_major (); - let used = Os_xen.MM.Heap_pages.used () in + let used = OS.MM.Heap_pages.used () in report_mem_usage used; let frac = float_of_int used /. float_of_int total_pages in if frac > 0.9 then `Memory_critical From 0f476c4d7b99b13527bdb9b6270cec9a9bd2fc13 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:36:02 +0100 Subject: [PATCH 2/6] mirage-nat 2.0.0 and mirage-qubes 0.8.0 compatibility --- client_net.ml | 20 +++++++++++--------- client_net.mli | 10 +++++----- firewall.ml | 9 ++++++--- my_nat.ml | 8 +++----- my_nat.mli | 2 +- unikernel.ml | 21 ++++++++++----------- uplink.ml | 13 ++++++++----- uplink.mli | 4 ++-- 8 files changed, 46 insertions(+), 41 deletions(-) diff --git a/client_net.ml b/client_net.ml index 68fe6d3..5cd819d 100644 --- a/client_net.ml +++ b/client_net.ml @@ -56,12 +56,13 @@ let input_arp ~fixed_arp ~iface request = iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size) (** Handle an IPv4 packet from the client. *) -let input_ipv4 ~iface ~router packet = - match Nat_packet.of_ipv4_packet packet with +let input_ipv4 get_ts cache ~iface ~router packet = + match Nat_packet.of_ipv4_packet cache ~now:(get_ts ()) packet with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); Lwt.return () - | Ok packet -> + | Ok None -> Lwt.return () + | Ok (Some packet) -> let `IPv4 (ip, _) = packet in let src = ip.Ipv4_packet.src in if src = iface#other_ip then Firewall.ipv4_from_client router ~src:iface packet @@ -72,7 +73,7 @@ let input_ipv4 ~iface ~router packet = ) (** Connect to a new client's interface and listen for incoming frames. *) -let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = +let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks = Netback.make ~domid ~device_id >>= fun backend -> Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); ClientEth.connect backend >>= fun eth -> @@ -83,6 +84,7 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks Router.add_client router iface >>= fun () -> Cleanup.on_cleanup cleanup_tasks (fun () -> Router.remove_client router iface); let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in + let fragment_cache = Fragments.Cache.create (256 * 1024) in Netback.listen backend ~header_size:Ethernet_wire.sizeof_ethernet (fun frame -> match Ethernet_packet.Unmarshal.of_cstruct frame with | exception ex -> @@ -94,18 +96,18 @@ let add_vif { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanup_tasks | Ok (eth, payload) -> match eth.Ethernet_packet.ethertype with | `ARP -> input_arp ~fixed_arp ~iface payload - | `IPv4 -> input_ipv4 ~iface ~router payload + | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router payload | `IPv6 -> return () (* TODO: oh no! *) ) >|= or_raise "Listen on client interface" Netback.pp_error (** A new client VM has been found in XenStore. Find its interface and connect to it. *) -let add_client ~router vif client_ip = +let add_client get_ts ~router vif client_ip = let cleanup_tasks = Cleanup.create () in Log.info (fun f -> f "add client vif %a with IP %a" Dao.ClientVif.pp vif Ipaddr.V4.pp client_ip); Lwt.async (fun () -> Lwt.catch (fun () -> - add_vif vif ~client_ip ~router ~cleanup_tasks + add_vif get_ts vif ~client_ip ~router ~cleanup_tasks ) (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" @@ -116,7 +118,7 @@ let add_client ~router vif client_ip = cleanup_tasks (** Watch XenStore for notifications of new clients. *) -let listen router = +let listen get_ts router = Dao.watch_clients (fun new_set -> (* Check for removed clients *) !clients |> Dao.VifMap.iter (fun key cleanup -> @@ -129,7 +131,7 @@ let listen router = (* Check for added clients *) new_set |> Dao.VifMap.iter (fun key ip_addr -> if not (Dao.VifMap.mem key !clients) then ( - let cleanup = add_client ~router key ip_addr in + let cleanup = add_client get_ts ~router key ip_addr in clients := !clients |> Dao.VifMap.add key cleanup ) ) diff --git a/client_net.mli b/client_net.mli index 7bc2660..97ebd68 100644 --- a/client_net.mli +++ b/client_net.mli @@ -3,8 +3,8 @@ (** Handling client VMs. *) -val listen : Router.t -> 'a Lwt.t -(** [listen router] is a thread that watches for clients being added to and - removed from XenStore. Clients are connected to the client network and - packets are sent via [router]. We ensure the source IP address is correct - before routing a packet. *) +val listen : (unit -> int64) -> Router.t -> 'a Lwt.t +(** [listen get_timestamp router] is a thread that watches for clients being + added to and removed from XenStore. Clients are connected to the client + network and packets are sent via [router]. We ensure the source IP address + is correct before routing a packet. *) diff --git a/firewall.ml b/firewall.ml index 77656d2..beaa948 100644 --- a/firewall.ml +++ b/firewall.ml @@ -15,6 +15,7 @@ let transmit_ipv4 packet iface = (fun () -> Lwt.catch (fun () -> + let fragments = ref [] in iface#writev `IPv4 (fun b -> match Nat_packet.into_cstruct packet b with | Error e -> @@ -22,9 +23,11 @@ let transmit_ipv4 packet iface = Ipaddr.V4.pp iface#other_ip Nat_packet.pp_error e); 0 - | Ok n -> n - ) - ) + | 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 diff --git a/my_nat.ml b/my_nat.ml index bfaf702..02a4b5a 100644 --- a/my_nat.ml +++ b/my_nat.ml @@ -15,14 +15,13 @@ module Nat = Mirage_nat_lru type t = { table : Nat.t; - get_time : unit -> Mirage_nat.time; } -let create ~get_time ~max_entries = +let create ~max_entries = let tcp_size = 7 * max_entries / 8 in let udp_size = max_entries - tcp_size in Nat.empty ~tcp_size ~udp_size ~icmp_size:100 >|= fun table -> - { get_time; table } + { table } let translate t packet = Nat.translate t.table packet >|= function @@ -41,10 +40,9 @@ let reset t = Nat.reset t.table let add_nat_rule_and_translate t ~xl_host action packet = - let now = t.get_time () in let apply_action xl_port = Lwt.catch (fun () -> - Nat.add t.table ~now packet (xl_host, xl_port) action + Nat.add t.table packet (xl_host, xl_port) action ) (function | Out_of_memory -> Lwt.return (Error `Out_of_memory) diff --git a/my_nat.mli b/my_nat.mli index 770eaa0..cdc5eda 100644 --- a/my_nat.mli +++ b/my_nat.mli @@ -10,7 +10,7 @@ type action = [ | `Redirect of Mirage_nat.endpoint ] -val create : get_time:(unit -> Mirage_nat.time) -> max_entries:int -> t Lwt.t +val create : max_entries:int -> t Lwt.t val reset : t -> unit Lwt.t val translate : t -> Nat_packet.t -> Nat_packet.t option Lwt.t val add_nat_rule_and_translate : t -> xl_host:Ipaddr.V4.t -> diff --git a/unikernel.ml b/unikernel.ml index 84cac6d..25e4739 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -11,11 +11,11 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct module Uplink = Uplink.Make(Clock) (* Set up networking and listen for incoming packets. *) - let network ~clock nat qubesDB = + let network nat qubesDB = (* Read configuration from QubesDB *) Dao.read_network_config qubesDB >>= fun config -> (* Initialise connection to NetVM *) - Uplink.connect ~clock config >>= fun uplink -> + Uplink.connect config >>= fun uplink -> (* Report success *) Dao.set_iptables_error qubesDB "" >>= fun () -> (* Set up client-side networking *) @@ -29,8 +29,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct in (* Handle packets from both networks *) Lwt.choose [ - Client_net.listen router; - Uplink.listen uplink router + Client_net.listen Clock.elapsed_ns router; + Uplink.listen uplink Clock.elapsed_ns router ] (* We don't use the GUI, but it's interesting to keep an eye on it. @@ -41,7 +41,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (fun () -> gui >>= fun gui -> Log.info (fun f -> f "GUI agent connected"); - GUI.listen gui + GUI.listen gui () ) (fun `Cant_happen -> assert false) (fun ex -> @@ -51,8 +51,8 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct ) (* Main unikernel entry point (called from auto-generated main.ml). *) - let start clock = - let start_time = Clock.elapsed_ns clock in + let start _clock = + let start_time = Clock.elapsed_ns () in (* Start qrexec agent, GUI agent and QubesDB agent in parallel *) let qrexec = RExec.connect ~domid:0 () in GUI.connect ~domid:0 () |> watch_gui; @@ -63,7 +63,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct qubesDB >>= fun qubesDB -> let startup_time = let (-) = Int64.sub in - let time_in_ns = Clock.elapsed_ns clock - start_time in + let time_in_ns = Clock.elapsed_ns () - start_time in Int64.to_float time_in_ns /. 1e9 in Log.info (fun f -> f "QubesDB and qrexec agents connected in %.3f s" startup_time); @@ -72,10 +72,9 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> return () in (* Set up networking *) - let get_time () = Clock.elapsed_ns clock in let max_entries = Key_gen.nat_table_size () in - My_nat.create ~get_time ~max_entries >>= fun nat -> - let net_listener = network ~clock nat qubesDB in + My_nat.create ~max_entries >>= fun nat -> + let net_listener = network nat qubesDB in (* Report memory usage to XenStore *) Memory_pressure.init (); (* Run until something fails or we get a shutdown request. *) diff --git a/uplink.ml b/uplink.ml index 06d4df3..92b46a6 100644 --- a/uplink.ml +++ b/uplink.ml @@ -17,6 +17,7 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct eth : Eth.t; arp : Arp.t; interface : interface; + fragments : Fragments.Cache.t; } class netvm_iface eth mac ~my_ip ~other_ip : interface = object @@ -31,13 +32,13 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct ) end - let listen t router = + 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 ip with + 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 @@ -46,7 +47,8 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); Lwt.return () - | Ok packet -> + | Ok None -> Lwt.return_unit + | Ok (Some packet) -> Firewall.ipv4_from_netvm router packet ) ~ipv6:(fun _ip -> return ()) @@ -55,7 +57,7 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let interface t = t.interface - let connect ~clock:_ config = + let connect config = let ip = config.Dao.uplink_our_ip in Netif.connect "0" >>= fun net -> Eth.connect net >>= fun eth -> @@ -67,5 +69,6 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct let interface = new netvm_iface eth netvm_mac ~my_ip:ip ~other_ip:config.Dao.uplink_netvm_ip in - return { net; eth; arp; interface } + let fragments = Fragments.Cache.create (256 * 1024) in + return { net; eth; arp; interface ; fragments } end diff --git a/uplink.mli b/uplink.mli index 6e2f5f4..14fbd86 100644 --- a/uplink.mli +++ b/uplink.mli @@ -8,12 +8,12 @@ open Fw_utils module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig type t - val connect : clock:Clock.t -> Dao.network_config -> t Lwt.t + val connect : Dao.network_config -> t Lwt.t (** Connect to our NetVM (gateway). *) val interface : t -> interface (** The network interface to NetVM. *) - val listen : t -> Router.t -> unit Lwt.t + val listen : t -> (unit -> int64) -> Router.t -> unit Lwt.t (** Handle incoming frames from NetVM. *) end From 3fc418e80cafc8b6cc6f137e613d5f04b23aa825 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:39:20 +0100 Subject: [PATCH 3/6] qualify all return with Lwt, use Lwt.return_unit where possible --- client_net.ml | 18 +++++++++--------- config.ml | 4 ++-- dao.ml | 7 +++---- firewall.ml | 25 ++++++++++++------------- fw_utils.ml | 3 --- unikernel.ml | 4 ++-- uplink.ml | 6 +++--- 7 files changed, 31 insertions(+), 36 deletions(-) diff --git a/client_net.ml b/client_net.ml index 5cd819d..4665aa1 100644 --- a/client_net.ml +++ b/client_net.ml @@ -23,7 +23,7 @@ let writev eth dst proto fillfn = (* Usually Netback_shutdown, because the client disconnected *) Log.err (fun f -> f "uncaught exception trying to send to client: @[%s@]" (Printexc.to_string ex)); - Lwt.return () + Lwt.return_unit ) class client_iface eth ~domid ~gateway_ip ~client_ip client_mac : client_link = @@ -48,10 +48,10 @@ let input_arp ~fixed_arp ~iface request = match Arp_packet.decode request with | Error e -> Log.warn (fun f -> f "Ignored unknown ARP message: %a" Arp_packet.pp_error e); - Lwt.return () + Lwt.return_unit | Ok arp -> match Client_eth.ARP.input fixed_arp arp with - | None -> return () + | None -> Lwt.return_unit | Some response -> iface#writev `ARP (fun b -> Arp_packet.encode_into response b; Arp_packet.size) @@ -60,8 +60,8 @@ let input_ipv4 get_ts cache ~iface ~router packet = match Nat_packet.of_ipv4_packet cache ~now:(get_ts ()) packet with | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message: %a" Nat_packet.pp_error e); - Lwt.return () - | Ok None -> Lwt.return () + Lwt.return_unit + | Ok None -> Lwt.return_unit | Ok (Some packet) -> let `IPv4 (ip, _) = packet in let src = ip.Ipv4_packet.src in @@ -69,7 +69,7 @@ let input_ipv4 get_ts cache ~iface ~router packet = else ( Log.warn (fun f -> f "Incorrect source IP %a in IP packet from %a (dropping)" Ipaddr.V4.pp src Ipaddr.V4.pp iface#other_ip); - return () + Lwt.return_unit ) (** Connect to a new client's interface and listen for incoming frames. *) @@ -92,12 +92,12 @@ let add_vif get_ts { Dao.ClientVif.domid; device_id } ~client_ip ~router ~cleanu Cstruct.hexdump_pp frame ); Lwt.return_unit - | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); return () + | Error err -> Log.warn (fun f -> f "Invalid Ethernet frame: %s" err); Lwt.return_unit | Ok (eth, payload) -> match eth.Ethernet_packet.ethertype with | `ARP -> input_arp ~fixed_arp ~iface payload | `IPv4 -> input_ipv4 get_ts fragment_cache ~iface ~router payload - | `IPv6 -> return () (* TODO: oh no! *) + | `IPv6 -> Lwt.return_unit (* TODO: oh no! *) ) >|= or_raise "Listen on client interface" Netback.pp_error @@ -112,7 +112,7 @@ let add_client get_ts ~router vif client_ip = (fun ex -> Log.warn (fun f -> f "Error with client %a: %s" Dao.ClientVif.pp vif (Printexc.to_string ex)); - return () + Lwt.return_unit ) ); cleanup_tasks diff --git a/config.ml b/config.ml index ae4f8f4..5e284fb 100644 --- a/config.ml +++ b/config.ml @@ -30,8 +30,8 @@ let main = package "netchannel" ~min:"1.11.0"; package "mirage-net-xen"; package "ipaddr" ~min:"4.0.0"; - package "mirage-qubes"; - package "mirage-nat" ~min:"1.2.0"; + package "mirage-qubes" ~min:"0.8.0"; + package "mirage-nat" ~min:"2.0.0"; package "mirage-logs"; package "mirage-xen" ~min:"5.0.0"; ] diff --git a/dao.ml b/dao.ml index a68cc64..a34b8b7 100644 --- a/dao.ml +++ b/dao.ml @@ -3,7 +3,6 @@ open Lwt.Infix open Qubes -open Fw_utils open Astring let src = Logs.Src.create "dao" ~doc:"QubesDB data access" @@ -68,13 +67,13 @@ let watch_clients fn = begin Lwt.catch (fun () -> directory ~handle backend_vifs) (function - | Xs_protocol.Enoent _ -> return [] - | ex -> fail ex) + | Xs_protocol.Enoent _ -> Lwt.return [] + | ex -> Lwt.fail ex) end >>= fun items -> Lwt_list.map_p (vifs ~handle) items >>= fun items -> fn (List.concat items |> VifMap.of_list); (* Wait for further updates *) - fail Xs_protocol.Eagain + Lwt.fail Xs_protocol.Eagain ) type network_config = { diff --git a/firewall.ml b/firewall.ml index beaa948..e80d7a3 100644 --- a/firewall.ml +++ b/firewall.ml @@ -1,7 +1,6 @@ (* Copyright (C) 2015, Thomas Leonard See the README file for details. *) -open Fw_utils open Packet open Lwt.Infix @@ -32,7 +31,7 @@ let transmit_ipv4 packet iface = Log.warn (fun f -> f "Failed to write packet to %a: %s" Ipaddr.V4.pp iface#other_ip (Printexc.to_string ex)); - Lwt.return () + Lwt.return_unit ) ) (fun ex -> @@ -40,7 +39,7 @@ let transmit_ipv4 packet iface = (Printexc.to_string ex) Nat_packet.pp packet ); - Lwt.return () + Lwt.return_unit ) let forward_ipv4 t packet = @@ -127,19 +126,19 @@ let add_nat_and_forward_ipv4 t packet = | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT rewrite rule: %s (%a)" e pp_header packet); - Lwt.return () + Lwt.return_unit (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) let nat_to t ~host ~port packet = match Router.resolve t host with - | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return () + | Ipaddr.V6 _ -> Log.warn (fun f -> f "Cannot NAT with IPv6"); Lwt.return_unit | Ipaddr.V4 target -> let xl_host = t.Router.uplink#my_ip in My_nat.add_nat_rule_and_translate t.Router.nat ~xl_host (`Redirect (target, port)) packet >>= function | Ok packet -> forward_ipv4 t packet | Error e -> Log.warn (fun f -> f "Failed to add NAT redirect rule: %s (%a)" e pp_header packet); - Lwt.return () + Lwt.return_unit (* Handle incoming packets *) @@ -150,12 +149,12 @@ let apply_rules t rules ~dst info = | `Accept, (`External _ | `NetVM) -> transmit_ipv4 packet t.Router.uplink | `Accept, `Firewall -> Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" (pp_packet t) info); - return () + Lwt.return_unit | `NAT, _ -> add_nat_and_forward_ipv4 t packet | `NAT_to (host, port), _ -> nat_to t packet ~host ~port | `Drop reason, _ -> Log.info (fun f -> f "Dropped packet (%s) %a" reason (pp_packet t) info); - return () + Lwt.return_unit let handle_low_memory t = match Memory_pressure.status () with @@ -167,7 +166,7 @@ let handle_low_memory t = let ipv4_from_client t ~src packet = handle_low_memory t >>= function - | `Memory_critical -> return () + | `Memory_critical -> Lwt.return_unit | `Ok -> (* Check for existing NAT entry for this packet *) translate t packet >>= function @@ -177,23 +176,23 @@ let ipv4_from_client t ~src packet = let `IPv4 (ip, _transport) = packet in let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in match classify ~src:(resolve_client src) ~dst:(resolve_host dst) packet with - | None -> return () + | None -> Lwt.return_unit | Some info -> apply_rules t Rules.from_client ~dst info let ipv4_from_netvm t packet = handle_low_memory t >>= function - | `Memory_critical -> return () + | `Memory_critical -> Lwt.return_unit | `Ok -> let `IPv4 (ip, _transport) = packet in let src = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.src) in let dst = Router.classify t (Ipaddr.V4 ip.Ipv4_packet.dst) in match classify ~src ~dst:(resolve_host dst) packet with - | None -> return () + | None -> Lwt.return_unit | Some info -> match src with | `Client _ | `Firewall -> Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" (pp_packet t) info); - return () + Lwt.return_unit | `External _ | `NetVM as src -> translate t packet >>= function | Some frame -> forward_ipv4 t frame diff --git a/fw_utils.ml b/fw_utils.ml index c034e72..9c5bab4 100644 --- a/fw_utils.ml +++ b/fw_utils.ml @@ -41,9 +41,6 @@ let error fmt = let err s = Failure s in Printf.ksprintf err fmt -let return = Lwt.return -let fail = Lwt.fail - let or_raise msg pp = function | Ok x -> x | Error e -> failwith (Fmt.strf "%s: %a" msg pp e) diff --git a/unikernel.ml b/unikernel.ml index 25e4739..2b20c9f 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -46,7 +46,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (fun `Cant_happen -> assert false) (fun ex -> Log.warn (fun f -> f "GUI thread failed: %s" (Printexc.to_string ex)); - return () + Lwt.return_unit ) ) @@ -70,7 +70,7 @@ module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct (* Watch for shutdown requests from Qubes *) let shutdown_rq = OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> - return () in + Lwt.return_unit in (* Set up networking *) let max_entries = Key_gen.nat_table_size () in My_nat.create ~max_entries >>= fun nat -> diff --git a/uplink.ml b/uplink.ml index 92b46a6..042fc84 100644 --- a/uplink.ml +++ b/uplink.ml @@ -46,12 +46,12 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct Lwt.return_unit | Error e -> Log.warn (fun f -> f "Ignored unknown IPv4 message from uplink: %a" Nat_packet.pp_error e); - Lwt.return () + Lwt.return_unit | Ok None -> Lwt.return_unit | Ok (Some packet) -> Firewall.ipv4_from_netvm router packet ) - ~ipv6:(fun _ip -> return ()) + ~ipv6:(fun _ip -> Lwt.return_unit) frame ) >|= or_raise "Uplink listen loop" Netif.pp_error @@ -70,5 +70,5 @@ module Make(Clock : Mirage_clock_lwt.MCLOCK) = struct ~my_ip:ip ~other_ip:config.Dao.uplink_netvm_ip in let fragments = Fragments.Cache.create (256 * 1024) in - return { net; eth; arp; interface ; fragments } + Lwt.return { net; eth; arp; interface ; fragments } end From 28bda78d209d8a436b3e6eff8a2142cac68a3093 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:46:02 +0100 Subject: [PATCH 4/6] fix deprecation warnings (Mirage_clock_lwt -> Mirage_clock) --- unikernel.ml | 2 +- uplink.ml | 2 +- uplink.mli | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unikernel.ml b/unikernel.ml index 2b20c9f..27f772a 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -7,7 +7,7 @@ open Qubes let src = Logs.Src.create "unikernel" ~doc:"Main unikernel code" module Log = (val Logs.src_log src : Logs.LOG) -module Main (Clock : Mirage_clock_lwt.MCLOCK) = struct +module Main (Clock : Mirage_clock.MCLOCK) = struct module Uplink = Uplink.Make(Clock) (* Set up networking and listen for incoming packets. *) diff --git a/uplink.ml b/uplink.ml index 042fc84..1fde66b 100644 --- a/uplink.ml +++ b/uplink.ml @@ -9,7 +9,7 @@ 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_lwt.MCLOCK) = struct +module Make(Clock : Mirage_clock.MCLOCK) = struct module Arp = Arp.Make(Eth)(OS.Time) type t = { diff --git a/uplink.mli b/uplink.mli index 14fbd86..0f494dd 100644 --- a/uplink.mli +++ b/uplink.mli @@ -5,7 +5,7 @@ open Fw_utils -module Make(Clock : Mirage_clock_lwt.MCLOCK) : sig +module Make(Clock : Mirage_clock.MCLOCK) : sig type t val connect : Dao.network_config -> t Lwt.t From 730957d19b00b66e03f6114915f01c45b13c88c3 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 15:46:22 +0100 Subject: [PATCH 5/6] upgrade opam repository to current head and mirage to 3.7.4 --- Dockerfile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/Dockerfile b/Dockerfile index c6ef858..3125969 100644 --- a/Dockerfile +++ b/Dockerfile @@ -7,9 +7,9 @@ FROM ocurrent/opam@sha256:3f3ce7e577a94942c7f9c63cbdd1ecbfe0ea793f581f69047f3155 # 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 fetch origin master && git reset --hard 5eed470abc5c7991e448c9653698c03d6ea146d1 && opam update +RUN cd ~/opam-repository && git fetch origin master && git reset --hard d205c265cee9a86869259180fd2238da98370430 && opam update -RUN opam depext -i -y mirage.3.5.2 lwt +RUN opam depext -i -y mirage.3.7.4 lwt RUN mkdir /home/opam/qubes-mirage-firewall ADD config.ml /home/opam/qubes-mirage-firewall/config.ml WORKDIR /home/opam/qubes-mirage-firewall From a734bcd2d3d87a93ce7cfd60d04c730520367d70 Mon Sep 17 00:00:00 2001 From: Hannes Mehnert Date: Sat, 11 Jan 2020 16:01:08 +0100 Subject: [PATCH 6/6] [ci skip] adjust expected sha256 --- build-with-docker.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/build-with-docker.sh b/build-with-docker.sh index 31dd331..d2944fe 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: cae3c66d38a50671f694cd529062c538592438b95935d707b97d80b57fbfc186" +echo "SHA2 last known: 8a337e61e7d093f7c1f0fa5fe277dace4d606bfa06cfde3f2d61d6bdee6eefbc" echo "(hashes should match for released versions)"