Remove all Mirage_time.S and Mirage_clock.S

Signed-off-by: Patrick Ferris <patrick@sirref.org>

Author: patricoferris

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

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

src/dns_forward/dns_forward.mli

@@ -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
@@ -259,8 +257,7 @@ module Rpc: sig
 
     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)