Update Mirage packages

This also allows VPNkit to be build with OCaml 5+

Signed-off-by: Patrick Ferris <[email protected]>

Author: patricoferris

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})))
 

src/bin/config/discover.ml

@@ -11,7 +11,7 @@ let os_type () =
 let flags () =
   match os_type () with
   | "Linux" ->
-    [ "-ccopt"; "-static" ]
+      [ "-ccopt"; "-static" ]
   | _ ->
     []
 

src/bin/config/dune

@@ -1,3 +1,3 @@
 (executable
  (name discover)
- (libraries sexplib))
+ (libraries unix sexplib))

src/bin/connect.ml

@@ -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

src/bin/main.ml

@@ -863,21 +863,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 +886,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)

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
@@ -253,7 +253,7 @@ 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
 

src/dns_forward/dns_forward_rpc.ml

@@ -370,8 +370,8 @@ module Server = struct
         );
       Lwt_result.return ()
 
-    let shutdown server =
-      Sockets.shutdown server.server
+    let stop server =
+      Sockets.stop server.server
 
   end
 end

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

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

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;

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

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

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

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

src/dns_forward_test/test.ml

@@ -579,7 +579,7 @@ let test_cache () =
       >>= function
       | Error _ -> failwith "failed initial lookup"
       | Ok _ ->
-          S.shutdown server
+          S.stop server
           >>= fun () ->
           R.answer request r
           >>= function

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(Time:Mirage_time.S)(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,7 +95,7 @@ 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 ->
@@ -105,13 +105,13 @@ module Make(Time:Mirage_time.S)(S:Tcpip.Stack.V4) = struct
       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 =

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(Time:Mirage_time.S)(S:Tcpip.Stack.V4V6) : S with type stack = S.t

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-time tcpip mirage-kv)
   (wrapped     false))

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

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