diff --git a/.travis.yml b/.travis.yml index 3c0a765..64a3562 100644 --- a/.travis.yml +++ b/.travis.yml @@ -19,4 +19,4 @@ addons: - camlp4-extra - time env: - - FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-xen:https://github.com/talex5/mirage-platform.git#mm mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum tcpip:https://github.com/mirage/mirage-tcpip.git mirage-net-xen:https://github.com/talex5/mirage-net-xen.git#disconnect" + - FORK_USER=talex5 FORK_BRANCH=unikernel OCAML_VERSION=4.02 MIRAGE_BACKEND=xen PINS="mirage-xen:https://github.com/talex5/mirage-platform.git#mm mirage-qubes:https://github.com/talex5/mirage-qubes.git mirage-nat:https://github.com/talex5/mirage-nat.git#simplify-checksum tcpip:https://github.com/mirage/mirage-tcpip.git mirage-net-xen:https://github.com/talex5/mirage-net-xen.git#disconnect" diff --git a/README.md b/README.md index 4955131..ea11b28 100644 --- a/README.md +++ b/README.md @@ -22,6 +22,7 @@ To build (tested by creating a fresh Fedora 23 AppVM in Qubes): opam pin add -y mirage-xen 'https://github.com/talex5/mirage-platform.git#mm' opam pin add -y mirage-net-xen 'https://github.com/talex5/mirage-net-xen.git#disconnect' opam pin add -y tcpip https://github.com/mirage/mirage-tcpip.git + opam pin add -y mirage-qubes https://github.com/talex5/mirage-qubes.git opam pin add -y mirage-nat 'https://github.com/talex5/mirage-nat.git#simplify-checksum' opam install mirage diff --git a/client_eth.ml b/client_eth.ml index 4d0248d..af0f299 100644 --- a/client_eth.ml +++ b/client_eth.ml @@ -109,16 +109,16 @@ module ARP = struct let input_query t frame = let open Arpv4_wire in let req_ipv4 = Ipaddr.V4.of_int32 (get_arp_tpa frame) in - Log.info "who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4)); + Log.info (fun f -> f "who-has %s?" (Ipaddr.V4.to_string req_ipv4)); if req_ipv4 = t.client_link#other_ip then ( - Log.info "ignoring request for client's own IP" Logs.unit; + Log.info (fun f -> f "ignoring request for client's own IP"); None ) else match lookup t req_ipv4 with | None -> - Log.info "unknown address; not responding" Logs.unit; + Log.info (fun f -> f "unknown address; not responding"); None | Some req_mac -> - Log.info "responding to: who-has %s?" (fun f -> f (Ipaddr.V4.to_string req_ipv4)); + Log.info (fun f -> f "responding to: who-has %s?" (Ipaddr.V4.to_string req_ipv4)); Some (to_wire { op = `Reply; (* The Target Hardware Address and IP are copied from the request *) @@ -134,18 +134,18 @@ module ARP = struct let sha = Macaddr.of_bytes_exn (copy_arp_sha frame) in match lookup t spa with | Some real_mac when Macaddr.compare sha real_mac = 0 -> - Log.info "client suggests updating %s -> %s (as expected)" - (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)); + Log.info (fun f -> f "client suggests updating %s -> %s (as expected)" + (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)); | Some other_mac -> - Log.warn "client suggests incorrect update %s -> %s (should be %s)" - (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac)); + Log.warn (fun f -> f "client suggests incorrect update %s -> %s (should be %s)" + (Ipaddr.V4.to_string spa) (Macaddr.to_string sha) (Macaddr.to_string other_mac)); | None -> - Log.warn "client suggests incorrect update %s -> %s (unexpected IP)" - (fun f -> f (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)) + Log.warn (fun f -> f "client suggests incorrect update %s -> %s (unexpected IP)" + (Ipaddr.V4.to_string spa) (Macaddr.to_string sha)) let input t frame = match Arpv4_wire.get_arp_op frame with |1 -> input_query t frame |2 -> input_gratuitous t frame; None - |n -> Log.warn "unknown message %d - ignored" (fun f -> f n); None + |n -> Log.warn (fun f -> f "unknown message %d - ignored" n); None end diff --git a/client_net.ml b/client_net.ml index 83710d3..2c9c2f5 100644 --- a/client_net.ml +++ b/client_net.ml @@ -33,16 +33,15 @@ let input_ipv4 ~client_ip ~router frame packet = let src = Wire_structs.Ipv4_wire.get_ipv4_src packet |> Ipaddr.V4.of_int32 in if src = client_ip then Firewall.ipv4_from_client router frame else ( - Log.warn "Incorrect source IP %a in IP packet from %a (dropping)" - (fun f -> f Ipaddr.V4.pp_hum src Ipaddr.V4.pp_hum client_ip); + 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); return () ) (** Connect to a new client's interface and listen for incoming frames. *) let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks = Netback.make ~domid ~device_id >>= fun backend -> - Log.info "Client %d (IP: %s) ready" (fun f -> - f domid (Ipaddr.V4.to_string client_ip)); + Log.info (fun f -> f "Client %d (IP: %s) ready" domid (Ipaddr.V4.to_string client_ip)); ClientEth.connect backend >>= or_fail "Can't make Ethernet device" >>= fun eth -> let client_mac = Netback.mac backend in let client_eth = router.Router.client_eth in @@ -53,32 +52,32 @@ let add_vif { Dao.domid; device_id; client_ip } ~router ~cleanup_tasks = let fixed_arp = Client_eth.ARP.create ~net:client_eth iface in Netback.listen backend (fun frame -> match Wire_structs.parse_ethernet_frame frame with - | None -> Log.warn "Invalid Ethernet frame" Logs.unit; return () + | None -> Log.warn (fun f -> f "Invalid Ethernet frame"); return () | Some (typ, _destination, payload) -> match typ with | Some Wire_structs.ARP -> input_arp ~fixed_arp ~eth payload | Some Wire_structs.IPv4 -> input_ipv4 ~client_ip ~router frame payload | Some Wire_structs.IPv6 -> return () - | None -> Logs.warn "Unknown Ethernet type" Logs.unit; Lwt.return_unit + | None -> Logs.warn (fun f -> f "Unknown Ethernet type"); Lwt.return_unit ) (** A new client VM has been found in XenStore. Find its interface and connect to it. *) let add_client ~router domid = let cleanup_tasks = Cleanup.create () in - Log.info "add client domain %d" (fun f -> f domid); + Log.info (fun f -> f "add client domain %d" domid); Lwt.async (fun () -> Lwt.catch (fun () -> Dao.client_vifs domid >>= function | [] -> - Log.warn "Client has no interfaces" Logs.unit; + Log.warn (fun f -> f "Client has no interfaces"); return () | vif :: others -> - if others <> [] then Log.warn "Client has multiple interfaces; using first" Logs.unit; + if others <> [] then Log.warn (fun f -> f "Client has multiple interfaces; using first"); add_vif vif ~router ~cleanup_tasks ) (fun ex -> - Log.warn "Error connecting client domain %d: %s" - (fun f -> f domid (Printexc.to_string ex)); + Log.warn (fun f -> f "Error connecting client domain %d: %s" + domid (Printexc.to_string ex)); return () ) ); @@ -87,13 +86,13 @@ let add_client ~router domid = (** Watch XenStore for notifications of new clients. *) let listen router = let backend_vifs = "backend/vif" in - Log.info "Watching %s" (fun f -> f backend_vifs); + Log.info (fun f -> f "Watching %s" backend_vifs); Dao.watch_clients (fun new_set -> (* Check for removed clients *) !clients |> IntMap.iter (fun key cleanup -> if not (IntSet.mem key new_set) then ( clients := !clients |> IntMap.remove key; - Log.info "client %d has gone" (fun f -> f key); + Log.info (fun f -> f "client %d has gone" key); Cleanup.cleanup cleanup ) ); diff --git a/command.ml b/command.ml index c2dad09..da70727 100644 --- a/command.ml +++ b/command.ml @@ -12,14 +12,14 @@ module Log = (val Logs.src_log src : Logs.LOG) let set_date_time flow = Flow.read_line flow >|= function - | `Eof -> Log.warn "EOF reading time from dom0" Logs.unit; 1 - | `Ok line -> Log.info "TODO: set time to %S" (fun f -> f line); 0 + | `Eof -> Log.warn (fun f -> f "EOF reading time from dom0"); 1 + | `Ok line -> Log.info (fun f -> f "TODO: set time to %S" line); 0 let handler ~user:_ cmd flow = (* Write a message to the client and return an exit status of 1. *) let error fmt = fmt |> Printf.ksprintf @@ fun s -> - Log.warn "<< %s" (fun f -> f s); + Log.warn (fun f -> f "<< %s" s); Flow.ewritef flow "%s [while processing %S]" s cmd >|= fun () -> 1 in match cmd with | "QUBESRPC qubes.SetDateTime dom0" -> set_date_time flow diff --git a/firewall.ml b/firewall.ml index 74fcbe6..2329611 100644 --- a/firewall.ml +++ b/firewall.ml @@ -33,7 +33,7 @@ let ports transport = let classify t frame = match Nat_rewrite.layers frame with | None -> - Log.warn "Failed to parse frame" Logs.unit; + Log.warn (fun f -> f "Failed to parse frame"); None | Some (_eth, ip, transport) -> let src, dst = Nat_rewrite.addresses_of_ip ip in @@ -81,31 +81,31 @@ let translate t frame = let random_user_port () = 1024 + Random.int (0xffff - 1024) -let rec add_nat_rule_and_transmit ?(retries=100) t frame fn fmt logf = +let rec add_nat_rule_and_transmit ?(retries=100) t frame fn logf = let xl_port = random_user_port () in match fn xl_port with | exception Out_of_memory -> (* Because hash tables resize in big steps, this can happen even if we have a fair chunk of free memory. *) - Log.warn "Out_of_memory adding NAT rule. Dropping NAT table..." Logs.unit; + Log.warn (fun f -> f "Out_of_memory adding NAT rule. Dropping NAT table..."); Router.reset t; - add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn fmt logf + add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf | Nat_rewrite.Overlap when retries < 0 -> return () | Nat_rewrite.Overlap -> if retries = 0 then ( - Log.warn "Failed to find a free port; resetting NAT table" Logs.unit; + Log.warn (fun f -> f "Failed to find a free port; resetting NAT table"); Router.reset t; ); - add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn fmt logf (* Try a different port *) + add_nat_rule_and_transmit ~retries:(retries - 1) t frame fn logf (* Try a different port *) | Nat_rewrite.Unparseable -> - Log.warn "Failed to add NAT rule: Unparseable" Logs.unit; + Log.warn (fun f -> f "Failed to add NAT rule: Unparseable"); return () | Nat_rewrite.Ok _ -> - Log.info fmt (logf xl_port); + Log.info (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; + Log.warn (fun f -> f "No NAT entry, even after adding one!"); return () (* Add a NAT rule for the endpoints in this frame, via a random port on the firewall. *) @@ -113,14 +113,13 @@ let add_nat_and_forward_ipv4 t ~frame = let xl_host = Ipaddr.V4 t.Router.uplink#my_ip in add_nat_rule_and_transmit t frame (Nat_rewrite.make_nat_entry t.Router.nat frame xl_host) - "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) + f "added NAT entry: %s:%d -> firewall:%d -> %d:%s" (Ipaddr.to_string src) sport xl_port dport (Ipaddr.to_string dst) ) (* Add a NAT rule to redirect this conversation to [host:port] instead of us. *) @@ -131,14 +130,14 @@ let nat_to t ~frame ~host ~port = (fun xl_port -> Nat_rewrite.make_redirect_entry t.Router.nat frame (xl_host, xl_port) (target, port) ) - "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a" (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 pp_host host + f "added NAT redirect %s:%d -> %d:firewall:%d -> %d:%a" + (Ipaddr.to_string src) sport dport xl_port port pp_host host ) (* Handle incoming packets *) @@ -149,21 +148,21 @@ let apply_rules t rules info = | `Accept, `Client client_link -> transmit ~frame client_link | `Accept, (`External _ | `NetVM) -> transmit ~frame t.Router.uplink | `Accept, `Unknown_client _ -> - Log.warn "Dropping packet to unknown client %a" (fun f -> f pp_packet info); + Log.warn (fun f -> f "Dropping packet to unknown client %a" 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); + Log.warn (fun f -> f "Bad rule: firewall can't accept packets %a" pp_packet info); return () | `NAT, _ -> add_nat_and_forward_ipv4 t ~frame | `NAT_to (host, port), _ -> nat_to t ~frame ~host ~port | `Drop reason, _ -> - Log.info "Dropped packet (%s) %a" (fun f -> f reason pp_packet info); + Log.info (fun f -> f "Dropped packet (%s) %a" reason pp_packet info); return () let handle_low_memory t = match Memory_pressure.status () with | `Memory_critical -> (* TODO: should happen before copying and async *) - Log.warn "Memory low - dropping packet and resetting NAT table" Logs.unit; + Log.warn (fun f -> f "Memory low - dropping packet and resetting NAT table"); Router.reset t; `Memory_critical | `Ok -> `Ok @@ -190,7 +189,7 @@ let ipv4_from_netvm t frame = | 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); + Log.warn (fun f -> f "Frame from NetVM has internal source IP address! %a" pp_packet info); return () | `External _ | `NetVM -> match translate t frame with diff --git a/memory_pressure.ml b/memory_pressure.ml index 21e8b17..ed5b7e5 100644 --- a/memory_pressure.ml +++ b/memory_pressure.ml @@ -12,8 +12,8 @@ let pagesize_kb = Io_page.page_size / 1024 let meminfo ~used = let mem_total = total_pages * pagesize_kb in let mem_free = (total_pages - used) * pagesize_kb in - Log.info "Writing meminfo: free %d / %d kB (%.2f %%)" - (fun f -> f mem_free mem_total (float_of_int mem_free /. float_of_int mem_total *. 100.0)); + Log.info (fun f -> f "Writing meminfo: free %d / %d kB (%.2f %%)" + mem_free mem_total (float_of_int mem_free /. float_of_int mem_total *. 100.0)); Printf.sprintf "MemTotal: %d kB\n\ MemFree: %d kB\n\ Buffers: 0 kB\n\ diff --git a/mirage_logs.ml b/mirage_logs.ml index 499a629..d337881 100644 --- a/mirage_logs.ml +++ b/mirage_logs.ml @@ -19,7 +19,7 @@ let fmt_timestamp tm = module Make (C : V1.CLOCK) = struct let init_logging () = - let report src level k fmt msgf = + let report src level ~over k msgf = let now = C.time () |> Clock.gmtime |> fmt_timestamp in let lvl = string_of_level level in let k _ = @@ -28,8 +28,9 @@ module Make (C : V1.CLOCK) = struct output_string stderr (msg ^ "\n"); flush stderr; MProf.Trace.label msg; + over (); k () in - msgf @@ fun ?header:_ ?tags:_ -> + msgf @@ fun ?header:_ ?tags:_ fmt -> Format.kfprintf k log_fmt ("%s: %s [%s] " ^^ fmt) now lvl (Logs.Src.name src) in Logs.set_reporter { Logs.report } end diff --git a/router.ml b/router.ml index ba1a2c3..a36c1bb 100644 --- a/router.ml +++ b/router.ml @@ -25,8 +25,8 @@ let target t buf = match Client_eth.lookup t.client_eth dst_ip with | Some client_link -> Some (client_link :> interface) | None -> - Log.warn "Packet to unknown internal client %a - dropping" - (fun f -> f Ipaddr.V4.pp_hum dst_ip); + Log.warn (fun f -> f "Packet to unknown internal client %a - dropping" + Ipaddr.V4.pp_hum dst_ip); None ) else Some t.uplink diff --git a/unikernel.ml b/unikernel.ml index 911bfe5..ef5799b 100644 --- a/unikernel.ml +++ b/unikernel.ml @@ -21,8 +21,8 @@ module Main (Clock : V1.CLOCK) = struct let network qubesDB = (* Read configuration from QubesDB *) let config = Dao.read_network_config qubesDB in - Logs.info "Client (internal) network is %a" - (fun f -> f Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix); + Logs.info (fun f -> f "Client (internal) network is %a" + Ipaddr.V4.Prefix.pp_hum config.Dao.clients_prefix); (* Initialise connection to NetVM *) Uplink.connect config >>= fun uplink -> (* Report success *) @@ -55,10 +55,12 @@ module Main (Clock : V1.CLOCK) = struct gui >>= fun gui -> Lwt.async (fun () -> GUI.listen gui); qubesDB >>= fun qubesDB -> - Log.info "agents connected in %.3f s (CPU time used since boot: %.3f s)" - (fun f -> f (Clock.time () -. start_time) (Sys.time ())); + Log.info (fun f -> f "agents connected in %.3f s (CPU time used since boot: %.3f s)" + (Clock.time () -. start_time) (Sys.time ())); (* Watch for shutdown requests from Qubes *) - let shutdown_rq = OS.Lifecycle.await_shutdown () >>= fun (`Poweroff | `Reboot) -> return () in + let shutdown_rq = + OS.Lifecycle.await_shutdown_request () >>= fun (`Poweroff | `Reboot) -> + return () in (* Set up networking *) let net_listener = network qubesDB in (* Report memory usage to XenStore *)