WIP: add some network diagnostics

src/bin/curl.ml

@@ -0,0 +1,80 @@
+(* A debug tool, intended to check the I/O subsystem is working correctly. *)
+
+open Lwt.Infix
+
+let lookup host =
+  Host.Dns.getaddrinfo host `INET
+  >>= function
+  | [] ->
+    Lwt.fail_with (Printf.sprintf "unable to lookup %s" host)
+  | Ipaddr.V6 _ :: _ ->
+    Lwt.fail_with "IPv6 not currently supported."
+  | Ipaddr.V4 ipv4 :: _ ->
+    Lwt.return (Ipaddr.V4 ipv4)
+
+module Client(FLOW: Mirage_flow.S) = struct
+  module C = Mirage_channel.Make(FLOW)
+  let get flow host path =
+    let request = "GET " ^ path ^ " HTTP/1.0\r\nHost: " ^ host ^ "\r\nConnection: close\r\n\r\n" in
+    let c = C.create flow in
+    Printf.printf "writing\n%s\n" request;
+    C.write_string c request 0 (String.length request);
+    C.flush c
+    >>= function
+    | Error e ->
+      Printf.printf "error sending request: %s\n" (Fmt.str "%a" C.pp_write_error e);
+      Lwt.return_unit
+    | Ok () ->
+      let rec loop () =
+        C.read_some c >>= function
+        | Ok `Eof        -> Lwt.return_unit
+        | Error e        ->
+          Printf.printf "error reading response: %s\n" (Fmt.str "%a" C.pp_error e);
+          Lwt.return_unit
+        | Ok (`Data buf) ->
+          print_string (Cstruct.to_string buf);
+          loop () in
+      loop ()
+end
+
+let curl _verbose urls =
+  let module HTTP = Client(Host.Sockets.Stream.Tcp) in
+  let fetch host port path =
+    let path = if path = "" then "/" else path in
+    lookup host
+    >>= fun ipv4 ->
+    Printf.printf "connecting to %s:%d\n" (Ipaddr.to_string ipv4) port;
+    Host.Sockets.Stream.Tcp.connect (ipv4, port)
+    >>= function
+    | Error (`Msg m) ->
+      Printf.printf "unable to connect: %s\n" m;
+      Lwt.return_unit
+    | Ok socket ->
+      Printf.printf "connected\n";
+      Lwt.finalize
+        (fun () ->
+          HTTP.get socket host path
+        ) (fun () -> Host.Sockets.Stream.Tcp.close socket) in
+  try
+    Host.Main.run begin
+      Lwt_list.iter_s (fun url ->
+        let uri = Uri.of_string url in
+        if Uri.scheme uri <> Some "http" then begin
+          Printf.printf "only http:// URLs are currently supported by this debug tool\n";
+          Lwt.return_unit
+        end else begin
+          Printf.printf "trying URL %s\n" url;
+          let path = Uri.path uri in
+          match Uri.host uri, Uri.port uri with
+          | Some host, Some port ->
+            fetch host port path
+          | Some host, None ->
+            fetch host 80 path
+          | _, _ ->
+            Printf.printf "unable to parse host and port from URL\n";
+            Lwt.return_unit
+          end
+      ) urls
+    end
+  with e ->
+    Printf.printf "Host.Main.run caught exception %s: %s\n" (Printexc.to_string e) (Printexc.get_backtrace ())

src/bin/main.ml

@@ -483,7 +483,7 @@ let hvsock_addr_of_uri ~default_serviceid uri =
       max_connections port_forwards dns http hosts host_names gateway_names
       vm_names listen_backlog port_max_idle_time debug
       server_macaddr domain allowed_bind_addresses gateway_ip host_ip lowest_ip highest_ip
-      dhcp_json_path mtu udpv4_forwards tcpv4_forwards gateway_forwards_path gc_compact
+      dhcp_json_path mtu udpv4_forwards tcpv4_forwards gateway_forwards_path forwards_path gc_compact
     =
     let level =
       let env_debug =
@@ -543,6 +543,7 @@ let hvsock_addr_of_uri ~default_serviceid uri =
       udpv4_forwards;
       tcpv4_forwards;
       gateway_forwards_path;
+      forwards_path;
       pcap_snaplen;
     } in
     match socket_url with
@@ -816,6 +817,14 @@ let gateway_forwards_path =
   in
   Arg.(value & opt (some string) None doc)
 
+let forwards_path =
+  let doc =
+    Arg.info ~doc:
+      "Path of forwards configuration file"
+      [ "forwards" ]
+  in
+  Arg.(value & opt (some string) None doc)
+
 let gc_compact =
   let doc =
     Arg.info ~doc:
