IH-628, clock: add timer module

This module can be used to know when a certain amount has passed since the
timer started by polling. Useful for encoding timeouts, schedule actions
periodically and similar.

Signed-off-by: Pau Ruiz Safont <[email protected]>

clock.opam

@@ -2,7 +2,7 @@
 opam-version: "2.0"
 synopsis: "Xapi's library for managing time"
 maintainer: ["Xapi project maintainers"]
-authors: ["Jonathan Ludlam"]
+authors: ["Jonathan Ludlam" "Pau Ruiz Safont"]
 license: "LGPL-2.1-only WITH OCaml-LGPL-linking-exception"
 homepage: "https://xapi-project.github.io/"
 bug-reports: "https://github.com/xapi-project/xen-api/issues"
@@ -11,6 +11,7 @@ depends: [
   "ocaml" {>= "4.12"}
   "alcotest" {with-test}
   "astring"
+  "mtime"
   "ptime"
   "odoc" {with-doc}
 ]

dune-project

@@ -19,11 +19,12 @@
 (package
   (name clock)
   (synopsis "Xapi's library for managing time")
-  (authors "Jonathan Ludlam")
+  (authors "Jonathan Ludlam" "Pau Ruiz Safont")
   (depends
     (ocaml (>= 4.12))
     (alcotest :with-test)
     astring
+    mtime
     ptime
   )
 )

ocaml/libs/clock/date.ml

