From 2c5b0222412bd8d99adfaa9e3548317805b1b68b Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Jun 2024 16:57:13 +0100 Subject: [PATCH] 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 --- clock.opam | 3 +- dune-project | 3 +- ocaml/libs/clock/date.ml | 2 +- ocaml/libs/clock/dune | 13 +- ocaml/libs/clock/test_timer.ml | 233 ++++++++++++++++++++++++++++++++ ocaml/libs/clock/test_timer.mli | 0 ocaml/libs/clock/timer.ml | 63 +++++++++ ocaml/libs/clock/timer.mli | 65 +++++++++ 8 files changed, 374 insertions(+), 8 deletions(-) create mode 100644 ocaml/libs/clock/test_timer.ml create mode 100644 ocaml/libs/clock/test_timer.mli create mode 100644 ocaml/libs/clock/timer.ml create mode 100644 ocaml/libs/clock/timer.mli diff --git a/clock.opam b/clock.opam index d3f7290a9b6..44c24235c58 100644 --- a/clock.opam +++ b/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} ] diff --git a/dune-project b/dune-project index f3539471223..b26e27062df 100644 --- a/dune-project +++ b/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 ) ) diff --git a/ocaml/libs/clock/date.ml b/ocaml/libs/clock/date.ml index f916a2a99c7..d5efa2dfbf4 100644 --- a/ocaml/libs/clock/date.ml +++ b/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 = [| diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 416ec3f586f..cb4d710d41e 100644 --- a/ocaml/libs/clock/dune +++ b/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) ) diff --git a/ocaml/libs/clock/test_timer.ml b/ocaml/libs/clock/test_timer.ml new file mode 100644 index 00000000000..2d5e20d7d8a --- /dev/null +++ b/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)] diff --git a/ocaml/libs/clock/test_timer.mli b/ocaml/libs/clock/test_timer.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/ocaml/libs/clock/timer.ml b/ocaml/libs/clock/timer.ml new file mode 100644 index 00000000000..cadfa7688f1 --- /dev/null +++ b/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) diff --git a/ocaml/libs/clock/timer.mli b/ocaml/libs/clock/timer.mli new file mode 100644 index 00000000000..5f21d4692cd --- /dev/null +++ b/ocaml/libs/clock/timer.mli @@ -0,0 +1,65 @@ +(** This module is useful for knowing that a set amount of time has passed + since a particular moment in time. For example, to know when pasta is + cooked al dente. They are meant to be used by polling them. *) +type t + +type countdown = Remaining of Mtime.Span.t | Expired of Mtime.Span.t + +val start : duration:Mtime.Span.t -> t +(** [start ~duration] starts a timer that expires after [duration] has elapsed. + The elapsed time is counted in monotonic time, not in POSIX time. *) + +val duration : t -> Mtime.Span.t +(** [duration timer] returns the amount of time after which the timer expires, + from the moment it was started. *) + +val has_expired : t -> bool +(** [has_expired timer] returns whether [timer] has reached its duration. *) + +val elapsed : t -> Mtime.Span.t +(** [elapsed timer] returns the amount of time elapsed since [timer] was + started. *) + +val remaining : t -> countdown +(** [remaining timer] returns the amount of time left until [timer] expires or + the amount of time since it expired. *) + +val deadline_of : t -> float +(** [deadline_of timer] returns the posix timestamp when the timer expires. + This is an approximation as the timer doesn't take leap seconds into + account when waiting. The use of this function is discouraged and it's + only provided for backwards-compatible reasons. *) + +val shorten_by : Mtime.Span.t -> t -> t +(** [shorten_by amount timer] creates a new timer with the duration of [timer] + shortened by [amount]. The starting time doesn't change. The duration of a + timer cannot go below 0. When a timer has a duration of 0, it's always + considered expired. *) + +val extend_by : Mtime.Span.t -> t -> t +(** [extend_by amount timer] creates a new timer with the duration of [timer] + delayed by [amount]. The starting time doesn't change. *) + +val pp : t Fmt.t +(** [pp] pretty-prints the timer. It uses the system clock to calculate + the elapsed time every time the timer is printed. *) + +(** Mtime.Span helpers *) + +val span_is_shorter : Mtime.Span.t -> than:Mtime.Span.t -> bool +(** [is_shorter dur ~than] returns whether [dur] lasts less than [than]. *) + +val span_is_longer : Mtime.Span.t -> than:Mtime.Span.t -> bool +(** [is_longer dur ~than] returns whether [dur] lasts more than [than]. *) + +val span_to_s : Mtime.Span.t -> float +(** [span_to_s span] converts a time span into seconds, represented by a float. + When the span is longer than ~55 years, rounding errors appear. Avoid + whenever possible, this is unavoidable when using Thread.wait functions and + related. *) + +val s_to_span : float -> Mtime.Span.t option +(** [s_to_span seconds] converts a float representing seconds to a timespan. + Returns None when [seconds] is negative, is not a number or larger than + ~104 days. Avoid whenever possible, some RPC function already use this so + it needs to be available. *)