IH-628: Add new package for timekeeping

clock.opam

@@ -0,0 +1,32 @@
+# 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" "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"
+depends: [
+  "dune" {>= "3.0"}
+  "ocaml" {>= "4.12"}
+  "alcotest" {with-test}
+  "astring"
+  "mtime"
+  "ptime"
+  "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"

dune-project

@@ -15,6 +15,20 @@
   (name zstd)
 )
 
+
+(package
+  (name clock)
+  (synopsis "Xapi's library for managing time")
+  (authors "Jonathan Ludlam" "Pau Ruiz Safont")
+  (depends
+    (ocaml (>= 4.12))
+    (alcotest :with-test)
+    astring
+    mtime
+    ptime
+  )
+)
+
 (package
   (name xapi-rrdd-plugin)
 )
@@ -451,19 +465,17 @@ 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)
-    astring
-    base-unix
+    (clock (= :version))
     ptime
-    (odoc :with-doc)
   )
 )
 
 (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 +489,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 +511,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 +524,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 +539,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)

ocaml/libs/clock/date.ml

@@ -0,0 +1,170 @@
+(* 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.
+*)
+
+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
+
+(* 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
+  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

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] *)

ocaml/libs/clock/dune

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

ocaml/libs/xapi-stdext/lib/xapi-stdext-date/test.ml → ocaml/libs/clock/test_date.ml

@@ -1,4 +1,4 @@
-open Xapi_stdext_date.Date
+open Clock.Date
 
 let check_float = Alcotest.(check @@ float 1e-2)
 
@@ -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