Upgrading Mirage Packages

This also allows VPNkit to be built with OCaml 5+ compilers.

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" ]
+    [ ]
   | _ ->
     []
 

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;