diff --git a/dune b/dune index 97e3f6362..841abdd22 100644 --- a/dune +++ b/dune @@ -23,6 +23,7 @@ (rule (target vpnkit.tgz) + (enabled_if (= %{os_type} "macOS")) (deps vpnkit.exe (:gen ./scripts/mac_package.exe)) (action (run %{gen} -out %{target} -in %{deps}))) diff --git a/dune-project b/dune-project index c0049c40d..ec79e5ec5 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,3 @@ -(lang dune 2.0) +(lang dune 3.4) + (name vpnkit) diff --git a/dune-workspace b/dune-workspace new file mode 100644 index 000000000..de9d55eea --- /dev/null +++ b/dune-workspace @@ -0,0 +1,8 @@ +(lang dune 3.4) +(env + (dev + (flags + (:standard -warn-error +A-67-69))) ; Disable some unused warnings. + (release + (flags + (:standard -warn-error +A-58)))) diff --git a/scripts/licenses.ml b/scripts/licenses.ml index 4c7469eb7..0a4f615a2 100644 --- a/scripts/licenses.ml +++ b/scripts/licenses.ml @@ -1155,11 +1155,6 @@ let speclist = [("-out", Arg.Set_string output_file, "Set output file name"); ("-in", Arg.Set_string input_file, "Set input file name")] -let run cmd = match Unix.system cmd with - | Unix.WEXITED 0 -> () - | Unix.WEXITED n -> failwith (Printf.sprintf "%s: %d" cmd n) - | _ -> failwith (Printf.sprintf "%s: unexpected signal" cmd) - let trim_comment line = match Stringext.cut ~on:"#" line with | None -> line | Some (line, _comment) -> line diff --git a/src/bin/config/discover.ml b/src/bin/config/discover.ml index b81996840..80bb37d72 100644 --- a/src/bin/config/discover.ml +++ b/src/bin/config/discover.ml @@ -11,7 +11,7 @@ let os_type () = let flags () = match os_type () with | "Linux" -> - [ "-ccopt"; "-static" ] + [ "-ccopt"; "-static" ] | _ -> [] diff --git a/src/bin/config/dune b/src/bin/config/dune index 5d3d7407a..d2a51b865 100644 --- a/src/bin/config/dune +++ b/src/bin/config/dune @@ -1,3 +1,3 @@ (executable (name discover) - (libraries sexplib)) + (libraries unix sexplib)) diff --git a/src/bin/connect.ml b/src/bin/connect.ml index 86e47c0c1..9f53a4262 100644 --- a/src/bin/connect.ml +++ b/src/bin/connect.ml @@ -46,7 +46,7 @@ module Hvsock = struct (* Avoid using `detach` because we don't want to exhaust the thread pool since this will block the main TCP/IP stack. *) module F = - Hvsock_lwt.Flow_shutdown.Make(Host.Time) + Hvsock_lwt.Flow_shutdown.Make (Hvsock_lwt.In_main_thread.Make(Host.Main)) (Hvsock.Af_hyperv) @@ -83,8 +83,7 @@ module Hvsock = struct let read t = F.read t.flow let write t = F.write t.flow let writev t = F.writev t.flow - let shutdown_read t = F.shutdown_read t.flow - let shutdown_write t = F.shutdown_write t.flow + let shutdown t = F.shutdown t.flow let pp_error = F.pp_error let pp_write_error = F.pp_write_error type error = F.error diff --git a/src/bin/dune b/src/bin/dune index fae10e6fe..deb870612 100644 --- a/src/bin/dune +++ b/src/bin/dune @@ -1,8 +1,8 @@ (executable (name main) (libraries cmdliner ofs logs.fmt hostnet hvsock hvsock.lwt - fd-send-recv duration mirage-clock-unix mirage-random - fs9p mirage-random-stdlib) + fd-send-recv duration + fs9p) (flags :standard (:include flags.sexp)) diff --git a/src/bin/main.ml b/src/bin/main.ml index 379f73375..8ea7593ce 100644 --- a/src/bin/main.ml +++ b/src/bin/main.ml @@ -55,10 +55,10 @@ let hvsock_addr_of_uri ~default_serviceid uri = module Connect_hvsock = Connect.Hvsock module Bind = Bind.Make(Host.Sockets) module Dns_policy = Hostnet_dns.Policy(Host.Files) - module Forward_unix = Forward.Make(Mclock)(Connect_unix)(Bind) - module Forward_hvsock = Forward.Make(Mclock)(Connect_hvsock)(Bind) - module HV = Hvsock_lwt.Flow.Make(Host.Time)(Host.Fn)(Hvsock.Af_hyperv) - module HV_generic = Hvsock_lwt.Flow.Make(Host.Time)(Host.Fn)(Hvsock.Socket) + module Forward_unix = Forward.Make(Connect_unix)(Bind) + module Forward_hvsock = Forward.Make(Connect_hvsock)(Bind) + module HV = Hvsock_lwt.Flow.Make(Host.Fn)(Hvsock.Af_hyperv) + module HV_generic = Hvsock_lwt.Flow.Make(Host.Fn)(Hvsock.Socket) module HostsFile = Hosts.Make(Host.Files) let file_descr_of_int (x: int) : Unix.file_descr = @@ -100,7 +100,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = | x -> Lwt.return x | exception e -> Log.err (fun f -> f "Caught %s while creating Hyper-V socket" (Printexc.to_string e)); - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop () in loop () @@ -126,7 +126,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = (Hvsock.Af_hyperv.string_of_sockaddr sockaddr)); log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) ) >>= fun () -> aux () in @@ -138,7 +138,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = | x -> Lwt.return x | exception e -> Log.err (fun f -> f "Caught %s while creating hypervisor socket" (Printexc.to_string e)); - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop () in loop () @@ -165,7 +165,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = (Hvsock.Socket.string_of_sockaddr sockaddr)); log_exception_continue "HV_generic.Socket.close" (fun () -> HV_generic.Socket.close socket) >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) ) >>= fun () -> aux () in @@ -187,11 +187,11 @@ let hvsock_addr_of_uri ~default_serviceid uri = | Unix.Unix_error(_, _, _) -> log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) | _ -> log_exception_continue "HV.Socket.close" (fun () -> HV.Socket.close socket) >>= fun () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) ) >>= fun () -> aux () @@ -398,8 +398,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = match Uri.scheme uri with | Some ("hyperv-connect"|"hyperv-listen") -> let module Slirp_stack = - Slirp.Make(Vmnet.Make(HV))(Dns_policy) - (Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make(Vmnet.Make(HV))(Dns_policy)(Vnet) in let sockaddr = hvsock_addr_of_uri ~default_serviceid:ethernet_serviceid @@ -431,8 +430,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = else hvsock_listen sockaddr callback | Some "fd" | None -> let module Slirp_stack = - Slirp.Make(Vmnet.Make(Host.Sockets.Stream.Unix))(Dns_policy) - (Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make(Vmnet.Make(Host.Sockets.Stream.Unix))(Dns_policy)(Vnet) in begin match http_intercept_api_path with | None -> () @@ -466,8 +464,7 @@ let hvsock_addr_of_uri ~default_serviceid uri = end | _ -> let module Slirp_stack = - Slirp.Make(Vmnet.Make(HV_generic))(Dns_policy) - (Mclock)(Mirage_random_stdlib)(Vnet) + Slirp.Make(Vmnet.Make(HV_generic))(Dns_policy)(Vnet) in Slirp_stack.create_static vnet_switch configuration >>= fun stack_config -> @@ -863,21 +860,21 @@ let gc_compact = in Arg.(value & opt (some int) None doc) -let command = +let term, info = let doc = "proxy TCP/IP connections from an ethernet link via sockets" in let man = [`S "DESCRIPTION"; `P "Terminates TCP/IP and UDP/IP connections from a client and proxy the\ flows via userspace sockets"] in - Term.(pure main + Term.(const main $ socket $ port_control_urls $ introspection_urls $ diagnostics_urls $ pcap_urls $ pcap_snaplen $ max_connections $ port_forwards $ dns $ http $ http_intercept_api_path $ 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 $ forwards_path $ gc_compact), - Term.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man + Cmd.info (Filename.basename Sys.argv.(0)) ~version:Version.git ~doc ~man let () = Printexc.record_backtrace true; @@ -886,4 +883,5 @@ let () = Log.err (fun f -> f "Lwt.async failure %a: %s" Fmt.exn exn (Printexc.get_backtrace ())) ); - Term.exit @@ Term.eval command + let command = Cmd.v info term in + exit (Cmd.eval command) diff --git a/src/dns_forward/dns_forward.mli b/src/dns_forward/dns_forward.mli index bed26507e..62b3a6997 100644 --- a/src/dns_forward/dns_forward.mli +++ b/src/dns_forward/dns_forward.mli @@ -37,7 +37,7 @@ module Flow: sig on a well-known address (see Server) *) module type Client = sig - include Mirage_flow_combinators.SHUTDOWNABLE + include Mirage_flow.S type address (** Identifies an endpoint for [connect] *) @@ -64,7 +64,7 @@ module Flow: sig (** Accept connections forever, calling the callback with each one. Connections are closed automatically when the callback finishes. *) - val shutdown: server -> unit Lwt.t + val stop: server -> unit Lwt.t (** Stop accepting connections on the given server *) end end @@ -215,16 +215,14 @@ module Rpc: sig module Persistent: sig module Make (Flow: Flow.Client with type address = Ipaddr.t * int) - (Framing: Framing.S with type flow = Flow.flow) - (Time: Mirage_time.S): S + (Framing: Framing.S with type flow = Flow.flow) : S (** Construct a multiplexing RPC client given a Flow and a method of Framing messages over the flow. *) end module Nonpersistent: sig module Make (Flow: Flow.Client with type address = Ipaddr.t * int) - (Framing: Framing.S with type flow = Flow.flow) - (Time: Mirage_time.S): S + (Framing: Framing.S with type flow = Flow.flow): S (** Construct an RPC client given a Flow which sends one message per fresh connection over the flow. *) end @@ -253,14 +251,13 @@ module Rpc: sig (** Listen and accept incoming connections, use the provided callback to answer requests. *) - val shutdown: server -> unit Lwt.t + val stop: server -> unit Lwt.t (** Shutdown the server and free any allocated resources. *) end module Make (Flow: Flow.Server with type address = Ipaddr.t * int) - (Framing: Framing.S with type flow = Flow.flow) - (Time: Mirage_time.S): S + (Framing: Framing.S with type flow = Flow.flow): S (** Construct an RPC server given a Flow and a method of Framing messages over the flow. *) end @@ -297,10 +294,7 @@ module Resolver: sig end module Make - (Client: Rpc.Client.S) - (Time : Mirage_time.S) - (Clock : Mirage_clock.MCLOCK): - S + (Client: Rpc.Client.S) : S (** Construct a DNS resolver which will use the given [Client] Implementation to contact upstream servers, and the given [Time] implementation to handle timeouts. *) diff --git a/src/dns_forward/dns_forward_cache.ml b/src/dns_forward/dns_forward_cache.ml index 0af0f62dd..6868b6352 100644 --- a/src/dns_forward/dns_forward_cache.ml +++ b/src/dns_forward/dns_forward_cache.ml @@ -37,7 +37,6 @@ type answer = { timeout: unit Lwt.t; } -module Make(Time: Mirage_time.S) = struct type t = { max_bindings: int; (* For every question we store a mapping of server address to the answer *) @@ -89,7 +88,7 @@ module Make(Time: Mirage_time.S) = struct in let timeout = let open Lwt.Infix in - Time.sleep_ns (Duration.of_sec @@ Int32.to_int min_ttl) + Mirage_sleep.ns (Duration.of_sec @@ Int32.to_int min_ttl) >>= fun () -> if Question.Map.mem question t.cache then begin let address_to_answer = @@ -109,4 +108,3 @@ module Make(Time: Mirage_time.S) = struct in t.cache <- Question.Map.add question (Address.Map.add address answer address_to_answer) t.cache -end diff --git a/src/dns_forward/dns_forward_cache.mli b/src/dns_forward/dns_forward_cache.mli index 504e90252..26167c4bd 100644 --- a/src/dns_forward/dns_forward_cache.mli +++ b/src/dns_forward/dns_forward_cache.mli @@ -15,7 +15,6 @@ * *) -module Make(Time: Mirage_time.S): sig type t (** A cache of DNS answers *) @@ -32,4 +31,3 @@ module Make(Time: Mirage_time.S): sig val insert: t -> Dns_forward_config.Address.t -> Dns.Packet.question -> Dns.Packet.rr list -> unit (** Insert the answer to the question into the cache *) -end diff --git a/src/dns_forward/dns_forward_resolver.ml b/src/dns_forward/dns_forward_resolver.ml index a4c968dd9..2894ba901 100644 --- a/src/dns_forward/dns_forward_resolver.ml +++ b/src/dns_forward/dns_forward_resolver.ml @@ -72,12 +72,10 @@ let or_fail_msg m = m >>= function module type S = Dns_forward_s.RESOLVER module Make - (Client: Dns_forward_s.RPC_CLIENT) - (Time : Mirage_time.S) - (Clock : Mirage_clock.MCLOCK) = + (Client: Dns_forward_s.RPC_CLIENT) = struct - module Cache = Dns_forward_cache.Make(Time) + module Cache = Dns_forward_cache type address = Dns_forward_config.Address.t type message_cb = ?src:address -> ?dst:address -> buf:Cstruct.t -> unit -> unit Lwt.t @@ -153,7 +151,7 @@ struct | None -> let c = List.find (fun c -> c.server = server) t.connections in begin - let now_ns = Clock.elapsed_ns () in + let now_ns = Mirage_mtime.elapsed_ns () in (* If no timeout is configured, we will stop listening after 5s to avoid leaking threads if a server is offline *) let timeout_ns = @@ -177,11 +175,11 @@ struct in make 0L in let requests = List.map (fun delay_ns -> - Time.sleep_ns delay_ns >>= fun () -> + Mirage_sleep.ns delay_ns >>= fun () -> Client.rpc c.client buffer ) delays_ns in let timeout = - Time.sleep_ns timeout_ns >|= fun () -> + Mirage_sleep.ns timeout_ns >|= fun () -> Error (`Msg "timeout") in Lwt.pick (timeout :: requests) diff --git a/src/dns_forward/dns_forward_resolver.mli b/src/dns_forward/dns_forward_resolver.mli index c958f3af2..71eaf4528 100644 --- a/src/dns_forward/dns_forward_resolver.mli +++ b/src/dns_forward/dns_forward_resolver.mli @@ -18,7 +18,4 @@ module type S = Dns_forward_s.RESOLVER module Make - (Client: Dns_forward_s.RPC_CLIENT) - (Time: Mirage_time.S) - (Clock: Mirage_clock.MCLOCK): - S + (Client: Dns_forward_s.RPC_CLIENT) : S diff --git a/src/dns_forward/dns_forward_rpc.ml b/src/dns_forward/dns_forward_rpc.ml index ec2b69f96..6f416bbab 100644 --- a/src/dns_forward/dns_forward_rpc.ml +++ b/src/dns_forward/dns_forward_rpc.ml @@ -29,8 +29,7 @@ module Client = struct module Nonpersistent = struct module Make (Sockets: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Packet: Dns_forward_s.READERWRITER with type flow = Sockets.flow) - (Time: Mirage_time.S) = struct + (Packet: Dns_forward_s.READERWRITER with type flow = Sockets.flow) = struct type address = Dns_forward_config.Address.t type request = Cstruct.t type response = Cstruct.t @@ -115,8 +114,7 @@ module Client = struct module Persistent = struct module Make (Sockets: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Packet: Dns_forward_s.READERWRITER with type flow = Sockets.flow) - (Time: Mirage_time.S) = struct + (Packet: Dns_forward_s.READERWRITER with type flow = Sockets.flow) = struct type address = Dns_forward_config.Address.t type request = Cstruct.t type response = Cstruct.t @@ -220,7 +218,7 @@ module Client = struct Lwt_result.return rw) >>= fun rw -> (* Add a fresh idle timer *) - t.disconnect_on_idle <- (let open Lwt.Infix in Time.sleep_ns Duration.(of_sec 30) >>= fun () -> disconnect t); + t.disconnect_on_idle <- (let open Lwt.Infix in Mirage_sleep.ns Duration.(of_sec 30) >>= fun () -> disconnect t); Lwt_result.return rw let connect ~gen_transaction_id ?(message_cb = fun ?src:_ ?dst:_ ~buf:_ () -> Lwt.return_unit) address = @@ -320,8 +318,7 @@ module Server = struct module Make (Sockets: Dns_forward_s.FLOW_SERVER with type address = Ipaddr.t * int) - (Packet : Dns_forward_s.READERWRITER with type flow = Sockets.flow) - (Time : Mirage_time.S) = + (Packet : Dns_forward_s.READERWRITER with type flow = Sockets.flow) = struct type address = Dns_forward_config.Address.t @@ -370,8 +367,8 @@ module Server = struct ); Lwt_result.return () - let shutdown server = - Sockets.shutdown server.server + let stop server = + Sockets.stop server.server end end diff --git a/src/dns_forward/dns_forward_rpc.mli b/src/dns_forward/dns_forward_rpc.mli index c378a39c8..76f248d2e 100644 --- a/src/dns_forward/dns_forward_rpc.mli +++ b/src/dns_forward/dns_forward_rpc.mli @@ -23,16 +23,12 @@ module Client: sig module Persistent: sig module Make (Flow: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow) - (Time: Mirage_time.S): - S + (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow):S end module Nonpersistent: sig module Make (Flow: Dns_forward_s.FLOW_CLIENT with type address = Ipaddr.t * int) - (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow) - (Time: Mirage_time.S): - S + (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow):S end end @@ -41,7 +37,5 @@ module Server: sig module Make (Flow: Dns_forward_s.FLOW_SERVER with type address = Ipaddr.t * int) - (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow) - (Time: Mirage_time.S): - S + (Framing: Dns_forward_s.READERWRITER with type flow = Flow.flow):S end diff --git a/src/dns_forward/dns_forward_s.ml b/src/dns_forward/dns_forward_s.ml index 1c1480b54..2dec70a6f 100644 --- a/src/dns_forward/dns_forward_s.ml +++ b/src/dns_forward/dns_forward_s.ml @@ -22,7 +22,7 @@ module type Comparable = sig end module type FLOW_CLIENT = sig - include Mirage_flow_combinators.SHUTDOWNABLE + include Mirage_flow.S type address val connect: ?read_buffer_size:int -> address -> (flow, [ `Msg of string ]) Lwt_result.t @@ -35,7 +35,7 @@ module type FLOW_SERVER = sig val getsockname: server -> address type flow val listen: server -> (flow -> unit Lwt.t) -> unit - val shutdown: server -> unit Lwt.t + val stop: server -> unit Lwt.t end module type RPC_CLIENT = sig @@ -57,7 +57,7 @@ module type RPC_SERVER = sig type server val bind: address -> (server, [ `Msg of string ]) Lwt_result.t val listen: server -> (request -> (response, [ `Msg of string ]) Lwt_result.t) -> (unit, [ `Msg of string ]) Lwt_result.t - val shutdown: server -> unit Lwt.t + val stop: server -> unit Lwt.t end module type RESOLVER = sig diff --git a/src/dns_forward/dns_forward_server.ml b/src/dns_forward/dns_forward_server.ml index 873ede914..db55db727 100644 --- a/src/dns_forward/dns_forward_server.ml +++ b/src/dns_forward/dns_forward_server.ml @@ -52,5 +52,5 @@ module Make(Server: Dns_forward_s.RPC_SERVER)(Resolver: Dns_forward_s.RESOLVER) >>= fun () -> match server with | None -> Lwt.return_unit - | Some server -> Server.shutdown server + | Some server -> Server.stop server end diff --git a/src/dns_forward/dune b/src/dns_forward/dune index fa19afe10..b7c40e859 100644 --- a/src/dns_forward/dune +++ b/src/dns_forward/dune @@ -1,7 +1,7 @@ (library (name dns_forward) (libraries lwt logs dns astring result cstruct fmt ipaddr - mirage-flow mirage-flow-combinators mirage-time mirage-channel mirage-clock + mirage-flow mirage-flow-combinators mirage-sleep mirage-channel mirage-clock sexplib duration) (preprocess (pps ppx_sexp_conv))) diff --git a/src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml b/src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml index 4ef24b783..74d96f117 100644 --- a/src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml +++ b/src/dns_forward_lwt_unix/dns_forward_lwt_unix.ml @@ -193,6 +193,13 @@ module Tcp = struct Lwt.return_unit ) + let shutdown t = function + | `read -> shutdown_read t + | `write -> shutdown_write t + | `read_write -> + shutdown_read t >>= fun () -> + shutdown_write t + type server = { mutable server_fd: Lwt_unix.file_descr option; read_buffer_size: int; @@ -221,7 +228,7 @@ module Tcp = struct let getsockname server = getsockname "Tcp.getsockname" server.server_fd - let shutdown server = match server.server_fd with + let stop server = match server.server_fd with | None -> Lwt.return_unit | Some fd -> server.server_fd <- None; @@ -279,7 +286,7 @@ module Tcp = struct Lwt_unix.listen fd 32; loop fd ) (fun () -> - shutdown server + stop server ) ) (fun e -> Log.info (fun f -> f "%s: caught %s so shutting down server" @@ -373,8 +380,7 @@ module Udp = struct Log.debug (fun f -> f "%s: close" (string_of_flow t)); Lwt_unix.close fd - let shutdown_read _t = Lwt.return_unit - let shutdown_write _t = Lwt.return_unit + let shutdown _t _ = Lwt.return_unit type server = { mutable server_fd: Lwt_unix.file_descr option; @@ -396,7 +402,7 @@ module Udp = struct | e -> errorf "udp:%s: bind caught %s" (string_of_address address) (Printexc.to_string e) - let shutdown t = match t.server_fd with + let stop t = match t.server_fd with | None -> Lwt.return_unit | Some fd -> t.server_fd <- None; @@ -449,26 +455,21 @@ module Udp = struct Lwt.async loop end -module Time = struct - let sleep_ns ns = Lwt_unix.sleep (Duration.to_f ns) -end -module Clock = Mclock - module R = struct open Dns_forward - module Udp_client = Rpc.Client.Nonpersistent.Make(Udp)(Framing.Udp(Udp))(Time) - module Udp = Resolver.Make(Udp_client)(Time)(Clock) + module Udp_client = Rpc.Client.Nonpersistent.Make(Udp)(Framing.Udp(Udp)) + module Udp = Resolver.Make(Udp_client) - module Tcp_client = Rpc.Client.Persistent.Make(Tcp)(Framing.Tcp(Tcp))(Time) - module Tcp = Resolver.Make(Tcp_client)(Time)(Clock) + module Tcp_client = Rpc.Client.Persistent.Make(Tcp)(Framing.Tcp(Tcp)) + module Tcp = Resolver.Make(Tcp_client) end module Server = struct open Dns_forward - module Udp_server = Rpc.Server.Make(Udp)(Framing.Udp(Udp))(Time) + module Udp_server = Rpc.Server.Make(Udp)(Framing.Udp(Udp)) module Udp = Server.Make(Udp_server)(R.Udp) - module Tcp_server = Rpc.Server.Make(Tcp)(Framing.Tcp(Tcp))(Time) + module Tcp_server = Rpc.Server.Make(Tcp)(Framing.Tcp(Tcp)) module Tcp = Server.Make(Tcp_server)(R.Tcp) end diff --git a/src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli b/src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli index 4a3cc0d2e..601acf918 100644 --- a/src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli +++ b/src/dns_forward_lwt_unix/dns_forward_lwt_unix.mli @@ -33,4 +33,3 @@ module Server: sig (** A forwarding DNS proxy over TCP *) end -module Clock: Mirage_clock.MCLOCK diff --git a/src/dns_forward_test/dune b/src/dns_forward_test/dune index 26795c666..5451a79ca 100644 --- a/src/dns_forward_test/dune +++ b/src/dns_forward_test/dune @@ -2,6 +2,14 @@ (names test) (libraries dns_forward dns_forward_lwt_unix lwt-dllist logs logs.fmt alcotest)) +(executable + (name test_fake) + (libraries dns_forward dns_forward_lwt_unix lwt-dllist logs logs.fmt alcotest fake_sleep fake_time)) + (rule (alias runtest) (action (run ./test.exe))) + +(rule + (alias runtest) + (action (run ./test_fake.exe))) diff --git a/src/dns_forward_test/fake_sleep/dune b/src/dns_forward_test/fake_sleep/dune new file mode 100644 index 000000000..ad2729b29 --- /dev/null +++ b/src/dns_forward_test/fake_sleep/dune @@ -0,0 +1,4 @@ +(library + (name fake_sleep) + (libraries lwt fake_time) + (implements mirage-sleep)) diff --git a/src/dns_forward_test/fake.mli b/src/dns_forward_test/fake_sleep/mirage_sleep.ml similarity index 60% rename from src/dns_forward_test/fake.mli rename to src/dns_forward_test/fake_sleep/mirage_sleep.ml index ded1fad1a..462dbd182 100644 --- a/src/dns_forward_test/fake.mli +++ b/src/dns_forward_test/fake_sleep/mirage_sleep.ml @@ -1,3 +1,4 @@ + (* * Copyright (C) 2017 Docker Inc * @@ -15,17 +16,18 @@ * *) -(** A fake Time and Clock module for testing the timing without having to actually - wait. *) - -module Time: Mirage_time.S - -module Clock: Mirage_clock.MCLOCK +type t = { time : int64; mutable canceled : bool; thread : unit Lwt.u } -val advance: int64 -> unit -(** [advance nsecs]: advances the clock by [nsecs]. Note this will make sleeping - threads runnable but it will not wait for them to finish or even to run. - External synchronisation still needs to be used. *) +let ns n = + let open Lwt.Infix in + (* All sleeping is relative to the start of the program for now *) + let now = 0L in + let rec loop () = + let tod = !Fake_time_state.timeofday in + if tod > Int64.add now n then Lwt.return_unit else ( + Lwt_condition.wait Fake_time_state.c >>= fun () -> + loop () + ) in + loop () -val reset: unit -> unit -(** [reset ()] sets the clock back to the initial value for another test. *) +let new_sleepers () = [] diff --git a/src/dns_forward_test/fake_time/dune b/src/dns_forward_test/fake_time/dune new file mode 100644 index 000000000..740e71fad --- /dev/null +++ b/src/dns_forward_test/fake_time/dune @@ -0,0 +1,4 @@ +(library + (name fake_time) + (implements mirage-mtime) + (libraries lwt)) diff --git a/src/dns_forward_test/fake_time/fake_time_state.ml b/src/dns_forward_test/fake_time/fake_time_state.ml new file mode 100644 index 000000000..597f1bcb4 --- /dev/null +++ b/src/dns_forward_test/fake_time/fake_time_state.ml @@ -0,0 +1,10 @@ +let timeofday = ref 0L +let c = Lwt_condition.create () + +let advance nsecs = + timeofday := Int64.add !timeofday nsecs; + Lwt_condition.broadcast c () + +let reset () = + timeofday := 0L; + Lwt_condition.broadcast c () diff --git a/src/dns_forward_test/fake.ml b/src/dns_forward_test/fake_time/mirage_mtime.ml similarity index 51% rename from src/dns_forward_test/fake.ml rename to src/dns_forward_test/fake_time/mirage_mtime.ml index 55f4633fc..1544bd3a0 100644 --- a/src/dns_forward_test/fake.ml +++ b/src/dns_forward_test/fake_time/mirage_mtime.ml @@ -15,35 +15,5 @@ * *) -(* A fake Time and Clock module for testing the timing without having to actually - wait. *) - -let timeofday = ref 0L -let c = Lwt_condition.create () - -let advance nsecs = - timeofday := Int64.add !timeofday nsecs; - Lwt_condition.broadcast c () - -let reset () = - timeofday := 0L; - Lwt_condition.broadcast c () - -module Time = struct - let sleep_ns n = - let open Lwt.Infix in - (* All sleeping is relative to the start of the program for now *) - let now = 0L in - let rec loop () = - if !timeofday > Int64.add now n then Lwt.return_unit else ( - Lwt_condition.wait c >>= fun () -> - loop () - ) in - loop () - -end - -module Clock = struct - let elapsed_ns () = !timeofday - let period_ns () = None -end +let elapsed_ns () = !Fake_time_state.timeofday +let period_ns () = None diff --git a/src/dns_forward_test/flow.ml b/src/dns_forward_test/flow.ml index 647cf2f92..c9d3569d1 100644 --- a/src/dns_forward_test/flow.ml +++ b/src/dns_forward_test/flow.ml @@ -84,6 +84,14 @@ let shutdown_write flow = Lwt_condition.signal flow.l2r_c (); Lwt.return_unit +let shutdown flow = function + | `read -> shutdown_read flow + | `write -> shutdown_write flow + | `read_write -> + let open Lwt.Infix in + shutdown_read flow >>= fun () -> + shutdown_write flow + let writev flow bufs = if flow.l2r_closed then Lwt.return (Error `Closed) else ( List.iter (fun buf -> ignore @@ Lwt_dllist.add_l buf flow.l2r) bufs; @@ -145,7 +153,8 @@ let listen server (cb: flow -> unit Lwt.t) = ); Lwt.return (Result.Ok flow) in server.listen_cb <- listen_cb -let shutdown server = + +let stop server = server.listen_cb <- (fun _ -> Lwt.return (Result.Error (`Msg "shutdown"))); Hashtbl.remove bound server.address; Lwt.return_unit diff --git a/src/dns_forward_test/rpc.ml b/src/dns_forward_test/rpc.ml index 02b818b64..dca66a7e9 100644 --- a/src/dns_forward_test/rpc.ml +++ b/src/dns_forward_test/rpc.ml @@ -85,7 +85,7 @@ let bind address = let listen server cb = server.listen_cb <- cb; Lwt.return (Result.Ok ()) -let shutdown server = +let stop server = server.listen_cb <- (fun _ -> Lwt.return (Result.Error (`Msg "shutdown"))); Hashtbl.remove bound server.address; Lwt.return_unit diff --git a/src/dns_forward_test/server.ml b/src/dns_forward_test/server.ml index 24e2c5882..e4a18f410 100644 --- a/src/dns_forward_test/server.ml +++ b/src/dns_forward_test/server.ml @@ -87,6 +87,6 @@ module Make(Server: Rpc.Server.S) = struct >>= fun () -> Lwt.return (Ok server) - let shutdown = Server.shutdown + let stop = Server.stop end diff --git a/src/dns_forward_test/server.mli b/src/dns_forward_test/server.mli index df75911e5..af9eed9ac 100644 --- a/src/dns_forward_test/server.mli +++ b/src/dns_forward_test/server.mli @@ -32,7 +32,7 @@ module Make(Server: Rpc.Server.S): sig val serve: address: Config.Address.t -> t -> server Error.t (** Serve requests on the given IP and port forever *) - val shutdown: server -> unit Lwt.t + val stop: server -> unit Lwt.t (** Shutdown the running server *) val get_nr_queries: t -> int diff --git a/src/dns_forward_test/test.ml b/src/dns_forward_test/test.ml index 61d117de2..d2f83142c 100644 --- a/src/dns_forward_test/test.ml +++ b/src/dns_forward_test/test.ml @@ -1,6 +1,4 @@ - module Error = Dns_forward.Error.Infix -module Clock = Dns_forward_lwt_unix.Clock let fresh_id = let next = ref 1000 in @@ -77,11 +75,6 @@ let test_server () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); | Error (`Msg m) -> failwith m -module NormalTime = struct - type 'a io = 'a Lwt.t - let sleep_ns ns = Lwt_unix.sleep (Duration.to_f ns) -end - let test_local_lookups () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); match Lwt_main.run begin @@ -95,7 +88,7 @@ let test_local_lookups () = let open Error in S.serve ~address:public_address public_server >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Rpc)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make (Rpc) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; @@ -144,8 +137,8 @@ let test_local_lookups () = let test_udp_nonpersistent () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Udp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Nonpersistent.Make(Flow)(Dns_forward.Framing.Udp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Udp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Nonpersistent.Make(Flow)(Dns_forward.Framing.Udp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) @@ -155,7 +148,7 @@ let test_udp_nonpersistent () = let open Error in S.serve ~address:public_address public_server >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; @@ -228,8 +221,8 @@ let test_udp_nonpersistent () = let test_tcp_multiplexing () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) @@ -239,7 +232,7 @@ let test_tcp_multiplexing () = let open Error in S.serve ~address:public_address public_server >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 0 }; @@ -313,8 +306,8 @@ let test_tcp_multiplexing () = let test_good_bad_server () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) @@ -329,7 +322,7 @@ let test_good_bad_server () = let bad_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in S.serve ~address:bad_address bad_server >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in (* Forward to a good server and a bad server, both with timeouts. The request to the bad request should fail fast but the good server should be given up to @@ -370,92 +363,12 @@ let test_good_bad_server () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); | Error (`Msg m) -> failwith m -(* One good one dead server should behave like the good server *) -let test_good_dead_server () = - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(Fake.Time) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(Fake.Time) in - let module S = Server.Make(Proto_server) in - let foo_public = "8.8.8.8" in - (* a public server mapping 'foo' to a public ip *) - let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in - let public_address = - let port = fresh_port () in - { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } in - let open Error in - S.serve ~address:public_address public_server - >>= fun _ -> - let bad_server = S.make ~delay:30. [] in - let bad_address = - let port = fresh_port () in - { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } in - S.serve ~address:bad_address bad_server - >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(Fake.Time)(Fake.Clock) in - let open Dns_forward.Config in - (* Forward to a good server and a bad server, both with timeouts. The request to - the bad request should fail fast but the good server should be given up to - the timeout to respond *) - let servers = Server.Set.of_list [ - { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - { Server.address = bad_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; - ] in - let config = { servers; search = []; assume_offline_after_drops = Some 1 } in - let open Lwt.Infix in - R.create ~gen_transaction_id:Random.int config - >>= fun r -> - let request = make_a_query (Dns.Name.of_string "foo") in - let t = R.answer request r in - (* First request will trigger the internal timeout and mark the bad server - as offline. The sleep timeout here will only trigger if this fails. *) - Fake.advance Duration.(of_sec 1); - (* HACK: we want to let all threads run until they block but we don't have - an API for that. This assumes that all computation will finish in 0.1s *) - Lwt_unix.sleep 0.1 >>= fun () -> - Fake.advance Duration.(of_sec 1); - Lwt_unix.sleep 0.1 >>= fun () -> - Lwt.pick [ - (Lwt_unix.sleep 1. >>= fun () -> Lwt.fail_with "test_good_dead_server: initial request had no response"); - t >>= fun _ -> Lwt.return_unit - ] - >>= fun () -> - (* The bad server should be marked offline and no-one will wait for it *) - Fake.reset (); - Fake.advance Duration.(of_ms 500); (* avoid the timeouts winning the race with the actual result *) - let request = - R.answer request r - >>= function - | Ok reply -> - let len = Cstruct.length reply in - let buf = reply in - begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with - | Some { Dns.Packet.answers = _ :: _ ; _ } -> Lwt.return_true - | Some packet -> failwith ("test_good_dead_server bad response: " ^ (Dns.Packet.to_string packet)) - | None -> failwith "test_good_dead_server: failed to parse response" - end - | Error _ -> failwith "test_good_dead_server timeout: did the failure overtake the success?" in - let timeout = - Lwt_unix.sleep 5. - >>= fun () -> - Lwt.return false in - Lwt.pick [ request; timeout ] - >>= fun ok -> - if not ok then failwith "test_good_dead_server hit timeout"; - R.destroy r - >>= fun () -> - Lwt.return (Ok ()) - end with - | Ok () -> - Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - | Error (`Msg m) -> failwith m - (* One bad server should be ignored *) let test_bad_server () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); match Lwt_main.run begin - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) @@ -465,7 +378,7 @@ let test_bad_server () = let open Error in S.serve ~address:public_address public_server >>= fun _ -> - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in let port = fresh_port () in let bad_address = { Dns_forward.Config.Address.ip = Ipaddr.V4 Ipaddr.V4.localhost; port } in @@ -503,8 +416,8 @@ let test_bad_server () = let test_timeout () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) @@ -517,7 +430,7 @@ let test_timeout () = S.serve ~address:bar_address bar_server >>= fun _ -> (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = bar_address; zones = Domain.Set.empty; timeout_ms = Some 0; order = 0 } @@ -551,8 +464,8 @@ let test_timeout () = let test_cache () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in (* a public server mapping 'foo' to a public ip *) @@ -565,7 +478,7 @@ let test_cache () = S.serve ~address:bar_address bar_server >>= fun server -> (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = bar_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 } @@ -579,7 +492,7 @@ let test_cache () = >>= function | Error _ -> failwith "failed initial lookup" | Ok _ -> - S.shutdown server + S.stop server >>= fun () -> R.answer request r >>= function @@ -600,8 +513,8 @@ let test_cache () = slow private server. *) let test_order () = Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); - let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in - let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow))(NormalTime) in + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in let module S = Server.Make(Proto_server) in let foo_public = "8.8.8.8" in let foo_private = "192.168.1.1" in @@ -622,7 +535,7 @@ let test_order () = >>= fun _ -> (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Proto_client)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Proto_client) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = None; order = 1 }; @@ -674,7 +587,7 @@ let test_forwarder_zone () = S.serve ~address:bar_address bar_server >>= fun _ -> (* a resolver which uses both servers *) - let module R = Dns_forward.Resolver.Make(Rpc)(NormalTime)(Mclock) in + let module R = Dns_forward.Resolver.Make(Rpc) in let open Dns_forward.Config in let servers = Server.Set.of_list [ { Server.address = foo_address; zones = Domain.Set.add [ "foo" ] Domain.Set.empty; timeout_ms = None; order = 0 }; @@ -733,7 +646,6 @@ let test_forwarder_set = [ "Server order", `Quick, test_order; "Caching", `Quick, test_cache; "Tolerate bad server", `Quick, test_good_bad_server; - "Tolerate broken server", `Quick, test_good_dead_server; ] open Dns_forward.Config diff --git a/src/dns_forward_test/test_fake.ml b/src/dns_forward_test/test_fake.ml new file mode 100644 index 000000000..e66299419 --- /dev/null +++ b/src/dns_forward_test/test_fake.ml @@ -0,0 +1,124 @@ +module Error = Dns_forward.Error.Infix + +let fresh_id = + let next = ref 1000 in + fun () -> + let this = !next in + next := !next mod 0xffff; + this + +let make_a_query name = + let open Dns.Packet in + let id = fresh_id () in + let detail = { qr = Query; opcode = Standard; aa = true; tc = false; rd = true; ra = false; rcode = NoError } in + let questions = [ make_question Q_A name ] in + let answers = [] in + let authorities = [] in + let additionals = [] in + let pkt = { id; detail; questions; answers; authorities; additionals } in + marshal pkt + +let fresh_port = + let next = ref 0 in + fun () -> + let port = !next in + incr next; + port + +(* One good one dead server should behave like the good server *) +let test_good_dead_server () = + Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + match Lwt_main.run begin + let module Proto_server = Dns_forward.Rpc.Server.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module Proto_client = Dns_forward.Rpc.Client.Persistent.Make(Flow)(Dns_forward.Framing.Tcp(Flow)) in + let module S = Server.Make(Proto_server) in + let foo_public = "8.8.8.8" in + (* a public server mapping 'foo' to a public ip *) + let public_server = S.make [ "foo", Ipaddr.of_string_exn foo_public ] in + let public_address = + let port = fresh_port () in + { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } in + let open Error in + S.serve ~address:public_address public_server + >>= fun _ -> + let bad_server = S.make ~delay:30. [] in + let bad_address = + let port = fresh_port () in + { Dns_forward.Config.Address.ip = Ipaddr.(V4 V4.localhost); port } in + S.serve ~address:bad_address bad_server + >>= fun _ -> + let module R = Dns_forward.Resolver.Make(Proto_client) in + let open Dns_forward.Config in + (* Forward to a good server and a bad server, both with timeouts. The request to + the bad request should fail fast but the good server should be given up to + the timeout to respond *) + let servers = Server.Set.of_list [ + { Server.address = public_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; + { Server.address = bad_address; zones = Domain.Set.empty; timeout_ms = Some 1000; order = 0 }; + ] in + let config = { servers; search = []; assume_offline_after_drops = Some 1 } in + let open Lwt.Infix in + R.create ~gen_transaction_id:Random.int config + >>= fun r -> + let request = make_a_query (Dns.Name.of_string "foo") in + let t = R.answer request r in + (* First request will trigger the internal timeout and mark the bad server + as offline. The sleep timeout here will only trigger if this fails. *) + Fake_time_state.advance Duration.(of_sec 1); + (* HACK: we want to let all threads run until they block but we don't have + an API for that. This assumes that all computation will finish in 0.1s *) + Lwt_unix.sleep 0.1 >>= fun () -> + Fake_time_state.advance Duration.(of_sec 1); + Lwt_unix.sleep 0.1 >>= fun () -> + Lwt.pick [ + (Lwt_unix.sleep 1. >>= fun () -> Lwt.fail_with "test_good_dead_server: initial request had no response"); + t >>= fun _ -> Lwt.return_unit + ] + >>= fun () -> + (* The bad server should be marked offline and no-one will wait for it *) + Fake_time_state.reset (); + Fake_time_state.advance Duration.(of_ms 500); (* avoid the timeouts winning the race with the actual result *) + let request = + R.answer request r + >>= function + | Ok reply -> + let len = Cstruct.length reply in + let buf = reply in + begin match Dns.Protocol.Server.parse (Cstruct.sub buf 0 len) with + | Some { Dns.Packet.answers = _ :: _ ; _ } -> Lwt.return_true + | Some packet -> failwith ("test_good_dead_server bad response: " ^ (Dns.Packet.to_string packet)) + | None -> failwith "test_good_dead_server: failed to parse response" + end + | Error _ -> failwith "test_good_dead_server timeout: did the failure overtake the success?" in + let timeout = + Lwt_unix.sleep 5. + >>= fun () -> + Lwt.return false in + Lwt.pick [ request; timeout ] + >>= fun ok -> + if not ok then failwith "test_good_dead_server hit timeout"; + R.destroy r + >>= fun () -> + Lwt.return (Ok ()) + end with + | Ok () -> + Alcotest.(check int) "number of connections" 0 (List.length @@ Rpc.get_connections ()); + | Error (`Msg m) -> failwith m + +let tests = [ + "Tolerate broken server", `Quick, test_good_dead_server; +] + +let () = + Logs.set_reporter (Logs_fmt.reporter ()); + Lwt.async_exception_hook := (fun exn -> + Logs.err (fun f -> f "Lwt.async failure %s: %s" + (Printexc.to_string exn) + (Printexc.get_backtrace ()) + ) + ); + Random.self_init (); + + Alcotest.run "dns-forward-fake" [ + "Test infrastructure", tests + ] diff --git a/src/dns_mirage/dns_resolver_mirage.ml b/src/dns_mirage/dns_resolver_mirage.ml index c075d6c73..c5332aacf 100644 --- a/src/dns_mirage/dns_resolver_mirage.ml +++ b/src/dns_mirage/dns_resolver_mirage.ml @@ -20,7 +20,7 @@ open Dns_resolver module DP = Packet -let default_ns = Ipaddr.V4.of_string_exn "8.8.8.8" +let default_ns = Ipaddr.of_string_exn "8.8.8.8" let default_port = 53 module type S = sig @@ -31,20 +31,20 @@ module type S = sig val resolve : (module Protocol.CLIENT) -> - t -> Ipaddr.V4.t -> int -> + t -> Ipaddr.t -> int -> Packet.q_class -> Packet.q_type -> Name.t -> Packet.t Lwt.t val gethostbyname : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + ?server:Ipaddr.t -> ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> string -> Ipaddr.t list Lwt.t val gethostbyaddr : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + ?server:Ipaddr.t -> ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> Ipaddr.V4.t -> string list Lwt.t @@ -80,10 +80,10 @@ module Static = struct return (Hashtbl.find_all s.rev addr) end -module Make(Time:Mirage_time.S)(S:Tcpip.Stack.V4) = struct +module Make(S:Tcpip.Stack.V4V6) = struct type stack = S.t - type endp = Ipaddr.V4.t * int + type endp = Ipaddr.t * int type t = { s: S.t; @@ -95,23 +95,23 @@ module Make(Time:Mirage_time.S)(S:Tcpip.Stack.V4) = struct { s; res } let connect_to_resolver {s; res} ((dst,dst_port) as endp) = - let udp = S.udpv4 s in + let udp = S.udp s in try Hashtbl.find res endp with Not_found -> - let timerfn () = Time.sleep_ns (Duration.of_sec 5) in + let timerfn () = Mirage_sleep.ns (Duration.of_sec 5) in let mvar = Lwt_mvar.create_empty () in (* TODO: test that port is free. Needs more functions exposed in tcpip *) let src_port = (Random.int 64511) + 1024 in let callback ~src:_ ~dst:_ ~src_port:_ buf = Lwt_mvar.put mvar buf in let cleanfn () = return () in - S.UDPV4.listen (S.udpv4 s) ~port:src_port callback; + S.UDP.listen (S.udp s) ~port:src_port callback; let txfn buf = - S.UDPV4.write ~src_port ~dst ~dst_port udp buf >>= function + S.UDP.write ~src_port ~dst ~dst_port udp buf >>= function | Error e -> Fmt.kstr fail_with "Attempting to communicate with remote resolver: %a" - S.UDPV4.pp_error e + S.UDP.pp_error e | Ok () -> Lwt.return_unit in let rec rxfn f = diff --git a/src/dns_mirage/dns_resolver_mirage.mli b/src/dns_mirage/dns_resolver_mirage.mli index 45c319afa..b82480b5b 100644 --- a/src/dns_mirage/dns_resolver_mirage.mli +++ b/src/dns_mirage/dns_resolver_mirage.mli @@ -14,7 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -val default_ns : Ipaddr.V4.t +val default_ns : Ipaddr.t val default_port : int module type S = sig @@ -25,20 +25,20 @@ module type S = sig val resolve : (module Dns.Protocol.CLIENT) -> - t -> Ipaddr.V4.t -> int -> + t -> Ipaddr.t -> int -> Dns.Packet.q_class -> Dns.Packet.q_type -> Dns.Name.t -> Dns.Packet.t Lwt.t val gethostbyname : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + ?server:Ipaddr.t -> ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> string -> Ipaddr.t list Lwt.t val gethostbyaddr : t -> - ?server:Ipaddr.V4.t -> ?dns_port:int -> + ?server:Ipaddr.t -> ?dns_port:int -> ?q_class:Dns.Packet.q_class -> ?q_type:Dns.Packet.q_type -> Ipaddr.V4.t -> string list Lwt.t @@ -52,4 +52,4 @@ type static_dns = module Static : S with type stack = static_dns -module Make(Time:Mirage_time.S)(S:Tcpip.Stack.V4) : S with type stack = S.t +module Make(S:Tcpip.Stack.V4V6) : S with type stack = S.t diff --git a/src/dns_mirage/dune b/src/dns_mirage/dune index 88901b339..2d9b9478c 100644 --- a/src/dns_mirage/dune +++ b/src/dns_mirage/dune @@ -1,4 +1,4 @@ (library (name mirage_dns) - (libraries dns_lwt duration mirage-time mirage-stack mirage-kv) + (libraries dns_lwt duration mirage-sleep tcpip mirage-kv) (wrapped false)) diff --git a/src/forwarder/multiplexer.ml b/src/forwarder/multiplexer.ml index 5d49217bd..62ac301b2 100644 --- a/src/forwarder/multiplexer.ml +++ b/src/forwarder/multiplexer.ml @@ -261,6 +261,11 @@ module Make (Flow : Mirage_flow.S) = struct (* boilerplate: *) let shutdown_read _chanel = Lwt.return_unit + let shutdown channel = function + | `write -> shutdown_write channel + | `read -> shutdown_read channel + | `read_write -> shutdown_read channel >>= fun () -> shutdown_write channel + let write channel buf = writev channel [buf] type flow = channel diff --git a/src/forwarder/multiplexer.mli b/src/forwarder/multiplexer.mli index 97c98407b..f1e1a1bc6 100644 --- a/src/forwarder/multiplexer.mli +++ b/src/forwarder/multiplexer.mli @@ -6,7 +6,7 @@ module Make (Flow : Mirage_flow.S) : sig val connect : flow -> Frame.Destination.t -> channel Lwt.t - include Mirage_flow_combinators.SHUTDOWNABLE with type flow = channel + include Mirage_flow.S with type flow = channel val read_into: channel -> Cstruct.t -> (unit Mirage_flow.or_eof, error) result Lwt.t end diff --git a/src/hostnet/dune b/src/hostnet/dune index 222bbbd6e..5451d850b 100644 --- a/src/hostnet/dune +++ b/src/hostnet/dune @@ -8,6 +8,6 @@ luv_unix lwt.unix threads astring fs9p dns_forward tar mirage-vnetif uuidm cohttp-lwt mirage-channel ezjsonm duration mirage-time mirage-clock - mirage-random tcpip.checksum forwarder cstructs sha) + tcpip.checksum forwarder cstructs sha) (foreign_stubs (language c) (names stubs_utils)) (wrapped false)) diff --git a/src/hostnet/filter.ml b/src/hostnet/filter.ml index f84a57ab0..d6df5a54f 100644 --- a/src/hostnet/filter.ml +++ b/src/hostnet/filter.ml @@ -40,7 +40,7 @@ module Make(Input: Sig.VMNET) = struct let filter valid_subnets valid_sources next buf = match Ethernet.Packet.of_cstruct buf with | Ok (_header, payload) -> - let src = Ipaddr.V4.of_int32 @@ Ipv4_wire.get_ipv4_src payload in + let src = Ipv4_wire.get_src payload in let from_valid_networks = List.fold_left (fun acc network -> acc || (Ipaddr.V4.Prefix.mem src network) @@ -57,17 +57,16 @@ module Make(Input: Sig.VMNET) = struct let src = Ipaddr.V4.to_string src in let dst = Ipaddr.V4.to_string @@ - Ipaddr.V4.of_int32 @@ - Ipv4_wire.get_ipv4_dst payload + Ipv4_wire.get_dst payload in let body = Cstruct.shift payload Ipv4_wire.sizeof_ipv4 in begin match Ipv4_packet.Unmarshal.int_to_protocol - @@ Ipv4_wire.get_ipv4_proto payload + @@ Ipv4_wire.get_proto payload with | Some `UDP -> - let src_port = Udp_wire.get_udp_source_port body in - let dst_port = Udp_wire.get_udp_dest_port body in + let src_port = Udp_wire.get_src_port body in + let dst_port = Udp_wire.get_dst_port body in Log.warn (fun f -> f "dropping unexpected UDP packet sent from %s:%d to %s:%d \ (valid subnets = %s; valid sources = %s)" @@ -78,8 +77,8 @@ module Make(Input: Sig.VMNET) = struct (List.map Ipaddr.V4.to_string valid_sources)) ) | Some `TCP -> - let src_port = Tcp.Tcp_wire.get_tcp_src_port body in - let dst_port = Tcp.Tcp_wire.get_tcp_dst_port body in + let src_port = Tcp.Tcp_wire.get_src_port body in + let dst_port = Tcp.Tcp_wire.get_dst_port body in Log.warn (fun f -> f "dropping unexpected TCP packet sent from %s:%d to %s:%d \ (valid subnets = %s; valid sources = %s)" @@ -93,7 +92,7 @@ module Make(Input: Sig.VMNET) = struct Log.warn (fun f -> f "dropping unknown IP protocol %d sent from %s to %s (valid \ subnets = %s; valid sources = %s)" - (Ipv4_wire.get_ipv4_proto payload) src dst + (Ipv4_wire.get_proto payload) src dst (String.concat ", " (List.map Ipaddr.V4.Prefix.to_string valid_subnets)) (String.concat ", " diff --git a/src/hostnet/forward.ml b/src/hostnet/forward.ml index 4929f3bfb..2d0ff826c 100644 --- a/src/hostnet/forward.ml +++ b/src/hostnet/forward.ml @@ -58,7 +58,6 @@ module Port = struct end module Make - (Clock: Mirage_clock.MCLOCK) (Connector: Sig.Connector) (Socket: Sig.SOCKETS) = struct @@ -142,7 +141,7 @@ unix::unix:" Mux.Channel.connect mux destination let start_tcp_proxy description remote_port server = - let module Proxy = Mirage_flow_combinators.Proxy(Clock)(Mux.Channel)(Socket.Stream.Tcp) in + let module Proxy = Mirage_flow_combinators.Proxy(Mux.Channel)(Socket.Stream.Tcp) in Socket.Stream.Tcp.listen server (fun local -> open_channel remote_port >>= fun remote -> @@ -155,8 +154,8 @@ unix::unix:" | Ok (l_stats, r_stats) -> Log.debug (fun f -> f "%s completed: l2r = %a; r2l = %a" description - Mirage_flow.pp_stats l_stats - Mirage_flow.pp_stats r_stats + Mirage_flow_combinators.pp_stats l_stats + Mirage_flow_combinators.pp_stats r_stats ) ) (fun () -> Mux.Channel.close remote @@ -165,7 +164,7 @@ unix::unix:" Lwt.return () let start_unix_proxy description remote_port server = - let module Proxy = Mirage_flow_combinators.Proxy(Clock)(Mux.Channel)(Socket.Stream.Unix) in + let module Proxy = Mirage_flow_combinators.Proxy(Mux.Channel)(Socket.Stream.Unix) in Socket.Stream.Unix.listen server (fun local -> open_channel remote_port >>= fun remote -> @@ -178,8 +177,8 @@ unix::unix:" | Ok (l_stats, r_stats) -> Log.debug (fun f -> f "%s completed: l2r = %a; r2l = %a" description - Mirage_flow.pp_stats l_stats - Mirage_flow.pp_stats r_stats + Mirage_flow_combinators.pp_stats l_stats + Mirage_flow_combinators.pp_stats r_stats ) ) (fun () -> Mux.Channel.close remote @@ -379,9 +378,9 @@ unix::unix:" let stop t = Log.debug (fun f -> f "%s: closing listening socket" (to_string t)); match t.server with - | Some (`Tcp s) -> Socket.Stream.Tcp.shutdown s - | Some (`Udp s) -> Socket.Datagram.Udp.shutdown s - | Some (`Unix s) -> Socket.Stream.Unix.shutdown s + | Some (`Tcp s) -> Socket.Stream.Tcp.stop s + | Some (`Udp s) -> Socket.Datagram.Udp.stop s + | Some (`Unix s) -> Socket.Stream.Unix.stop s | None -> Lwt.return_unit let of_string x = diff --git a/src/hostnet/forward.mli b/src/hostnet/forward.mli index 9ee094335..319938ce1 100644 --- a/src/hostnet/forward.mli +++ b/src/hostnet/forward.mli @@ -7,7 +7,6 @@ module Port : sig end module Make - (Clock: Mirage_clock.MCLOCK) (Connector: Sig.Connector) (Socket: Sig.SOCKETS): Active_list.Instance diff --git a/src/hostnet/forwards.ml b/src/hostnet/forwards.ml index e082e1854..74b1c2900 100644 --- a/src/hostnet/forwards.ml +++ b/src/hostnet/forwards.ml @@ -80,13 +80,13 @@ let update xs = 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 + include Mirage_flow.S 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 +module Read_some (FLOW : Mirage_flow.S) : sig include Read_some val connect : FLOW.flow -> flow @@ -135,8 +135,16 @@ end = struct 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 + let shutdown_write flow = FLOW.shutdown flow.flow `write + let shutdown_read flow = FLOW.shutdown flow.flow `read + + let shutdown f = function + | `read -> shutdown_read f + | `write -> shutdown_write f + | `read_write -> + let open Lwt.Infix in + shutdown_read f >>= fun () -> + shutdown_write f end module Handshake (FLOW : Read_some) = struct @@ -338,8 +346,7 @@ module Unix = struct 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 + let shutdown flow = Remote.shutdown flow.flow end module Stream = struct @@ -407,21 +414,17 @@ module Stream = struct | `Direct flow -> Direct.close flow | `Forwarded flow -> Forwarded.close flow - let shutdown_write = function - | `Direct flow -> Direct.shutdown_write flow - | `Forwarded flow -> Forwarded.shutdown_write flow - - let shutdown_read = function - | `Direct flow -> Direct.shutdown_read flow - | `Forwarded flow -> Forwarded.shutdown_read flow + let shutdown f v = match f with + | `Direct flow -> Direct.shutdown flow v + | `Forwarded flow -> Forwarded.shutdown flow v end end -module Test (Clock : Mirage_clock.MCLOCK) = struct +module Test = struct module Remote = Read_some (Host.Sockets.Stream.Unix) module Proxy = - Mirage_flow_combinators.Proxy (Clock) (Remote) (Host.Sockets.Stream.Tcp) + Mirage_flow_combinators.Proxy (Remote) (Host.Sockets.Stream.Tcp) module Handshake = Handshake (Remote) open Lwt.Infix @@ -483,5 +486,5 @@ module Test (Clock : Mirage_clock.MCLOCK) = struct Host.Sockets.Stream.Tcp.close remote))); Lwt.return s - let shutdown = Host.Sockets.Stream.Unix.shutdown + let stop = Host.Sockets.Stream.Unix.stop end diff --git a/src/hostnet/forwards.mli b/src/hostnet/forwards.mli index 98b1b3c72..5c5ccd819 100644 --- a/src/hostnet/forwards.mli +++ b/src/hostnet/forwards.mli @@ -33,9 +33,9 @@ module Stream : sig module Tcp : Sig.FLOW_CLIENT with type address = Ipaddr.t * int end -module Test (Clock : Mirage_clock.MCLOCK) : sig +module Test : sig type server val start_forwarder : string -> server Lwt.t - val shutdown : server -> unit Lwt.t + val stop : server -> unit Lwt.t end diff --git a/src/hostnet/host.ml b/src/hostnet/host.ml index 3f29b451c..3e04ecde8 100644 --- a/src/hostnet/host.ml +++ b/src/hostnet/host.ml @@ -202,8 +202,7 @@ module Sockets = struct Luv.Handle.close fd return) >>= fun () -> Lwt.return_unit - let shutdown_read _t = Lwt.return_unit - let shutdown_write _t = Lwt.return_unit + let shutdown _t _ = Lwt.return_unit type server = { idx : int; @@ -317,7 +316,7 @@ module Sockets = struct >>*= fun x -> Lwt.return x - let shutdown server = + let stop server = if not server.closed then ( server.closed <- true; Luv_lwt.in_luv (fun return -> @@ -573,6 +572,12 @@ module Sockets = struct | Ok () -> return ())) else Lwt.return_unit + let shutdown flow = function + | `read -> shutdown_read flow + | `read_write | `write -> + shutdown_read flow >>= fun () -> + shutdown_write flow + let read_into t buf = if t.closed then (Log.info (fun f -> f "read_into %s already closed: EOF" t.description); Lwt.return (Ok `Eof)) @@ -696,7 +701,7 @@ module Sockets = struct Lwt.return []) >|= fun extra -> make ip ((idx, (ip, bound_port), fd) :: extra) - let shutdown server = + let stop server = let fds = server.listening_fds in server.listening_fds <- []; Lwt_list.iter_s @@ -889,6 +894,17 @@ module Sockets = struct | Ok () -> return ())) else Lwt.return_unit + let shutdown flow = function + | `read -> shutdown_read flow + | `write -> shutdown_write flow + | `read_write -> + if not flow.closed then ( + flow.closed <- true; + Luv_lwt.in_luv (fun return -> + Connection_limit.deregister flow.idx; + Luv.Handle.close flow.fd return)) + else Lwt.return_unit + let read_into t buf = if t.closed then (Log.info (fun f -> f "read_into %s already closed: EOF" t.description); Lwt.return (Ok `Eof)) @@ -918,6 +934,14 @@ module Sockets = struct mutable disable_connection_tracking : bool; } + let stop server = + if not server.closed then ( + server.closed <- true; + Luv_lwt.in_luv (fun return -> + Connection_limit.deregister server.idx; + Luv.Handle.close server.fd return)) + else Lwt.return_unit + let bind ?(description = "") path = let description = Fmt.str "unix:%s %s" path description in Luv_lwt.in_luv (fun return -> @@ -1042,14 +1066,6 @@ module Sockets = struct | Ok (fd, idx) -> Lwt.return { idx; fd; closed = false; disable_connection_tracking = false } - - let shutdown server = - if not server.closed then ( - server.closed <- true; - Luv_lwt.in_luv (fun return -> - Connection_limit.deregister server.idx; - Luv.Handle.close server.fd return)) - else Lwt.return_unit end end end @@ -1064,7 +1080,7 @@ end module TestServer (F : ClientServer) = struct let with_server address f = F.bind address >>= fun server -> - Lwt.finalize (fun () -> f server) (fun () -> F.shutdown server) + Lwt.finalize (fun () -> f server) (fun () -> F.stop server) let with_flow flow f = Lwt.finalize f (fun () -> F.close flow) diff --git a/src/hostnet/hostnet_dhcp.ml b/src/hostnet/hostnet_dhcp.ml index b7c27010d..81b227309 100644 --- a/src/hostnet/hostnet_dhcp.ml +++ b/src/hostnet/hostnet_dhcp.ml @@ -13,7 +13,7 @@ let global_dhcp_configuration = ref None let update_global_configuration x = global_dhcp_configuration := x -module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S) = struct +module Make (Netif: Mirage_net.S) = struct type t = { netif: Netif.t; @@ -111,7 +111,7 @@ module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S) = struct Lwt.return database | Ok pkt -> let elapsed_seconds = - Clock.elapsed_ns () + Mirage_mtime.elapsed_ns () |> Duration.to_sec |> Int32.of_int in diff --git a/src/hostnet/hostnet_dhcp.mli b/src/hostnet/hostnet_dhcp.mli index d02d977e2..d1d823c60 100644 --- a/src/hostnet/hostnet_dhcp.mli +++ b/src/hostnet/hostnet_dhcp.mli @@ -1,4 +1,4 @@ -module Make (Clock: Mirage_clock.MCLOCK) (Netif: Mirage_net.S): sig +module Make (Netif: Mirage_net.S): sig type t val make: configuration:Configuration.t -> Netif.t -> t diff --git a/src/hostnet/hostnet_dns.ml b/src/hostnet/hostnet_dns.ml index 80d55f9de..ceb16a208 100644 --- a/src/hostnet/hostnet_dns.ml +++ b/src/hostnet/hostnet_dns.ml @@ -189,8 +189,6 @@ module Make (Tcp: Tcpip.Tcp.S with type ipaddr = Ipaddr.V4.t) (Socket: Sig.SOCKETS) (D: Sig.DNS) - (Time: Mirage_time.S) - (Clock: Mirage_clock.MCLOCK) (Recorder: Sig.RECORDER) = struct @@ -201,17 +199,17 @@ struct module Dns_tcp_client = Dns_forward.Rpc.Client.Persistent.Make(Socket.Stream.Tcp) - (Dns_forward.Framing.Tcp(Socket.Stream.Tcp))(Time) + (Dns_forward.Framing.Tcp(Socket.Stream.Tcp)) module Dns_tcp_resolver = - Dns_forward.Resolver.Make(Dns_tcp_client)(Time)(Clock) + Dns_forward.Resolver.Make(Dns_tcp_client) module Dns_udp_client = Dns_forward.Rpc.Client.Nonpersistent.Make(Socket.Datagram.Udp) - (Dns_forward.Framing.Udp(Socket.Datagram.Udp))(Time) + (Dns_forward.Framing.Udp(Socket.Datagram.Udp)) module Dns_udp_resolver = - Dns_forward.Resolver.Make(Dns_udp_client)(Time)(Clock) + Dns_forward.Resolver.Make(Dns_udp_client) (* We need to be able to parse the incoming framed TCP messages *) module Dns_tcp_framing = Dns_forward.Framing.Tcp(Tcp) @@ -257,40 +255,40 @@ struct packet creation fn *) let frame = Io_page.to_cstruct (Io_page.get 1) in let smac = "\000\000\000\000\000\000" in - Ethernet__Ethernet_wire.set_ethernet_src smac 0 frame; - Ethernet__Ethernet_wire.set_ethernet_ethertype frame 0x0800; + Cstruct.blit_from_string smac 0 frame 6 6; + Cstruct.BE.set_uint16 frame 12 0x0800; let buf = Cstruct.shift frame Ethernet.Packet.sizeof_ethernet in - Ipv4_wire.set_ipv4_hlen_version buf ((4 lsl 4) + (5)); - Ipv4_wire.set_ipv4_tos buf 0; - Ipv4_wire.set_ipv4_ttl buf 38; + Ipv4_wire.set_hlen_version buf ((4 lsl 4) + (5)); + Cstruct.set_uint8 buf 0 0; + Ipv4_wire.set_ttl buf 38; let proto = Ipv4_packet.Marshal.protocol_to_int `UDP in - Ipv4_wire.set_ipv4_proto buf proto; - Ipv4_wire.set_ipv4_src buf (Ipaddr.V4.to_int32 source_ip); - Ipv4_wire.set_ipv4_dst buf (Ipaddr.V4.to_int32 dest_ip); + Ipv4_wire.set_proto buf proto; + Ipv4_wire.set_src buf source_ip; + Ipv4_wire.set_dst buf dest_ip; let header_len = Ethernet.Packet.sizeof_ethernet + Ipv4_wire.sizeof_ipv4 in let frame = Cstruct.sub frame 0 (header_len + Udp_wire.sizeof_udp) in let udp_buf = Cstruct.shift frame header_len in - Udp_wire.set_udp_source_port udp_buf source_port; - Udp_wire.set_udp_dest_port udp_buf dest_port; - Udp_wire.set_udp_length udp_buf (Udp_wire.sizeof_udp + Cstruct.lenv bufs); - Udp_wire.set_udp_checksum udp_buf 0; + Udp_wire.set_src_port udp_buf source_port; + Udp_wire.set_dst_port udp_buf dest_port; + Udp_wire.set_length udp_buf (Udp_wire.sizeof_udp + Cstruct.lenv bufs); + Udp_wire.set_checksum udp_buf 0; (* Only for recording, no need to set a checksum. *) (* Ip.writev *) let bufs = frame :: bufs in let tlen = Cstruct.lenv bufs - Ethernet.Packet.sizeof_ethernet in let dmac = String.make 6 '\000' in (* Ip.adjust_output_header *) - Ethernet__Ethernet_wire.set_ethernet_dst dmac 0 frame; + Cstruct.blit_from_string dmac 0 frame 0 6; let buf = Cstruct.sub frame Ethernet.Packet.sizeof_ethernet Ipv4_wire.sizeof_ipv4 in (* Set the mutable values in the ipv4 header *) - Ipv4_wire.set_ipv4_len buf tlen; - Ipv4_wire.set_ipv4_id buf (Random.int 65535); (* TODO *) - Ipv4_wire.set_ipv4_csum buf 0; + Ipv4_wire.set_len buf tlen; + Ipv4_wire.set_id buf (Random.int 65535); (* TODO *) + Ipv4_wire.set_checksum buf 0; (* Only for recording, no need to set a checksum *) Recorder.record recorder bufs | None -> diff --git a/src/hostnet/hostnet_dns.mli b/src/hostnet/hostnet_dns.mli index 1132b4598..cb042caa5 100644 --- a/src/hostnet/hostnet_dns.mli +++ b/src/hostnet/hostnet_dns.mli @@ -16,8 +16,6 @@ module Make (Tcp: Tcpip.Tcp.S with type ipaddr = Ipaddr.V4.t) (Socket: Sig.SOCKETS) (Dns_resolver: Sig.DNS) - (Time: Mirage_time.S) - (Clock: Mirage_clock.MCLOCK) (Recorder: Sig.RECORDER) : sig diff --git a/src/hostnet/hostnet_http.ml b/src/hostnet/hostnet_http.ml index 910bc5f8b..ec6a17357 100644 --- a/src/hostnet/hostnet_http.ml +++ b/src/hostnet/hostnet_http.ml @@ -97,7 +97,7 @@ end module Make (Ip: Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) (Udp: Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) - (Tcp:Mirage_flow_combinators.SHUTDOWNABLE) + (Tcp:Mirage_flow.S) (Remote: Sig.FLOW_CLIENT with type address = Ipaddr.t * int) (Dns_resolver: Sig.DNS) = struct @@ -295,7 +295,7 @@ module Make Lwt.return false ) >>= fun continue -> - if continue then loop () else Remote.shutdown_write remote + if continue then loop () else Remote.shutdown remote `write in loop () in Lwt.join [ diff --git a/src/hostnet/hostnet_http.mli b/src/hostnet/hostnet_http.mli index 1b1909567..14048a5ab 100644 --- a/src/hostnet/hostnet_http.mli +++ b/src/hostnet/hostnet_http.mli @@ -13,7 +13,7 @@ end module Make (Ip: Tcpip.Ip.S with type ipaddr = Ipaddr.V4.t) (Udp: Tcpip.Udp.S with type ipaddr = Ipaddr.V4.t) - (Tcp: Mirage_flow_combinators.SHUTDOWNABLE) + (Tcp: Mirage_flow.S) (Remote: Sig.FLOW_CLIENT with type address = Ipaddr.t * int) (Dns_resolver: Sig.DNS) : sig diff --git a/src/hostnet/hostnet_icmp.ml b/src/hostnet/hostnet_icmp.ml index 0791a9ec4..c07607985 100644 --- a/src/hostnet/hostnet_icmp.ml +++ b/src/hostnet/hostnet_icmp.ml @@ -22,10 +22,7 @@ type datagram = { } module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S) -= struct + (Sockets: Sig.SOCKETS) = struct module Icmp = Sockets.Datagram.Udp @@ -53,8 +50,8 @@ module Make let start_background_gc phys_to_flow virt_to_flow ids_in_use max_idle_time = let rec loop () = - Time.sleep_ns max_idle_time >>= fun () -> - let now_ns = Clock.elapsed_ns () in + Mirage_sleep.ns max_idle_time >>= fun () -> + let now_ns = Mirage_mtime.elapsed_ns () in let to_shutdown = Hashtbl.fold (fun phys flow acc -> if Int64.(sub now_ns flow.last_use) > max_idle_time then begin @@ -134,8 +131,8 @@ module Make probably reflects some kernel datastructure size rather than the real on-the-wire size. This confuses our IPv4 parser so we correct the size here. *) - let len = Ipv4_wire.get_ipv4_len datagram in - Ipv4_wire.set_ipv4_len datagram (min len n); + let len = Ipv4_wire.get_len datagram in + Ipv4_wire.set_len datagram (min len n); match Frame.ipv4 [ datagram ] with | Error (`Msg m) -> Log.err (fun f -> f "Error unmarshalling IP datagram: %s" m); @@ -145,9 +142,9 @@ module Make let flow = Hashtbl.find t.phys_to_flow (src, id) in let id' = snd flow.virt in (* Rewrite the id in the Echo response *) - Icmpv4_wire.set_icmpv4_id raw id'; - Icmpv4_wire.set_icmpv4_csum raw 0; - Icmpv4_wire.set_icmpv4_csum raw (Tcpip_checksum.ones_complement raw); + Cstruct.BE.set_uint16 raw 5 id'; (* TODO: Upstream *) + Icmpv4_wire.set_checksum raw 0; + Icmpv4_wire.set_checksum raw (Tcpip_checksum.ones_complement raw); try_to_send ~src ~dst:(fst flow.virt) ~payload:raw end else begin Log.debug (fun f -> @@ -163,15 +160,15 @@ module Make let flow = Hashtbl.find t.phys_to_flow (dst, id) in let id' = snd flow.virt in (* Rewrite the id in the nested original packet *) - Icmpv4_wire.set_icmpv4_id original_icmp id'; - Icmpv4_wire.set_icmpv4_csum original_icmp 0; - Icmpv4_wire.set_icmpv4_csum original_icmp (Tcpip_checksum.ones_complement original_icmp); + Cstruct.BE.set_uint16 original_icmp 5 id'; (* TODO: Upstream *) + Icmpv4_wire.set_checksum original_icmp 0; + Icmpv4_wire.set_checksum original_icmp (Tcpip_checksum.ones_complement original_icmp); (* Rewrite the src address to use the internal address *) - let new_src = Ipaddr.V4.to_int32 @@ fst flow.virt in - Ipv4_wire.set_ipv4_src original_ipv4 new_src; + let new_src = fst flow.virt in + Ipv4_wire.set_src original_ipv4 new_src; (* Note we don't recompute the IPv4 checksum since the packet is truncated *) - Icmpv4_wire.set_icmpv4_csum icmp_buffer 0; - Icmpv4_wire.set_icmpv4_csum icmp_buffer (Tcpip_checksum.ones_complement icmp_buffer); + Icmpv4_wire.set_checksum icmp_buffer 0; + Icmpv4_wire.set_checksum icmp_buffer (Tcpip_checksum.ones_complement icmp_buffer); try_to_send ~src:src' ~dst:(fst flow.virt) ~payload:icmp_buffer end else begin Log.debug (fun f -> f "Dropping TTL exceeded src' = %a dst' = %a; src = %a; dst = %a; id = %d" @@ -190,11 +187,11 @@ module Make match Hashtbl.find Hostnet_udp.external_to_internal src_port with | Ipaddr.V4 internal_src, internal_port -> (* Rewrite the src address on the IPv4 to use the internal address *) - Ipv4_wire.set_ipv4_src original_ipv4 (Ipaddr.V4.to_int32 internal_src); + Ipv4_wire.set_src original_ipv4 internal_src; (* Rewrite the src_port on the UDP to use the internal address *) - Udp_wire.set_udp_source_port original_udp internal_port; - Icmpv4_wire.set_icmpv4_csum icmp_buffer 0; - Icmpv4_wire.set_icmpv4_csum icmp_buffer (Tcpip_checksum.ones_complement icmp_buffer); + Udp_wire.set_src_port original_udp internal_port; + Icmpv4_wire.set_checksum icmp_buffer 0; + Icmpv4_wire.set_checksum icmp_buffer (Tcpip_checksum.ones_complement icmp_buffer); try_to_send ~src:src' ~dst:internal_src ~payload:icmp_buffer | _, _ -> Log.debug (fun f -> f "Dropping TTL exceeded from internal IPv6 address"); @@ -265,7 +262,7 @@ module Make let phys = dst, id' in let description = Printf.sprintf "%s id=%d -> %s id=%d" (Ipaddr.V4.to_string @@ fst virt) (snd virt) (Ipaddr.V4.to_string @@ fst phys) (snd phys) in - let last_use = Clock.elapsed_ns () in + let last_use = Mirage_mtime.elapsed_ns () in let flow = { description; virt; phys; last_use } in Hashtbl.replace t.phys_to_flow phys flow; Hashtbl.replace t.virt_to_flow virt flow; diff --git a/src/hostnet/hostnet_icmp.mli b/src/hostnet/hostnet_icmp.mli index 7dafff442..0fdb9ea0b 100644 --- a/src/hostnet/hostnet_icmp.mli +++ b/src/hostnet/hostnet_icmp.mli @@ -18,10 +18,7 @@ type datagram = { type reply = Cstruct.t -> unit Lwt.t module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S) -: sig + (Sockets: Sig.SOCKETS) : sig type t (** An ICMP NAT implementation *) diff --git a/src/hostnet/hostnet_udp.ml b/src/hostnet/hostnet_udp.ml index f006c8a1c..04e27d1fe 100644 --- a/src/hostnet/hostnet_udp.ml +++ b/src/hostnet/hostnet_udp.ml @@ -25,9 +25,7 @@ type datagram = { let external_to_internal = Hashtbl.create 7 module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S) = + (Sockets: Sig.SOCKETS) = struct module Udp = Sockets.Datagram.Udp @@ -85,7 +83,7 @@ struct let expire table by_last_use flow = Lwt.catch (fun () -> - Udp.shutdown flow.server + Udp.stop flow.server ) (fun e -> Log.err (fun f -> f "Hostnet_udp %s: close raised %a" flow.description Fmt.exn e); @@ -98,17 +96,17 @@ struct Lwt.return_unit let touch t flow = - let last_use = Clock.elapsed_ns () in + let last_use = Mirage_mtime.elapsed_ns () in (* Remove the old entry t.last_use and add a new one for last_use *) t.by_last_use := By_last_use.(add last_use flow @@ remove flow.last_use !(t.by_last_use)); flow.last_use <- last_use let start_background_gc table by_last_use max_idle_time new_flow_lock = let rec loop () = - Time.sleep_ns max_idle_time >>= fun () -> + Mirage_sleep.ns max_idle_time >>= fun () -> Lwt_mutex.with_lock new_flow_lock (fun () -> - let now_ns = Clock.elapsed_ns () in + let now_ns = Mirage_mtime.elapsed_ns () in let to_shutdown = Hashtbl.fold (fun _ flow acc -> if Int64.(sub now_ns flow.last_use) > max_idle_time then begin @@ -230,7 +228,7 @@ struct >>= fun server -> Udp.getsockname server >>= fun external_address -> - let last_use = Clock.elapsed_ns () in + let last_use = Mirage_mtime.elapsed_ns () in let flow = { description = d; src = datagram.src; server; external_address; last_use } in Hashtbl.replace t.table datagram.src flow; t.by_last_use := By_last_use.add last_use flow !(t.by_last_use); diff --git a/src/hostnet/hostnet_udp.mli b/src/hostnet/hostnet_udp.mli index c1897fd72..c1fcef3db 100644 --- a/src/hostnet/hostnet_udp.mli +++ b/src/hostnet/hostnet_udp.mli @@ -16,9 +16,7 @@ type datagram = { type reply = Cstruct.t -> unit Lwt.t module Make - (Sockets: Sig.SOCKETS) - (Clock: Mirage_clock.MCLOCK) - (Time: Mirage_time.S): + (Sockets: Sig.SOCKETS): sig type t diff --git a/src/hostnet/sig.ml b/src/hostnet/sig.ml index d3002ce06..309f257cf 100644 --- a/src/hostnet/sig.ml +++ b/src/hostnet/sig.ml @@ -8,7 +8,7 @@ module type READ_INTO = sig end module type FLOW_CLIENT = sig - include Mirage_flow_combinators.SHUTDOWNABLE + include Mirage_flow.S type address @@ -53,7 +53,7 @@ module type FLOW_SERVER = sig (** Accept connections forever, calling the callback with each one. Connections are closed automatically when the callback finishes. *) - val shutdown: server -> unit Lwt.t + val stop : server -> unit Lwt.t (** Stop accepting connections on the given server *) end @@ -146,8 +146,6 @@ module type HOST = sig include FILES end - module Time: Mirage_time.S - module Dns: sig include DNS end diff --git a/src/hostnet/slirp.ml b/src/hostnet/slirp.ml index ec7daaf06..7c883b83a 100644 --- a/src/hostnet/slirp.ml +++ b/src/hostnet/slirp.ml @@ -58,9 +58,7 @@ type uuid_table = { module Make (Vmnet: Sig.VMNET) (Dns_policy: Sig.DNS_POLICY) - (Clock: Mirage_clock.MCLOCK) - (Random: Mirage_random.S) - (Vnet : Vnetif.BACKEND with type macaddr = Macaddr.t) = + (Vnet : Vnetif.BACKEND) = struct (* module Tcpip_stack = Tcpip_stack.Make(Vmnet)(Host.Time) *) @@ -75,7 +73,7 @@ struct module Netif = Capture.Make(Filteredif) module Recorder = (Netif: Sig.RECORDER with type t = Netif.t) module Switch = Mux.Make(Netif) - module Dhcp = Hostnet_dhcp.Make(Clock)(Switch) + module Dhcp = Hostnet_dhcp.Make(Switch) (* This ARP implementation will respond to the VM: *) module Global_arp_ethif = Ethernet.Make(Switch) @@ -84,30 +82,30 @@ struct (* This stack will attach to a switch port and represent a single remote IP *) module Stack_ethif = Ethernet.Make(Switch.Port) module Stack_arpv4 = Static_arp.Make(Stack_ethif) - module Stack_ipv4 = Static_ipv4.Make(Random)(Clock)(Stack_ethif)(Stack_arpv4) + module Stack_ipv4 = Static_ipv4.Make(Stack_ethif)(Stack_arpv4) module Stack_icmpv4 = Icmpv4.Make(Stack_ipv4) module Stack_tcp_wire = Tcp.Wire.Make(Stack_ipv4) - module Stack_udp = Udp.Make(Stack_ipv4)(Random) + module Stack_udp = Udp.Make(Stack_ipv4) module Stack_tcp = struct - include Tcp.Flow.Make(Stack_ipv4)(Host.Time)(Clock)(Random) - let shutdown_read _flow = + include Tcp.Flow.Make(Stack_ipv4) + let shutdown flow = function + | `read -> (* No change to the TCP PCB: all this means is that I've got my finders in my ears and am nolonger listening to what you say. *) Lwt.return () - let shutdown_write = close + | `write | `read_write -> close flow (* Disable Nagle's algorithm *) let write = write_nodelay end module Dns_forwarder = - Hostnet_dns.Make(Stack_ipv4)(Stack_udp)(Stack_tcp)(Host.Sockets)(Host.Dns) - (Host.Time)(Clock)(Recorder) + Hostnet_dns.Make(Stack_ipv4)(Stack_udp)(Stack_tcp)(Host.Sockets)(Host.Dns)(Recorder) module Http_forwarder = Hostnet_http.Make(Stack_ipv4)(Stack_udp)(Stack_tcp)(Forwards.Stream.Tcp)(Host.Dns) - module Udp_nat = Hostnet_udp.Make(Host.Sockets)(Clock)(Host.Time) - module Icmp_nat = Hostnet_icmp.Make(Host.Sockets)(Clock)(Host.Time) + module Udp_nat = Hostnet_udp.Make(Host.Sockets) + module Icmp_nat = Hostnet_icmp.Make(Host.Sockets) let dns_forwarder ~local_address ~builtin_names = Dns_forwarder.create ~local_address ~builtin_names (Dns_policy.config ()) @@ -202,7 +200,7 @@ struct and possibly terminate them. If we use a monotonic clock driven from a CPU counter: the clock will be paused while the computer is asleep so we will conclude the flows are still active. *) - let idle_time t : Duration.t = Int64.sub (Clock.elapsed_ns ()) t.last_active_time_ns + let idle_time t : Duration.t = Int64.sub (Mirage_mtime.elapsed_ns ()) t.last_active_time_ns let to_string t = Printf.sprintf "%s socket = %s last_active = %s" @@ -219,7 +217,7 @@ struct let create id socket = let socket = Some socket in - let last_active_time_ns = Clock.elapsed_ns () in + let last_active_time_ns = Mirage_mtime.elapsed_ns () in let t = { id; socket; last_active_time_ns } in all := Id.Map.add id t !all; t @@ -242,7 +240,7 @@ struct let touch id = if Id.Map.mem id !all then begin let flow = Id.Map.find id !all in - flow.last_active_time_ns <- Clock.elapsed_ns () + flow.last_active_time_ns <- Mirage_mtime.elapsed_ns () end end end @@ -268,9 +266,9 @@ struct (** A generic TCP/IP endpoint *) let touch t = - t.last_active_time_ns <- Clock.elapsed_ns () + t.last_active_time_ns <- Mirage_mtime.elapsed_ns () - let idle_time t : Duration.t = Int64.sub (Clock.elapsed_ns ()) t.last_active_time_ns + let idle_time t : Duration.t = Int64.sub (Mirage_mtime.elapsed_ns ()) t.last_active_time_ns let create recorder switch arp_table remote local mtu = let netif = Switch.port switch remote in @@ -286,7 +284,7 @@ struct Stack_tcp.connect ipv4 >>= fun tcp4 -> let pending = Tcp.Id.Set.empty in - let last_active_time_ns = Clock.elapsed_ns () in + let last_active_time_ns = Mirage_mtime.elapsed_ns () in let established = Tcp.Id.Set.empty in let tcp_stack = { recorder; netif; ethif; arp; ipv4; icmpv4; udp4; tcp4; remote; mtu; pending; @@ -377,7 +375,7 @@ struct end module Proxy = - Mirage_flow_combinators.Proxy(Clock)(Stack_tcp)(Forwards.Stream.Tcp) + Mirage_flow_combinators.Proxy (Stack_tcp)(Forwards.Stream.Tcp) let forward_via_tcp_socket t ~id (ip, port) () = Forwards.Stream.Tcp.connect (ip, port) @@ -429,12 +427,12 @@ struct let would_fragment ~ip_header ~ip_payload = let open Icmpv4_wire in let header = Cstruct.create sizeof_icmpv4 in - set_icmpv4_ty header 0x03; - set_icmpv4_code header 0x04; - set_icmpv4_csum header 0x0000; + set_ty header 0x03; + set_code header 0x04; + set_checksum header 0x0000; (* this field is unused for icmp destination unreachable *) - set_icmpv4_id header 0x00; - set_icmpv4_seq header safe_outgoing_mtu; + Cstruct.BE.set_uint16 header 5 0x00; (* Set ID *) + Cstruct.BE.set_uint16 header 7 safe_outgoing_mtu; (* Set seq *) let icmp_payload = match ip_payload with | Some ip_payload -> if (Cstruct.length ip_payload > 8) then begin @@ -443,7 +441,7 @@ struct end else Cstruct.append ip_header ip_payload | None -> ip_header in - set_icmpv4_csum header + set_checksum header (Tcpip_checksum.ones_complement_list [ header; icmp_payload ]); let icmp_packet = Cstruct.append header icmp_payload in @@ -466,7 +464,7 @@ struct end type connection = { - vnet_client_id: Vnet.id; + vnet_client_id: int; after_disconnect: unit Lwt.t; interface: Netif.t; switch: Switch.t; @@ -1036,7 +1034,7 @@ struct if port_max_idle_time <= 0 then Lwt.return_unit (* never delete a port *) else begin - Host.Time.sleep_ns (Duration.of_sec 30) + Mirage_sleep.ns (Duration.of_sec 30) >>= fun () -> let max_age = Duration.of_sec port_max_idle_time in Lwt_mutex.with_lock t.endpoints_m diff --git a/src/hostnet/slirp.mli b/src/hostnet/slirp.mli index 14da62270..9d38a7eca 100644 --- a/src/hostnet/slirp.mli +++ b/src/hostnet/slirp.mli @@ -6,10 +6,8 @@ type pcap = (string * int64 option) option module Make (Vmnet: Sig.VMNET) - (Dns_policy: Sig.DNS_POLICY) - (Clock: Mirage_clock.MCLOCK) - (Random: Mirage_random.S) - (Vnet : Vnetif.BACKEND with type macaddr = Macaddr.t) : + (_ : Sig.DNS_POLICY) + (Vnet : Vnetif.BACKEND) : sig type stack diff --git a/src/hostnet/vmnet.ml b/src/hostnet/vmnet.ml index 39d02bd8f..e68d23942 100644 --- a/src/hostnet/vmnet.ml +++ b/src/hostnet/vmnet.ml @@ -88,7 +88,7 @@ module Command = struct let process_uuid uuid_str = if (String.compare (String.make 36 '\000') uuid_str) = 0 then begin - let random_uuid = (Uuidm.v `V4) in + let random_uuid = Uuidm.v4_gen (Random.State.make_self_init ()) () in Log.info (fun f -> f "Generated UUID on behalf of client: %a" Uuidm.pp random_uuid); (* generate random uuid on behalf of client if client sent diff --git a/src/hostnet_test/dune b/src/hostnet_test/dune index 16f8bb5c0..002fabfaf 100644 --- a/src/hostnet_test/dune +++ b/src/hostnet_test/dune @@ -2,5 +2,5 @@ (name main) (libraries hostnet cmdliner alcotest logs.fmt protocol-9p mirage_dns mirage-clock-unix charrua-client.mirage forwarder sha - mirage-random-stdlib arp.mirage) + arp.mirage tcpip.ipv6 mirage-crypto-rng.unix) (preprocess no_preprocessing)) diff --git a/src/hostnet_test/forwarding.ml b/src/hostnet_test/forwarding.ml index ef2533f46..e2f0e5115 100644 --- a/src/hostnet_test/forwarding.ml +++ b/src/hostnet_test/forwarding.ml @@ -13,7 +13,7 @@ let (>>*=) m f = m >>= function let run ?(timeout=Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> + Mirage_sleep.ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -27,8 +27,7 @@ module ForwardServer = struct module Mux = Forwarder.Multiplexer.Make(Host.Sockets.Stream.Tcp) module Proxy = - Mirage_flow_combinators.Proxy - (Mclock)(Mux.Channel)(Host.Sockets.Stream.Tcp) + Mirage_flow_combinators.Proxy (Mux.Channel)(Host.Sockets.Stream.Tcp) let accept flow = let forever, _u = Lwt.task () in @@ -134,7 +133,7 @@ module ForwardServer = struct } end -module Forward = Forward.Make(Mclock)(struct +module Forward = Forward.Make(struct include Host.Sockets.Stream.Tcp open Lwt.Infix @@ -171,7 +170,7 @@ module PortsServer = struct ); f port >>= fun () -> - Host.Sockets.Stream.Tcp.shutdown server + Host.Sockets.Stream.Tcp.stop server end module LocalTCPClient = struct @@ -218,7 +217,7 @@ let udp_echo t len = >>= function | Error _ -> Lwt.fail_with "Datagram.Udp.write error" | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop () in loop () in @@ -239,7 +238,7 @@ let udp_echo t len = | Error _ -> Lwt.fail_with "Datagram.Udp.read Error" in let timeout () = - Host.Time.sleep_ns (Duration.of_sec 5) + Mirage_sleep.ns (Duration.of_sec 5) >>= fun () -> Lwt.fail_with "udp_echo timeout" in Lwt.pick [ sender (); receiver (); timeout () ] @@ -270,7 +269,7 @@ module LocalTCPServer = struct { local_port; server } let to_string t = Printf.sprintf "tcp:127.0.0.1:%d" t.local_port - let destroy t = Host.Sockets.Stream.Tcp.shutdown t.server + let destroy t = Host.Sockets.Stream.Tcp.stop t.server let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> destroy server) @@ -313,7 +312,7 @@ module LocalUDPServer = struct { local_port; server } let to_string t = Printf.sprintf "udp:127.0.0.1:%d" t.local_port - let destroy t = Host.Sockets.Datagram.Udp.shutdown t.server + let destroy t = Host.Sockets.Datagram.Udp.stop t.server let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> Log.info (fun f -> f "LocalUDPServer closing server socket"); destroy server) @@ -394,7 +393,7 @@ let http_get flow = Channel.flush ch >>= function | Error e -> Fmt.kstr failwith "%a" Channel.pp_write_error e | Ok () -> - Host.Sockets.Stream.Tcp.shutdown_write flow + Host.Sockets.Stream.Tcp.shutdown flow `write >>= fun () -> read_http ch >|= fun response -> @@ -495,7 +494,7 @@ let test_10_tcp_connections () = let run_test ?(timeout=Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> + Mirage_sleep.ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -511,7 +510,7 @@ let test_tcpv4_forwarded_configuration () = (fun () -> Host.Sockets.Stream.Tcp.listen server LocalTCPServer.accept; let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (primary_dns_ip, local_tcpv4_forwarded_port) + Client.TCP.create_connection (Client.tcp stack.Client.t) (primary_dns_ip, local_tcpv4_forwarded_port) >>= function | Error _ -> Log.err (fun f -> f "Failed to connect to gateway:%d" local_tcpv4_forwarded_port); @@ -522,7 +521,7 @@ let test_tcpv4_forwarded_configuration () = let http_get = "GET / HTTP/1.0\nHost: dave.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 + Client.TCP.write flow buf >>= function | Error `Closed -> Log.err (fun f -> f "EOF writing HTTP request to gateway:%d" local_tcpv4_forwarded_port); @@ -533,7 +532,7 @@ let test_tcpv4_forwarded_configuration () = failwith "Failure on writing HTTP GET" | Ok () -> let rec loop total_bytes = - Client.TCPV4.read flow >>= function + Client.TCP.read flow >>= function | Ok `Eof -> Lwt.return total_bytes | Error _ -> Log.err (fun f -> @@ -548,7 +547,7 @@ let test_tcpv4_forwarded_configuration () = loop 0 >|= fun total_bytes -> Log.info (fun f -> f "Response had %d total bytes" total_bytes); ) (fun () -> - Host.Sockets.Stream.Tcp.shutdown server + Host.Sockets.Stream.Tcp.stop server ) in run ~pcap:"test_tcpv4_forwarded_configuration" t diff --git a/src/hostnet_test/main.ml b/src/hostnet_test/main.ml index cdd071b0f..be8f916b0 100644 --- a/src/hostnet_test/main.ml +++ b/src/hostnet_test/main.ml @@ -23,6 +23,7 @@ let reporter = (* Run it *) let () = Logs.set_reporter (reporter ()); + Mirage_crypto_rng_unix.use_default (); Lwt.async_exception_hook := (fun exn -> Log.err (fun f -> f "Lwt.async failure %s: %s" (Printexc.to_string exn) diff --git a/src/hostnet_test/slirp_stack.ml b/src/hostnet_test/slirp_stack.ml index 8ad6ca087..826e70cd2 100644 --- a/src/hostnet_test/slirp_stack.ml +++ b/src/hostnet_test/slirp_stack.ml @@ -66,16 +66,15 @@ end module VMNET = Vmnet.Make(Host.Sockets.Stream.Tcp) module Vnet = Basic_backend.Make -module Slirp_stack = - Slirp.Make(VMNET)(Dns_policy)(Mclock)(Mirage_random_stdlib)(Vnet) +module Slirp_stack = Slirp.Make(VMNET)(Dns_policy)(Vnet) module Client = struct module Netif = VMNET module Ethif1 = Ethernet.Make(Netif) - module Arpv41 = Arp.Make(Ethif1)(Host.Time) + module Arpv41 = Arp.Make(Ethif1) - module Dhcp_client_mirage1 = Dhcp_client_mirage.Make(Mirage_random_stdlib)(Host.Time)(Netif) - module Ipv41 = Dhcp_ipv4.Make(Mirage_random_stdlib)(Mclock)(Host.Time)(Netif)(Ethif1)(Arpv41) + module Dhcp_client_mirage1 = Dhcp_client_mirage.Make(Netif) + module Ipv41 = Dhcp_ipv4.Make(Netif)(Ethif1)(Arpv41) module Icmpv41 = struct include Icmpv4.Make(Ipv41) let packets = Queue.create () @@ -97,10 +96,11 @@ module Client = struct Lwt.return_unit end end - module Udp1 = Udp.Make(Ipv41)(Mirage_random_stdlib) - module Tcp1 = Tcp.Flow.Make(Ipv41)(Host.Time)(Mclock)(Mirage_random_stdlib) - include Tcpip_stack_direct.Make(Host.Time) - (Mirage_random_stdlib)(Netif)(Ethif1)(Arpv41)(Ipv41)(Icmpv41)(Udp1)(Tcp1) + module Ipv61 = Ipv6.Make(Netif)(Ethif1) + module Ipv = Tcpip_stack_direct.IPV4V6(Ipv41)(Ipv61) + module Udp1 = Udp.Make(Ipv) + module Tcp1 = Tcp.Flow.Make(Ipv) + include Tcpip_stack_direct.MakeV4V6 (Netif)(Ethif1)(Arpv41)(Ipv)(Icmpv41)(Udp1)(Tcp1) let or_error name m = m >>= function @@ -118,20 +118,22 @@ module Client = struct Arpv41.connect ethif >>= fun arp -> Dhcp_client_mirage1.connect interface >>= fun _dhcp -> Ipv41.connect interface ethif arp >>= fun ipv4 -> + Ipv61.connect interface ethif >>= fun ipv6 -> + Ipv.connect ~ipv4_only:true ~ipv6_only:false ipv4 ipv6 >>= fun ip -> Icmpv41.connect ipv4 >>= fun icmpv4 -> - Udp1.connect ipv4 >>= fun udp4 -> - Tcp1.connect ipv4 >>= fun tcp4 -> - connect interface ethif arp ipv4 icmpv4 udp4 tcp4 + Udp1.connect ip >>= fun udp4 -> + Tcp1.connect ip >>= fun tcp4 -> + connect interface ethif arp ip icmpv4 udp4 tcp4 >>= fun t -> Log.info (fun f -> f "Client has connected"); Lwt.return { t; icmpv4 ; netif=interface } end -module DNS = Dns_resolver_mirage.Make(Host.Time)(Client) +module DNS = Dns_resolver_mirage.Make(Client) -let primary_dns_ip = Ipaddr.V4.of_string_exn "192.168.65.1" +let primary_dns_ip = Ipaddr.of_string_exn "192.168.65.1" -let localhost_ip = Ipaddr.V4.of_string_exn "192.168.65.2" +let localhost_ip = Ipaddr.of_string_exn "192.168.65.2" let preferred_ip1 = Ipaddr.V4.of_string_exn "192.168.65.250" @@ -185,11 +187,12 @@ let start_stack config () = let stop_stack server = Log.info (fun f -> f "Shutting down slirp stack"); - Host.Sockets.Stream.Tcp.shutdown server + Host.Sockets.Stream.Tcp.stop server let pcap_dir = "./_pcap/" let with_stack ?uuid ?preferred_ip ~pcap f = + config >>= fun config -> start_stack config () >>= fun (server, port) -> diff --git a/src/hostnet_test/suite.ml b/src/hostnet_test/suite.ml index 8c4380e62..71a094511 100644 --- a/src/hostnet_test/suite.ml +++ b/src/hostnet_test/suite.ml @@ -9,11 +9,11 @@ let src = module Log = (val Logs.src_log src : Logs.LOG) let pp_ips = Fmt.(list ~sep:(any ", ") Ipaddr.pp) -let pp_ip4s = Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) +let pp_ip_prefix = Fmt.(list ~sep:(any ", ") Ipaddr.Prefix.pp) let run_test ?(timeout=Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> + Mirage_sleep.ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -22,8 +22,8 @@ let run ?timeout ~pcap t = run_test ?timeout (with_stack ~pcap t) let test_dhcp_query () = let t _ stack = - let ips = Client.IPV4.get_ip (Client.ipv4 stack.Client.t) in - Log.info (fun f -> f "Got an IP: %a" pp_ip4s ips); + let ips = Client.IP.configured_ips (Client.ip stack.Client.t) in + Log.info (fun f -> f "Got an IP: %a" pp_ip_prefix ips); Lwt.return () in run ~pcap:"test_dhcp_query.pcap" t @@ -38,7 +38,7 @@ let test_max_connections () = Log.info (fun f -> f "Setting max connections to 0"); Connection_limit.set_max (Some 0); begin - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) + Client.TCP.create_connection (Client.tcp stack.Client.t) (Ipaddr.V4 ip, 80) >|= function | Ok _ -> Log.err (fun f -> @@ -53,7 +53,7 @@ let test_max_connections () = Connection_limit.set_max None; (* Check that connections work again *) begin - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) + Client.TCP.create_connection (Client.tcp stack.Client.t) (Ipaddr.V4 ip, 80) >|= function | Ok _ -> Log.debug (fun f -> f "Connected to www.google.com"); @@ -81,7 +81,7 @@ let test_http_fetch () = DNS.gethostbyname resolver "www.google.com" >>= function | Ipaddr.V4 ip :: _ -> begin - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) + Client.TCP.create_connection (Client.tcp stack.Client.t) (Ipaddr.V4 ip, 80) >>= function | Error _ -> Log.err (fun f -> f "Failed to connect to www.google.com:80"); @@ -92,7 +92,7 @@ let test_http_fetch () = 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 + Client.TCP.write flow buf >>= function | Error `Closed -> Log.err (fun f -> f "EOF writing HTTP request to www.google.com:80"); @@ -103,7 +103,7 @@ let test_http_fetch () = failwith "Failure on writing HTTP GET" | Ok () -> let rec loop total_bytes = - Client.TCPV4.read flow >>= function + Client.TCP.read flow >>= function | Ok `Eof -> Lwt.return total_bytes | Error _ -> Log.err (fun f -> @@ -129,7 +129,7 @@ let test_http_fetch () = let test_tcp_forwards () = let t _ stack = let path = "/tmp/forwards.sock" in - let module ForwardsTest = Forwards.Test(Mclock) in + let module ForwardsTest = Forwards.Test in ForwardsTest.start_forwarder path >>= fun forwarder -> Forwards.update [ @@ -146,7 +146,7 @@ let test_tcp_forwards () = DNS.gethostbyname resolver "www.google.com" >>= function | Ipaddr.V4 ip :: _ -> begin - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, 80) + Client.TCP.create_connection (Client.tcp stack.Client.t) (Ipaddr.V4 ip, 80) >>= function | Error _ -> Log.err (fun f -> f "Failed to connect to www.google.com:80"); @@ -157,7 +157,7 @@ let test_tcp_forwards () = 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 + Client.TCP.write flow buf >>= function | Error `Closed -> Log.err (fun f -> f "EOF writing HTTP request to www.google.com:80"); @@ -168,7 +168,7 @@ let test_tcp_forwards () = failwith "Failure on writing HTTP GET" | Ok () -> let rec loop total_bytes = - Client.TCPV4.read flow >>= function + Client.TCP.read flow >>= function | Ok `Eof -> Lwt.return total_bytes | Error _ -> Log.err (fun f -> @@ -190,7 +190,7 @@ let test_tcp_forwards () = failwith "http_fetch dns" ) (fun () -> Forwards.update []; - ForwardsTest.shutdown forwarder + ForwardsTest.stop forwarder ) in run ~pcap:"test_tcp_forwards.pcap" t @@ -232,7 +232,7 @@ module DevNullServer = struct { local_port; server } let to_string t = Printf.sprintf "tcp:127.0.0.1:%d" t.local_port - let destroy t = Host.Sockets.Stream.Tcp.shutdown t.server + let destroy t = Host.Sockets.Stream.Tcp.stop t.server let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> destroy server) @@ -258,8 +258,8 @@ let test_many_connections n () = if Connection_limit.get_num_connections () >= n then Lwt.return acc else - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) - (Ipaddr.V4.localhost, local_port) + Client.TCP.create_connection (Client.tcp stack.Client.t) + (Ipaddr.V4 Ipaddr.V4.localhost, local_port) >>= function | Ok c -> Log.info (fun f -> @@ -283,12 +283,12 @@ let test_stream_data connections length () = let t local_port _ stack = Lwt_list.iter_p (fun () -> let rec connect () = - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) - (Ipaddr.V4.localhost, local_port) + Client.TCP.create_connection (Client.tcp stack.Client.t) + (Ipaddr.V4 Ipaddr.V4.localhost, local_port) >>= function | Error `Refused -> Log.info (fun f -> f "DevNullServer Refused connection"); - Host.Time.sleep_ns (Duration.of_ms 200) + Mirage_sleep.ns (Duration.of_ms 200) >>= fun () -> connect () | Error `Timeout -> @@ -297,8 +297,8 @@ let test_stream_data connections length () = | Error e -> Log.err (fun f -> f "DevNullServer connnection failure: %a" - Client.TCPV4.pp_error e); - Fmt.kstr failwith "%a" Client.TCPV4.pp_error e + Client.TCP.pp_error e); + Fmt.kstr failwith "%a" Client.TCP.pp_error e | Ok flow -> Log.info (fun f -> f "Connected to local server"); Lwt.return flow @@ -313,7 +313,7 @@ let test_stream_data connections length () = else begin let this_time = min remaining (Cstruct.length page) in let buf = Cstruct.sub page 0 this_time in - Client.TCPV4.write flow buf >>= function + Client.TCP.write flow buf >>= function | Error `Closed -> Log.err (fun f -> f "EOF writing to DevNullServerwith %d bytes left" @@ -331,8 +331,8 @@ let test_stream_data connections length () = end in loop length >>= fun () -> - Client.TCPV4.close flow >>= fun () -> - Client.TCPV4.read flow >|= function + Client.TCP.close flow >>= fun () -> + Client.TCP.read flow >|= function | Ok `Eof -> Log.err (fun f -> f "EOF reading result from DevNullServer"); (* failwith "EOF reading result from DevNullServer" *) diff --git a/src/hostnet_test/test_bridge.ml b/src/hostnet_test/test_bridge.ml index df17f2c08..c5bba035f 100644 --- a/src/hostnet_test/test_bridge.ml +++ b/src/hostnet_test/test_bridge.ml @@ -10,6 +10,11 @@ module Log = (val Logs.src_log src : Logs.LOG) exception Test_failure of string +let get_ips c = + (* TODO: Check logic *) + Client.Ipv.configured_ips c + |> List.map Ipaddr.Prefix.netmask + (* Open multiple connections and verify that the connection succeeds and MAC and IP changes *) let test_connect n () = Host.Main.run begin @@ -17,10 +22,10 @@ let test_connect n () = match x, used_ips, used_macs with | 0, _, _ -> Lwt.return_unit | x, used_ips, used_macs -> - let uuid = (Uuidm.v `V4) in + let uuid = (Uuidm.v4_gen (Random.get_state ()) ()) in with_stack ~uuid ~pcap:"test_connect.pcap" (fun _ client_stack -> (* Same IP should not appear twice *) - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in assert(List.length ips == 1); let ip = List.hd ips in assert((List.mem ip used_ips) == false); @@ -31,7 +36,7 @@ let test_connect n () = Lwt.return (ip, mac) ) >>= fun (ip, mac) -> - Log.info (fun f -> f "Stack %d got IP %s and MAC %s" x (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); + Log.info (fun f -> f "Stack %d got IP %s and MAC %s" x (Ipaddr.to_string ip) (Macaddr.to_string mac)); loop (x - 1) ([ip] @ used_ips) ([mac] @ used_macs) in loop n [] [] @@ -40,23 +45,23 @@ let test_connect n () = (* Connect twice with the same UUID and verify that MAC and IP are the same *) let test_reconnect () = Host.Main.run begin - let uuid = (Uuidm.v `V4) in + let uuid = (Uuidm.v4_gen (Random.get_state ()) ()) in Log.info (fun f -> f "Using UUID %s" (Uuidm.to_string uuid)); with_stack ~uuid ~pcap:"test_reconnect.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in let ip = List.hd ips in let mac = (VMNET.mac client_stack.netif) in Lwt.return (ip, mac) ) >>= fun (ip, mac) -> - Log.info (fun f -> f "First connection got IP %s and MAC %s" (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); + Log.info (fun f -> f "First connection got IP %s and MAC %s" (Ipaddr.to_string ip) (Macaddr.to_string mac)); with_stack ~uuid ~pcap:"test_reconnect.2.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in let ip = List.hd ips in let mac = (VMNET.mac client_stack.netif) in Lwt.return (ip, mac) ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.info (fun f -> f "Reconnect got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); - assert(Ipaddr.V4.compare ip reconnect_ip == 0); + Log.info (fun f -> f "Reconnect got IP %s and MAC %s" (Ipaddr.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); + assert(Ipaddr.compare ip reconnect_ip == 0); assert(Macaddr.compare mac reconnect_mac == 0); Lwt.return () end @@ -64,51 +69,51 @@ let test_reconnect () = (* Connect with random UUID and request an unused IP *) let test_connect_preferred_ipv4 preferred_ip () = Host.Main.run begin - let uuid = (Uuidm.v `V4) in + let uuid = (Uuidm.v4_gen (Random.get_state ()) ()) in Log.info (fun f -> f "Using UUID %s, requesting IP %s" (Uuidm.to_string uuid) (Ipaddr.V4.to_string preferred_ip)); with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in let ip = List.hd ips in let mac = (VMNET.mac client_stack.netif) in Lwt.return (ip, mac) ) >>= fun (ip, mac) -> (* Verify that we got the IP we requested *) - assert(Ipaddr.V4.compare ip preferred_ip == 0); - Log.info (fun f -> f "First connection got IP %s and MAC %s" (Ipaddr.V4.to_string ip) (Macaddr.to_string mac)); + assert(Ipaddr.compare ip (V4 preferred_ip) == 0); + Log.info (fun f -> f "First connection got IP %s and MAC %s" (Ipaddr.to_string ip) (Macaddr.to_string mac)); with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.2.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in let ip = List.hd ips in let mac = (VMNET.mac client_stack.netif) in Lwt.return (ip, mac) ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.info (fun f -> f "Reconnect got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); + Log.info (fun f -> f "Reconnect got IP %s and MAC %s" (Ipaddr.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); (* Verify that we got the same IP and MAC when reconnecting with the same UUID *) - assert(Ipaddr.V4.compare ip reconnect_ip == 0); + assert(Ipaddr.compare ip reconnect_ip == 0); assert(Macaddr.compare mac reconnect_mac == 0); (* Try to reconnect with the same UUID, but request a different IP (this should fail) *) let different_ip = Ipaddr.V4.of_int32 (Int32.succ (Ipaddr.V4.to_int32 preferred_ip)) in Lwt.catch (fun () -> with_stack ~uuid ~preferred_ip:different_ip ~pcap:"test_connect_preferred_ipv4.3.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in let ip = List.hd ips in let mac = (VMNET.mac client_stack.netif) in Lwt.return (ip, mac) ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.err (fun f -> f "Failure: Request for different IP got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); + Log.err (fun f -> f "Failure: Request for different IP got IP %s and MAC %s" (Ipaddr.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); raise (Test_failure "Request for different IP for same UUID succeeded")) (fun e -> match e with | Failure _ -> Lwt.return () (* test was successful, an exception was triggered *) | e -> raise e) >>= fun () -> (* Try to reconnect with a different UUID, but request a used IP (this should fail) *) Lwt.catch (fun () -> - let uuid = (Uuidm.v `V4) in + let uuid = (Uuidm.v4_gen (Random.get_state ()) ()) in with_stack ~uuid ~preferred_ip ~pcap:"test_connect_preferred_ipv4.4.pcap" (fun _ client_stack -> - let ips = Client.IPV4.get_ip (Client.ipv4 client_stack.t) in + let ips = get_ips (Client.ip client_stack.t) in let ip = List.hd ips in let mac = (VMNET.mac client_stack.netif) in Lwt.return (ip, mac) ) >>= fun (reconnect_ip, reconnect_mac) -> - Log.err (fun f -> f "Failure: Request for same IP with different UUID got IP %s and MAC %s" (Ipaddr.V4.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); + Log.err (fun f -> f "Failure: Request for same IP with different UUID got IP %s and MAC %s" (Ipaddr.to_string reconnect_ip) (Macaddr.to_string reconnect_mac)); raise (Test_failure "Request for same IP with different UUID succeeded")) (fun e -> match e with | Failure _ -> Lwt.return () (* test was successful, an exception was triggered *) diff --git a/src/hostnet_test/test_dns.ml b/src/hostnet_test/test_dns.ml index e2aff3219..57b5ef1fb 100644 --- a/src/hostnet_test/test_dns.ml +++ b/src/hostnet_test/test_dns.ml @@ -13,7 +13,7 @@ let pp_ip4s = Fmt.(list ~sep:(any ", ") Ipaddr.V4.pp) let run_test ?(timeout=Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> + Mirage_sleep.ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -183,21 +183,21 @@ module Server = struct Udp.getsockname server >>= fun (_, realport) -> let t = { ip; port = realport; server } in - Lwt.finalize (fun () -> f t.port) (fun () -> Udp.shutdown t.server) + Lwt.finalize (fun () -> f t.port) (fun () -> Udp.stop t.server) end -let err_udp e = Fmt.kstr failwith "%a" Client.UDPV4.pp_error e +let err_udp e = Fmt.kstr failwith "%a" Client.UDP.pp_error e let udp_rpc client src_port dst dst_port buffer = - let udpv4 = Client.udpv4 client.Client.t in + let udpv4 = Client.udp client.Client.t in let send_request () = - Client.UDPV4.write ~src_port ~dst ~dst_port udpv4 buffer + Client.UDP.write ~src_port ~dst ~dst_port udpv4 buffer >>= function | Error e -> err_udp e | Ok () -> Lwt.return_unit in let response = ref None in - Client.UDPV4.listen (Client.udpv4 client.Client.t) ~port:src_port (fun ~src:_ ~dst:_ ~src_port:remote_src_port buffer -> + Client.UDP.listen (Client.udp client.Client.t) ~port:src_port (fun ~src:_ ~dst:_ ~src_port:remote_src_port buffer -> Log.debug (fun f -> f "Received UDP %d -> %d" remote_src_port src_port); begin match !response with @@ -212,7 +212,7 @@ let udp_rpc client src_port dst dst_port buffer = match !response with | Some x -> Lwt.return x | None -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop () in loop () diff --git a/src/hostnet_test/test_forward_protocol.ml b/src/hostnet_test/test_forward_protocol.ml index 2347212b4..e7ac56ebe 100644 --- a/src/hostnet_test/test_forward_protocol.ml +++ b/src/hostnet_test/test_forward_protocol.ml @@ -103,8 +103,10 @@ module Shared_memory = struct let otherend t = {write= t.read; read= t.write; closed= false} - let shutdown_write t = - Pipe.shutdown_write t.write ; + let shutdown t = function + | `read -> Lwt.return_unit + | `write | `read_write -> + Pipe.shutdown_write t.write; Lwt.return_unit let close t = @@ -125,8 +127,6 @@ module Shared_memory = struct let writev t bufs = Lwt.return (Pipe.write t.write bufs) - let shutdown_read _chanel = Lwt.return_unit - let write channel buf = writev channel [buf] type flow = t @@ -142,7 +142,7 @@ module Shared_memory = struct end (* Check it matches the signature *) -module Test : Mirage_flow_combinators.SHUTDOWNABLE = Shared_memory +module Test : Mirage_flow.S = Shared_memory module Mux = Forwarder.Multiplexer.Make (Shared_memory) @@ -211,7 +211,7 @@ let test_close_shutdown () = >>= fun channel -> Mux.Channel.close channel >>= fun () -> - Mux.Channel.shutdown_write channel + Mux.Channel.shutdown channel `write >>= fun () -> if not (Mux.is_running left_mux) then failwith "left_mux has failed"; @@ -276,7 +276,7 @@ let read_and_write channel to_write = let read = count_recv channel in send channel to_write >>= fun written_sha -> - Mux.Channel.shutdown_write channel + Mux.Channel.shutdown channel `write >>= fun () -> read >>= fun (num_read, sha) -> diff --git a/src/hostnet_test/test_half_close.ml b/src/hostnet_test/test_half_close.ml index cab4c69fb..51c7694ca 100644 --- a/src/hostnet_test/test_half_close.ml +++ b/src/hostnet_test/test_half_close.ml @@ -22,7 +22,7 @@ module Server = struct Host.Sockets.Stream.Tcp.listen server on_accept; Lwt.return { server; port } let destroy t = - Host.Sockets.Stream.Tcp.shutdown t.server + Host.Sockets.Stream.Tcp.stop t.server end let with_server on_accept f = Server.create on_accept @@ -30,7 +30,7 @@ let with_server on_accept f = Lwt.finalize (fun () -> f server) (fun () -> Server.destroy server) module Outgoing = struct - module C = Mirage_channel.Make(Slirp_stack.Client.TCPV4) + module C = Mirage_channel.Make(Slirp_stack.Client.TCP) end module Incoming = struct module C = Mirage_channel.Make(Host.Sockets.Stream.Tcp) @@ -85,7 +85,7 @@ let test_mirage_half_close () = let open Slirp_stack in let ip = Ipaddr.V4.localhost in let port = server.Server.port in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + Client.TCP.create_connection (Client.tcp stack.t) (Ipaddr.V4 ip, port) >|= flow ip port >>= fun flow -> Log.info (fun f -> f "Connected to %a:%d" Ipaddr.V4.pp ip port); let oc = Outgoing.C.create flow in @@ -93,7 +93,7 @@ let test_mirage_half_close () = Outgoing.C.flush oc >|= unit >>= fun () -> (* This will perform a TCP half-close *) - Client.TCPV4.close flow >>= fun () -> + Client.TCP.close flow >>= fun () -> (* Verify the response is still intact *) Outgoing.C.read_line oc >|= data >>= fun bufs -> @@ -102,7 +102,7 @@ let test_mirage_half_close () = then failf "Expected to read '%s', got '%s'" response txt; Log.info (fun f -> f "Read the response. Waiting for cleanup"); Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); (forwarded >|= fun x -> `Result x) ] ) >>= function | `Timeout -> failwith "TCP half close test timed-out" @@ -124,7 +124,7 @@ let test_host_half_close () = Incoming.C.flush ic >|= unit >>= fun () -> (* This will perform a TCP half-close *) - Host.Sockets.Stream.Tcp.shutdown_write flow >>= fun () -> + Host.Sockets.Stream.Tcp.shutdown flow `write >>= fun () -> (* Read the response from the other side of the connection *) Incoming.C.read_line ic >|= data @@ -141,7 +141,7 @@ let test_host_half_close () = let open Slirp_stack in let ip = Ipaddr.V4.localhost in let port = server.Server.port in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + Client.TCP.create_connection (Client.tcp stack.t) (Ipaddr.V4 ip, port) >|= flow ip port >>= fun flow -> Log.info (fun f -> f "Connected to %a:%d" Ipaddr.V4.pp ip port); let oc = Outgoing.C.create flow in @@ -159,7 +159,7 @@ let test_host_half_close () = Outgoing.C.flush oc >|= unit >>= fun () -> Log.info (fun f -> f "Written response and will wait."); Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); (forwarded >|= fun x -> `Result x) ] ) >>= function | `Timeout -> failwith "TCP half close test timed-out" @@ -176,7 +176,7 @@ let test_connect_valid_invalid_port () = let open Slirp_stack in let ip = Ipaddr.V4.localhost in let port = server.Server.port in - let mkconn = Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + let mkconn = Client.TCP.create_connection (Client.tcp stack.t) (Ipaddr.V4 ip, port) >|= function | Ok _ -> Log.debug (fun f -> @@ -189,7 +189,7 @@ let test_connect_valid_invalid_port () = Server.destroy server; >>= fun () -> (* Now that a server is down, connect to an invalid port and ensure it fails quickly *) - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + Client.TCP.create_connection (Client.tcp stack.t) (Ipaddr.V4 ip, port) >|= function | Ok _ -> Log.err (fun f -> @@ -199,7 +199,7 @@ let test_connect_valid_invalid_port () = Log.debug (fun f -> f "Expected failure to connect to localhost:%d" port); in Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 5) >|= fun () -> `Timeout); + (Mirage_sleep.ns (Duration.of_sec 5) >|= fun () -> `Timeout); (mkconn >|= fun x -> `Result x) ] ) >>= function | `Timeout -> failwith "TCP server invalid port test timed-out" @@ -218,7 +218,7 @@ let test_connect_valid_invalid_port () = let rec mkconn = function | 0 -> Lwt.return (); | 3 -> Server.destroy server >>= fun () -> mkconn 1; - | count -> Client.TCPV4.create_connection (Client.tcpv4 stack.t) (ip, port) + | count -> Client.TCP.create_connection (Client.tcp stack.t) (Ipaddr.V4 ip, port) >|= function | Ok _ -> Log.debug (fun f -> @@ -230,7 +230,7 @@ let test_connect_valid_invalid_port () = fun () -> mkconn (count-1); in Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 5) >|= fun () -> `Timeout); + (Mirage_sleep.ns (Duration.of_sec 5) >|= fun () -> `Timeout); (mkconn 8 >|= fun x -> `Result x) ] ) >>= function | `Timeout -> failwith "TCP server valid port test timed-out" diff --git a/src/hostnet_test/test_http.ml b/src/hostnet_test/test_http.ml index 929b78702..0429e11b5 100644 --- a/src/hostnet_test/test_http.ml +++ b/src/hostnet_test/test_http.ml @@ -87,7 +87,7 @@ module Server = struct Host.Sockets.Stream.Tcp.listen server on_accept; Lwt.return { server; port } let destroy t = - Host.Sockets.Stream.Tcp.shutdown t.server + Host.Sockets.Stream.Tcp.stop t.server end let with_server on_accept f = Server.create on_accept @@ -95,7 +95,7 @@ let with_server on_accept f = Lwt.finalize (fun () -> f server) (fun () -> Server.destroy server) module Outgoing = struct - module C = Mirage_channel.Make(Slirp_stack.Client.TCPV4) + module C = Mirage_channel.Make(Slirp_stack.Client.TCP) module IO = Cohttp_mirage_io.Make(C) module Request = Cohttp.Request.Make(IO) module Response = Cohttp.Response.Make(IO) @@ -109,15 +109,15 @@ end let send_http_request stack (ip, port) request = let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack) (ip, port) + Client.TCP.create_connection (Client.tcp stack) (ip, port) >>= function | Ok flow -> - Log.info (fun f -> f "Connected to %s:80" (Ipaddr.V4.to_string ip)); + Log.info (fun f -> f "Connected to %s:80" (Ipaddr.to_string ip)); let oc = Outgoing.C.create flow in Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:80" (Ipaddr.V4.to_string ip)); + Log.err (fun f -> f "Failed to connect to %s:80" (Ipaddr.to_string ip)); failwith "http_fetch" let intercept ~pcap ?(port = 80) proxy request = @@ -145,11 +145,11 @@ let intercept ~pcap ?(port = 80) proxy request = >>= function | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> - send_http_request stack.t (Ipaddr.V4.of_string_exn "127.0.0.1", port) + send_http_request stack.t (Ipaddr.of_string_exn "127.0.0.1", port) request >>= fun () -> Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); (forwarded >>= fun x -> Lwt.return (`Result x)) ] @@ -335,7 +335,7 @@ let test_proxy_authorization proxy () = let err_flush e = Fmt.kstr failwith "%a" Incoming.C.pp_write_error e let test_http_connect_tunnel proxy () = - let test_dst_ip = Ipaddr.V4.of_string_exn "1.2.3.4" in + let test_dst_ip = Ipaddr.of_string_exn "1.2.3.4" in Host.Main.run begin Slirp_stack.with_stack ~pcap:"test_http_connect.pcap" (fun _ stack -> with_server (fun flow -> @@ -356,14 +356,14 @@ let test_http_connect_tunnel proxy () = (Cohttp.Code.string_of_method req.Cohttp.Request.meth); let uri = Cohttp.Request.uri req in Alcotest.check Alcotest.(option string) "host" - (Some (Ipaddr.V4.to_string test_dst_ip)) (Uri.host uri); + (Some (Ipaddr.to_string test_dst_ip)) (Uri.host uri); Alcotest.check Alcotest.(option int) "port" (Some 443) (Uri.port uri); Alcotest.check Alcotest.(option string) "host" - (Some (Ipaddr.V4.to_string test_dst_ip ^ ":443")) + (Some (Ipaddr.to_string test_dst_ip ^ ":443")) (Cohttp.Header.get req.Cohttp.Request.headers "host"); Alcotest.check Alcotest.string "resource" - (Ipaddr.V4.to_string test_dst_ip ^ ":443") + (Ipaddr.to_string test_dst_ip ^ ":443") req.Cohttp.Request.resource; (* If the proxy uses auth, then there has to be a Proxy-Authorization header. If theres no auth, there should be no header. *) @@ -396,13 +396,13 @@ let test_http_connect_tunnel proxy () = | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) + Client.TCP.create_connection (Client.tcp stack.t) (test_dst_ip, 443) >>= function | Error _ -> Log.err (fun f -> f "TCPV4.create_connection %a:443 failed" - Ipaddr.V4.pp test_dst_ip); + Ipaddr.pp test_dst_ip); failwith "TCPV4.create_connection" | Ok flow -> let ic = Outgoing.C.create flow in @@ -477,13 +477,13 @@ let test_http_connect_tunnel proxy () = | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3129) >>= function | Error _ -> Log.err (fun f -> f "TCPV4.create_connection %s:%d failed" - (Ipaddr.V4.to_string primary_dns_ip) 3129); + (Ipaddr.to_string primary_dns_ip) 3129); failwith "TCPV4.create_connection" | Ok flow -> let oc = Outgoing.C.create flow in @@ -551,13 +551,13 @@ let test_http_connect_tunnel proxy () = | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_connect: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let request = let connect = Cohttp.Request.make ~meth:`CONNECT (Uri.make ()) in @@ -589,7 +589,7 @@ let test_http_connect_tunnel proxy () = let txt = Cstruct.to_string buf in Alcotest.check Alcotest.string "message" "there" txt; Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); (forwarded >>= fun x -> Lwt.return (`Result x)) ] @@ -615,13 +615,13 @@ let test_http_connect_tunnel proxy () = | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_connect_rejected: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let request = let connect = Cohttp.Request.make ~meth:`CONNECT (Uri.make ()) in @@ -656,13 +656,13 @@ let test_http_connect_tunnel proxy () = | Error (`Msg m) -> failwith ("Failed to enable HTTP proxy: " ^ m) | Ok () -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_connect_fail: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let request = let connect = Cohttp.Request.make ~meth:`CONNECT (Uri.make ()) in @@ -691,13 +691,13 @@ let test_http_connect_tunnel proxy () = Host.Main.run begin Slirp_stack.with_stack ~pcap:"test_http_proxy_get_dns.pcap" (fun _ stack -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_get_dns: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let host = "does.not.exist.recoil.org" in let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ()) in @@ -722,13 +722,13 @@ let test_http_connect_tunnel proxy () = Host.Main.run begin Slirp_stack.with_stack ~pcap:"test_http_proxy_get.pcap" (fun _ stack -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_get: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let host = "www.mobyproject.org" in let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ()) in @@ -767,13 +767,13 @@ let test_http_connect_tunnel proxy () = let host = "127.0.0.1" in let port = server.Server.port in let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_get: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ~port ()) in Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc @@ -839,13 +839,13 @@ let test_http_connect_tunnel proxy () = | Error (`Msg m) -> failwith ("Failed to disable HTTP proxy: " ^ m) | Ok () -> (* Connect to the builtin HTTP Proxy *) - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_connection_close: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %a:3128" Ipaddr.V4.pp primary_dns_ip); + Log.info (fun f -> f "Connected to %a:3128" Ipaddr.pp primary_dns_ip); let oc = Outgoing.C.create flow in let request = let uri = Uri.make ~scheme:"http" ~host:"localhost" ~port () in @@ -879,7 +879,7 @@ let test_http_connect_tunnel proxy () = Alcotest.check Alcotest.string "body" body txt; Lwt.return (`Result ()) in Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); response; ] @@ -911,13 +911,13 @@ let test_http_connect_tunnel proxy () = let host = host_or_ip in let port = server.Server.port in let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_get: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let request = Cohttp.Request.make ~meth:`GET (Uri.make ~host ~port ()) in Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc @@ -952,13 +952,13 @@ let test_http_connect_tunnel proxy () = Host.Main.run begin Slirp_stack.with_stack ~pcap:"test_http_proxy_head.pcap" (fun _ stack -> let open Slirp_stack in - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (primary_dns_ip, 3128) + Client.TCP.create_connection (Client.tcp stack.t) (primary_dns_ip, 3128) >>= function | Error _ -> - Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.err (fun f -> f "Failed to connect to %s:3128" (Ipaddr.to_string primary_dns_ip)); failwith "test_proxy_head: connect failed" | Ok flow -> - Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.V4.to_string primary_dns_ip)); + Log.info (fun f -> f "Connected to %s:3128" (Ipaddr.to_string primary_dns_ip)); let oc = Outgoing.C.create flow in let host = "www.mobyproject.org" in let request = Cohttp.Request.make ~meth:`HEAD (Uri.make ~host ()) in @@ -987,7 +987,7 @@ let test_http_connect_tunnel proxy () = (* any HTTP response will do *) Lwt.return `Ok in Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); t ] >>= function | `Timeout -> failwith "test_proxy_head timed out" @@ -1028,7 +1028,7 @@ let test_http_connect_tunnel proxy () = | Ok () -> (* Create a regular HTTP connection, this should be caught by the transparent proxy *) - Client.TCPV4.create_connection (Client.tcpv4 stack.t) (Ipaddr.V4.of_string_exn host, port) + Client.TCP.create_connection (Client.tcp stack.t) (Ipaddr.of_string_exn host, port) >>= function | Error _ -> Log.err (fun f -> f "Failed to connect to %s:%d" host port); @@ -1045,7 +1045,7 @@ let test_http_connect_tunnel proxy () = Outgoing.Request.write ~flush:true (fun _writer -> Lwt.return_unit) request oc >>= fun () -> Lwt.pick [ - (Host.Time.sleep_ns (Duration.of_sec 100) >|= fun () -> `Timeout); + (Mirage_sleep.ns (Duration.of_sec 100) >|= fun () -> `Timeout); forwarded >|= fun request -> Log.info (fun f -> f "Successfully received: %s" @@ -1090,7 +1090,7 @@ let tests = [ [ "check that HTTP GET headers are correct", `Quick, test_http_proxy_headers ]; "HTTP proxy: GET to localhost works", - [ "check that HTTP GET to localhost via IP", `Quick, test_http_proxy_localhost (Ipaddr.V4.to_string Slirp_stack.localhost_ip) ]; + [ "check that HTTP GET to localhost via IP", `Quick, test_http_proxy_localhost (Ipaddr.to_string Slirp_stack.localhost_ip) ]; "HTTP proxy: transparent proxy respects excludes", [ "check that the transparent proxy will inspect and respect the Host: header", `Quick, test_transparent_http_proxy_exclude ]; diff --git a/src/hostnet_test/test_nat.ml b/src/hostnet_test/test_nat.ml index 8961f8fae..a29a7a089 100644 --- a/src/hostnet_test/test_nat.ml +++ b/src/hostnet_test/test_nat.ml @@ -10,7 +10,7 @@ module Log = (val Logs.src_log src : Logs.LOG) let run ?(timeout=Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> + Mirage_sleep.ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -61,7 +61,7 @@ module EchoServer = struct let to_string t = Printf.sprintf "udp:127.0.0.1:%d" t.local_port - let destroy t = Host.Sockets.Datagram.Udp.shutdown t.server + let destroy t = Host.Sockets.Datagram.Udp.stop t.server let with_server f = create () >>= fun server -> Lwt.finalize (fun () -> f server) (fun () -> destroy server) @@ -84,7 +84,7 @@ module UdpServer = struct let seen_source_ports = PortSet.empty in let num_received = 0 in let t = { port; highest; num_received; seen_source_ports; c } in - Client.UDPV4.listen (Client.udpv4 stack) ~port (fun ~src:_ ~dst:_ ~src_port buffer -> + Client.UDP.listen (Client.udp stack) ~port (fun ~src:_ ~dst:_ ~src_port buffer -> t.highest <- max t.highest (Cstruct.get_uint8 buffer 0); t.seen_source_ports <- PortSet.add src_port t.seen_source_ports; t.num_received <- t.num_received + 1; @@ -97,14 +97,14 @@ module UdpServer = struct let wait_for_data ~highest t = if t.highest < highest then begin Lwt.pick [ Lwt_condition.wait t.c; - Host.Time.sleep_ns (Duration.of_sec 1) ] + Mirage_sleep.ns (Duration.of_sec 1) ] >>= fun () -> Lwt.return (t.highest >= highest) end else Lwt.return true let wait_for_ports ~num t = if PortSet.cardinal t.seen_source_ports < num then begin Lwt.pick [ Lwt_condition.wait t.c; - Host.Time.sleep_ns (Duration.of_sec 1) ] + Mirage_sleep.ns (Duration.of_sec 1) ] >|= fun () -> PortSet.cardinal t.seen_source_ports >= num end else Lwt.return true @@ -113,12 +113,12 @@ module UdpServer = struct then Lwt.return true else Lwt.pick [ Lwt_condition.wait t.c; - Host.Time.sleep_ns (Duration.of_sec 1) ] + Mirage_sleep.ns (Duration.of_sec 1) ] >>= fun () -> Lwt.return false end -let err_udp e = Fmt.kstr failwith "%a" Client.UDPV4.pp_error e +let err_udp e = Fmt.kstr failwith "%a" Client.UDP.pp_error e (* Start a local UDP echo server, send traffic to it and listen for a response *) @@ -128,7 +128,7 @@ let test_udp () = let buffer = Cstruct.create 1024 in (* Send '1' *) Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in let virtual_port = 1024 in let server = UdpServer.make stack.t virtual_port in let rec loop remaining = @@ -137,9 +137,9 @@ let test_udp () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -160,7 +160,7 @@ let test_udp_reply_last_use () = let buffer = Cstruct.create 1024 in (* Send '1' *) Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in let virtual_port = 1024 in let server = UdpServer.make stack.t virtual_port in let rec loop remaining = @@ -169,9 +169,9 @@ let test_udp_reply_last_use () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -201,7 +201,7 @@ let test_udp_reply_last_use () = if get_last_use () <> last_use then Lwt.return_unit else - Host.Time.sleep_ns (Duration.of_sec 5) + Mirage_sleep.ns (Duration.of_sec 5) >>= fun () -> loop (remaining - 1) in loop 5 @@ -218,7 +218,7 @@ let test_udp_expiry () = let buffer = Cstruct.create 1024 in (* Send '1' *) Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in let virtual_port = 1024 in let server = UdpServer.make stack.t virtual_port in (* Send spam to almost fill up the table. Leave one entry. *) @@ -226,9 +226,9 @@ let test_udp_expiry () = let rec spam from_port remaining = match remaining with | 0 -> Lwt.return_unit | n -> - Client.UDPV4.write + Client.UDP.write ~src_port:(from_port + n) - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:(local_port + 1) (* not the echo server *) udpv4 buffer >>= function @@ -244,9 +244,9 @@ let test_udp_expiry () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -264,7 +264,7 @@ let test_udp_expiry () = | 0 -> failwith (Printf.sprintf "Failed to fill NAT table, active = %d, limit = %d" active limit) | _ -> if active <> limit - then Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (remaining - 1) + then Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop (remaining - 1) else Lwt.return_unit in loop 5 >>= fun () -> @@ -278,7 +278,7 @@ let test_udp_expiry () = | 0 -> failwith (Printf.sprintf "Failed to expire NAT table, active = %d, limit = %d" active limit) | _ -> if active >= limit - then Host.Time.sleep_ns (Duration.of_sec 1) >>= fun () -> loop (remaining - 1) + then Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop (remaining - 1) else Lwt.return_unit in loop 5 >>= fun () -> @@ -305,7 +305,7 @@ let test_udp_2 () = let buffer = Cstruct.create 1024 in (* Send '1' *) Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in (* Listen on one virtual source port and count received packets *) let virtual_port1 = 1024 in @@ -317,9 +317,9 @@ let test_udp_2 () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port1 local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port1 - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -341,9 +341,9 @@ let test_udp_2 () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port2 local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port2 - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -369,7 +369,7 @@ let test_nat_punch () = let buffer = Cstruct.create 1024 in (* Send '1' *) Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in (* Listen on one virtual source port and count received packets *) let virtual_port1 = 1024 in @@ -382,9 +382,9 @@ let test_nat_punch () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port1 dst_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port1 - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port udpv4 buffer >>= function | Error e -> err_udp e @@ -431,7 +431,7 @@ let test_shared_nat_rule () = let buffer = Cstruct.create 1024 in (* Send '1' *) Cstruct.set_uint8 buffer 0 1; - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in let virtual_port = 1024 in let server = UdpServer.make stack.t virtual_port in let init_table_size = @@ -444,9 +444,9 @@ let test_shared_nat_rule () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -470,8 +470,8 @@ let test_shared_nat_rule () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + Client.UDP.write ~src_port:virtual_port + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port udpv4 buffer >>= function | Error e -> err_udp e @@ -497,7 +497,7 @@ let test_source_ports () = (fun { EchoServer.local_port = local_port2; _ } -> with_stack ~pcap:"test_source_ports.pcap" (fun _ stack -> let buffer = Cstruct.create 1024 in - let udpv4 = Client.udpv4 stack.t in + let udpv4 = Client.udp stack.t in (* This is the port we shall send from *) let virtual_port = 1024 in let server = UdpServer.make stack.t virtual_port in @@ -508,9 +508,9 @@ let test_source_ports () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port1 (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port1 udpv4 buffer >>= function | Error e -> err_udp e @@ -518,9 +518,9 @@ let test_source_ports () = Log.debug (fun f -> f "Sending %d -> %d value %d" virtual_port local_port2 (Cstruct.get_uint8 buffer 0)); - Client.UDPV4.write + Client.UDP.write ~src_port:virtual_port - ~dst:Ipaddr.V4.localhost + ~dst:(V4 Ipaddr.V4.localhost) ~dst_port:local_port2 udpv4 buffer >>= function | Error e -> err_udp e diff --git a/src/hostnet_test/test_nmap.ml b/src/hostnet_test/test_nmap.ml index 43364ee9c..b1c7fc925 100644 --- a/src/hostnet_test/test_nmap.ml +++ b/src/hostnet_test/test_nmap.ml @@ -12,7 +12,7 @@ let failf fmt = Fmt.kstr failwith fmt let run_test ?(timeout=Duration.of_sec 60) t = let timeout = - Host.Time.sleep_ns timeout >>= fun () -> + Mirage_sleep.ns timeout >>= fun () -> Lwt.fail_with "timeout" in Host.Main.run @@ Lwt.pick [ timeout; t ] @@ -27,13 +27,13 @@ let test_nmap () = let start = Unix.gettimeofday () in let open_ports = ref [] in let connect_disconnect ip port = - Client.TCPV4.create_connection (Client.tcpv4 stack.Client.t) (ip, port) + Client.TCP.create_connection (Client.tcp stack.Client.t) (ip, port) >>= function | Error _ -> Lwt.return_unit | Ok flow -> open_ports := port :: !open_ports; - Client.TCPV4.close flow + Client.TCP.close flow >>= fun () -> Lwt.return_unit in (* Limit the number of concurrent connection requests *) @@ -67,7 +67,7 @@ let test_nmap () = scan_all_ports ip (first + 1) last end in let rec show_status () = - Host.Time.sleep_ns (Duration.of_sec 5) + Mirage_sleep.ns (Duration.of_sec 5) >>= fun () -> Log.info (fun f -> f "Connections completed: %d; connections in progress: %d" !completed !cur_concurrent); show_status () in @@ -93,11 +93,11 @@ let test_nmap () = else begin let ping = Packets.icmp_echo_request ~id:0x1234 ~seq ~len:0 in Log.info (fun f -> f "sending ping to verify the stack is still working"); - Client.Icmpv41.write stack.Client.icmpv4 ~dst:localhost_ip ping + Client.Icmpv41.write stack.Client.icmpv4 ~dst:(Ipaddr.to_v4 localhost_ip |> Option.get) ping >>= function | Error e -> failf "Icmpv41.write failed: %a" Client.Icmpv41.pp_error e | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop (seq + 1) end in diff --git a/src/hostnet_test/test_ping.ml b/src/hostnet_test/test_ping.ml index aaee5e387..5e177fea0 100644 --- a/src/hostnet_test/test_ping.ml +++ b/src/hostnet_test/test_ping.ml @@ -27,7 +27,7 @@ let test_ping () = >>= function | Error e -> failf "Icmpv41.write failed: %a" Slirp_stack.Client.Icmpv41.pp_error e | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> loop (seq + 1) end in @@ -54,7 +54,7 @@ let test_two_pings () = >>= function | Error e -> failf "Icmpv41.write failed: %a" Slirp_stack.Client.Icmpv41.pp_error e | Ok () -> - Host.Time.sleep_ns (Duration.of_sec 1) + Mirage_sleep.ns (Duration.of_sec 1) >>= fun () -> if Queue.length Slirp_stack.Client.Icmpv41.packets > 0 then begin let all = Queue.fold (fun xs x -> x :: xs) [] Slirp_stack.Client.Icmpv41.packets in diff --git a/vpnkit.opam b/vpnkit.opam index 23894d04c..b09d3f383 100644 --- a/vpnkit.opam +++ b/vpnkit.opam @@ -36,11 +36,11 @@ depends: [ "base64" {>= "3.5.0"} "cstruct" {>= "6.0.0"} "pcap-format" {>= "0.4.0"} - "cmdliner" {< "1.1.0"} + "cmdliner" {>= "1.1.0"} "charrua" {>= "1.3.0"} "charrua-client" "charrua-server" - "hvsock" {>= "2.0.0"} + "hvsock" {>= "3.0.1"} "fd-send-recv" {>= "2.0.0"} "logs" "fmt" @@ -52,9 +52,8 @@ depends: [ "mirage-net" {>= "4.0.0"} "mirage-time" {>= "3.0.0"} "mirage-channel" {>= "4.0.1"} - "mirage-stack" "cohttp-lwt" {>= "0.99.0"} - "protocol-9p" {>= "2.0.0"} + "protocol-9p" {>= "2.0.2"} "mirage-vnetif" {>= "0.5.0" & < "0.6.0"} "io-page-unix" "uuidm" @@ -64,7 +63,6 @@ depends: [ "mirage-clock" {>= "4.0.0"} "mirage-clock-unix" {>= "4.0.0"} "mirage-random" {>= "3.0.0"} - "mirage-random-stdlib" "re" {>= "1.9.0"} "ppx_inline_test" ]