ligo/src/lib_base/block_locator.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.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.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

type t = raw
and raw = Block_header.t * Block_hash.t list

let raw x = x

let pp ppf (hd, h_lst) =
  let repeats = 10 in
  let coef = 2 in
  (* list of hashes *)
  let rec pp_hash_list ppf (h_lst , acc , d , r) =
    match h_lst with
    | [] ->
        Format.fprintf ppf ""
    | hd :: tl ->
        let new_d = if r > 1 then d else d * coef in
        let new_r = if r > 1 then r - 1 else repeats in
        Format.fprintf ppf "%a (%i)\n%a"
          Block_hash.pp hd acc pp_hash_list (tl , acc - d , new_d , new_r) in
  Format.fprintf ppf "%a (head)\n%a"
    Block_hash.pp (Block_header.hash hd)
    pp_hash_list (h_lst , -1, 1, repeats - 1)

let pp_short ppf (hd, h_lst) =
  Format.fprintf ppf "head: %a, %d predecessors"
    Block_hash.pp (Block_header.hash hd)
    (List.length h_lst)

let encoding =
  let open Data_encoding in
  (* TODO add a [description] *)
  (obj2
     (req "current_head" (dynamic_size Block_header.encoding))
     (req "history" (Variable.list Block_hash.encoding)))

let bounded_encoding ?max_header_size ?max_length () =
  let open Data_encoding in
  (* TODO add a [description] *)
  (obj2
     (req "current_head"
        (dynamic_size
           (Block_header.bounded_encoding ?max_size:max_header_size ())))
     (req "history" (Variable.list ?max_length Block_hash.encoding)))


type seed = {
  sender_id: P2p_peer.Id.t ;
  receiver_id: P2p_peer.Id.t ;
}

(* Random generator for locator steps.

   We draw steps by sequence of 10. The first sequence's steps are of
   length 1 (consecutive). The second sequence's steps are of a random
   length between 1 and 2. The third sequence's steps are of a random
   length between 2 and 4, and so on...

   The sequence is deterministic for a given triple of sender,
   receiver and block hash. *)
module Step : sig

  type state
  val init: seed -> Block_hash.t -> state
  val next: state -> int * state

end = struct

  type state = Int32.t * int * MBytes.t

  let init seed head =
    let open Hacl.Hash in
    let st = SHA256.init () in
    List.iter (SHA256.update st) [
      P2p_peer.Id.to_bytes seed.sender_id ;
      P2p_peer.Id.to_bytes seed.receiver_id ;
      Block_hash.to_bytes head ] ;
    (1l, 9, SHA256.finish st)

  let draw seed n =
    Int32.rem (MBytes.get_int32 seed 0) n,
    Hacl.Hash.SHA256.digest seed

  let next (step, counter, seed) =
    let random_gap, seed =
      if step <= 1l then
        0l, seed
      else
        draw seed (Int32.succ (Int32.div step 2l)) in
    let new_state =
      if counter = 0 then
        (Int32.mul step 2l, 9, seed)
      else
        (step, counter - 1, seed) in
    Int32.to_int (Int32.sub step random_gap), new_state

end

let estimated_length seed (head, hist) =
  let rec loop acc state = function
    | [] -> acc
    | _ :: hist ->
        let step, state = Step.next state in
        loop (acc + step) state hist in
  let state = Step.init seed (Block_header.hash head) in
  let step, state = Step.next state in
  loop step state hist

let fold ~f ~init (head, hist) seed =
  let rec loop state acc = function
    | [] | [_] -> acc
    | block :: (pred :: rem as hist) ->
        let step, state = Step.next state in
        let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in
        loop state acc hist in
  let head = Block_header.hash head in
  let state = Step.init seed head in
  loop state init (head :: hist)

type step = {
  block: Block_hash.t ;
  predecessor: Block_hash.t ;
  step: int ;
  strict_step: bool ;
}

let pp_step ppf step = Format.fprintf ppf "%d%s" step.step (if step.strict_step then "" else " max")

let to_steps seed locator =
  fold locator seed
    ~init:[]
    ~f: begin fun acc ~block ~pred ~step ~strict_step ->
      { block ; predecessor = pred ; step ; strict_step } :: acc
    end

let compute ~predecessor ~genesis block_hash header seed ~size =
  let rec loop acc size state block =
    if size = 0 then
      Lwt.return (List.rev acc)
    else
      let step, state = Step.next state in
      predecessor block step >>= function
      | None ->
          (* We reached genesis before size *)
          if Block_hash.equal block genesis then
            Lwt.return (List.rev acc)
          else
            Lwt.return (List.rev (genesis :: acc))
      | Some pred ->
          loop (pred :: acc) (size - 1) state pred in
  if size <= 0 then
    Lwt.return (header, [])
  else
    let state = Step.init seed block_hash in
    let step, state = Step.next state in
    predecessor block_hash step >>= function
    | None -> Lwt.return (header, [])
    | Some p ->
        loop [p] (size-1) state p >>= fun hist ->
        Lwt.return (header, hist)

type validity =
  | Unknown
  | Known_valid
  | Known_invalid

let unknown_prefix ~is_known (head, hist) =
  let rec loop hist acc =
    match hist with
    | [] -> Lwt.return_none
    | h :: t ->
        is_known h >>= function
        | Known_valid ->
            Lwt.return_some (h, (List.rev (h :: acc)))
        | Known_invalid ->
            Lwt.return_none
        | Unknown ->
            loop t (h :: acc)
  in
  is_known (Block_header.hash head) >>= function
  | Known_valid ->
      Lwt.return_some (Block_header.hash head, (head, []))
  | Known_invalid ->
      Lwt.return_none
  | Unknown ->
      loop hist [] >>= function
      | None ->
          Lwt.return_none
      | Some (tail, hist) ->
          Lwt.return_some (tail, (head, hist))