Mirage time variant

arp.opam

@@ -13,14 +13,13 @@ depends: [
   "ipaddr" {>= "4.0.0"}
   "macaddr" {>= "4.0.0"}
   "logs"
-  "mirage-time" {>= "2.0.0"}
+  "mirage-time" {>= "4.0.0"}
   "lwt"
   "duration"
   "ethernet" {>= "3.0.0"}
   "fmt" {>= "0.8.7"}
   "alcotest" {with-test}
   "mirage-vnetif" {with-test & >= "0.5.0"}
-  "mirage-time-unix" {with-test & >= "2.0.0"}
 ]
 build: [
   ["dune" "subst"] {dev}

bench/bench.ml

@@ -74,7 +74,7 @@ open Lwt.Infix
 module B = Basic_backend.Make
 module V = Vnetif.Make(B)
 module E = Ethernet.Make(V)
-module A = Arp.Make(E)(Time)
+module A = Arp.Make(E)
 
 let c = ref 0
 let gen arp buf =
@@ -102,7 +102,7 @@ let rec query arp () =
   incr count2 ;
   let ip = gen_ip () in
   Lwt.async (fun () -> A.query arp ip >|= fun _ -> ());
-  Time.sleep_ns (Duration.of_us 100) >>= fun () ->
+  Mirage_time.sleep_ns (Duration.of_us 100) >>= fun () ->
   query arp ()
 
 type arp_stack = {
@@ -138,43 +138,43 @@ let runit () =
         let res = generate 28 in
         Cstruct.blit res 0 b 0 28 ;
         28) () ;
-    Time.sleep_ns (Duration.of_sec 5)
+    Mirage_time.sleep_ns (Duration.of_sec 5)
   ] >>= fun () ->
   Printf.printf "%d random input\n%!" !count ;
   count := 0 ;
   Lwt.pick [
     (V.listen stack.netif ~header_size (fun b -> incr count ; A.input stack.arp b) >|= fun _ -> ());
     send other.ethif gen_arp () ;
-    Time.sleep_ns (Duration.of_sec 5)
+    Mirage_time.sleep_ns (Duration.of_sec 5)
   ] >>= fun () ->
   Printf.printf "%d random ARP input\n%!" !count ;
   count := 0 ;
   Lwt.pick [
     (V.listen stack.netif ~header_size (fun b -> incr count ; A.input stack.arp b) >|= fun _ -> ());
     send other.ethif gen_req () ;
-    Time.sleep_ns (Duration.of_sec 5)
+    Mirage_time.sleep_ns (Duration.of_sec 5)
   ] >>= fun () ->
   Printf.printf "%d requests\n%!" !count ;
   count := 0 ;
   Lwt.pick [
     (V.listen stack.netif ~header_size (fun b -> incr count ; A.input stack.arp b) >|= fun _ -> ());
     send other.ethif gen_rep () ;
-    Time.sleep_ns (Duration.of_sec 5)
+    Mirage_time.sleep_ns (Duration.of_sec 5)
   ] >>= fun () ->
   Printf.printf "%d replies\n%!" !count ;
   count := 0 ;
   Lwt.pick [
     (V.listen stack.netif ~header_size (fun b -> incr count ; A.input stack.arp b) >|= fun _ -> ());
     send other.ethif (gen stack.arp) () ;
-    Time.sleep_ns (Duration.of_sec 5)
+    Mirage_time.sleep_ns (Duration.of_sec 5)
   ] >>= fun () ->
   Printf.printf "%d mixed\n%!" !count ;
   count := 0 ;
   Lwt.pick [
     (V.listen stack.netif ~header_size (fun b -> incr count ; A.input stack.arp b) >|= fun _ -> ());
     send other.ethif gen_rep  () ;
     query stack.arp () ;
-    Time.sleep_ns (Duration.of_sec 5)
+    Mirage_time.sleep_ns (Duration.of_sec 5)
   ] >|= fun () ->
   Printf.printf "%d queries (%d qs)\n%!" !count !count2
 

bench/dune

@@ -1,4 +1,3 @@
 (executable
  (name bench)
- (libraries arp.mirage mirage-vnetif lwt ipaddr ethernet mirage-time-unix
-   lwt.unix))
+ (libraries arp.mirage mirage-vnetif lwt ipaddr ethernet mirage-time lwt.unix))

mirage/arp.ml

@@ -34,7 +34,7 @@ open Lwt.Infix
 
 let logsrc = Logs.Src.create "ARP" ~doc:"Mirage ARP handler"
 