@@ -824,7 +833,7 @@ let gc_compact =
   in
   Arg.(value & opt (some int) None doc)
 
-let command =
+let ethernet_cmd =
   let doc = "proxy TCP/IP connections from an ethernet link via sockets" in
   let man =
     [`S "DESCRIPTION";
@@ -837,8 +846,24 @@ let command =
         $ host_names $ gateway_names $ vm_names $ listen_backlog $ port_max_idle_time $ debug
         $ server_macaddr $ domain $ allowed_bind_addresses $ gateway_ip $ host_ip
         $ lowest_ip $ highest_ip $ dhcp_json_path $ mtu $ udpv4_forwards $ tcpv4_forwards
-        $ gateway_forwards_path $ gc_compact),
-  Term.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man
+        $ gateway_forwards_path $ forwards_path $ gc_compact),
+  Term.info "ethernet" ~version:Version.git ~doc ~man
+
+
+let verbose =
+  let doc = "Extra verbose logging"in
+  Arg.(value & flag & info ["v"; "verbose"] ~doc)
+
+let urls = Arg.(value & pos_all string [] & info [] ~docv:"URL")
+
+let curl_cmd =
+  let doc = "A debug command which fetches a resource over HTTP" in
+  let man =
+    [`S "DESCRIPTION";
+     `P "Fetch a resource over HTTP to help diagnose local firewall or anti-virus problems."]
+  in
+  Term.(const Curl.curl $ verbose $ urls),
+Term.info "curl" ~version:Version.git ~doc ~man
 
 let () =
   Printexc.record_backtrace true;
@@ -847,4 +872,4 @@ let () =
   Log.err (fun f ->
       f "Lwt.async failure %a: %s" Fmt.exn exn (Printexc.get_backtrace ()))
   );
-  Term.exit @@ Term.eval command
+  Term.exit @@ Term.eval_choice ethernet_cmd [ethernet_cmd; curl_cmd]

src/fs9p/dune

@@ -1,4 +1,4 @@
 (library
  (name fs9p)
  (wrapped false)
- (libraries protocol-9p mirage-flow))
+ (libraries protocol-9p mirage-flow result))

src/hostnet/configuration.ml

@@ -57,11 +57,12 @@ type t = {
   udpv4_forwards: Gateway_forwards.t;
   tcpv4_forwards: Gateway_forwards.t;
   gateway_forwards_path: string option;
+  forwards_path: string option;
   pcap_snaplen: int;
 }
 
 let to_string t =
-  Printf.sprintf "server_macaddr = %s; max_connection = %s; dns_path = %s; dns = %s; resolver = %s; domain = %s; allowed_bind_addresses = %s; gateway_ip = %s; host_ip = %s; lowest_ip = %s; highest_ip = %s; dhcp_json_path = %s; dhcp_configuration = %s; mtu = %d; http_intercept = %s; http_intercept_path = %s; port_max_idle_time = %s; host_names = %s; gateway_names = %s; vm_names = %s; udpv4_forwards = %s; tcpv4_forwards = %s; gateway_forwards_path = %s; pcap_snaplen = %d"
+  Printf.sprintf "server_macaddr = %s; max_connection = %s; dns_path = %s; dns = %s; resolver = %s; domain = %s; allowed_bind_addresses = %s; gateway_ip = %s; host_ip = %s; lowest_ip = %s; highest_ip = %s; dhcp_json_path = %s; dhcp_configuration = %s; mtu = %d; http_intercept = %s; http_intercept_path = %s; port_max_idle_time = %s; host_names = %s; gateway_names = %s; vm_names = %s; udpv4_forwards = %s; tcpv4_forwards = %s; gateway_forwards_path = %s; forwards_path = %s; pcap_snaplen = %d"
     (Macaddr.to_string t.server_macaddr)
     (match t.max_connections with None -> "None" | Some x -> string_of_int x)
     (match t.dns_path with None -> "None" | Some x -> x)
@@ -85,6 +86,7 @@ let to_string t =
     (Gateway_forwards.to_string t.udpv4_forwards)
     (Gateway_forwards.to_string t.tcpv4_forwards)
     (match t.gateway_forwards_path with None -> "None" | Some x -> x)
+    (match t.forwards_path with None -> "None" | Some x -> x)
     t.pcap_snaplen
 
 let no_dns_servers =
@@ -132,6 +134,7 @@ let default = {
   udpv4_forwards = [];
   tcpv4_forwards = [];
   gateway_forwards_path = None;
+  forwards_path = None;
   pcap_snaplen = default_pcap_snaplen;
 }