From 92c198d506408af6041e16b6db707734c42e2310 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Jun 2024 16:18:33 +0100 Subject: [PATCH 1/8] opam: record correct authorship for stdext packages Signed-off-by: Pau Ruiz Safont --- dune-project | 6 ++++++ xapi-stdext-date.opam | 2 +- xapi-stdext-encodings.opam | 2 +- xapi-stdext-pervasives.opam | 2 +- xapi-stdext-threads.opam | 2 +- xapi-stdext-unix.opam | 2 +- xapi-stdext-zerocheck.opam | 2 +- 7 files changed, 12 insertions(+), 6 deletions(-) diff --git a/dune-project b/dune-project index 87ebda7a964..77dca585ff3 100644 --- a/dune-project +++ b/dune-project @@ -451,6 +451,7 @@ This package provides an Lwt compatible interface to the library.") (package (name xapi-stdext-date) (synopsis "Xapi's standard library extension, Dates") + (authors "Jonathan Ludlam") (depends (ocaml (>= 4.12)) (alcotest :with-test) @@ -464,6 +465,7 @@ This package provides an Lwt compatible interface to the library.") (package (name xapi-stdext-encodings) (synopsis "Xapi's standard library extension, Encodings") + (authors "Jonathan Ludlam") (depends (ocaml (>= 4.13.0)) (alcotest (and (>= 0.6.0) :with-test)) @@ -477,6 +479,7 @@ This package provides an Lwt compatible interface to the library.") (package (name xapi-stdext-pervasives) (synopsis "Xapi's standard library extension, Pervasives") + (authors "Jonathan Ludlam") (depends (ocaml (>= 4.08)) logs @@ -498,6 +501,7 @@ This package provides an Lwt compatible interface to the library.") (package (name xapi-stdext-threads) (synopsis "Xapi's standard library extension, Threads") + (authors "Jonathan Ludlam") (depends ocaml base-threads @@ -510,6 +514,7 @@ This package provides an Lwt compatible interface to the library.") (package (name xapi-stdext-unix) (synopsis "Xapi's standard library extension, Unix") + (authors "Jonathan Ludlam") (depends (ocaml (>= 4.12.0)) base-unix @@ -524,6 +529,7 @@ This package provides an Lwt compatible interface to the library.") (package (name xapi-stdext-zerocheck) (synopsis "Xapi's standard library extension, Zerocheck") + (authors "Jonathan Ludlam") (depends ocaml (odoc :with-doc) diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index 10658f8b54e..2a8a207b897 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Xapi's standard library extension, Dates" maintainer: ["Xapi project maintainers"] -authors: ["xen-api@lists.xen.org"] +authors: ["Jonathan Ludlam"] 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" diff --git a/xapi-stdext-encodings.opam b/xapi-stdext-encodings.opam index 51ef29fe35f..c0f8c27c5e7 100644 --- a/xapi-stdext-encodings.opam +++ b/xapi-stdext-encodings.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Xapi's standard library extension, Encodings" maintainer: ["Xapi project maintainers"] -authors: ["xen-api@lists.xen.org"] +authors: ["Jonathan Ludlam"] 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" diff --git a/xapi-stdext-pervasives.opam b/xapi-stdext-pervasives.opam index 3dc2d169718..83f4f2da1da 100644 --- a/xapi-stdext-pervasives.opam +++ b/xapi-stdext-pervasives.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Xapi's standard library extension, Pervasives" maintainer: ["Xapi project maintainers"] -authors: ["xen-api@lists.xen.org"] +authors: ["Jonathan Ludlam"] 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" diff --git a/xapi-stdext-threads.opam b/xapi-stdext-threads.opam index 714a2e01575..de9699fe2e3 100644 --- a/xapi-stdext-threads.opam +++ b/xapi-stdext-threads.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Xapi's standard library extension, Threads" maintainer: ["Xapi project maintainers"] -authors: ["xen-api@lists.xen.org"] +authors: ["Jonathan Ludlam"] 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" diff --git a/xapi-stdext-unix.opam b/xapi-stdext-unix.opam index 8a7fc149f44..a20dfbb34e0 100644 --- a/xapi-stdext-unix.opam +++ b/xapi-stdext-unix.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Xapi's standard library extension, Unix" maintainer: ["Xapi project maintainers"] -authors: ["xen-api@lists.xen.org"] +authors: ["Jonathan Ludlam"] 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" diff --git a/xapi-stdext-zerocheck.opam b/xapi-stdext-zerocheck.opam index 8f070a416f3..fce24fb209d 100644 --- a/xapi-stdext-zerocheck.opam +++ b/xapi-stdext-zerocheck.opam @@ -2,7 +2,7 @@ opam-version: "2.0" synopsis: "Xapi's standard library extension, Zerocheck" maintainer: ["Xapi project maintainers"] -authors: ["xen-api@lists.xen.org"] +authors: ["Jonathan Ludlam"] 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" From 836e2d8080ef2f3497cfaace884f593afb14afbf Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Jun 2024 16:34:57 +0100 Subject: [PATCH 2/8] IH-628: add new package clock for timekeeping It currently duplicates the date module from stdext, dropping the deprecated bindings Signed-off-by: Pau Ruiz Safont --- clock.opam | 30 ++++++++ dune-project | 12 +++ ocaml/libs/clock/date.ml | 13 ++++ ocaml/libs/clock/date.mli | 76 +++++++++++++++++++ ocaml/libs/clock/dune | 18 +++++ ocaml/libs/clock/test_date.ml | 133 +++++++++++++++++++++++++++++++++ ocaml/libs/clock/test_date.mli | 0 quality-gate.sh | 2 +- 8 files changed, 283 insertions(+), 1 deletion(-) create mode 100644 clock.opam create mode 100644 ocaml/libs/clock/date.ml create mode 100644 ocaml/libs/clock/date.mli create mode 100644 ocaml/libs/clock/dune create mode 100644 ocaml/libs/clock/test_date.ml create mode 100644 ocaml/libs/clock/test_date.mli diff --git a/clock.opam b/clock.opam new file mode 100644 index 00000000000..e61bf665c7b --- /dev/null +++ b/clock.opam @@ -0,0 +1,30 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Xapi's library for managing time" +maintainer: ["Xapi project maintainers"] +authors: ["Jonathan Ludlam"] +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" +depends: [ + "dune" {>= "3.0"} + "alcotest" {with-test} + "ptime" {with-test} + "xapi-stdext-date" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/xapi-project/xen-api.git" diff --git a/dune-project b/dune-project index 77dca585ff3..3144b5d2e7b 100644 --- a/dune-project +++ b/dune-project @@ -15,6 +15,18 @@ (name zstd) ) + +(package + (name clock) + (synopsis "Xapi's library for managing time") + (authors "Jonathan Ludlam") + (depends + (alcotest :with-test) + (ptime :with-test) + xapi-stdext-date + ) +) + (package (name xapi-rrdd-plugin) ) diff --git a/ocaml/libs/clock/date.ml b/ocaml/libs/clock/date.ml new file mode 100644 index 00000000000..bda7ab8f237 --- /dev/null +++ b/ocaml/libs/clock/date.ml @@ -0,0 +1,13 @@ +(* Copyright (C) Cloud Software Group Inc. + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as published + by the Free Software Foundation; version 2.1 only. with the special + exception on linking described in file LICENSE. + + This program is distributed in the hope that it will be useful, + 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. + *) + +include Xapi_stdext_date.Date diff --git a/ocaml/libs/clock/date.mli b/ocaml/libs/clock/date.mli new file mode 100644 index 00000000000..2a0123813b3 --- /dev/null +++ b/ocaml/libs/clock/date.mli @@ -0,0 +1,76 @@ +(* + * Copyright (C) 2006-2009 Citrix Systems Inc. + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published + * by the Free Software Foundation; version 2.1 only. with the special + * exception on linking described in file LICENSE. + * + * This program is distributed in the hope that it will be useful, + * 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. + *) + +(** date-time with support for keeping timezone for ISO 8601 conversion *) +type t + +(** Conversions *) + +val of_ptime : Ptime.t -> t +(** Convert ptime to time in UTC *) + +val to_ptime : t -> Ptime.t +(** Convert date/time to a ptime value: the number of seconds since 00:00:00 + UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) + +val of_unix_time : float -> t +(** Convert calendar time [x] (as returned by e.g. Unix.time), to time in UTC *) + +val to_unix_time : t -> float +(** Convert date/time to a unix timestamp: the number of seconds since + 00:00:00 UTC, 1 Jan 1970. Assumes the underlying {!t} is in UTC *) + +val to_rfc822 : t -> string +(** Convert date/time to email-formatted (RFC 822) string. *) + +val to_rfc3339 : t -> string +(** Convert date/time to an RFC-3339-formatted string. It also complies with + the ISO 8601 format *) + +val of_iso8601 : string -> t +(** Convert ISO 8601 formatted string to a date/time value. Does not accept a + timezone annotated datetime - i.e. string must be UTC, and end with a Z *) + +val epoch : t +(** 00:00:00 UTC, 1 Jan 1970, in UTC *) + +val now : unit -> t +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in UTC *) + +val _localtime_string : Ptime.tz_offset_s option -> Ptime.t -> string +(** exposed for testing *) + +val localtime : unit -> t +(** Count the number of seconds passed since 00:00:00 UTC, 1 Jan 1970, in local + time *) + +(** Comparisons *) + +val eq : t -> t -> bool +(** [eq a b] returns whether [a] and [b] are equal *) + +val compare : t -> t -> int +(** [compare a b] returns -1 if [a] is earlier than [b], 1 if [a] is later than + [b] or the ordering of the timezone printer *) + +val is_earlier : than:t -> t -> bool +(** [is_earlier ~than a] returns whether the timestamp [a] happens before + [than] *) + +val is_later : than:t -> t -> bool +(** [is_later ~than a] returns whether the timestamp [a] happens after [than] + *) + +val diff : t -> t -> Ptime.Span.t +(** [diff a b] returns the span of time corresponding to [a - b] *) diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune new file mode 100644 index 00000000000..3468d54a5c5 --- /dev/null +++ b/ocaml/libs/clock/dune @@ -0,0 +1,18 @@ +(library + (name clock) + (public_name clock) + (modules date) + (libraries + astring + ptime + ptime.clock.os + xapi-stdext-date + ) +) + +(test + (name test_date) + (package clock) + (modules test_date) + (libraries alcotest clock ptime) +) diff --git a/ocaml/libs/clock/test_date.ml b/ocaml/libs/clock/test_date.ml new file mode 100644 index 00000000000..97e7bba9798 --- /dev/null +++ b/ocaml/libs/clock/test_date.ml @@ -0,0 +1,133 @@ +open Clock.Date + +let check_float = Alcotest.(check @@ float 1e-2) + +let check_string = Alcotest.(check string) + +let check_true str = Alcotest.(check bool) str true + +let dash_time_str = "2020-04-07T08:28:32Z" + +let no_dash_utc_time_str = "20200407T08:28:32Z" + +let tests = + let test_of_unix_time_invertible () = + let non_int_time = 1586245987.70200706 in + let time = non_int_time |> Float.floor in + check_float "to_unix_time inverts of_unix_time" time + (time |> of_unix_time |> to_unix_time) ; + check_true "of_unix_time inverts to_unix_time" + @@ eq (time |> of_unix_time) + (time |> of_unix_time |> to_unix_time |> of_unix_time) + in + let test_only_utc () = + let utc = "2020-12-20T18:10:19Z" in + let _ = of_iso8601 utc in + (* UTC is valid *) + let non_utc = "2020-12-20T18:10:19+02:00" in + let exn = + Invalid_argument + "Xapi_stdext_date__Date.of_iso8601: 2020-12-20T18:10:19+02:00" + in + Alcotest.check_raises "only UTC is accepted" exn (fun () -> + of_iso8601 non_utc |> ignore + ) + in + let test_ca333908 () = + check_float "dash time and no dash time represent the same unix timestamp" + (dash_time_str |> of_iso8601 |> to_unix_time) + (no_dash_utc_time_str |> of_iso8601 |> to_unix_time) + in + let test_of_iso8601_invertible_when_no_dashes () = + check_string "to_rfc3339 inverts of_iso8601" no_dash_utc_time_str + (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339) ; + check_true "of_iso8601 inverts to_rfc3339" + (eq + (no_dash_utc_time_str |> of_iso8601) + (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339 |> of_iso8601) + ) + in + (* CA-338243 - breaking backwards compatibility will break XC and XRT *) + let test_to_rfc3339_backwards_compatibility () = + check_string "to_rfc3339 is backwards compatible" no_dash_utc_time_str + (dash_time_str |> of_iso8601 |> to_rfc3339) + in + let test_localtime_string () = + let[@warning "-8"] (Ok (t, _, _)) = + Ptime.of_rfc3339 "2020-04-07T09:01:28Z" + in + let minus_2_hrs = -7200 in + let plus_3_hrs = 10800 in + let zero_hrs = 0 in + check_string "can subtract 2 hours" + (_localtime_string (Some minus_2_hrs) t) + "20200407T07:01:28" ; + check_string "can add 3 hours" + (_localtime_string (Some plus_3_hrs) t) + "20200407T12:01:28" ; + check_string "can add None" (_localtime_string None t) "20200407T09:01:28" ; + check_string "can add zero" + (_localtime_string (Some zero_hrs) t) + "20200407T09:01:28" + in + (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) + let test_ca342171 () = + (* no exception is thrown + backward compatible formatting *) + let localtime_string = localtime () |> to_rfc3339 in + Alcotest.(check int) + "localtime string has correct number of chars" + (String.length localtime_string) + (String.length no_dash_utc_time_str - 1) ; + Alcotest.(check bool) + "localtime string does not contain a Z" false + (String.contains localtime_string 'Z') + in + let test_xsi894 () = + let missing_tz_no_dash = "20201210T17:19:20" in + let missing_tz_dash = "2020-12-10T17:19:20" in + check_string "can process missing tz no dash" missing_tz_no_dash + (missing_tz_no_dash |> of_iso8601 |> to_rfc3339) ; + check_string "can process missing tz with dashes, but return without dashes" + missing_tz_no_dash + (missing_tz_dash |> of_iso8601 |> to_rfc3339) ; + check_float "to_unix_time assumes UTC" 1607620760. + (missing_tz_no_dash |> of_iso8601 |> to_unix_time) ; + let localtime' = localtime () in + check_string "to_rfc3339 inverts of_iso8601 for localtime" + (localtime' |> to_rfc3339) + (localtime' |> to_rfc3339 |> of_iso8601 |> to_rfc3339) + in + let test_email_date (unix_timestamp, expected) = + let formatted = of_unix_time unix_timestamp |> to_rfc822 in + check_string "String is properly RFC-822-formatted" expected formatted + in + let test_email_dates () = + let dates = + [ + (-1221847200., "Tue, 14 Apr 1931 06:00:00 GMT") + ; (0., "Thu, 1 Jan 1970 00:00:00 GMT") + ; (626637180., "Thu, 9 Nov 1989 17:53:00 GMT") + ; (2889734400., "Thu, 28 Jul 2061 00:00:00 GMT") + ] + in + List.iter test_email_date dates + in + [ + ("test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible) + ; ("test_only_utc", `Quick, test_only_utc) + ; ("test_ca333908", `Quick, test_ca333908) + ; ( "test_of_iso8601_invertible_when_no_dashes" + , `Quick + , test_of_iso8601_invertible_when_no_dashes + ) + ; ( "test_to_rfc3339_backwards_compatibility" + , `Quick + , test_to_rfc3339_backwards_compatibility + ) + ; ("test_localtime_string", `Quick, test_localtime_string) + ; ("test_ca342171", `Quick, test_ca342171) + ; ("test_xsi894", `Quick, test_xsi894) + ; ("RFC 822 formatting", `Quick, test_email_dates) + ] + +let () = Alcotest.run "Date" [("Conversions", tests)] diff --git a/ocaml/libs/clock/test_date.mli b/ocaml/libs/clock/test_date.mli new file mode 100644 index 00000000000..e69de29bb2d diff --git a/quality-gate.sh b/quality-gate.sh index b504ed69d1b..7bc8f35cf0a 100755 --- a/quality-gate.sh +++ b/quality-gate.sh @@ -25,7 +25,7 @@ verify-cert () { } mli-files () { - N=515 + N=514 # do not count ml files from the tests in ocaml/{tests/perftest/quicktest} MLIS=$(git ls-files -- '**/*.mli' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) MLS=$(git ls-files -- '**/*.ml' | grep -vE "ocaml/tests|ocaml/perftest|ocaml/quicktest|ocaml/message-switch/core_test" | xargs -I {} sh -c "echo {} | cut -f 1 -d '.'" \;) From 9c8011b361afacc2a6dcf6cdd196a02b8288d27c Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Jun 2024 16:44:05 +0100 Subject: [PATCH 3/8] xapi-stdext-date: move implementation to clock package Signed-off-by: Pau Ruiz Safont --- clock.opam | 5 +- dune-project | 11 +- ocaml/libs/clock/date.ml | 158 +++++++++++++++++- ocaml/libs/clock/dune | 3 +- ocaml/libs/clock/test_date.ml | 3 +- .../xapi-stdext/lib/xapi-stdext-date/date.ml | 158 +----------------- .../xapi-stdext/lib/xapi-stdext-date/dune | 14 +- .../xapi-stdext/lib/xapi-stdext-date/test.ml | 133 --------------- xapi-stdext-date.opam | 5 +- 9 files changed, 170 insertions(+), 320 deletions(-) delete mode 100644 ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml diff --git a/clock.opam b/clock.opam index e61bf665c7b..d3f7290a9b6 100644 --- a/clock.opam +++ b/clock.opam @@ -8,9 +8,10 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.0"} + "ocaml" {>= "4.12"} "alcotest" {with-test} - "ptime" {with-test} - "xapi-stdext-date" + "astring" + "ptime" "odoc" {with-doc} ] build: [ diff --git a/dune-project b/dune-project index 3144b5d2e7b..8dc8d2c2665 100644 --- a/dune-project +++ b/dune-project @@ -21,9 +21,10 @@ (synopsis "Xapi's library for managing time") (authors "Jonathan Ludlam") (depends + (ocaml (>= 4.12)) (alcotest :with-test) - (ptime :with-test) - xapi-stdext-date + astring + ptime ) ) @@ -465,12 +466,8 @@ This package provides an Lwt compatible interface to the library.") (synopsis "Xapi's standard library extension, Dates") (authors "Jonathan Ludlam") (depends - (ocaml (>= 4.12)) - (alcotest :with-test) - astring - base-unix + (clock (= :version)) ptime - (odoc :with-doc) ) ) diff --git a/ocaml/libs/clock/date.ml b/ocaml/libs/clock/date.ml index bda7ab8f237..f916a2a99c7 100644 --- a/ocaml/libs/clock/date.ml +++ b/ocaml/libs/clock/date.ml @@ -10,4 +10,160 @@ GNU Lesser General Public License for more details. *) -include Xapi_stdext_date.Date +let months = + [| + "Jan" + ; "Feb" + ; "Mar" + ; "Apr" + ; "May" + ; "Jun" + ; "Jul" + ; "Aug" + ; "Sep" + ; "Oct" + ; "Nov" + ; "Dec" + |] + +let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] + +type print_timezone = Empty | TZ of string + +(* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) +type t = Ptime.date * Ptime.time * print_timezone + +let utc = TZ "Z" + +let of_dt print_type dt = + let date, time = dt in + (date, time, print_type) + +let to_dt (date, time, _) = (date, time) + +let best_effort_iso8601_to_rfc3339 x = + (* (a) add dashes + * (b) add UTC tz if no tz provided *) + let x = + try + Scanf.sscanf x "%04d%02d%02dT%s" (fun y mon d rest -> + Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest + ) + with _ -> x + in + let tz = + try + Scanf.sscanf x "%04d-%02d-%02dT%02d:%02d:%02d%s" (fun _ _ _ _ _ _ tz -> + Some tz + ) + with _ -> None + in + match tz with + | None | Some "" -> + (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) + (Printf.sprintf "%sZ" x, Empty) + | Some tz -> + (x, TZ tz) + +let of_iso8601 x = + let rfc3339, print_timezone = best_effort_iso8601_to_rfc3339 x in + match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with + | Error _ -> + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) + | Ok (t, tz, _) -> ( + match tz with + | None | Some 0 -> + Ptime.to_date_time t |> of_dt print_timezone + | Some _ -> + invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) + ) + +let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = + match print_type with + | TZ tz -> + Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz + | Empty -> + Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s + +let weekday ~year ~mon ~day = + let a = (14 - mon) / 12 in + let y = year - a in + let m = mon + (12 * a) - 2 in + (day + y + (y / 4) - (y / 100) + (y / 400) + (31 * m / 12)) mod 7 + +let to_rfc822 ((year, mon, day), ((h, min, s), _), print_type) = + let timezone = + match print_type with Empty | TZ "Z" -> "GMT" | TZ tz -> tz + in + let weekday = weekday ~year ~mon ~day in + Printf.sprintf "%s, %d %s %d %02d:%02d:%02d %s" days.(weekday) day + months.(mon - 1) + year h min s timezone + +let to_ptime_t t = + match to_dt t |> Ptime.of_date_time with + | Some t -> + t + | None -> + let _, (_, offset), _ = t in + invalid_arg + (Printf.sprintf "%s: dt='%s', offset='%i' is invalid" __FUNCTION__ + (to_rfc3339 t) offset + ) + +let to_ptime = to_ptime_t + +let of_ptime t = Ptime.to_date_time t |> of_dt utc + +let of_unix_time s = + match Ptime.of_float_s s with + | None -> + invalid_arg (Printf.sprintf "%s: %f" __FUNCTION__ s) + | Some t -> + of_ptime t + +let to_unix_time t = to_ptime_t t |> Ptime.to_float_s + +let _localtime current_tz_offset t = + let tz_offset_s = current_tz_offset |> Option.value ~default:0 in + let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt Empty in + let _, (_, localtime_offset), _ = localtime in + if localtime_offset <> tz_offset_s then + invalid_arg + (Printf.sprintf "%s: offsets don't match. offset='%i', t='%s'" + __FUNCTION__ tz_offset_s (Ptime.to_rfc3339 t) + ) ; + localtime + +let _localtime_string current_tz_offset t = + _localtime current_tz_offset t |> to_rfc3339 + +let localtime () = + _localtime (Ptime_clock.current_tz_offset_s ()) (Ptime_clock.now ()) + +let now () = of_ptime (Ptime_clock.now ()) + +let epoch = of_ptime Ptime.epoch + +let is_earlier ~than t = Ptime.is_earlier ~than:(to_ptime than) (to_ptime t) + +let is_later ~than t = Ptime.is_later ~than:(to_ptime than) (to_ptime t) + +let diff a b = Ptime.diff (to_ptime a) (to_ptime b) + +let compare_print_tz a b = + match (a, b) with + | Empty, Empty -> + 0 + | TZ a_s, TZ b_s -> + String.compare a_s b_s + | Empty, TZ _ -> + -1 + | TZ _, Empty -> + 1 + +let compare ((_, _, a_z) as a) ((_, _, b_z) as b) = + let ( ) a b = if a = 0 then b else a in + Ptime.compare (to_ptime a) (to_ptime b) compare_print_tz a_z b_z + +let eq x y = compare x y = 0 diff --git a/ocaml/libs/clock/dune b/ocaml/libs/clock/dune index 3468d54a5c5..55bcbb0f3e6 100644 --- a/ocaml/libs/clock/dune +++ b/ocaml/libs/clock/dune @@ -4,9 +4,8 @@ (modules date) (libraries astring - ptime + (re_export ptime) ptime.clock.os - xapi-stdext-date ) ) diff --git a/ocaml/libs/clock/test_date.ml b/ocaml/libs/clock/test_date.ml index 97e7bba9798..78f673f635c 100644 --- a/ocaml/libs/clock/test_date.ml +++ b/ocaml/libs/clock/test_date.ml @@ -26,8 +26,7 @@ let tests = (* UTC is valid *) let non_utc = "2020-12-20T18:10:19+02:00" in let exn = - Invalid_argument - "Xapi_stdext_date__Date.of_iso8601: 2020-12-20T18:10:19+02:00" + Invalid_argument "Clock__Date.of_iso8601: 2020-12-20T18:10:19+02:00" in Alcotest.check_raises "only UTC is accepted" exn (fun () -> of_iso8601 non_utc |> ignore diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml index 77f3994fe68..45e9bba5efb 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/date.ml @@ -12,163 +12,7 @@ * GNU Lesser General Public License for more details. *) -let months = - [| - "Jan" - ; "Feb" - ; "Mar" - ; "Apr" - ; "May" - ; "Jun" - ; "Jul" - ; "Aug" - ; "Sep" - ; "Oct" - ; "Nov" - ; "Dec" - |] - -let days = [|"Sun"; "Mon"; "Tue"; "Wed"; "Thu"; "Fri"; "Sat"|] - -type print_timezone = Empty | TZ of string - -(* we must store the print_type with iso8601 to handle the case where the local time zone is UTC *) -type t = Ptime.date * Ptime.time * print_timezone - -let utc = TZ "Z" - -let of_dt print_type dt = - let date, time = dt in - (date, time, print_type) - -let to_dt (date, time, _) = (date, time) - -let best_effort_iso8601_to_rfc3339 x = - (* (a) add dashes - * (b) add UTC tz if no tz provided *) - let x = - try - Scanf.sscanf x "%04d%02d%02dT%s" (fun y mon d rest -> - Printf.sprintf "%04d-%02d-%02dT%s" y mon d rest - ) - with _ -> x - in - let tz = - try - Scanf.sscanf x "%04d-%02d-%02dT%02d:%02d:%02d%s" (fun _ _ _ _ _ _ tz -> - Some tz - ) - with _ -> None - in - match tz with - | None | Some "" -> - (* the caller didn't specify a tz. we must try to add one so that ptime can at least attempt to parse *) - (Printf.sprintf "%sZ" x, Empty) - | Some tz -> - (x, TZ tz) - -let of_iso8601 x = - let rfc3339, print_timezone = best_effort_iso8601_to_rfc3339 x in - match Ptime.of_rfc3339 rfc3339 |> Ptime.rfc3339_error_to_msg with - | Error _ -> - invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) - | Ok (t, tz, _) -> ( - match tz with - | None | Some 0 -> - Ptime.to_date_time t |> of_dt print_timezone - | Some _ -> - invalid_arg (Printf.sprintf "%s: %s" __FUNCTION__ x) - ) - -let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = - match print_type with - | TZ tz -> - Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i%s" y mon d h min s tz - | Empty -> - Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s - -let weekday ~year ~mon ~day = - let a = (14 - mon) / 12 in - let y = year - a in - let m = mon + (12 * a) - 2 in - (day + y + (y / 4) - (y / 100) + (y / 400) + (31 * m / 12)) mod 7 - -let to_rfc822 ((year, mon, day), ((h, min, s), _), print_type) = - let timezone = - match print_type with Empty | TZ "Z" -> "GMT" | TZ tz -> tz - in - let weekday = weekday ~year ~mon ~day in - Printf.sprintf "%s, %d %s %d %02d:%02d:%02d %s" days.(weekday) day - months.(mon - 1) - year h min s timezone - -let to_ptime_t t = - match to_dt t |> Ptime.of_date_time with - | Some t -> - t - | None -> - let _, (_, offset), _ = t in - invalid_arg - (Printf.sprintf "%s: dt='%s', offset='%i' is invalid" __FUNCTION__ - (to_rfc3339 t) offset - ) - -let to_ptime = to_ptime_t - -let of_ptime t = Ptime.to_date_time t |> of_dt utc - -let of_unix_time s = - match Ptime.of_float_s s with - | None -> - invalid_arg (Printf.sprintf "%s: %f" __FUNCTION__ s) - | Some t -> - of_ptime t - -let to_unix_time t = to_ptime_t t |> Ptime.to_float_s - -let _localtime current_tz_offset t = - let tz_offset_s = current_tz_offset |> Option.value ~default:0 in - let localtime = t |> Ptime.to_date_time ~tz_offset_s |> of_dt Empty in - let _, (_, localtime_offset), _ = localtime in - if localtime_offset <> tz_offset_s then - invalid_arg - (Printf.sprintf "%s: offsets don't match. offset='%i', t='%s'" - __FUNCTION__ tz_offset_s (Ptime.to_rfc3339 t) - ) ; - localtime - -let _localtime_string current_tz_offset t = - _localtime current_tz_offset t |> to_rfc3339 - -let localtime () = - _localtime (Ptime_clock.current_tz_offset_s ()) (Ptime_clock.now ()) - -let now () = of_ptime (Ptime_clock.now ()) - -let epoch = of_ptime Ptime.epoch - -let is_earlier ~than t = Ptime.is_earlier ~than:(to_ptime than) (to_ptime t) - -let is_later ~than t = Ptime.is_later ~than:(to_ptime than) (to_ptime t) - -let diff a b = Ptime.diff (to_ptime a) (to_ptime b) - -let compare_print_tz a b = - match (a, b) with - | Empty, Empty -> - 0 - | TZ a_s, TZ b_s -> - String.compare a_s b_s - | Empty, TZ _ -> - -1 - | TZ _, Empty -> - 1 - -let compare ((_, _, a_z) as a) ((_, _, b_z) as b) = - let ( ) a b = if a = 0 then b else a in - Ptime.compare (to_ptime a) (to_ptime b) compare_print_tz a_z b_z - -let eq x y = compare x y = 0 +include Clock.Date let never = epoch diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune index c2ed6c448da..8566d86e12c 100644 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune +++ b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/dune @@ -1,16 +1,6 @@ (library (name xapi_stdext_date) (public_name xapi-stdext-date) - (modules :standard \ test) - (libraries astring - ptime - ptime.clock.os - unix) -) - -(test - (name test) - (package xapi-stdext-date) - (modules test) - (libraries alcotest xapi-stdext-date ptime) + (modules :standard) + (libraries clock ptime) ) diff --git a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml b/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml deleted file mode 100644 index c839722d81f..00000000000 --- a/ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml +++ /dev/null @@ -1,133 +0,0 @@ -open Xapi_stdext_date.Date - -let check_float = Alcotest.(check @@ float 1e-2) - -let check_string = Alcotest.(check string) - -let check_true str = Alcotest.(check bool) str true - -let dash_time_str = "2020-04-07T08:28:32Z" - -let no_dash_utc_time_str = "20200407T08:28:32Z" - -let tests = - let test_of_unix_time_invertible () = - let non_int_time = 1586245987.70200706 in - let time = non_int_time |> Float.floor in - check_float "to_unix_time inverts of_unix_time" time - (time |> of_unix_time |> to_unix_time) ; - check_true "of_unix_time inverts to_unix_time" - @@ eq (time |> of_unix_time) - (time |> of_unix_time |> to_unix_time |> of_unix_time) - in - let test_only_utc () = - let utc = "2020-12-20T18:10:19Z" in - let _ = of_iso8601 utc in - (* UTC is valid *) - let non_utc = "2020-12-20T18:10:19+02:00" in - let exn = - Invalid_argument - "Xapi_stdext_date__Date.of_iso8601: 2020-12-20T18:10:19+02:00" - in - Alcotest.check_raises "only UTC is accepted" exn (fun () -> - of_iso8601 non_utc |> ignore - ) - in - let test_ca333908 () = - check_float "dash time and no dash time represent the same unix timestamp" - (dash_time_str |> of_iso8601 |> to_unix_time) - (no_dash_utc_time_str |> of_iso8601 |> to_unix_time) - in - let test_of_iso8601_invertible_when_no_dashes () = - check_string "to_rfc3339 inverts of_iso8601" no_dash_utc_time_str - (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339) ; - check_true "of_iso8601 inverts to_rfc3339" - (eq - (no_dash_utc_time_str |> of_iso8601) - (no_dash_utc_time_str |> of_iso8601 |> to_rfc3339 |> of_iso8601) - ) - in - (* CA-338243 - breaking backwards compatibility will break XC and XRT *) - let test_to_rfc3339_backwards_compatibility () = - check_string "to_rfc3339 is backwards compatible" no_dash_utc_time_str - (dash_time_str |> of_iso8601 |> to_rfc3339) - in - let test_localtime_string () = - let[@warning "-8"] (Ok (t, _, _)) = - Ptime.of_rfc3339 "2020-04-07T09:01:28Z" - in - let minus_2_hrs = -7200 in - let plus_3_hrs = 10800 in - let zero_hrs = 0 in - check_string "can subtract 2 hours" - (_localtime_string (Some minus_2_hrs) t) - "20200407T07:01:28" ; - check_string "can add 3 hours" - (_localtime_string (Some plus_3_hrs) t) - "20200407T12:01:28" ; - check_string "can add None" (_localtime_string None t) "20200407T09:01:28" ; - check_string "can add zero" - (_localtime_string (Some zero_hrs) t) - "20200407T09:01:28" - in - (* sanity check (on top of test_localtime_string) that localtime produces valid looking output *) - let test_ca342171 () = - (* no exception is thrown + backward compatible formatting *) - let localtime_string = localtime () |> to_rfc3339 in - Alcotest.(check int) - "localtime string has correct number of chars" - (String.length localtime_string) - (String.length no_dash_utc_time_str - 1) ; - Alcotest.(check bool) - "localtime string does not contain a Z" false - (String.contains localtime_string 'Z') - in - let test_xsi894 () = - let missing_tz_no_dash = "20201210T17:19:20" in - let missing_tz_dash = "2020-12-10T17:19:20" in - check_string "can process missing tz no dash" missing_tz_no_dash - (missing_tz_no_dash |> of_iso8601 |> to_rfc3339) ; - check_string "can process missing tz with dashes, but return without dashes" - missing_tz_no_dash - (missing_tz_dash |> of_iso8601 |> to_rfc3339) ; - check_float "to_unix_time assumes UTC" 1607620760. - (missing_tz_no_dash |> of_iso8601 |> to_unix_time) ; - let localtime' = localtime () in - check_string "to_rfc3339 inverts of_iso8601 for localtime" - (localtime' |> to_rfc3339) - (localtime' |> to_rfc3339 |> of_iso8601 |> to_rfc3339) - in - let test_email_date (unix_timestamp, expected) = - let formatted = of_unix_time unix_timestamp |> to_rfc822 in - check_string "String is properly RFC-822-formatted" expected formatted - in - let test_email_dates () = - let dates = - [ - (-1221847200., "Tue, 14 Apr 1931 06:00:00 GMT") - ; (0., "Thu, 1 Jan 1970 00:00:00 GMT") - ; (626637180., "Thu, 9 Nov 1989 17:53:00 GMT") - ; (2889734400., "Thu, 28 Jul 2061 00:00:00 GMT") - ] - in - List.iter test_email_date dates - in - [ - ("test_of_unix_time_invertible", `Quick, test_of_unix_time_invertible) - ; ("test_only_utc", `Quick, test_only_utc) - ; ("test_ca333908", `Quick, test_ca333908) - ; ( "test_of_iso8601_invertible_when_no_dashes" - , `Quick - , test_of_iso8601_invertible_when_no_dashes - ) - ; ( "test_to_rfc3339_backwards_compatibility" - , `Quick - , test_to_rfc3339_backwards_compatibility - ) - ; ("test_localtime_string", `Quick, test_localtime_string) - ; ("test_ca342171", `Quick, test_ca342171) - ; ("test_xsi894", `Quick, test_xsi894) - ; ("RFC 822 formatting", `Quick, test_email_dates) - ] - -let () = Alcotest.run "Date" [("Conversions", tests)] diff --git a/xapi-stdext-date.opam b/xapi-stdext-date.opam index 2a8a207b897..ee8aa096ab2 100644 --- a/xapi-stdext-date.opam +++ b/xapi-stdext-date.opam @@ -8,10 +8,7 @@ homepage: "https://xapi-project.github.io/" bug-reports: "https://github.com/xapi-project/xen-api/issues" depends: [ "dune" {>= "3.0"} - "ocaml" {>= "4.12"} - "alcotest" {with-test} - "astring" - "base-unix" + "clock" {= version} "ptime" "odoc" {with-doc} ] From 3341cc176b7755fe0c644d8980afffa198bc7c59 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Fri, 21 Jun 2024 16:57:13 +0100 Subject: [PATCH 4/8] 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 8dc8d2c2665..3240d722d69 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 55bcbb0f3e6..009e2ba7176 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 + (re_export mtime) + mtime.clock.os (re_export 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..3cf6c7c2027 --- /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 |> Float.round) 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. *) From 01745954a7f29e74e75f1cfb9f1672e47514eecb Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 24 Jun 2024 11:45:22 +0100 Subject: [PATCH 5/8] IH-628: remove deadlines from timers These could help with the porting of the redo_log code, but Edwin's has working code that changes the API of the timed calls to use durations instead of deadlines. Signed-off-by: Pau Ruiz Safont --- ocaml/libs/clock/timer.ml | 13 ++----------- ocaml/libs/clock/timer.mli | 6 ------ 2 files changed, 2 insertions(+), 17 deletions(-) diff --git a/ocaml/libs/clock/timer.ml b/ocaml/libs/clock/timer.ml index 3cf6c7c2027..b4ef6dadaf9 100644 --- a/ocaml/libs/clock/timer.ml +++ b/ocaml/libs/clock/timer.ml @@ -1,4 +1,4 @@ -type t = {start: Ptime.t; elapsed: Mtime_clock.counter; duration: Mtime.Span.t} +type t = {elapsed: Mtime_clock.counter; duration: Mtime.Span.t} type countdown = Remaining of Mtime.Span.t | Expired of Mtime.Span.t @@ -6,8 +6,7 @@ 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 start ~duration = {elapsed= Mtime_clock.counter (); duration} let duration {duration; _} = duration @@ -25,14 +24,6 @@ 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 diff --git a/ocaml/libs/clock/timer.mli b/ocaml/libs/clock/timer.mli index 5f21d4692cd..8a60bb89382 100644 --- a/ocaml/libs/clock/timer.mli +++ b/ocaml/libs/clock/timer.mli @@ -24,12 +24,6 @@ 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 From e06ce37513c10f9ce3c132c41a171d52bb74695f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Mon, 7 Aug 2023 10:11:06 +0100 Subject: [PATCH 6/8] log: add pretty printer module Because the debug module doesn't use best practices, pretty-printers using the Format module are not ergonomic to use when they are needed for constructing loglines. Provide a module for adapters, containing Mtime's spans for the time being. Signed-off-by: Pau Ruiz Safont --- ocaml/libs/log/debug.ml | 2 ++ ocaml/libs/log/debug.mli | 4 ++++ ocaml/libs/log/dune | 2 ++ ocaml/xapi-guard/lib/disk_cache.ml | 4 ++-- 4 files changed, 10 insertions(+), 2 deletions(-) diff --git a/ocaml/libs/log/debug.ml b/ocaml/libs/log/debug.ml index b4a5721b9e3..a38051a3cfb 100644 --- a/ocaml/libs/log/debug.ml +++ b/ocaml/libs/log/debug.ml @@ -352,3 +352,5 @@ functor try f () with e -> log_backtrace_internal ~level:Syslog.Debug ~msg:"debug" e () end + +module Pp = struct let mtime_span () = Fmt.str "%a" Mtime.Span.pp end diff --git a/ocaml/libs/log/debug.mli b/ocaml/libs/log/debug.mli index af1b214b2fe..f6301c3d587 100644 --- a/ocaml/libs/log/debug.mli +++ b/ocaml/libs/log/debug.mli @@ -88,3 +88,7 @@ module Make : functor (_ : BRAND) -> DEBUG val is_disabled : string -> Syslog.level -> bool (** [is_disabled brand level] returns [true] if logging for [brand] at [level] is disabled, * otherwise returns [false]. *) + +module Pp : sig + val mtime_span : unit -> Mtime.Span.t -> string +end diff --git a/ocaml/libs/log/dune b/ocaml/libs/log/dune index b8b637e7bf5..fdfd739d082 100644 --- a/ocaml/libs/log/dune +++ b/ocaml/libs/log/dune @@ -6,6 +6,8 @@ (names syslog_stubs)) (libraries astring + fmt + mtime logs threads.posix xapi-backtrace diff --git a/ocaml/xapi-guard/lib/disk_cache.ml b/ocaml/xapi-guard/lib/disk_cache.ml index 5e8b9bb0650..9674a4ff01b 100644 --- a/ocaml/xapi-guard/lib/disk_cache.ml +++ b/ocaml/xapi-guard/lib/disk_cache.ml @@ -398,9 +398,9 @@ end = struct let* failed = retry true in ( if failed then let elapsed = Mtime_clock.count counter in - D.debug "%s: Pushed %s after trying for %s" __FUN + D.debug "%s: Pushed %s after trying for %a" __FUN (print_key (uuid, timestamp, key)) - (Fmt.to_to_string Mtime.Span.pp elapsed) + Debug.Pp.mtime_span elapsed ) ; Lwt.return_unit From c1bcd7429a059ab73c5bcd12e40cfd4d662b2c70 Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 26 Jun 2024 11:12:59 +0100 Subject: [PATCH 7/8] xapi_globs: add duration type for arguments This allows to define in the code the exact amount of time, including the measure of time used as base. This is usually minutes. On top of that it allows for two type of configuration parameters: one that retains backwards compatibility, using seconds as floats. They can be used to define relatively short amounts of time (less that 104 days). For longer amounts of time, seconds can be encoded as integers. When printing the configuration, both the literal value used to configure the global and the amount using time units is shown. Signed-off-by: Pau Ruiz Safont --- ocaml/xapi/xapi_globs.ml | 37 +++++++++++++++++++++++++++++++++++-- 1 file changed, 35 insertions(+), 2 deletions(-) diff --git a/ocaml/xapi/xapi_globs.ml b/ocaml/xapi/xapi_globs.ml index c31ed490a0d..c8bf2adaa8b 100644 --- a/ocaml/xapi/xapi_globs.ml +++ b/ocaml/xapi/xapi_globs.ml @@ -951,7 +951,12 @@ let ignore_vtpm_unimplemented = ref false let evacuation_batch_size = ref 10 -type xapi_globs_spec_ty = Float of float ref | Int of int ref +type xapi_globs_spec = + | Float of float ref + | Int of int ref + | ShortDurationFromSeconds of Mtime.Span.t ref + (** From float, max of 104 days *) + | LongDurationFromSeconds of Mtime.Span.t ref (** From int *) let extauth_ad_backend = ref "winbind" @@ -1120,13 +1125,41 @@ let options_of_xapi_globs_spec = List.map (fun (name, ty) -> ( name - , (match ty with Float x -> Arg.Set_float x | Int x -> Arg.Set_int x) + , ( match ty with + | Float x -> + Arg.Set_float x + | Int x -> + Arg.Set_int x + | ShortDurationFromSeconds x -> + Arg.Float + (fun y -> + match Clock.Timer.s_to_span y with + | Some y -> + x := y + | None -> + D.warn + "Ignoring argument '%s', invalid float being used: %f. \ + (it only allows durations of less than 104 days)" + name y + ) + | LongDurationFromSeconds x -> + Arg.Int (fun y -> x := Mtime.Span.(y * s)) + ) , (fun () -> match ty with | Float x -> string_of_float !x | Int x -> string_of_int !x + | ShortDurationFromSeconds x -> + let literal = + Mtime.Span.to_uint64_ns !x |> fun ns -> + Int64.div ns 1_000_000_000L |> Int64.to_int |> string_of_int + in + Fmt.str "%s (%a)" literal Mtime.Span.pp !x + | LongDurationFromSeconds x -> + let literal = Clock.Timer.span_to_s !x |> string_of_float in + Fmt.str "%s (%a)" literal Mtime.Span.pp !x ) , Printf.sprintf "Set the value of '%s'" name ) From d75ded9087b259c0962075cfc42fd2f5dd66e00f Mon Sep 17 00:00:00 2001 From: Pau Ruiz Safont Date: Wed, 26 Jun 2024 17:04:58 +0100 Subject: [PATCH 8/8] clock/date: Note procedence of the weekday algorithm Signed-off-by: Pau Ruiz Safont --- ocaml/libs/clock/date.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/ocaml/libs/clock/date.ml b/ocaml/libs/clock/date.ml index d5efa2dfbf4..a4a43cde623 100644 --- a/ocaml/libs/clock/date.ml +++ b/ocaml/libs/clock/date.ml @@ -85,6 +85,7 @@ let to_rfc3339 ((y, mon, d), ((h, min, s), _), print_type) = | Empty -> Printf.sprintf "%04i%02i%02iT%02i:%02i:%02i" y mon d h min s +(* Extracted from tondering.dk/claus/cal/chrweek.php#calcdow *) let weekday ~year ~mon ~day = let a = (14 - mon) / 12 in let y = year - a in