mte/src/timestamp.ml

type t = Ptime.t option
type span = Ptime.Span.t option

let epoch = Some Ptime.epoch

let diff a b =
  match (a, b) with
  | None, _ | _, None -> None
  | Some a, Some b -> Some (Ptime.diff a b)

let add_span_exn t span =
  match (t, span) with
  | None, _ | _, None -> None
  | Some t, Some span -> (
      match Ptime.add_span t span with
      | None -> Fmt.failwith "add_span_exn: not in the range [min;max]"
      | Some v -> Some v)

let of_span_exn = function
  | None -> None
  | Some span -> (
      match Ptime.of_span span with
      | None -> Fmt.failwith "of_span_exn: not in the range [min;max]"
      | Some p -> Some p)

(* -- *)

(* TODO
   this doesn't handle "never" value, and truncate time *)
let of_string s =
  match Float.of_string_opt s with
  | None -> Error "Timestamp.of_string failure: not a float"
  | Some v -> (
      match Ptime.of_float_s v with
      | None -> Error "Timestamp.of_string failure"
      | Some v -> Ok (Some v))

let pp fmt t =
  match t with
  | None -> Fmt.pf fmt {|"never"|}
  | Some v ->
      let v = Ptime.to_float_s v in
      Fmt.pf fmt {|%f|} v

(* microseconds since the UNIX Epoch, or "never" if None *)
let jsont =
  let number_or_never_jsont =
    let never =
      let dec s =
        match s with
        | "never" -> None
        | _ -> Jsont.Error.msg Jsont.Meta.none "unexpected string value"
      in
      let enc = function None -> "never" | _ -> assert false in
      Jsont.map ~dec ~enc Jsont.string
    in
    let number =
      let dec n = Ptime.of_float_s n in
      let enc = function Some n -> Ptime.to_float_s n | _ -> assert false in
      Jsont.map ~dec ~enc Jsont.number
    in
    let enc = function None -> never | Some _ -> number in
    Jsont.any ~dec_string:never ~dec_number:number ~enc ()
  in
  let make t = t in
  Jsont.Object.map ~kind:"Timestamp" make
  |> Jsont.Object.mem "t_s" number_or_never_jsont ~enc:Fun.id
  |> Jsont.Object.finish

let ptime_to_int64 ptime = ptime |> Ptime.to_float_s |> Int64.of_float

let ptime_of_int64 i =
  match Ptime.of_float_s (Int64.to_float i) with
  | None -> Fmt.failwith "ptime_of_int64 error: `%Ld` is not a valid ptime" i
  | Some ts -> ts

let encode_int64 = function None -> Int64.max_int | Some p -> ptime_to_int64 p
let decode_int64 i = if i = Int64.max_int then None else Some (ptime_of_int64 i)

(* UINT64_MAX represents "never". *)
let bin = Bin.map Bin.neint64 decode_int64 encode_int64
let bin_nbo = Bin.map Bin.beint64 decode_int64 encode_int64

let caqti : t Caqti_type.t =
  let encode v = Ok (encode_int64 v) in
  let decode v = Ok (decode_int64 v) in
  Caqti_type.custom ~encode ~decode Caqti_type.int64

let compare a b =
  match (a, b) with
  | None, None -> Some 0
  | None, _ | _, None -> None
  | Some a, Some b ->
      let a = ptime_to_int64 a in
      let b = ptime_to_int64 b in
      let c = Int64.compare a b in
      Some c

module Span = struct
  type t = span

  (* TODO
   this doesn't handle "never" value, and truncate time *)
  let of_string s =
    match Float.of_string_opt s with
    | None -> Error "Timestamp.Span.of_string failure: not a float"
    | Some v -> (
        match Ptime.Span.of_float_s v with
        | None -> Error "Timestamp.Span.of_string failure"
        | Some v -> Ok (Some v))

  let pp fmt t =
    match t with
    | None -> Fmt.pf fmt {|"forever"|}
    | Some v ->
        let v = Ptime.Span.to_float_s v in
        Fmt.pf fmt {|%f|} v

  let to_int64 ptime = ptime |> Ptime.Span.to_float_s |> Int64.of_float

  let of_int64 i =
    match Ptime.Span.of_float_s (Int64.to_float i) with
    | None ->
        Fmt.failwith
          "ptime_span_of_int64 error: `%Ld` is not a valid ptime span" i
    | Some ts -> ts

  let encode_int64 = function None -> Int64.max_int | Some p -> to_int64 p
  let decode_int64 i = if i = Int64.max_int then None else Some (of_int64 i)

  (* UINT64_MAX represents "forever" *)
  let bin = Bin.map Bin.neint64 decode_int64 encode_int64
  let bin_nbo = Bin.map Bin.beint64 decode_int64 encode_int64

  let caqti : t Caqti_type.t =
    let encode v = Ok (encode_int64 v) in
    let decode v = Ok (decode_int64 v) in
    Caqti_type.custom ~encode ~decode Caqti_type.int64

  let jsont =
    let number_or_forever_jsont =
      let forever =
        let dec s =
          match s with
          | "forever" -> None
          | _ -> Jsont.Error.msg Jsont.Meta.none "unexpected string value"
        in
        let enc = function None -> "forever" | _ -> assert false in
        Jsont.map ~dec ~enc Jsont.string
      in
      let number =
        let dec n =
          (* relative time is in us *)
          let n = n /. 1_000_000. in
          Ptime.Span.of_float_s n
        in
        let enc = function
          | Some span ->
              let n = Ptime.Span.to_float_s span in
              n *. 1_000_000.
          | _ -> assert false
        in
        Jsont.map ~dec ~enc Jsont.number
      in
      let enc = function None -> forever | Some _ -> number in
      Jsont.any ~dec_string:forever ~dec_number:number ~enc ()
    in

    let make t_s = t_s in
    Jsont.Object.map ~kind:"RelativeTime" make
    |> Jsont.Object.mem "t_s" number_or_forever_jsont ~enc:Fun.id
    |> Jsont.Object.finish
end