-module Make (Ethernet : Ethernet.S) (Time : Mirage_time.S) = struct
+module Make (Ethernet : Ethernet.S) = struct
 
   type error = [
     | `Timeout
@@ -60,14 +60,14 @@ module Make (Ethernet : Ethernet.S) (Time : Mirage_time.S) = struct
         (fun m -> m "error %a while outputting packet %a to %a"
             Ethernet.pp_error e Arp_packet.pp arp Macaddr.pp destination)
 
-  let rec tick t () =
+  let rec tick ~probe_delay t () =
     if t.ticking then
-      Time.sleep_ns probe_repeat_delay >>= fun () ->
+      Mirage_time.sleep_ns probe_delay >>= fun () ->
       let state, requests, timeouts = Arp_handler.tick t.state in
       t.state <- state ;
       Lwt_list.iter_p (output t) requests >>= fun () ->
       List.iter (fun (_, u) -> Lwt.wakeup u (Error `Timeout)) timeouts ;
-      tick t ()
+      tick ~probe_delay t ()
     else
       Lwt.return_unit
 
@@ -135,11 +135,11 @@ module Make (Ethernet : Ethernet.S) (Time : Mirage_time.S) = struct
     | Arp_handler.Wait (t, _) -> t
     | Arp_handler.Mac mac -> Lwt.return (Ok mac)
 
-  let connect ethif =
+  let connect ?(probe_delay = probe_repeat_delay) ethif =
     let mac = Ethernet.mac ethif in
     let state = init_empty mac in
     let t = { ethif; state; ticking = true} in
-    Lwt.async (tick t);
+    Lwt.async (tick ~probe_delay t);
     Lwt.return t
 
   let disconnect t =

mirage/arp.mli

@@ -65,8 +65,8 @@ module type S = sig
 end
 
 
-module Make (Ethernet : Ethernet.S) (Time : Mirage_time.S) : sig
+module Make (Ethernet : Ethernet.S) : sig
   include S
 
-  val connect : Ethernet.t -> t Lwt.t
+  val connect : ?probe_delay:int64 -> Ethernet.t -> t Lwt.t
 end

test/mirage/tests.ml

@@ -1,20 +1,9 @@
 open Lwt.Infix
 
-let time_reduction_factor = 600
-
-module Time = struct
-  type 'a io = 'a Lwt.t
-  let sleep_ns ns = Lwt_unix.sleep (Duration.to_f ns)
-end
-module Fast_time = struct
-  type 'a io = 'a Lwt.t
-  let sleep_ns time = Time.sleep_ns Int64.(div time (of_int time_reduction_factor))
-end
-
 module B = Basic_backend.Make
 module V = Vnetif.Make(B)
 module E = Ethernet.Make(V)
-module A = Arp.Make(E)(Fast_time)
+module A = Arp.Make(E)
 
 let src = Logs.Src.create "test_arp" ~doc:"Mirage ARP tester"
 module Log = (val Logs.src_log src : Logs.LOG)
@@ -59,7 +48,7 @@ let failf fmt = Fmt.kstr (fun s -> Alcotest.fail s) fmt
 
 let timeout ~time t =
   let msg = Printf.sprintf "Timed out: didn't complete in %d milliseconds" time in
-  Lwt.pick [ t; Time.sleep_ns (Duration.of_ms time) >>= fun () -> fail msg; ]
+  Lwt.pick [ t; Mirage_time.sleep_ns (Duration.of_ms time) >>= fun () -> fail msg; ]
 
 let check_response expected buf =
   match Arp_packet.decode buf with
@@ -133,7 +122,7 @@ let get_arp ?backend () =
   in
   V.connect backend >>= fun netif ->
   E.connect netif >>= fun ethif ->
-  A.connect ethif >>= fun arp ->
+  A.connect ~probe_delay:(Duration.of_ms 2) ethif >>= fun arp ->
   Lwt.return { backend; netif; ethif; arp }
 
 (* we almost always want two stacks on the same backend *)
