diff --git a/src/node/shell/block_locator.ml b/src/node/shell/block_locator.ml new file mode 100644 index 000000000..35942442d --- /dev/null +++ b/src/node/shell/block_locator.ml @@ -0,0 +1,109 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open State + +type t = Block_hash.t list + +type error += Invalid_locator of P2p.Peer_id.t * t + +let encoding = + let open Data_encoding in + (* TODO add a [description] *) + list Block_hash.encoding + +let compute (b: Block.t) sz = + let rec loop acc sz step cpt b = + if sz = 0 then + Lwt.return (List.rev acc) + else + Block.predecessor b >>= function + | None -> + Lwt.return (List.rev (Block.hash b :: acc)) + | Some predecessor -> + if cpt = 0 then + loop (Block.hash b :: acc) (sz - 1) + (step * 2) (step * 20 - 1) predecessor + else if cpt mod step = 0 then + loop (Block.hash b :: acc) (sz - 1) + step (cpt - 1) predecessor + else + loop acc sz step (cpt - 1) predecessor in + loop [] sz 1 9 b + +let estimated_length hist = + let rec loop acc step cpt = function + | [] -> acc + | _ :: hist -> + if cpt = 0 then + loop (acc+step) (step*2) 9 hist + else + loop (acc+step) step (cpt-1) hist + in + loop 0 1 9 hist + +let fold ~f acc hist = + let rec loop step cpt acc = function + | [] | [_] -> acc + | block :: (pred :: rem as hist) -> + let step, cpt = + if cpt = 0 then + 2 * step, 9 + else + step, cpt - 1 in + let acc = f acc ~block ~pred ~step ~strict_step:(rem <> []) in + loop step cpt acc hist + in + loop 1 9 acc hist + +type step = { + block: Block_hash.t ; + predecessor: Block_hash.t ; + step: int ; + strict_step: bool ; +} + +let to_steps hist = + fold + ~f:begin fun acc ~block ~pred ~step ~strict_step -> { + block ; predecessor = pred ; step ; strict_step ; + } :: acc + end + [] hist + +let rec known_ancestor net_state acc hist = + match hist with + | [] -> Lwt.return_none + | h :: hist -> + Block.read_opt net_state h >>= function + | Some block -> Lwt.return (Some (block, List.rev (h :: acc))) + | None -> + Block.known_invalid net_state h >>= function + | true -> Lwt.return_none + | false -> known_ancestor net_state (h :: acc) hist + +let known_ancestor net_state hist = + known_ancestor net_state [] hist + +let find_new net_state hist sz = + let rec path sz acc h = + if sz <= 0 then Lwt.return (List.rev acc) + else + read_chain_store net_state begin fun chain_store _data -> + Store.Chain.In_chain.read_opt (chain_store, h) + end >>= function + | None -> Lwt.return (List.rev acc) + | Some s -> path (sz-1) (s :: acc) s in + known_ancestor net_state hist >>= function + | None -> Lwt.return_nil + | Some (known, _) -> + Chain.head net_state >>= fun head -> + Chain_traversal.common_ancestor known head >>= fun ancestor -> + path sz [] (Block.hash ancestor) + diff --git a/src/node/shell/block_locator.mli b/src/node/shell/block_locator.mli new file mode 100644 index 000000000..def0f6125 --- /dev/null +++ b/src/node/shell/block_locator.mli @@ -0,0 +1,57 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open State + +type t = private Block_hash.t list +(** A type for sparse block locator (/à la/ Bitcoin) *) + +val encoding: t Data_encoding.t + +type error += Invalid_locator of P2p.Peer_id.t * t + +val compute: Block.t -> int -> t Lwt.t +(** [compute block max_length] compute the sparse block locator for + the [block]. The locator contains at most [max_length] elements. *) + +val fold: + f:('a -> block:Block_hash.t -> pred:Block_hash.t -> step:int -> strict_step:bool -> 'a) -> + 'a -> t -> 'a +(** [map f l] applies [f] to each block of the locator, the last one + excepted. The function also receives the expected predecessor + [pred] of the [block] after [step] steps, i.e. the next block in + the locator. When [strict_step] is [true], then [step] is the + exact number of predecessor to be followed before to found + [pred]. Otherwise, it is only an upper bound. *) + +type step = { + block: Block_hash.t ; + predecessor: Block_hash.t ; + step: int ; + strict_step: bool ; +} +val to_steps: t -> step list + +val estimated_length: t -> int +(** [estimated_length locator] estimate the length of the chain + represented by [locator]. *) + +val known_ancestor: State.Net.t -> t -> (Block.t * t) option Lwt.t +(** [known_ancestor net_state locator] computes the first block of + [locator] that is known to be a valid block. It also computes the + 'prefix' of [locator] with end at the first valid block. The + function returns [None] when no block in the locator are known or + if the first known block is invalid. *) + +val find_new: + State.Net.t -> t -> int -> Block_hash.t list Lwt.t +(** [find_new net locator max_length] returns the blocks from our + current branch that would be unknown to a peer that sends us the + [locator]. *) + diff --git a/src/node/shell/chain.ml b/src/node/shell/chain.ml index 13fca8455..d693efe06 100644 --- a/src/node/shell/chain.ml +++ b/src/node/shell/chain.ml @@ -34,25 +34,6 @@ let mem net_state hash = Store.Chain.In_chain.known (chain_store, hash) end -let find_new net_state hist sz = - let rec common_ancestor hist = - match hist with - | [] -> Lwt.return (Net.genesis net_state).block - | h :: hist -> - mem net_state h >>= function - | false -> common_ancestor hist - | true -> Lwt.return h in - let rec path sz acc h = - if sz <= 0 then Lwt.return (List.rev acc) - else - read_chain_store net_state begin fun chain_store _data -> - Store.Chain.In_chain.read_opt (chain_store, h) - end >>= function - | None -> Lwt.return (List.rev acc) - | Some s -> path (sz-1) (s :: acc) s in - common_ancestor hist >>= fun ancestor -> - path sz [] ancestor - let locked_set_head chain_store data block = let rec pop_blocks ancestor block = let hash = Block.hash block in diff --git a/src/node/shell/chain.mli b/src/node/shell/chain.mli index 49ffda47e..97bbca416 100644 --- a/src/node/shell/chain.mli +++ b/src/node/shell/chain.mli @@ -35,9 +35,3 @@ val test_and_set_head: (** Atomically change the current head of the network's blockchain. This returns [true] whenever the change succeeded, or [false] when the current head os not equal to the [old] argument. *) - -val find_new: - Net.t -> Block_hash.t list -> int -> Block_hash.t list Lwt.t - (** [find_new net locator max_length], where [locator] is a sparse block - locator (/à la/ Bitcoin), returns the missing block when compared - with the current branch of [net]. *) diff --git a/src/node/shell/chain_traversal.ml b/src/node/shell/chain_traversal.ml index 6294aec07..c8e8ce9ad 100644 --- a/src/node/shell/chain_traversal.ml +++ b/src/node/shell/chain_traversal.ml @@ -37,25 +37,6 @@ let common_ancestor (b1: Block.t) (b2: Block.t) = | Some b1 -> loop b1 b2 in loop b1 b2 -let block_locator (b: Block.t) sz = - let rec loop acc sz step cpt b = - if sz = 0 then - Lwt.return (List.rev acc) - else - Block.predecessor b >>= function - | None -> - Lwt.return (List.rev (Block.hash b :: acc)) - | Some predecessor -> - if cpt = 0 then - loop (Block.hash b :: acc) (sz - 1) - (step * 2) (step * 20 - 1) predecessor - else if cpt mod step = 0 then - loop (Block.hash b :: acc) (sz - 1) - step (cpt - 1) predecessor - else - loop acc sz step (cpt - 1) predecessor in - loop [] sz 1 9 b - let iter_predecessors ?max ?min_fitness ?min_date heads ~f = let module Local = struct exception Exit end in let compare b1 b2 = diff --git a/src/node/shell/chain_traversal.mli b/src/node/shell/chain_traversal.mli index 2afafcd83..e15b12ce9 100644 --- a/src/node/shell/chain_traversal.mli +++ b/src/node/shell/chain_traversal.mli @@ -18,10 +18,6 @@ val common_ancestor: Block.t -> Block.t -> Block.t Lwt.t (** [common_ancestor state h1 h2] returns the first common ancestors in the history of blocks [h1] and [h2]. *) -val block_locator: Block.t -> int -> Block_hash.t list Lwt.t -(** [block_locator state max_length h] compute the sparse block locator - (/à la/ Bitcoin) for the block [h]. *) - val iter_predecessors: ?max:int -> ?min_fitness:Fitness.t -> diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index 72d59146a..5c4fa38bb 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -300,7 +300,7 @@ module Raw_protocol = end) type callback = { - notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ; + notify_branch: P2p.Peer_id.t -> Block_locator.t -> unit ; notify_head: P2p.Peer_id.t -> Block_hash.t -> Operation_hash.t list -> unit ; disconnection: P2p.Peer_id.t -> unit ; } @@ -404,7 +404,7 @@ module P2p_reader = struct @@ P2p.try_send global_db.p2p state.conn @@ Get_current_branch net_id ; Chain.head net_db.net_state >>= fun head -> - Chain_traversal.block_locator head 200 >>= fun locator -> + Block_locator.compute head 200 >>= fun locator -> ignore @@ P2p.try_send global_db.p2p state.conn @@ Current_branch (net_id, locator) ; @@ -414,7 +414,7 @@ module P2p_reader = struct may_activate global_db state net_id @@ fun net_db -> Lwt_list.exists_p (State.Block.known_invalid net_db.net_state) - locator >>= fun known_invalid -> + (locator :> Block_hash.t list) >>= fun known_invalid -> if not known_invalid then net_db.callback.notify_branch state.gid locator ; (* TODO Kickban *) diff --git a/src/node/shell/distributed_db.mli b/src/node/shell/distributed_db.mli index 54feb2dcb..1244b9a90 100644 --- a/src/node/shell/distributed_db.mli +++ b/src/node/shell/distributed_db.mli @@ -23,7 +23,7 @@ type net_db val state: net_db -> State.Net.t type callback = { - notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ; + notify_branch: P2p.Peer_id.t -> Block_locator.t -> unit ; notify_head: P2p.Peer_id.t -> Block_hash.t -> Operation_hash.t list -> unit ; disconnection: P2p.Peer_id.t -> unit ; } diff --git a/src/node/shell/distributed_db_message.ml b/src/node/shell/distributed_db_message.ml index f2406ec4b..5fefb9c58 100644 --- a/src/node/shell/distributed_db_message.ml +++ b/src/node/shell/distributed_db_message.ml @@ -10,7 +10,7 @@ type t = | Get_current_branch of Net_id.t - | Current_branch of Net_id.t * Block_hash.t list (* Block locator *) + | Current_branch of Net_id.t * Block_locator.t | Deactivate of Net_id.t | Get_current_head of Net_id.t @@ -51,7 +51,7 @@ let encoding = case ~tag:0x11 (obj2 (req "net_id" Net_id.encoding) - (req "current_branch" (list Block_hash.encoding))) + (req "current_branch" Block_locator.encoding)) (function | Current_branch (net_id, bhs) -> Some (net_id, bhs) | _ -> None) diff --git a/src/node/shell/distributed_db_message.mli b/src/node/shell/distributed_db_message.mli index 68ab57ab6..9aa1a1577 100644 --- a/src/node/shell/distributed_db_message.mli +++ b/src/node/shell/distributed_db_message.mli @@ -10,7 +10,7 @@ type t = | Get_current_branch of Net_id.t - | Current_branch of Net_id.t * Block_hash.t list (* Block locator *) + | Current_branch of Net_id.t * Block_locator.t | Deactivate of Net_id.t | Get_current_head of Net_id.t diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 3cdd2f829..c1833d9d3 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -320,6 +320,15 @@ module Block = struct Store.Block.Invalid_block.known store hash end + let known net_state hash = + Shared.use net_state.block_store begin fun store -> + Store.Block.Contents.known (store, hash) >>= fun known -> + if known then + Lwt.return_true + else + Store.Block.Invalid_block.known store hash + end + let read net_state hash = Shared.use net_state.block_store begin fun store -> Store.Block.Contents.read (store, hash) >>=? fun contents -> diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 362732233..ac42e75fa 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -89,6 +89,7 @@ module Block : sig type t type block = t + val known: Net.t -> Block_hash.t -> bool Lwt.t val known_valid: Net.t -> Block_hash.t -> bool Lwt.t val known_invalid: Net.t -> Block_hash.t -> bool Lwt.t diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 2dfff9d5c..ce2f42464 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -757,7 +757,9 @@ let rec create_validator ?parent worker ?max_child_ttl state db net = let rec loop () = Lwt_pipe.pop queue >>= function | `Branch (_gid, locator) -> - List.iter (Context_db.prefetch v session) locator ; + List.iter + (Context_db.prefetch v session) + (locator :> Block_hash.t list) ; loop () | `Head (gid, head, ops) -> Context_db.prefetch v session head ; diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index 2f0ade275..355993950 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -275,8 +275,9 @@ let test_ancestor s = let test_locator s = let check_locator h1 expected = - Chain_traversal.block_locator + Block_locator.compute (vblock s h1) (List.length expected) >>= fun l -> + let l = (l :> Block_hash.t list) in if List.length l <> List.length expected then Assert.fail_msg "Invalid locator length %s (found: %d, expected: %d)" @@ -414,12 +415,12 @@ let test_new_blocks s = (****************************************************************************) -(** Chain.find_new *) +(** Block_locator.find_new *) let test_find_new s = let test s h expected = - Chain_traversal.block_locator (vblock s h) 50 >>= fun loc -> - Chain.find_new s.net loc (List.length expected) >>= fun blocks -> + Block_locator.compute (vblock s h) 50 >>= fun loc -> + Block_locator.find_new s.net loc (List.length expected) >>= fun blocks -> if List.length blocks <> List.length expected then Assert.fail_msg "Invalid locator length %s (found: %d, expected: %d)"