Upgrading Mirage Packages

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

dune-project

@@ -1,2 +1,3 @@
-(lang dune 2.0)
+(lang dune 3.4)
+
 (name vpnkit)

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

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

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

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

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

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)

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. *)

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

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

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)

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