@@ -8,7 +8,7 @@
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU Lesser General Public License for more details.
- *)
+*)
 
 let months =
   [|

ocaml/libs/clock/dune

@@ -1,17 +1,20 @@
 (library
   (name clock)
   (public_name clock)
-  (modules date)
+  (modules date timer)
   (libraries
     astring
+    fmt
+    mtime
+    mtime.clock.os
     ptime
     ptime.clock.os
   )
 )
 
-(test
-  (name test_date)
+(tests
+  (names test_date test_timer)
   (package clock)
-  (modules test_date)
-  (libraries alcotest clock ptime)
+  (modules test_date test_timer)
+  (libraries alcotest clock fmt mtime ptime qcheck-core qcheck-core.runner)
 )

ocaml/libs/clock/test_timer.ml

@@ -0,0 +1,233 @@
+module Timer = Clock.Timer
+module Gen = QCheck2.Gen
+module Test = QCheck2.Test
+
+module QCheck_alcotest = struct
+  (* SPDX: BSD-2-Clause
+     From github.com/c-cube/qcheck
+  *)
+
+  module Q = QCheck2
+  module T = QCheck2.Test
+  module Raw = QCheck_base_runner.Raw
+
+  let seed_ =
+    lazy
+      (let s =
+         try int_of_string @@ Sys.getenv "QCHECK_SEED"
+         with _ -> Random.self_init () ; Random.int 1_000_000_000
+       in
+       Printf.printf "qcheck random seed: %d\n%!" s ;
+       s
+      )
+
+  let default_rand () =
+    (* random seed, for repeatability of tests *)
+    Random.State.make [|Lazy.force seed_|]
+
+  let verbose_ =
+    lazy
+      ( match Sys.getenv "QCHECK_VERBOSE" with
+      | "1" | "true" ->
+          true
+      | _ ->
+          false
+      | exception Not_found ->
+          false
+      )
+
+  let long_ =
+    lazy
+      ( match Sys.getenv "QCHECK_LONG" with
+      | "1" | "true" ->
+          true
+      | _ ->
+          false
+      | exception Not_found ->
+          false
+      )
+
+  let to_alcotest ?(colors = false) ?(verbose = Lazy.force verbose_)
+      ?(long = Lazy.force long_) ?(debug_shrink = None) ?debug_shrink_list
+      ?(rand = default_rand ()) (t : T.t) =
+    let (T.Test cell) = t in
+    let handler name cell r =
+      match (r, debug_shrink) with
+      | QCheck2.Test.Shrunk (step, x), Some out ->
+          let go =
+            match debug_shrink_list with
+            | None ->
+                true
+            | Some test_list ->
+                List.mem name test_list
+          in
+          if not go then
+            ()
+          else
+            QCheck_base_runner.debug_shrinking_choices ~colors ~out ~name cell
+              ~step x
+      | _ ->
+          ()
+    in
+    let print = Raw.print_std in
+    let name = T.get_name cell in
+    let run () =
+      let call = Raw.callback ~colors ~verbose ~print_res:true ~print in
+      T.check_cell_exn ~long ~call ~handler ~rand cell
+    in
+    ((name, `Slow, run) : unit Alcotest.test_case)
+end
+
+let spans =
+  Gen.oneofa ([|1; 100; 300|] |> Array.map (fun v -> Mtime.Span.(v * ms)))
+
+let test_timer_remaining =
+  let print = Fmt.to_to_string Mtime.Span.pp in
+  Test.make ~name:"Timer.remaining" ~print spans @@ fun duration ->
+  let timer = Timer.start ~duration in
+  let half = Timer.span_to_s duration /. 2. in
+  let elapsed = Mtime_clock.counter () in
+  Printf.printf "Sleeping for %f seconds...\n" half ;
+  Unix.sleepf half ;
+  let actual = Mtime_clock.count elapsed in
+  (* We expect to have slept [half] seconds, but we could've been woken up later
+     by the OS, it'll never be exact. Check that we're not too far off, or the
+     Expired / Remaining test below will be wrong.
+     The following equation must hold:
+     [duration / 2 <= actual < duration]
+  *)
+  QCheck2.assume (Timer.span_is_shorter actual ~than:duration) ;
+  QCheck2.assume
+    (not (Timer.span_is_shorter Mtime.Span.(2 * actual) ~than:duration)) ;
+  let () =
+    match Timer.remaining timer with
+    | Expired t ->
+        Test.fail_reportf
+          "Expected to have spare time, but got excess: %a. Duration: %a, \
+           actual: %a, timer: %a"
+          Mtime.Span.pp t Mtime.Span.pp duration Mtime.Span.pp actual Timer.pp
+          timer
+    | Remaining t ->
+        if Timer.span_is_longer Mtime.Span.(2 * t) ~than:duration then
+          Test.fail_reportf
+            "Expected to have less than half spare time, but got: %a. \
+             Duration: %a, actual: %a, timer: %a"
+            Mtime.Span.pp t Mtime.Span.pp duration Mtime.Span.pp actual Timer.pp
+            timer
+  in
+
+  (* 3 * half > duration, so we expect Excess to be reported now *)
+  Unix.sleepf (2. *. half) ;
+  let actual = Mtime_clock.count elapsed in
+  QCheck2.assume (Timer.span_is_longer actual ~than:duration) ;
+  let () =
+    match Timer.remaining timer with
+    | Expired _ ->
+        ()
+    | Remaining t ->
+        Test.fail_reportf
+          "Expected to have excess time, but got spare: %a. Duration: %a, \
+           actual: %a, timer: %a"
+          Mtime.Span.pp t Mtime.Span.pp duration Mtime.Span.pp actual Timer.pp
+          timer
+  in
+  if not (Timer.has_expired timer) then
+    Test.fail_reportf "Expected Timer to have expired. Duration: %a, timer: %a"
+      Mtime.Span.pp duration Timer.pp timer ;
+  true
+
+let tests_timer = List.map QCheck_alcotest.to_alcotest [test_timer_remaining]
+
+let combinations =
+  let pair x y = (x, y) in
+  let rec loop acc = function
+    | x :: xs ->
+        let acc = List.map (pair x) xs :: acc in
+        loop acc xs
+    | [] ->
+        List.(concat (rev acc))
+  in
+  loop []
+
+let test_span_compare =
+  let shortest = Mtime.Span.zero in
+  let long = Mtime.Span.of_uint64_ns Int64.max_int in
+  let longest = Mtime.Span.of_uint64_ns (-1L) in
+  let spec = combinations [shortest; long; longest] in
+  let pp_spec () = Fmt.str "%a" (Fmt.Dump.pair Mtime.Span.pp Mtime.Span.pp) in
+  let test_shorter (a, b) () =
+    let ( < ) a b = Mtime.Span.compare a b < 0 in
+    Alcotest.(check bool)
+      "is_shorter doesn't match compare" (a < b)
+      (Timer.span_is_shorter a ~than:b)
+  in
+  let tests_shorter =
+    List.map
+      (fun t ->
+        (Printf.sprintf "is_shorter %a" pp_spec t, `Quick, test_shorter t)
+      )
+      spec
+  in
+  let test_longer (a, b) () =
+    let ( > ) a b = Mtime.Span.compare a b > 0 in
+    Alcotest.(check bool)
+      "is_longer doesn't match compare" (a > b)
+      (Timer.span_is_longer a ~than:b)
+  in
+  let tests_longer =
+    List.map
+      (fun t -> (Printf.sprintf "is_longer %a" pp_spec t, `Quick, test_longer t))
+      spec
+  in
+  List.concat [tests_shorter; tests_longer]
+
+let test_conversion_to_s =
+  let shortest = Mtime.Span.zero in
+  let long = Mtime.Span.(104 * day) in
+  let longer = Mtime.Span.(105 * day) in
+  let spec = [(shortest, 0.); (long, 8.9856e+06); (longer, 9.072e+06)] in
+  let pp_spec () = Fmt.str "%a" Fmt.(Dump.pair Mtime.Span.pp float) in
+  let test_span_to_s (input, expected) () =
+    let actual = Timer.span_to_s input in
+    Alcotest.(check (float Float.epsilon))
+      "seconds match span length" expected actual
+  in
+  List.map
+    (fun t ->
+      (Printf.sprintf "span_to_s %a" pp_spec t, `Quick, test_span_to_s t)
+    )
+    spec
+
+let test_conversion_from_s =
+  let span = Alcotest.testable Mtime.Span.pp Mtime.Span.equal in
+  let shortest = 0. in
+  let short_enough = 9_007_199.254_740_991 in
+  let too_long = 9_007_199.254_740_992 in
+  let neg = -1. in
+  let spec =
+    let open Mtime.Span in
+    [
+      (shortest, Some zero)
+    ; (short_enough, Some (9_007_199_254_740_991 * ns))
+    ; (too_long, None)
+    ; (neg, None)
+    ]
+  in
+  let pp_spec () =
+    Fmt.str "%a" Fmt.(Dump.pair float (Dump.option Mtime.Span.pp))
+  in
+  let test_span_to_s (input, expected) () =
+    let actual = Timer.s_to_span input in
+    Alcotest.(check @@ option span)
+      "span length matches seconds" expected actual
+  in
+  List.map
+    (fun t ->
+      (Printf.sprintf "span_to_s %a" pp_spec t, `Quick, test_span_to_s t)
+    )
+    spec
+
+let tests_span =
+  List.concat [test_conversion_to_s; test_conversion_from_s; test_span_compare]
+
+let () = Alcotest.run "Timer" [("Timer", tests_timer); ("Span", tests_span)]

ocaml/libs/clock/timer.ml

@@ -0,0 +1,63 @@
+type t = {start: Ptime.t; elapsed: Mtime_clock.counter; duration: Mtime.Span.t}
+
+type countdown = Remaining of Mtime.Span.t | Expired of Mtime.Span.t
+
+let span_is_shorter a ~than:b = Mtime.Span.compare a b < 0
+
+let span_is_longer a ~than:b = Mtime.Span.compare a b > 0
+
+let start ~duration =
+  {start= Ptime_clock.now (); elapsed= Mtime_clock.counter (); duration}
+
+let duration {duration; _} = duration
+
+let elapsed t = Mtime_clock.count t.elapsed
+
+let remaining t =
+  let elapsed = Mtime_clock.count t.elapsed in
+  let difference = Mtime.Span.abs_diff elapsed t.duration in
+  if span_is_shorter elapsed ~than:t.duration then
+    Remaining difference
+  else
+    Expired difference
+
+let has_expired t =
+  let elapsed = Mtime_clock.count t.elapsed in
+  not (span_is_shorter elapsed ~than:t.duration)
+
+let deadline_of t =
+  Mtime.Span.to_uint64_ns t.duration
+  |> Int64.to_float
+  |> Ptime.Span.of_float_s
+  |> Option.get
+  |> Ptime.(Span.add Ptime.(to_span t.start))
+  |> Ptime.Span.to_float_s
+
+let shorten_by dur t =
+  let duration =
+    if span_is_longer dur ~than:t.duration then
+      Mtime.Span.zero
+    else
+      Mtime.Span.abs_diff dur t.duration
+  in
+  {t with duration}
+
+let extend_by dur t =
+  let duration = Mtime.Span.add dur t.duration in
+  {t with duration}
+
+let pp =
+  let open Fmt in
+  record
+    [
+      field "elapsed" elapsed Mtime.Span.pp
+    ; field "duration" duration Mtime.Span.pp
+    ]
+
+(* Conversion functions *)
+
+(* Rounding errors when there are more than 2^44 seconds, or about ~55 years.
+   *)
+let span_to_s span = Mtime.Span.to_float_ns span |> fun ns -> ns *. 1e-9
+
+let s_to_span s = Mtime.Span.of_float_ns (s *. 1e9)