@@ -188,7 +177,7 @@ let start_arp_listener stack () =
 let not_in_cache ~listen probe arp ip =
   Lwt.pick [
     single_check listen probe;
-    Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
+    Mirage_time.sleep_ns (Duration.of_ms 100) >>= fun () ->
     A.query arp ip >>= function
     | Ok _ -> failf "entry in cache when it shouldn't be %a" Ipaddr.V4.pp ip
     | Error `Timeout -> Lwt.return_unit
@@ -199,7 +188,7 @@ let not_in_cache ~listen probe arp ip =
 let set_ip_sends_garp () =
   two_arp () >>= fun (speak, listen) ->
   let emit_garp =
-    Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
+    Mirage_time.sleep_ns (Duration.of_ms 100) >>= fun () ->
     A.set_ips speak.arp [ first_ip ] >>= fun () ->
     Alcotest.(check (list ip)) "garp emitted when setting ip" [ first_ip ] (A.get_ips speak.arp);
     Lwt.return_unit
@@ -248,7 +237,7 @@ let input_single_garp () =
   timeout ~time:500 (
     Lwt.join [
       (V.listen listen.netif ~header_size one_and_done >|= fun _ -> ());
-      Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
+      Mirage_time.sleep_ns (Duration.of_ms 100) >>= fun () ->
       Lwt.async (fun () -> A.query listen.arp first_ip >|= ignore) ;
       A.set_ips speak.arp [ first_ip ];
     ])
@@ -273,7 +262,7 @@ let input_single_unicast () =
   timeout ~time:500 (
   Lwt.choose [
     (V.listen listen.netif ~header_size listener >|= fun _ -> ());
-    Time.sleep_ns (Duration.of_ms 2) >>= fun () ->
+    Mirage_time.sleep_ns (Duration.of_ms 2) >>= fun () ->
     E.write speak.ethif (V.mac listen.netif) `ARP ~size for_listener >>= fun _ ->
     query_and_no_response listen.arp first_ip
   ])
@@ -296,7 +285,7 @@ let input_resolves_wait () =
     Lwt.join [
       (V.listen listen.netif ~header_size listener >|= fun _ -> ());
       query_then_disconnect;
-      Time.sleep_ns (Duration.of_ms 1) >>= fun () ->
+      Mirage_time.sleep_ns (Duration.of_ms 1) >>= fun () ->
       E.write speak.ethif (V.mac listen.netif) `ARP ~size for_listener >|= function
       | Ok x -> x
       | Error _ -> failf "ethernet write failed"
@@ -337,10 +326,10 @@ let entries_expire () =
   Lwt.async (fun () -> A.query listen.arp first_ip >|= ignore) ;
   Lwt.async (fun () -> V.listen listen.netif ~header_size (start_arp_listener listen ()) >|= fun _ -> ());
   let test =
-    Time.sleep_ns (Duration.of_ms 10) >>= fun () ->
+    Mirage_time.sleep_ns (Duration.of_ms 10) >>= fun () ->
     set_and_check ~listener:listen.arp ~claimant:speak first_ip >>= fun () ->
     (* sleep for 5s to make sure we hit `tick` often enough *)
-    Time.sleep_ns (Duration.of_sec 5) >>= fun () ->
+    Mirage_time.sleep_ns (Duration.of_sec 5) >>= fun () ->
     (* asking now should generate a query *)
     not_in_cache ~listen:speak.netif expected_arp_query listen.arp first_ip
   in
@@ -371,8 +360,8 @@ let query_retries () =
   in
   Lwt.pick [
     (V.listen listen.netif ~header_size listener >|= fun _ -> ());
-    Time.sleep_ns (Duration.of_ms 2) >>= ask;
-    Time.sleep_ns (Duration.of_sec 6) >>= fun () ->
+    Mirage_time.sleep_ns (Duration.of_ms 2) >>= ask;
+    Mirage_time.sleep_ns (Duration.of_sec 6) >>= fun () ->
     fail "query didn't succeed or fail within 6s"
   ]
 
@@ -406,9 +395,9 @@ let requests_are_responded_to () =
       (* start the usual ARP listener, which should respond to requests *)
       arp_listener;
       (* send a request for the ARP listener to respond to *)
-      Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
+      Mirage_time.sleep_ns (Duration.of_ms 100) >>= fun () ->
       E.write inquirer.ethif Macaddr.broadcast `ARP ~size request >>= fun _ ->
-      Time.sleep_ns (Duration.of_ms 100) >>= fun () ->
+      Mirage_time.sleep_ns (Duration.of_ms 100) >>= fun () ->
       V.disconnect answerer.netif
     ];
   )
@@ -440,7 +429,7 @@ let requests_not_us () =
     (V.listen answerer.netif ~header_size (start_arp_listener answerer ()) >|= fun _ -> ());
     (V.listen inquirer.netif ~header_size (fail_on_receipt inquirer.netif) >|= fun _ -> ());
     make_requests >>= fun _ ->
-    Time.sleep_ns (Duration.of_ms 100) >>=
+    Mirage_time.sleep_ns (Duration.of_ms 100) >>=
     disconnect_listeners
   ]