From f17ade816906f212099ffe185f6c08375e61d68a Mon Sep 17 00:00:00 2001 From: David Scott Date: Tue, 5 Jul 2022 21:59:58 +0100 Subject: [PATCH 01/11] dune: add missing dependency on result Signed-off-by: David Scott --- src/fs9p/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/fs9p/dune b/src/fs9p/dune index d4a4da848..1c70daef4 100644 --- a/src/fs9p/dune +++ b/src/fs9p/dune @@ -1,4 +1,4 @@ (library (name fs9p) (wrapped false) - (libraries protocol-9p mirage-flow)) + (libraries protocol-9p mirage-flow result)) From 428ec4d91be0d0e0fb573ebcb0388e2ec88bed7e Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 09:54:23 +0100 Subject: [PATCH 02/11] Move RST handling into intercept_tcp Previously we had - Endpoint.input_tcp: which handled RST and then called intercept_tcp_syn with a default forwarding option (connect to (ip, port)) - Endpoint.intercept_tcp_syn: also used by services like the HTTP proxy The RST handling wasn't clear for the HTTP proxy etc, so rename intercept_tcp_syn to intercept_tcp and ensure it handles RST packets too. Signed-off-by: David Scott --- src/hostnet/slirp.ml | 26 +++++++++++++------------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/src/hostnet/slirp.ml b/src/hostnet/slirp.ml index dae38a749..614eade5b 100644 --- a/src/hostnet/slirp.ml +++ b/src/hostnet/slirp.ml @@ -319,7 +319,13 @@ struct t.established <- Tcp.Id.Set.empty; Lwt.return_unit - let intercept_tcp_syn t ~id ~syn on_syn_callback (buf: Cstruct.t) = + let intercept_tcp t ~id ~syn ~rst on_syn_callback (buf: Cstruct.t) = + (* Note that we must cleanup even when the connection is reset before it + is fully established. *) + ( if rst + then close_flow t ~id `Reset + else Lwt.return_unit ) + >>= fun () -> if syn then begin if Tcp.Id.Set.mem id t.pending then begin (* This can happen if the `connect` blocks for a few seconds *) @@ -372,13 +378,7 @@ struct Mirage_flow_combinators.Proxy(Clock)(Stack_tcp)(Host.Sockets.Stream.Tcp) let input_tcp t ~id ~syn ~rst (ip, port) (buf: Cstruct.t) = - (* Note that we must cleanup even when the connection is reset before it - is fully established. *) - ( if rst - then close_flow t ~id `Reset - else Lwt.return_unit ) - >>= fun () -> - intercept_tcp_syn t ~id ~syn (fun () -> + intercept_tcp t ~id ~syn ~rst (fun () -> Host.Sockets.Stream.Tcp.connect (ip, port) >>= function | Error (`Msg m) -> @@ -646,12 +646,12 @@ struct (* TCP to port 53 -> DNS forwarder *) | Ipv4 { src; dst; - payload = Tcp { src = src_port; dst = 53; syn; raw; + payload = Tcp { src = src_port; dst = 53; syn; rst; raw; payload = Payload _; _ }; _ } -> let id = Stack_tcp_wire.v ~src_port:53 ~dst:src ~src:dst ~dst_port:src_port in - Endpoint.intercept_tcp_syn t.endpoint ~id ~syn (fun () -> + Endpoint.intercept_tcp t.endpoint ~id ~syn ~rst (fun () -> !dns >>= fun t -> Dns_forwarder.handle_tcp ~t >|= fun handler -> with_no_keepalive handler @@ -660,7 +660,7 @@ struct (* HTTP proxy *) | Ipv4 { src; dst; - payload = Tcp { src = src_port; dst = dst_port; syn; raw; + payload = Tcp { src = src_port; dst = dst_port; syn; rst; raw; payload = Payload _; _ }; _ } -> let id = Stack_tcp_wire.v ~src_port:dst_port ~dst:src ~src:dst ~dst_port:src_port @@ -672,7 +672,7 @@ struct | None -> Lwt.return (Ok ()) | Some cb -> cb >>= fun cb -> - Endpoint.intercept_tcp_syn t.endpoint ~id ~syn (fun _ -> Lwt.return @@ with_no_keepalive cb) raw + Endpoint.intercept_tcp t.endpoint ~id ~syn ~rst (fun _ -> Lwt.return @@ with_no_keepalive cb) raw >|= ok end end @@ -750,7 +750,7 @@ struct >|= ok | Some cb -> cb >>= fun cb -> - Endpoint.intercept_tcp_syn t.endpoint ~id ~syn (fun _ -> Lwt.return @@ with_no_keepalive cb) raw + Endpoint.intercept_tcp t.endpoint ~id ~syn ~rst (fun _ -> Lwt.return @@ with_no_keepalive cb) raw >|= ok end | Ipv4 { src; dst; ihl; dnf; raw; ttl; From 108f6694709974c5dc830e630d833ae039590b94 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 14:56:30 +0100 Subject: [PATCH 03/11] extract a function which forwards to a TCP socket We will have a future function which forwards to a Unix socket. Signed-off-by: David Scott --- src/hostnet/slirp.ml | 81 ++++++++++++++++++++++---------------------- 1 file changed, 41 insertions(+), 40 deletions(-) diff --git a/src/hostnet/slirp.ml b/src/hostnet/slirp.ml index 614eade5b..b3c367541 100644 --- a/src/hostnet/slirp.ml +++ b/src/hostnet/slirp.ml @@ -377,47 +377,48 @@ struct module Proxy = Mirage_flow_combinators.Proxy(Clock)(Stack_tcp)(Host.Sockets.Stream.Tcp) - let input_tcp t ~id ~syn ~rst (ip, port) (buf: Cstruct.t) = - intercept_tcp t ~id ~syn ~rst (fun () -> - Host.Sockets.Stream.Tcp.connect (ip, port) - >>= function - | Error (`Msg m) -> - Log.debug (fun f -> - f "%a:%d: failed to connect, sending RST: %s" - Ipaddr.pp ip port m); - Lwt.return (fun _ -> None) - | Ok socket -> - let tcp = Tcp.Flow.create id socket in - let listeners port = - Log.debug (fun f -> - f "%a:%d handshake complete" Ipaddr.pp ip port); - let f flow = - match tcp.Tcp.Flow.socket with - | None -> - Log.err (fun f -> - f "%s callback called on closed socket" - (Tcp.Flow.to_string tcp)); + let forward_via_tcp_socket t ~id (ip, port) () = + Host.Sockets.Stream.Tcp.connect (ip, port) + >>= function + | Error (`Msg m) -> + Log.debug (fun f -> + f "%a:%d: failed to connect, sending RST: %s" + Ipaddr.pp ip port m); + Lwt.return (fun _ -> None) + | Ok socket -> + let tcp = Tcp.Flow.create id socket in + let listeners port = + Log.debug (fun f -> + f "%a:%d handshake complete" Ipaddr.pp ip port); + let f flow = + match tcp.Tcp.Flow.socket with + | None -> + Log.err (fun f -> + f "%s callback called on closed socket" + (Tcp.Flow.to_string tcp)); + Lwt.return_unit + | Some socket -> + Lwt.finalize (fun () -> + Proxy.proxy flow socket + >>= function + | Error e -> + Log.debug (fun f -> + f "%s proxy failed with %a" + (Tcp.Flow.to_string tcp) Proxy.pp_error e); Lwt.return_unit - | Some socket -> - Lwt.finalize (fun () -> - Proxy.proxy flow socket - >>= function - | Error e -> - Log.debug (fun f -> - f "%s proxy failed with %a" - (Tcp.Flow.to_string tcp) Proxy.pp_error e); - Lwt.return_unit - | Ok (_l_stats, _r_stats) -> - Lwt.return_unit - ) (fun () -> - Log.debug (fun f -> f "%s proxy terminated" (Tcp.Flow.to_string tcp)); - close_flow t ~id `Fin - ) - in - Some f - in - Lwt.return listeners - ) buf + | Ok (_l_stats, _r_stats) -> + Lwt.return_unit + ) (fun () -> + Log.debug (fun f -> f "%s proxy terminated" (Tcp.Flow.to_string tcp)); + close_flow t ~id `Fin + ) + in + Some f + in + Lwt.return listeners + + let input_tcp t ~id ~syn ~rst (ip, port) (buf: Cstruct.t) = + intercept_tcp t ~id ~syn ~rst (forward_via_tcp_socket t ~id (ip, port)) buf (* Send an ICMP destination reachable message in response to the given packet. This can be used to indicate the packet would From 06ae37b7ebf1c3aec4a47473195b8f2dbd47c49b Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 15:00:35 +0100 Subject: [PATCH 04/11] Tcp.Flow: prepare to support other socket types For now we only track connected TCP sockets, but in a future patch we will add Unix sockets. Prepare by tagging the socket with `Tcp socket and move the close logic into the module. Signed-off-by: David Scott --- src/hostnet/slirp.ml | 32 ++++++++++++++++++-------------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/src/hostnet/slirp.ml b/src/hostnet/slirp.ml index b3c367541..f70e87ffe 100644 --- a/src/hostnet/slirp.ml +++ b/src/hostnet/slirp.ml @@ -193,7 +193,9 @@ struct type t = { id: Stack_tcp_wire.t; - mutable socket: Host.Sockets.Stream.Tcp.flow option; + mutable socket: [ + | `Tcp of Host.Sockets.Stream.Tcp.flow + ] option; mutable last_active_time_ns: int64; } @@ -223,6 +225,18 @@ struct let t = { id; socket; last_active_time_ns } in all := Id.Map.add id t !all; t + let close id t = + (* Closing the socket should cause the proxy to exit cleanly *) + begin match t.socket with + | Some (`Tcp socket) -> + t.socket <- None; + Host.Sockets.Stream.Tcp.close socket + | None -> + (* If we have a Tcp.Flow still in the table, there should still be an + active socket, otherwise the state has gotten out-of-sync *) + Log.warn (fun f -> f "%s: no socket registered, possible socket leak" (string_of_id id)); + Lwt.return_unit + end let remove id = all := Id.Map.remove id !all let mem id = Id.Map.mem id !all @@ -299,17 +313,7 @@ struct end; Tcp.Flow.remove id; t.established <- Tcp.Id.Set.remove id t.established; - begin match tcp.Tcp.Flow.socket with - | Some socket -> - (* Note this should cause the proxy to exit cleanly *) - tcp.Tcp.Flow.socket <- None; - Host.Sockets.Stream.Tcp.close socket - | None -> - (* If we have a Tcp.Flow still in the table, there should still be an - active socket, otherwise the state has gotten out-of-sync *) - Log.warn (fun f -> f "%s: no socket registered, possible socket leak" (string_of_id id)); - Lwt.return_unit - end + Tcp.Flow.close id tcp end else Lwt.return_unit let destroy t = @@ -386,7 +390,7 @@ struct Ipaddr.pp ip port m); Lwt.return (fun _ -> None) | Ok socket -> - let tcp = Tcp.Flow.create id socket in + let tcp = Tcp.Flow.create id (`Tcp socket) in let listeners port = Log.debug (fun f -> f "%a:%d handshake complete" Ipaddr.pp ip port); @@ -397,7 +401,7 @@ struct f "%s callback called on closed socket" (Tcp.Flow.to_string tcp)); Lwt.return_unit - | Some socket -> + | Some (`Tcp socket) -> Lwt.finalize (fun () -> Proxy.proxy flow socket >>= function From d02e199e6249943b01add105ad719a718a411f6b Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 15:49:22 +0100 Subject: [PATCH 05/11] add a table of TCP -> Unix domain socket forwards This is modelled on the existing "Gateway_forwards" Signed-off-by: David Scott --- src/hostnet/forwards.ml | 100 +++++++++++++++++++++++++++++++++++++++ src/hostnet/forwards.mli | 30 ++++++++++++ 2 files changed, 130 insertions(+) create mode 100644 src/hostnet/forwards.ml create mode 100644 src/hostnet/forwards.mli diff --git a/src/hostnet/forwards.ml b/src/hostnet/forwards.ml new file mode 100644 index 000000000..33dbeabb3 --- /dev/null +++ b/src/hostnet/forwards.ml @@ -0,0 +1,100 @@ +let src = + let src = + Logs.Src.create "forwards" ~doc:"Forwards TCP/UDP streams to local services" + in + Logs.Src.set_level src (Some Logs.Info); + src + +module Log = (val Logs.src_log src : Logs.LOG) + +module Protocol = struct + type t = [ `Tcp ] + (* consider UDP later *) + + open Ezjsonm + + let to_json t = string (match t with `Tcp -> "tcp") + + let of_json j = + match get_string j with + | "tcp" -> `Tcp + | _ -> raise (Parse_error (j, "protocol should be tcp")) +end + +type forward = { + protocol : Protocol.t; + dst_prefix : Ipaddr.Prefix.t; + dst_port : int; + path : string; (* unix domain socket path *) +} + +let forward_to_json t = + let open Ezjsonm in + dict + [ + ("protocol", Protocol.to_json t.protocol); + ("dst_prefix", string (Ipaddr.Prefix.to_string t.dst_prefix)); + ("dst_port", int t.dst_port); + ("path", string t.path); + ] + +let forward_of_json j = + let open Ezjsonm in + let protocol = Protocol.of_json @@ find j [ "protocol" ] in + let dst_port = get_int @@ find j [ "dst_port" ] in + let path = get_string @@ find j [ "path" ] in + let dst_prefix = + match Ipaddr.Prefix.of_string @@ get_string @@ find j [ "dst_prefix" ] with + | Error (`Msg m) -> + raise (Parse_error (j, "dst_ip should be an IP prefix: " ^ m)) + | Ok x -> x + in + { protocol; dst_prefix; dst_port; path } + +type t = forward list + +let to_json = Ezjsonm.list forward_to_json +let of_json = Ezjsonm.get_list forward_of_json +let to_string x = Ezjsonm.to_string @@ to_json x + +let of_string x = + try Ok (of_json @@ Ezjsonm.from_string x) with + | Ezjsonm.Parse_error (_v, msg) -> Error (`Msg msg) + | e -> Error (`Msg (Printf.sprintf "parsing %s: %s" x (Printexc.to_string e))) + +let dynamic = ref [] +let static = ref [] +let all = ref [] + +let set_static xs = + static := xs; + all := !static @ !dynamic; + Log.info (fun f -> f "New Forward configuration: %s" (to_string !all)) + +let update xs = + dynamic := xs; + all := !static @ !dynamic; + Log.info (fun f -> f "New Forward configuration: %s" (to_string !all)) + +module Tcp = struct + let any_port = 0 + + let mem (dst_ip, dst_port) = + List.exists + (fun f -> + f.protocol = `Tcp + && Ipaddr.Prefix.mem dst_ip f.dst_prefix + && (f.dst_port = any_port || f.dst_port = dst_port)) + !all + + let find (dst_ip, dst_port) = + let f = + List.find + (fun f -> + f.protocol = `Tcp + && Ipaddr.Prefix.mem dst_ip f.dst_prefix + && (f.dst_port = any_port || f.dst_port = dst_port)) + !all + in + f.path +end diff --git a/src/hostnet/forwards.mli b/src/hostnet/forwards.mli new file mode 100644 index 000000000..85e8facee --- /dev/null +++ b/src/hostnet/forwards.mli @@ -0,0 +1,30 @@ +module Protocol : sig + type t = [ `Tcp ] + (* consider UDP later *) +end + +type forward = { + protocol : Protocol.t; + dst_prefix : Ipaddr.Prefix.t; + dst_port : int; + path : string; (* unix domain socket path *) +} + +type t = forward list + +val to_string : t -> string +val of_string : string -> (t, [ `Msg of string ]) result + +val set_static : t -> unit +(** update the static forwarding table *) + +val update : t -> unit +(** update the dynamic forwarding table *) + +module Tcp : sig + val mem : Ipaddr.t * int -> bool + (** [mem dst_ip dst_port] is true if there is a rule to forward TCP to [dst_ip,dst_port]. *) + + val find : Ipaddr.t * int -> string + (** [find dst_ip dst_port] returns the internal path to forward the TCP connection to. *) +end From 3d016c35a6bf9fcc6ee04c3c60d57e0f10dbac6b Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 15:51:11 +0100 Subject: [PATCH 06/11] add command-line `--forwards ` This reads and watches the for configuration updates, modelled on the existing `--gateway-forwards` Signed-off-by: David Scott --- src/bin/main.ml | 13 ++++++++-- src/hostnet/configuration.ml | 5 +++- src/hostnet/slirp.ml | 46 ++++++++++++++++++++++++++++++++++++ 3 files changed, 61 insertions(+), 3 deletions(-) diff --git a/src/bin/main.ml b/src/bin/main.ml index f59221f5e..56d221349 100644 --- a/src/bin/main.ml +++ b/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: @@ -837,7 +846,7 @@ 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), + $ gateway_forwards_path $ forwards_path $ gc_compact), Term.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man let () = diff --git a/src/hostnet/configuration.ml b/src/hostnet/configuration.ml index 26531aee3..0aa6d1383 100644 --- a/src/hostnet/configuration.ml +++ b/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; } diff --git a/src/hostnet/slirp.ml b/src/hostnet/slirp.ml index f70e87ffe..44eb28ab4 100644 --- a/src/hostnet/slirp.ml +++ b/src/hostnet/slirp.ml @@ -1515,6 +1515,52 @@ struct end ) >>= fun () -> + let read_forwards_file path = + Log.info (fun f -> f "Reading forwards file from %s" path); + Host.Files.read_file path + >>= function + | Error (`Msg "ENOENT") -> + Log.info (fun f -> f "Not reading forwards file %s becuase it does not exist" path); + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> f "Failed to read forwards from %s: %s." path m); + Forwards.update []; + Lwt.return_unit + | Ok txt -> + match Forwards.of_string txt with + | Ok xs -> + Forwards.update xs; + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> f "Failed to parse forwards from %s: %s." path m); + Lwt.return_unit + in + ( match c.forwards_path with + | None -> Lwt.return_unit + | Some path -> + begin Host.Files.watch_file path + (fun () -> + Log.info (fun f -> f "Forwards file %s has changed" path); + Lwt.async (fun () -> + log_exception_continue "Parsing forwards" + (fun () -> + read_forwards_file path + ) + ) + ) + >>= function + | Error (`Msg "ENOENT") -> + Log.info (fun f -> f "Not watching forwards file %s because it does not exist" path); + Lwt.return_unit + | Error (`Msg m) -> + Log.err (fun f -> f "Failed to watch forwards file %s for changes: %s" path m); + Lwt.return_unit + | Ok _watch -> + Log.info (fun f -> f "Watching forwards file %s for changes" path); + Lwt.return_unit + end + ) >>= fun () -> + Log.info (fun f -> f "Configuration %s" (Configuration.to_string c)); let global_arp_table : arp_table = { mutex = Lwt_mutex.create(); From ad7119ee7a1ed93a8507f6824c2f19faeca7eeff Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 16:04:01 +0100 Subject: [PATCH 07/11] add transparent TCP -> Unix domain socket forwarding Define a simple handshake with a .json-formatted request and response. Signed-off-by: David Scott --- src/hostnet/forwards.ml | 243 +++++++++++++++++++++++++++++++++++++++ src/hostnet/forwards.mli | 7 ++ src/hostnet/slirp.ml | 82 ++++++++++++- 3 files changed, 329 insertions(+), 3 deletions(-) diff --git a/src/hostnet/forwards.ml b/src/hostnet/forwards.ml index 33dbeabb3..6e14023b3 100644 --- a/src/hostnet/forwards.ml +++ b/src/hostnet/forwards.ml @@ -76,6 +76,180 @@ let update xs = all := !static @ !dynamic; Log.info (fun f -> f "New Forward configuration: %s" (to_string !all)) +(* Extend a SHUTDOWNABLE flow with a `read_some` API, as used by "channel". + Ideally we would use channel, but we need to access the underlying flow + without leaving data trapped in the buffer. *) +module type Read_some = sig + include Mirage_flow_combinators.SHUTDOWNABLE + + val read_some : + flow -> int -> (Cstructs.t Mirage_flow.or_eof, error) result Lwt.t +end + +module Read_some (FLOW : Mirage_flow_combinators.SHUTDOWNABLE) : sig + include Read_some + + val connect : FLOW.flow -> flow +end = struct + (* A flow with a buffer, filled by "read_some" and then drained by "read" *) + type flow = { mutable remaining : Cstruct.t; flow : FLOW.flow } + + let connect flow = { remaining = Cstruct.create 0; flow } + + type error = FLOW.error + + let pp_error = FLOW.pp_error + + type write_error = FLOW.write_error + + let pp_write_error = FLOW.pp_write_error + + let read_some flow len = + let open Lwt.Infix in + let rec loop acc len = + if Cstruct.length flow.remaining = 0 && len > 0 then + FLOW.read flow.flow >>= function + | Error e -> Lwt.return (Error e) + | Ok (`Data buf) -> + flow.remaining <- buf; + loop acc len + | Ok `Eof -> Lwt.return (Ok `Eof) + else if Cstruct.length flow.remaining < len then ( + let take = flow.remaining in + flow.remaining <- Cstruct.create 0; + loop (take :: acc) (len - Cstruct.length take)) + else + let take, leave = Cstruct.split flow.remaining len in + flow.remaining <- leave; + Lwt.return @@ Ok (`Data (List.rev (take :: acc))) + in + loop [] len + + let read flow = + if Cstruct.length flow.remaining > 0 then ( + let result = flow.remaining in + flow.remaining <- Cstruct.create 0; + Lwt.return @@ Ok (`Data result)) + else FLOW.read flow.flow + + let write flow = FLOW.write flow.flow + let writev flow = FLOW.writev flow.flow + let close flow = FLOW.close flow.flow + let shutdown_write flow = FLOW.shutdown_write flow.flow + let shutdown_read flow = FLOW.shutdown_read flow.flow +end + +module Handshake (FLOW : Read_some) = struct + (* A Message is a buffer prefixed with a uint16 length field. *) + module Message = struct + open Lwt.Infix + + let pp_error ppf = function + | `Flow e -> FLOW.pp_error ppf e + | `Eof -> Fmt.string ppf "EOF while reading handshake" + + let read flow = + FLOW.read_some flow 2 >>= function + | Error e -> Lwt.return (Error (`Flow e)) + | Ok `Eof -> Lwt.return (Error `Eof) + | Ok (`Data bufs) -> ( + let buf = Cstructs.to_cstruct bufs in + let len = Cstruct.LE.get_uint16 buf 0 in + FLOW.read_some flow len >>= function + | Error e -> Lwt.return (Error (`Flow e)) + | Ok `Eof -> Lwt.return (Error `Eof) + | Ok (`Data bufs) -> Lwt.return (Ok (Cstructs.to_cstruct bufs))) + + let write flow t = + let len = Cstruct.create 2 in + Cstruct.LE.set_uint16 len 0 (Cstruct.length t); + FLOW.writev flow [ len; t ] + end + + module Request = struct + type t = { + protocol : Protocol.t; + src_ip : Ipaddr.t; + src_port : int; + dst_ip : Ipaddr.t; + dst_port : int; + } + + open Ezjsonm + + let of_json j = + let protocol = Protocol.of_json @@ find j [ "protocol" ] in + let src_ip = + match Ipaddr.of_string @@ get_string @@ find j [ "src_ip" ] with + | Error (`Msg m) -> + raise (Parse_error (j, "src_ip should be an IPv4 address: " ^ m)) + | Ok x -> x + in + let src_port = get_int @@ find j [ "src_port" ] in + let dst_ip = + match Ipaddr.of_string @@ get_string @@ find j [ "dst_ip" ] with + | Error (`Msg m) -> + raise (Parse_error (j, "dst_ip should be an IPv4 address: " ^ m)) + | Ok x -> x + in + let dst_port = get_int @@ find j [ "dst_port" ] in + { protocol; src_ip; src_port; dst_ip; dst_port } + + let to_json t = + let open Ezjsonm in + dict + [ + ("protocol", Protocol.to_json t.protocol); + ("src_ip", string (Ipaddr.to_string t.src_ip)); + ("src_port", int t.src_port); + ("dst_ip", string (Ipaddr.to_string t.dst_ip)); + ("dst_port", int t.dst_port); + ] + + let to_string t = Ezjsonm.to_string @@ to_json t + + open Lwt.Infix + + let read flow = + Message.read flow >>= function + | Error (`Flow e) -> Lwt.return (Error (`Flow e)) + | Error `Eof -> Lwt.return (Error `Eof) + | Ok buf -> + let j = Ezjsonm.from_string @@ Cstruct.to_string buf in + Lwt.return (Ok (of_json j)) + + let write flow t = + Message.write flow @@ Cstruct.of_string @@ Ezjsonm.to_string @@ to_json t + end + + module Response = struct + type t = { accepted : bool } + + open Ezjsonm + + let of_json j = + let accepted = get_bool @@ find j [ "accepted" ] in + { accepted } + + let to_json t = + let open Ezjsonm in + dict [ ("accepted", bool t.accepted) ] + + open Lwt.Infix + + let read flow = + Message.read flow >>= function + | Error (`Flow e) -> Lwt.return (Error (`Flow e)) + | Error `Eof -> Lwt.return (Error `Eof) + | Ok buf -> + let j = Ezjsonm.from_string @@ Cstruct.to_string buf in + Lwt.return (Ok (of_json j)) + + let write flow t = + Message.write flow @@ Cstruct.of_string @@ Ezjsonm.to_string @@ to_json t + end +end + module Tcp = struct let any_port = 0 @@ -98,3 +272,72 @@ module Tcp = struct in f.path end + +module Unix = struct + module FLOW = Host.Sockets.Stream.Unix + module Remote = Read_some (FLOW) + module Handshake = Handshake (Remote) + + type flow = { flow : Remote.flow } + + let connect (dst_ip, dst_port) = + let open Lwt.Infix in + let path = Tcp.find (dst_ip, dst_port) in + let req = Fmt.str "%a, %d -> %s" Ipaddr.pp dst_ip dst_port path in + Log.info (fun f -> f "%s: connecting" req); + FLOW.connect path >>= function + | Error (`Msg m) -> Lwt.return (Error (`Msg m)) + | Ok flow -> ( + Log.info (fun f -> f "%s: writing handshake" req); + let remote = Remote.connect flow in + Handshake.Request.write remote + { + Handshake.Request.protocol = `Tcp; + src_ip = Ipaddr.V4 Ipaddr.V4.any; + src_port = 0; + dst_ip; + dst_port; + } + >>= function + | Error e -> + Log.info (fun f -> + f "%s: %a, returning RST" req Remote.pp_write_error e); + Remote.close remote >>= fun () -> + Lwt.return + (Error + (`Msg + (Fmt.str "writing handshake: %a" Remote.pp_write_error e))) + | Ok () -> ( + Log.info (fun f -> f "%s: reading handshake" req); + Handshake.Response.read remote >>= function + | Error e -> + Log.info (fun f -> + f "%s: %a, returning RST" req Handshake.Message.pp_error e); + Remote.close remote >>= fun () -> + Lwt.return + (Error + (`Msg + (Fmt.str "reading handshake: %a" + Handshake.Message.pp_error e))) + | Ok { Handshake.Response.accepted = false } -> + Log.info (fun f -> f "%s: request rejected" req); + Remote.close remote >>= fun () -> + Lwt.return (Error `ECONNREFUSED) + | Ok { Handshake.Response.accepted = true } -> + Log.info (fun f -> f "%s: forwarding connection" req); + Lwt.return (Ok { flow = remote }))) + + type error = Remote.error + + let pp_error = Remote.pp_error + + type write_error = Remote.write_error + + let pp_write_error = Remote.pp_write_error + let read flow = Remote.read flow.flow + let write flow = Remote.write flow.flow + let writev flow = Remote.writev flow.flow + let close flow = Remote.close flow.flow + let shutdown_write flow = Remote.shutdown_write flow.flow + let shutdown_read flow = Remote.shutdown_read flow.flow +end diff --git a/src/hostnet/forwards.mli b/src/hostnet/forwards.mli index 85e8facee..f933c66e8 100644 --- a/src/hostnet/forwards.mli +++ b/src/hostnet/forwards.mli @@ -28,3 +28,10 @@ module Tcp : sig val find : Ipaddr.t * int -> string (** [find dst_ip dst_port] returns the internal path to forward the TCP connection to. *) end + +module Unix : sig + include Mirage_flow_combinators.SHUTDOWNABLE + + val connect : + Ipaddr.t * int -> (flow, [> `ECONNREFUSED | `Msg of string ]) result Lwt.t +end diff --git a/src/hostnet/slirp.ml b/src/hostnet/slirp.ml index 44eb28ab4..8e0e0315f 100644 --- a/src/hostnet/slirp.ml +++ b/src/hostnet/slirp.ml @@ -195,6 +195,7 @@ struct id: Stack_tcp_wire.t; mutable socket: [ | `Tcp of Host.Sockets.Stream.Tcp.flow + | `Unix of Forwards.Unix.flow ] option; mutable last_active_time_ns: int64; } @@ -231,6 +232,9 @@ struct | Some (`Tcp socket) -> t.socket <- None; Host.Sockets.Stream.Tcp.close socket + | Some (`Unix socket) -> + t.socket <- None; + Forwards.Unix.close socket | None -> (* If we have a Tcp.Flow still in the table, there should still be an active socket, otherwise the state has gotten out-of-sync *) @@ -378,8 +382,10 @@ struct Stack_tcp.input t.tcp4 ~src ~dst buf end - module Proxy = + module Tcp_Proxy = Mirage_flow_combinators.Proxy(Clock)(Stack_tcp)(Host.Sockets.Stream.Tcp) + module Unix_Proxy = + Mirage_flow_combinators.Proxy(Clock)(Stack_tcp)(Forwards.Unix) let forward_via_tcp_socket t ~id (ip, port) () = Host.Sockets.Stream.Tcp.connect (ip, port) @@ -401,14 +407,71 @@ struct f "%s callback called on closed socket" (Tcp.Flow.to_string tcp)); Lwt.return_unit + | Some (`Unix _) -> + (* Should never happen but not currently forbidden by the types *) + Log.err (fun f -> + f "%s callback has a Unix socket, expected TCP" + (Tcp.Flow.to_string tcp)); + close_flow t ~id `Reset | Some (`Tcp socket) -> Lwt.finalize (fun () -> - Proxy.proxy flow socket + Tcp_Proxy.proxy flow socket >>= function | Error e -> Log.debug (fun f -> f "%s proxy failed with %a" - (Tcp.Flow.to_string tcp) Proxy.pp_error e); + (Tcp.Flow.to_string tcp) Tcp_Proxy.pp_error e); + Lwt.return_unit + | Ok (_l_stats, _r_stats) -> + Lwt.return_unit + ) (fun () -> + Log.debug (fun f -> f "%s proxy terminated" (Tcp.Flow.to_string tcp)); + close_flow t ~id `Fin + ) + in + Some f + in + Lwt.return listeners + + let forward_via_unix_socket t ~id (ip, port) () = + Forwards.Unix.connect (ip, port) + >>= function + | Error `ECONNREFUSED -> + Log.debug (fun f -> + f "%a:%d: ECONNREFUSED, sending RST" + Ipaddr.pp ip port); + Lwt.return (fun _ -> None) + | Error (`Msg m) -> + Log.debug (fun f -> + f "%a:%d: failed to connect, sending RST: %s" + Ipaddr.pp ip port m); + Lwt.return (fun _ -> None) + | Ok socket -> + let tcp = Tcp.Flow.create id (`Unix socket) in + let listeners port = + Log.debug (fun f -> + f "%a:%d handshake complete" Ipaddr.pp ip port); + let f flow = + match tcp.Tcp.Flow.socket with + | None -> + Log.err (fun f -> + f "%s callback called on closed socket" + (Tcp.Flow.to_string tcp)); + Lwt.return_unit + | Some (`Tcp _) -> + (* Should never happen but not currently forbidden by the types *) + Log.err (fun f -> + f "%s callback has a TCP socket, expected Unix" + (Tcp.Flow.to_string tcp)); + close_flow t ~id `Reset + | Some (`Unix socket) -> + Lwt.finalize (fun () -> + Unix_Proxy.proxy flow socket + >>= function + | Error e -> + Log.debug (fun f -> + f "%s proxy failed with %a" + (Tcp.Flow.to_string tcp) Unix_Proxy.pp_error e); Lwt.return_unit | Ok (_l_stats, _r_stats) -> Lwt.return_unit @@ -736,6 +799,19 @@ struct | None -> Lwt.return (Ok ()) ) + (* Transparent TCP forward? *) + | Ipv4 { src = src_ip ; dst = dst_ip; + payload = Tcp { src = src_port; + dst = dst_port; syn; rst; raw; _ }; _ } when Forwards.Tcp.mem (Ipaddr.V4 dst_ip, dst_port) -> + let id = + Stack_tcp_wire.v + ~src_port:dst_port ~dst:src_ip ~src:dst_ip ~dst_port:src_port + in + Endpoint.intercept_tcp t.endpoint ~id ~syn ~rst (fun () -> + Endpoint.forward_via_unix_socket t.endpoint ~id (Ipaddr.V4 dst_ip, dst_port) () + ) raw + >|= ok + (* Transparent HTTP intercept? *) | Ipv4 { src = dest_ip ; dst = local_ip; payload = Tcp { src = dest_port; From aeb2cf218e57ea078f0feba9a1a6ec95b6634283 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 16:08:14 +0100 Subject: [PATCH 08/11] add a test for the TCP forwarder Signed-off-by: David Scott --- src/hostnet/forwards.ml | 69 +++++++++++++++++++++++++++++++++++++ src/hostnet/forwards.mli | 7 ++++ src/hostnet_test/suite.ml | 71 +++++++++++++++++++++++++++++++++++++++ 3 files changed, 147 insertions(+) diff --git a/src/hostnet/forwards.ml b/src/hostnet/forwards.ml index 6e14023b3..b1b5d64bc 100644 --- a/src/hostnet/forwards.ml +++ b/src/hostnet/forwards.ml @@ -341,3 +341,72 @@ module Unix = struct let shutdown_write flow = Remote.shutdown_write flow.flow let shutdown_read flow = Remote.shutdown_read flow.flow end + +module Test (Clock : Mirage_clock.MCLOCK) = struct + module Remote = Read_some (Host.Sockets.Stream.Unix) + + module Proxy = + Mirage_flow_combinators.Proxy (Clock) (Remote) (Host.Sockets.Stream.Tcp) + + module Handshake = Handshake (Remote) + open Lwt.Infix + + type server = Host.Sockets.Stream.Unix.server + + let start_forwarder path = + Host.Sockets.Stream.Unix.bind path >>= fun s -> + Host.Sockets.Stream.Unix.listen s (fun flow -> + Log.info (fun f -> f "accepted flow"); + let local = Remote.connect flow in + Handshake.Request.read local >>= function + | Error e -> + Log.info (fun f -> + f "reading handshake request %a" Handshake.Message.pp_error e); + Lwt.return_unit + | Ok h -> ( + let req = Handshake.Request.to_string h in + Log.info (fun f -> f "%s: connecting" req); + Host.Sockets.Stream.Tcp.connect + (h.Handshake.Request.dst_ip, h.Handshake.Request.dst_port) + >>= function + | Error (`Msg m) -> ( + Log.info (fun f -> f "%s: %s" req m); + Handshake.Response.write local + { Handshake.Response.accepted = false } + >>= function + | Error e -> + Log.info (fun f -> + f "%s: writing handshake response %a" req + Remote.pp_write_error e); + Lwt.return_unit + | Ok () -> + Log.info (fun f -> f "%s: returned handshake response" req); + Lwt.return_unit) + | Ok remote -> + Log.info (fun f -> f "%s: connected" req); + Lwt.finalize + (fun () -> + Handshake.Response.write local + { Handshake.Response.accepted = true } + >>= function + | Error e -> + Log.info (fun f -> + f "%s: writing handshake response %a" req + Remote.pp_write_error e); + Lwt.return_unit + | Ok () -> ( + Log.info (fun f -> f "%s: proxying data" req); + Proxy.proxy local remote >>= function + | Error e -> + Log.info (fun f -> + f "%s: TCP proxy failed with %a" req + Proxy.pp_error e); + Lwt.return_unit + | Ok (_l_stats, _r_stats) -> Lwt.return_unit)) + (fun () -> + Log.info (fun f -> f "%s: disconnecting from remote" req); + Host.Sockets.Stream.Tcp.close remote))); + Lwt.return s + + let shutdown = Host.Sockets.Stream.Unix.shutdown +end diff --git a/src/hostnet/forwards.mli b/src/hostnet/forwards.mli index f933c66e8..a05b277f5 100644 --- a/src/hostnet/forwards.mli +++ b/src/hostnet/forwards.mli @@ -35,3 +35,10 @@ module Unix : sig val connect : Ipaddr.t * int -> (flow, [> `ECONNREFUSED | `Msg of string ]) result Lwt.t end + +module Test (Clock : Mirage_clock.MCLOCK) : sig + type server + + val start_forwarder : string -> server Lwt.t + val shutdown : server -> unit Lwt.t +end diff --git a/src/hostnet_test/suite.ml b/src/hostnet_test/suite.ml index 92f4da752..8c4380e62 100644 --- a/src/hostnet_test/suite.ml +++ b/src/hostnet_test/suite.ml @@ -126,6 +126,75 @@ let test_http_fetch () = in run ~pcap:"test_http_fetch.pcap" t +let test_tcp_forwards () = + let t _ stack = + let path = "/tmp/forwards.sock" in + let module ForwardsTest = Forwards.Test(Mclock) in + ForwardsTest.start_forwarder path + >>= fun forwarder -> + Forwards.update [ + { + Forwards.protocol = `Tcp; + dst_prefix = Ipaddr.V4 Ipaddr.V4.Prefix.global; + dst_port = 80; + path = path; + } + ]; + Lwt.finalize + (fun () -> + let resolver = DNS.create stack.Client.t in + DNS.gethostbyname resolver "www.google.com" >>= function + | Ipaddr.V4 ip :: _ -> + begin + Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) + >>= function + | Error _ -> + Log.err (fun f -> f "Failed to connect to www.google.com:80"); + failwith "http_fetch" + | Ok flow -> + Log.info (fun f -> f "Connected to www.google.com:80"); + let page = Io_page.(to_cstruct (get 1)) in + let http_get = "GET / HTTP/1.0\nHost: anil.recoil.org\n\n" in + Cstruct.blit_from_string http_get 0 page 0 (String.length http_get); + let buf = Cstruct.sub page 0 (String.length http_get) in + Client.TCPV4.write flow buf >>= function + | Error `Closed -> + Log.err (fun f -> + f "EOF writing HTTP request to www.google.com:80"); + failwith "EOF on writing HTTP GET" + | Error _ -> + Log.err (fun f -> + f "Failure writing HTTP request to www.google.com:80"); + failwith "Failure on writing HTTP GET" + | Ok () -> + let rec loop total_bytes = + Client.TCPV4.read flow >>= function + | Ok `Eof -> Lwt.return total_bytes + | Error _ -> + Log.err (fun f -> + f "Failure read HTTP response from www.google.com:80"); + failwith "Failure on reading HTTP GET" + | Ok (`Data buf) -> + Log.info (fun f -> + f "Read %d bytes from www.google.com:80" (Cstruct.length buf)); + Log.info (fun f -> f "%s" (Cstruct.to_string buf)); + loop (total_bytes + (Cstruct.length buf)) + in + loop 0 >|= fun total_bytes -> + Log.info (fun f -> f "Response had %d total bytes" total_bytes); + if total_bytes == 0 then failwith "response was empty" + end + | _ -> + Log.err (fun f -> + f "Failed to look up an IPv4 address for www.google.com"); + failwith "http_fetch dns" + ) (fun () -> + Forwards.update []; + ForwardsTest.shutdown forwarder + ) + in + run ~pcap:"test_tcp_forwards.pcap" t + module DevNullServer = struct (* Accept local TCP connections, throw away all incoming data and then return the total number of bytes processed. *) @@ -289,6 +358,8 @@ let test_dhcp = [ let test_tcp = [ "HTTP GET", [ "HTTP GET http://www.google.com/", `Quick, test_http_fetch ]; + "TCP forward", [ "HTTP GET http://www.google.com/ via TCP forwarder", `Quick, test_tcp_forwards ]; + "Max connections", [ "HTTP GET fails beyond max connections", `Quick, test_max_connections ]; From cbc5f705b8ab648c06ae314fd7d2e828c07dd621 Mon Sep 17 00:00:00 2001 From: David Scott Date: Fri, 17 Jun 2022 09:46:43 +0100 Subject: [PATCH 09/11] debug: add a `vpnkit.exe curl ` command This will allow testing of the I/O system. Signed-off-by: David Scott --- src/bin/curl.ml | 80 ++++++++++++++++++++++++++++++++++++++++++++++ src/bin/main.ml | 22 +++++++++++-- src/hostnet/sig.ml | 2 ++ 3 files changed, 101 insertions(+), 3 deletions(-) create mode 100755 src/bin/curl.ml diff --git a/src/bin/curl.ml b/src/bin/curl.ml new file mode 100755 index 000000000..4316d70a4 --- /dev/null +++ b/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 ()) \ No newline at end of file diff --git a/src/bin/main.ml b/src/bin/main.ml index 56d221349..e6249e88e 100644 --- a/src/bin/main.ml +++ b/src/bin/main.ml @@ -833,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"; @@ -847,7 +847,23 @@ let command = $ 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 $ forwards_path $ gc_compact), - Term.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man + 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; @@ -856,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] diff --git a/src/hostnet/sig.ml b/src/hostnet/sig.ml index d3002ce06..f80300653 100644 --- a/src/hostnet/sig.ml +++ b/src/hostnet/sig.ml @@ -130,6 +130,8 @@ module type FILES = sig end module type DNS = sig + val getaddrinfo: string -> Luv.Sockaddr.Address_family.t -> Ipaddr.t list Lwt.t + val resolve: Dns.Packet.question -> Dns.Packet.rr list Lwt.t (** Given a question, find associated resource records *) end From 694e0112a325d6bce361d9a127f4aad55d04ae75 Mon Sep 17 00:00:00 2001 From: David Scott Date: Sat, 2 Jul 2022 20:05:02 +0100 Subject: [PATCH 10/11] Add verbose debug printing around connect Signed-off-by: David Scott --- src/hostnet/host.ml | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/src/hostnet/host.ml b/src/hostnet/host.ml index 4a15c63bf..578916490 100644 --- a/src/hostnet/host.ml +++ b/src/hostnet/host.ml @@ -519,6 +519,7 @@ module Sockets = struct let connect ?read_buffer_size:_ (ip, port) = let description = Fmt.str "tcp:%a:%d" Ipaddr.pp ip port in + Printf.printf "%s connecting\n%!" description; let label = match ip with Ipaddr.V4 _ -> "TCPv4" | Ipaddr.V6 _ -> "TCPv6" in @@ -543,8 +544,10 @@ module Sockets = struct Luv.Handle.close fd (fun () -> return (Error (`Msg (Luv.Error.strerror err)))) | Ok sockaddr -> + Printf.printf "%s created sockaddr\n%!" description; Luv.TCP.connect fd sockaddr (function | Error err -> + Printf.printf "%s connect failed with %s\n%!" description (Luv.Error.strerror err); Connection_limit.deregister idx; Luv.Handle.close fd (fun () -> return (Error (`Msg (Luv.Error.strerror err)))) @@ -557,12 +560,15 @@ module Sockets = struct in Log.info (fun f -> f "%s" msg); Lwt.return (Error (`Msg msg)) - | Ok (fd, idx) -> Lwt.return (Ok (of_fd ~description ~idx ~label fd)) + | Ok (fd, idx) -> + Printf.printf "%s connected\n%!" description; + Lwt.return (Ok (of_fd ~description ~idx ~label fd)) let shutdown_read _ = Lwt.return () let shutdown_write { label; fd; closed; _ } = - if not closed then + if not closed then begin + Printf.printf "%s shutdown_write\n%!" label; Luv_lwt.in_luv (fun return -> Luv.Stream.shutdown fd (function | Error err -> @@ -571,7 +577,7 @@ module Sockets = struct (Luv.Error.strerror err)); return () | Ok () -> return ())) - else Lwt.return_unit + end else Lwt.return_unit let read_into t buf = read_into t.fd buf let read t = read t.fd From e64d913d312fb2010a0e626124b77a1f9954b100 Mon Sep 17 00:00:00 2001 From: David Scott Date: Wed, 13 Jul 2022 19:31:23 +0100 Subject: [PATCH 11/11] HACK: HTTP server always uses the forwarder Signed-off-by: David Scott --- src/hostnet/hostnet_http.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/hostnet/hostnet_http.ml b/src/hostnet/hostnet_http.ml index da92a5be0..559590906 100644 --- a/src/hostnet/hostnet_http.ml +++ b/src/hostnet/hostnet_http.ml @@ -237,7 +237,7 @@ module Make module Response = Cohttp.Response.Make(IO) end module Outgoing = struct - module C = Mirage_channel.Make(Socket.Stream.Tcp) + module C = Mirage_channel.Make(Forwards.Unix) module IO = Cohttp_mirage_io.Make(C) module Request = Cohttp.Request.Make(IO) module Response = Cohttp.Response.Make(IO) @@ -295,7 +295,7 @@ module Make Lwt.return false ) >>= fun continue -> - if continue then loop () else Socket.Stream.Tcp.shutdown_write remote + if continue then loop () else Forwards.Unix.shutdown_write remote in loop () in Lwt.join [ @@ -505,7 +505,7 @@ module Make let request = Cohttp.Request.make ~meth:`CONNECT ~headers uri in { request with Cohttp.Request.resource = host ^ ":" ^ (string_of_int port) } in - Socket.Stream.Tcp.connect address >>= function + Forwards.Unix.connect address >>= function | Error _ -> Log.warn (fun f -> f "Failed to connect to %s" (string_of_address address)); @@ -538,7 +538,7 @@ module Make (Cohttp.Response.sexp_of_t res))); let incoming = Incoming.C.create flow in proxy_bytes ~incoming ~outgoing ~flow ~remote - ) (fun () -> Socket.Stream.Tcp.close remote) + ) (fun () -> Forwards.Unix.close remote) ) (fun () -> Tcp.close flow) ) (fun e -> Log.warn (fun f -> f "tunnel_https_over_connect caught exception: %s" (Printexc.to_string e)); @@ -662,7 +662,7 @@ module Make (Sexplib.Sexp.to_string_hum (Cohttp.Request.sexp_of_t req)) ); - begin Socket.Stream.Tcp.connect next_hop_address >>= function + begin Forwards.Unix.connect next_hop_address >>= function | Error _ -> let message = match ty with | `Origin -> Printf.sprintf "unable to connect to %s. Do you need an HTTP proxy?" (string_of_address next_hop_address) @@ -714,7 +714,7 @@ module Make (Cohttp.Request.sexp_of_t req)) ); proxy_request ~description ~incoming ~outgoing ~flow ~remote ~req - ) (fun () -> Socket.Stream.Tcp.close remote) + ) (fun () -> Forwards.Unix.close remote) end (* A regular, non-transparent HTTP proxy implementation.