Source file bounded_history_repr.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

module type NAME = sig
  val name : string
end

module type KEY = sig
  type t

  val compare : t -> t -> int

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t
end

module type VALUE = sig
  type t

  val equal : t -> t -> bool

  val pp : Format.formatter -> t -> unit

  val encoding : t Data_encoding.t
end

module type S = sig
  type t

  type key

  type value

  val empty : capacity:int64 -> t

  val encoding : t Data_encoding.t

  val pp : Format.formatter -> t -> unit

  val find : key -> t -> value option

  type error +=
    | Key_bound_to_different_value of {
        key : key;
        existing_value : value;
        given_value : value;
      }

  val remember : key -> value -> t -> t tzresult

  module Internal_for_tests : sig
    val empty : capacity:int64 -> next_index:int64 -> t

    val keys : t -> key list
  end
end

module Make (Name : NAME) (Key : KEY) (Value : VALUE) :
  S with type key = Key.t and type value = Value.t = struct
  type key = Key.t

  type value = Value.t

  module Int64_map = Map.Make (Int64)
  module Map = Map.Make (Key)

  type t = {
    events : value Map.t;
        (** Values stored in the structure, indexes with the keys. *)
    sequence : key Int64_map.t;
        (** An additional map from int64 indexes to keys, to be able
            to remove old entries when the structure is full.  *)
    capacity : int64;
        (** The max number of the entries in the structure. Once the maximum size
            is reached, older entries are deleted to free space for new ones. *)
    next_index : int64;
        (** The index to use for the next entry to add in the structure. *)
    oldest_index : int64;
        (** The oldest index of the (oldest) entry that has been added to the
            data structure. If the structure is empty, [oldest_index] is
            equal to [next_index]. *)
    size : int64;
        (** Counts the number of entries that are stored in history. It
            satisfies the invariant: `0 <= size <= capacity` *)
  }

  let encoding : t Data_encoding.t =
    let open Data_encoding in
    let events_encoding =
      Data_encoding.conv
        Map.bindings
        (fun l -> Map.add_seq (List.to_seq l) Map.empty)
        Data_encoding.(list (tup2 Key.encoding Value.encoding))
    in
    let sequence_encoding =
      conv
        Int64_map.bindings
        (List.fold_left (fun m (k, v) -> Int64_map.add k v m) Int64_map.empty)
        (list (tup2 int64 Key.encoding))
    in
    conv
      (fun {events; sequence; capacity; next_index; oldest_index; size} ->
        (events, sequence, capacity, next_index, oldest_index, size))
      (fun (events, sequence, capacity, next_index, oldest_index, size) ->
        {events; sequence; capacity; next_index; oldest_index; size})
      (obj6
         (req "events" events_encoding)
         (req "sequence" sequence_encoding)
         (req "capacity" int64)
         (req "next_index" int64)
         (req "oldest_index" int64)
         (req "size" int64))

  let pp fmt {events; sequence; capacity; size; oldest_index; next_index} =
    Map.bindings events |> fun bindings ->
    Int64_map.bindings sequence |> fun sequence_bindings ->
    let pp_binding fmt (hash, history_proof) =
      Format.fprintf fmt "@[%a -> %a@;@]" Key.pp hash Value.pp history_proof
    in
    let pp_sequence_binding fmt (counter, hash) =
      Format.fprintf fmt "@[%s -> %a@;@]" (Int64.to_string counter) Key.pp hash
    in
    Format.fprintf
      fmt
      "@[<hov 2>History:@;\
      \ { capacity: %Ld;@;\
      \ current size: %Ld;@;\
      \ oldest index: %Ld;@;\
      \ next_index : %Ld;@;\
      \ bindings: %a;@;\
      \ sequence: %a; }@]"
      capacity
      size
      oldest_index
      next_index
      (Format.pp_print_list pp_binding)
      bindings
      (Format.pp_print_list pp_sequence_binding)
      sequence_bindings

  let empty ~capacity =
    let next_index = 0L in
    {
      events = Map.empty;
      sequence = Int64_map.empty;
      capacity;
      next_index;
      oldest_index = next_index;
      size = 0L;
    }

  type error +=
    | Key_bound_to_different_value of {
        key : key;
        existing_value : value;
        given_value : value;
      }

  let () =
    assert (not (String.equal Name.name "")) ;
    register_error_kind
      `Temporary
      ~id:
        (Format.sprintf
           "Bounded_history_repr.%s.key_bound_to_different_value"
           Name.name)
      ~title:(Name.name ^ ": Key already bound to a different value.")
      ~description:
        (Name.name
       ^ ": Remember called with a key that is already bound to a different\n\
         \        value.")
      Data_encoding.(
        obj3
          (req "key" Key.encoding)
          (req "existing_value" Value.encoding)
          (req "given_value" Value.encoding))
      (function
        | Key_bound_to_different_value {key; existing_value; given_value} ->
            Some (key, existing_value, given_value)
        | _ -> None)
      (fun (key, existing_value, given_value) ->
        Key_bound_to_different_value {key; existing_value; given_value})

  let remember key value t =
    let open Tzresult_syntax in
    if Compare.Int64.(t.capacity <= 0L) then return t
    else
      match Map.find key t.events with
      | Some value' when not (Value.equal value value') ->
          error
          @@ Key_bound_to_different_value
               {key; existing_value = value'; given_value = value}
      | _ -> (
          let events = Map.add key value t.events in
          let current_index = t.next_index in
          let next_index = Int64.succ current_index in
          let t =
            {
              events;
              sequence = Int64_map.add current_index key t.sequence;
              capacity = t.capacity;
              next_index;
              oldest_index = t.oldest_index;
              size = Int64.succ t.size;
            }
          in
          (* A negative size means that [t.capacity] is set to [Int64.max_int]
             and that the structure is full, so adding a new entry makes the size
             overflows. In this case, we remove an element in the else branch to
             keep the size of the structure equal to [Int64.max_int] at most. *)
          if Compare.Int64.(t.size > 0L && t.size <= t.capacity) then return t
          else
            let l = t.oldest_index in
            match Int64_map.find l t.sequence with
            | None ->
                (* If t.size > t.capacity > 0, there is necessarily
                   an entry whose index is t.oldest_index in [sequence]. *)
                assert false
            | Some h ->
                let sequence = Int64_map.remove l t.sequence in
                let events = Map.remove h events in
                return
                  {
                    next_index = t.next_index;
                    capacity = t.capacity;
                    size = t.capacity;
                    oldest_index = Int64.succ t.oldest_index;
                    sequence;
                    events;
                  })

  let find key t = Map.find_opt key t.events

  module Internal_for_tests = struct
    let empty ~capacity ~next_index =
      {(empty ~capacity) with next_index; oldest_index = next_index}

    let keys {sequence; oldest_index; _} =
      let l = Int64_map.bindings sequence in
      (* All entries with an index greater than oldest_index are well ordered.
         There are put in the [lp] list. Entries with an index smaller than
         oldest_index are also well ordered, but they should come after
         elements in [lp]. This happens in theory when the index reaches
         max_int and then overflows. *)
      let ln, lp =
        List.partition_map
          (fun (n, h) ->
            if Compare.Int64.(n < oldest_index) then Left h else Right h)
          l
      in
      (* do a tail recursive concatenation lp @ ln *)
      List.rev_append (List.rev lp) ln
  end
end