balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Shell: remove the on-disk index of operations

Browse Source 
Let's get serious. The full index of operations is not sustainable in
the production code. We now only keep the index of operations not yet
in the chain (i.e. the mempool/prevalidation). Operations from the
chain are now only accesible through a block. For instance, see the
RPC:

   /blocks/<hash>/proto/operations
This commit is contained in:
Grégoire Henry 2017-04-19 21:46:10 +02:00
parent 4995864316
commit f39eca214a
47 changed files with 2358 additions and 3246 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scripts/alphanet_version
View File

@ -1 +1 @@
2017-04-17
2017-04-19

4
src/Makefile.files
View File

@ -224,6 +224,8 @@ NODE_LIB_INTFS := \
node/shell/distributed_db_message.mli \
node/shell/distributed_db_metadata.mli \
node/shell/distributed_db.mli \
node/shell/chain_traversal.mli \
node/shell/chain.mli \
node/shell/prevalidation.mli \
node/shell/prevalidator.mli \
node/shell/validator.mli \
@ -269,6 +271,8 @@ FULL_NODE_LIB_IMPLS := \
node/shell/distributed_db_message.ml \
node/shell/distributed_db_metadata.ml \
node/shell/distributed_db.ml \
node/shell/chain_traversal.ml \
node/shell/chain.ml \
node/shell/prevalidation.ml \
node/shell/prevalidator.ml \
node/shell/validator.ml \

23
src/client/client_node_rpcs.ml
View File

@ -22,6 +22,12 @@ let forge_block cctxt ?net_id ?level ?proto_level ?predecessor ?timestamp fitnes
let validate_block cctxt net block =
call_err_service0 cctxt Services.validate_block (net, block)
type operation = Node_rpc_services.operation =
| Blob of Operation.t
| Hash of Operation_hash.t
let operation_encoding = Node_rpc_services.operation_encoding
let inject_block cctxt ?(async = false) ?(force = false) raw operations =
call_err_service0 cctxt Services.inject_block
{ raw ; blocking = not async ; force ; operations }
@ -66,7 +72,7 @@ module Blocks = struct
test_network: Context.test_network;
}
type preapply_param = Services.Blocks.preapply_param = {
operations: Operation_hash.t list ;
operations: operation list ;
sort: bool ;
timestamp: Time.t option ;
}
@ -89,8 +95,9 @@ module Blocks = struct
call_service1 cctxt Services.Blocks.timestamp h ()
let fitness cctxt h =
call_service1 cctxt Services.Blocks.fitness h ()
let operations cctxt h =
call_service1 cctxt Services.Blocks.operations h ()
let operations cctxt ?(contents = false) h =
call_service1 cctxt Services.Blocks.operations h
{ contents ; monitor = false }
let protocol cctxt h =
call_service1 cctxt Services.Blocks.protocol h ()
let test_network cctxt h =
@ -121,12 +128,10 @@ end
module Operations = struct
let contents cctxt hashes =
call_service1 cctxt Services.Operations.contents hashes ()
let monitor cctxt ?contents () =
call_streamed_service0 cctxt Services.Operations.list
{ monitor = Some true ; contents }
let monitor cctxt ?(contents = false) () =
call_streamed_service1 cctxt Services.Blocks.operations
`Prevalidation
{ contents ; monitor = true }
end

23
src/client/client_node_rpcs.mli
View File

@ -34,10 +34,16 @@ val validate_block:
Net_id.t -> Block_hash.t ->
unit tzresult Lwt.t
type operation =
| Blob of Operation.t
| Hash of Operation_hash.t
val operation_encoding: operation Data_encoding.t
val inject_block:
config ->
?async:bool -> ?force:bool ->
MBytes.t -> Operation_hash.t list list ->
MBytes.t -> operation list list ->
Block_hash.t tzresult Lwt.t
(** [inject_block cctxt ?async ?force raw_block] tries to inject
[raw_block] inside the node. If [?async] is [true], [raw_block]
@ -89,7 +95,8 @@ module Blocks : sig
block -> MBytes.t list tzresult Lwt.t
val operations:
config ->
block -> Operation_hash.t list list tzresult Lwt.t
?contents:bool ->
block -> (Operation_hash.t * Operation.t option) list list tzresult Lwt.t
val protocol:
config ->
block -> Protocol_hash.t tzresult Lwt.t
@ -144,21 +151,17 @@ module Blocks : sig
block ->
?timestamp:Time.t ->
?sort:bool ->
Hash.Operation_hash.t list -> preapply_result tzresult Lwt.t
operation list -> preapply_result tzresult Lwt.t
end
module Operations : sig
val contents:
config ->
Operation_hash.t list -> Operation.t list tzresult Lwt.t
val monitor:
config ->
?contents:bool -> unit ->
(Operation_hash.t * Operation.t option) list list tzresult
Lwt_stream.t tzresult Lwt.t
?contents:bool ->
unit ->
(Operation_hash.t * Operation.t option) list list tzresult Lwt_stream.t tzresult Lwt.t
end

9
src/client/client_rpcs.ml
View File

@ -277,8 +277,7 @@ let call_service2 cctxt service a1 a2 arg =
get_json cctxt meth path arg >>=? fun json ->
parse_answer cctxt service path json
let call_streamed_service0 cctxt service arg =
let meth, path, arg = RPC.forge_request service () arg in
let call_streamed cctxt service (meth, path, arg) =
get_streamed_json cctxt meth path arg >>=? fun json_st ->
let parsed_st, push = Lwt_stream.create () in
let rec loop () =
@ -296,6 +295,12 @@ let call_streamed_service0 cctxt service arg =
Lwt.async loop ;
return parsed_st
let call_streamed_service0 cctxt service arg =
call_streamed cctxt service (RPC.forge_request service () arg)
let call_streamed_service1 cctxt service arg1 arg2 =
call_streamed cctxt service (RPC.forge_request service ((), arg1) arg2)
let parse_err_answer config service path json =
match RPC.read_answer service json with
| Error msg -> (* TODO print_error *)

5
src/client/client_rpcs.mli
View File

@ -53,6 +53,11 @@ val call_streamed_service0:
(unit, unit, 'a, 'b) RPC.service ->
'a -> ('b, error list) result Lwt_stream.t tzresult Lwt.t
val call_streamed_service1:
config ->
(unit, unit * 'a, 'b, 'c) RPC.service ->
'a -> 'b -> ('c, error list) result Lwt_stream.t tzresult Lwt.t
val call_err_service0:
config ->
(unit, unit, 'i, 'o tzresult) RPC.service ->

17
src/client/embedded/alpha/baker/client_mining_forge.ml
View File

@ -49,7 +49,7 @@ let inject_block cctxt block
Client_proto_rpcs.Context.next_level cctxt block >>=? fun level ->
let operations_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute operations) in
(List.map Operation_list_hash.compute (List.map (List.map (function Client_node_rpcs.Blob op -> Tezos_data.Operation.hash op | Hash oph -> oph)) operations)) in
let shell =
{ Block_header.net_id = bi.net_id ; level = bi.level ;
proto_level = bi.proto_level ;
@ -92,10 +92,12 @@ let forge_block cctxt block
| None ->
Client_node_rpcs.Blocks.pending_operations
cctxt block >>=? fun (ops, pendings) ->
return (Operation_hash.Set.elements @@
Operation_hash.Set.union
(Prevalidation.preapply_result_operations ops)
pendings)
let ops =
Operation_hash.Set.elements @@
Operation_hash.Set.union
(Prevalidation.preapply_result_operations ops)
pendings in
return (List.map (fun x -> Client_node_rpcs.Hash x) ops)
| Some operations -> return operations
end >>=? fun operations ->
begin
@ -153,7 +155,7 @@ let forge_block cctxt block
&& Operation_hash.Map.is_empty operations.branch_delayed ) then
inject_block cctxt ?force ~src_sk
~priority ~timestamp ~fitness ~seed_nonce block
[operations.applied]
[List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
else
failwith "Cannot (fully) validate the given operations."
@ -425,6 +427,7 @@ let mine cctxt state =
block >>=? fun (res, ops) ->
let operations =
let open Operation_hash.Set in
List.map (fun x -> Client_node_rpcs.Hash x) @@
elements (union ops (Prevalidation.preapply_result_operations res)) in
let request = List.length operations in
Client_node_rpcs.Blocks.preapply cctxt.rpc_config block
@ -460,7 +463,7 @@ let mine cctxt state =
Client_keys.get_key cctxt delegate >>=? fun (_,_,src_sk) ->
inject_block cctxt.rpc_config
~force:true ~src_sk ~priority ~timestamp ~fitness ~seed_nonce
(`Hash bi.hash) [operations.applied]
(`Hash bi.hash) [List.map (fun h -> Client_node_rpcs.Hash h) operations.applied]
|> trace_exn (Failure "Error while injecting block") >>=? fun block_hash ->
State.record_block cctxt level block_hash seed_nonce
|> trace_exn (Failure "Error while recording block") >>=? fun () ->

4
src/client/embedded/alpha/baker/client_mining_forge.mli
View File

@ -22,7 +22,7 @@ val inject_block:
fitness:Fitness.t ->
seed_nonce:Nonce.t ->
src_sk:secret_key ->
Operation_hash.t list list ->
Client_node_rpcs.operation list list ->
Block_hash.t tzresult Lwt.t
(** [inject_block cctxt blk ?force ~priority ~timestamp ~fitness
~seed_nonce ~src_sk ops] tries to inject a block in the node. If
@ -34,7 +34,7 @@ val forge_block:
Client_rpcs.config ->
Client_proto_rpcs.block ->
?force:bool ->
?operations:Operation_hash.t list ->
?operations:Client_node_rpcs.operation list ->
?best_effort:bool ->
?sort:bool ->
?timestamp:Time.t ->

5
src/client/embedded/alpha/baker/client_mining_operations.ml
View File

@ -15,7 +15,7 @@ open Operation
type operation = {
hash: Operation_hash.t ;
content: Tezos_context.Operation.t option
content: Operation.t option
}
let monitor cctxt ?contents ?check () =
@ -81,7 +81,8 @@ let filter_valid_endorsement cctxt ({ hash ; content } : operation) =
pp_print_error error >>= fun () ->
Lwt.return_none
| Ok () ->
Client_node_rpcs.Blocks.preapply cctxt (`Hash block) [hash] >>= function
Client_node_rpcs.Blocks.preapply
cctxt (`Hash block) [Client_node_rpcs.Hash hash] >>= function
| Ok _ ->
Lwt.return (Some { hash ; source ; block ; slots })
| Error error ->

2
src/client/embedded/demo/client_proto_main.ml
View File

@ -16,7 +16,7 @@ let demo cctxt =
cctxt.Client_commands.message "Calling the 'echo' RPC." >>= fun () ->
let msg = "test" in
Client_proto_rpcs.echo cctxt.rpc_config block msg >>=? fun reply ->
fail_unless (reply = msg) (Unclassified "...") >>=? fun () ->
fail_unless (reply = msg) (failure "...") >>=? fun () ->
begin
cctxt.message "Calling the 'failing' RPC." >>= fun () ->
Client_proto_rpcs.failing cctxt.rpc_config block 3 >>= function

9
src/minutils/data_encoding.ml
View File

@ -78,8 +78,15 @@ module Kind = struct
| `Fixed n1, `Fixed n2 -> `Fixed (n1 + n2)
| `Dynamic, `Dynamic | `Fixed _, `Dynamic
| `Dynamic, `Fixed _ -> `Dynamic
| `Variable, (`Dynamic | `Fixed _)
| `Variable, `Fixed _
| (`Dynamic | `Fixed _), `Variable -> `Variable
| `Variable, `Dynamic ->
Printf.ksprintf invalid_arg
"Cannot merge two %s when the left element is of variable length \
and the right one of dynamic length. \
You should use the reverse order, or wrap the second one \
with Data_encoding.dynamic_size."
name
| `Variable, `Variable ->
Printf.ksprintf invalid_arg
"Cannot merge two %s with variable length. \

267
src/node/db/store.ml
View File

@ -66,196 +66,45 @@ module Net = struct
end
(**************************************************************************
* Generic store for "tracked" data: discovery_time, invalidity,
* incoming peers,... (for operations, block_headers, and protocols).
**************************************************************************)
module type DATA_STORE = sig
type store
type key
type key_set
type value
module Discovery_time : MAP_STORE
with type t := store
and type key := key
and type value := Time.t
module Contents : SINGLE_STORE
with type t = store * key
and type value := value
module RawContents : SINGLE_STORE
with type t = store * key
and type value := MBytes.t
module Validation_time : SINGLE_STORE
with type t = store * key
and type value := Time.t
module Errors : MAP_STORE
with type t := store
and type key := key
and type value = error list
module Pending : BUFFERED_SET_STORE
with type t = store
and type elt := key
and type Set.t = key_set
end
module Errors_value =
Store_helpers.Make_value(struct
type t = error list
let encoding = (Data_encoding.list (Error_monad.error_encoding ()))
end)
module Raw_value = struct
type t = MBytes.t
let of_bytes b = ok b
let to_bytes b = b
end
module Make_data_store
(S : STORE) (I : INDEX) (V : VALUE)
(Set : Set.S with type elt = I.t) = struct
type key = I.t
type value = V.t
type key_set = Set.t
let of_bytes = V.of_bytes
let to_bytes = V.to_bytes
module Indexed_store =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore (S) (struct let name = ["data"] end))
(I)
module Discovery_time =
Indexed_store.Make_map
(struct let name = ["discovery_time"] end)
(Store_helpers.Make_value(Time))
module Contents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct let name = ["contents"] end)
(V)
module RawContents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct let name = ["contents"] end)
(Raw_value)
module Errors =
Store_helpers.Make_map
(Store_helpers.Make_substore (S) (struct let name = ["invalids"] end))
(I)
(Errors_value)
module Pending =
Store_helpers.Make_buffered_set
(Store_helpers.Make_substore (S) (struct let name = ["pending"] end))
(I)
(Set)
module Validation_time =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct let name = ["validation_time"] end)
(Store_helpers.Make_value(Time))
end
(**************************************************************************
* Operation store under "net/<id>/operations/"
**************************************************************************)
module Operation = struct
module Value = Store_helpers.Make_value(Operation)
let compare o1 o2 =
let (>>) x y = if x = 0 then y () else x in
Net_id.compare o1.Operation.shell.net_id o2.Operation.shell.net_id >> fun () ->
MBytes.compare o1.proto o2.proto
let equal b1 b2 = compare b1 b2 = 0
let hash op = Operation_hash.hash_bytes [Value.to_bytes op]
let hash_raw bytes = Operation_hash.hash_bytes [bytes]
type store = Net.store
let get x = x
include
Make_data_store
(Store_helpers.Make_substore
(Net.Indexed_store.Store)
(struct let name = ["operations"] end))
(Operation_hash)
(Value)
(Operation_hash.Set)
let register s =
Base58.register_resolver Operation_hash.b58check_encoding begin fun str ->
let pstr = Operation_hash.prefix_path str in
Net.Indexed_store.fold_indexes s ~init:[]
~f:begin fun net acc ->
Indexed_store.resolve_index (s, net) pstr >>= fun l ->
Lwt.return (List.rev_append l acc)
end
end
end
(**************************************************************************
* Block_header store under "net/<id>/blocks/"
**************************************************************************)
module Block_header = struct
module Value = Store_helpers.Make_value(Block_header)
let compare b1 b2 =
let (>>) x y = if x = 0 then y () else x in
let rec list compare xs ys =
match xs, ys with
| [], [] -> 0
| _ :: _, [] -> -1
| [], _ :: _ -> 1
| x :: xs, y :: ys ->
compare x y >> fun () -> list compare xs ys in
Block_hash.compare b1.Block_header.shell.predecessor b2.Block_header.shell.predecessor >> fun () ->
compare b1.proto b2.proto >> fun () ->
Operation_list_list_hash.compare
b1.shell.operations_hash b2.shell.operations_hash >> fun () ->
Time.compare b1.shell.timestamp b2.shell.timestamp >> fun () ->
list compare b1.shell.fitness b2.shell.fitness
let equal b1 b2 = compare b1 b2 = 0
let hash block = Block_hash.hash_bytes [Value.to_bytes block]
let hash_raw bytes = Block_hash.hash_bytes [bytes]
module Block = struct
type store = Net.store
let get x = x
include Make_data_store
module Indexed_store =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Net.Indexed_store.Store)
(struct let name = ["blocks"] end))
(Block_hash)
(Value)
(Block_hash.Set)
module Operation_list_count =
type contents = {
header: Block_header.t ;
message: string ;
operation_list_count: int ;
}
module Contents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct let name = ["operation_list_count"] end)
(struct let name = ["contents"] end)
(Store_helpers.Make_value(struct
type t = int
let encoding = Data_encoding.int8
type t = contents
let encoding =
let open Data_encoding in
conv
(fun { header ; message ; operation_list_count } ->
(message, operation_list_count, header))
(fun (message, operation_list_count, header) ->
{ header ; message ; operation_list_count })
(obj3
(req "message" string)
(req "operation_list_count" uint8)
(req "header" Block_header.encoding))
end))
module Operations_index =
@ -265,15 +114,15 @@ module Block_header = struct
(struct let name = ["operations"] end))
(Store_helpers.Integer_index)
module Operation_list =
module Operation_hashes =
Operations_index.Make_map
(struct let name = ["list"] end)
(struct let name = ["hashes"] end)
(Store_helpers.Make_value(struct
type t = Operation_hash.t list
let encoding = Data_encoding.list Operation_hash.encoding
end))
module Operation_list_path =
module Operation_path =
Operations_index.Make_map
(struct let name = ["path"] end)
(Store_helpers.Make_value(struct
@ -281,6 +130,35 @@ module Block_header = struct
let encoding = Operation_list_list_hash.path_encoding
end))
module Operations =
Operations_index.Make_map
(struct let name = ["contents"] end)
(Store_helpers.Make_value(struct
type t = Operation.t list
let encoding = Data_encoding.(list (dynamic_size Operation.encoding))
end))
type invalid_block = {
level: int32 ;
(* errors: Error_monad.error list ; *)
}
module Invalid_block =
Store_helpers.Make_map
(Store_helpers.Make_substore
(Net.Indexed_store.Store)
(struct let name = ["invalid_blocks"] end))
(Block_hash)
(Store_helpers.Make_value(struct
type t = invalid_block
let encoding =
let open Data_encoding in
conv
(fun { level } -> (level))
(fun (level) -> { level })
int32
end))
let register s =
Base58.register_resolver Block_hash.b58check_encoding begin fun str ->
let pstr = Block_hash.prefix_path str in
@ -317,17 +195,11 @@ module Chain = struct
(struct let name = ["current_head"] end)
(Store_helpers.Make_value(Block_hash))
module Successor_in_chain =
module In_chain =
Store_helpers.Make_single_store
(Block_header.Indexed_store.Store)
(struct let name = ["successor_in_chain"] end)
(Store_helpers.Make_value(Block_hash))
module In_chain_insertion_time =
Store_helpers.Make_single_store
(Block_header.Indexed_store.Store)
(struct let name = ["in_chain_insertion_time"] end)
(Store_helpers.Make_value(Time))
(Block.Indexed_store.Store)
(struct let name = ["in_chain"] end)
(Store_helpers.Make_value(Block_hash)) (* successor *)
end
@ -338,19 +210,26 @@ end
module Protocol = struct
include Protocol
let hash_raw bytes = Protocol_hash.hash_bytes [bytes]
type store = global_store
let get x = x
include Make_data_store
module Indexed_store =
Store_helpers.Make_indexed_substore
(Store_helpers.Make_substore
(Raw_store)
(struct let name = ["protocols"] end))
(Protocol_hash)
module Contents =
Indexed_store.Make_map
(struct let name = ["contents"] end)
(Store_helpers.Make_value(Protocol))
(Protocol_hash.Set)
module RawContents =
Store_helpers.Make_single_store
(Indexed_store.Store)
(struct let name = ["contents"] end)
(Store_helpers.Raw_value)
let register s =
Base58.register_resolver Protocol_hash.b58check_encoding begin fun str ->
@ -358,13 +237,11 @@ module Protocol = struct
Indexed_store.resolve_index s pstr
end
end
let init dir =
Raw_store.init dir >>=? fun s ->
Block_header.register s ;
Operation.register s ;
Block.register s ;
Protocol.register s ;
return s

114
src/node/db/store.mli
View File

@ -8,6 +8,7 @@
(**************************************************************************)
open Store_sigs
open Tezos_data
type t
type global_store = t
@ -70,101 +71,55 @@ module Chain : sig
and type elt := Block_hash.t
and module Set := Block_hash.Set
module Successor_in_chain : SINGLE_STORE
module In_chain : SINGLE_STORE
with type t = store * Block_hash.t
and type value := Block_hash.t
module In_chain_insertion_time : SINGLE_STORE
with type t = store * Block_hash.t
and type value := Time.t
end
(** {2 Generic signature} *****************************************************)
(** Generic signature for Operations, Block_header, and Protocol "tracked"
contents (i.e. with 'discovery_time', 'validtity', ...) *)
module type DATA_STORE = sig
type store
type key
type key_set
type value
module Discovery_time : MAP_STORE
with type t := store
and type key := key
and type value := Time.t
module Contents : SINGLE_STORE
with type t = store * key
and type value := value
module RawContents : SINGLE_STORE
with type t = store * key
and type value := MBytes.t
module Validation_time : SINGLE_STORE
with type t = store * key
and type value := Time.t
module Errors : MAP_STORE
with type t := store
and type key := key
and type value = error list
module Pending : BUFFERED_SET_STORE
with type t = store
and type elt := key
and type Set.t = key_set
end
(** {2 Operation store} *****************************************************)
module Operation : sig
type store
val get: Net.store -> store
include DATA_STORE
with type store := store
and type key = Operation_hash.t
and type value = Operation.t
and type key_set = Operation_hash.Set.t
and type value := Block_hash.t (* successor *)
end
(** {2 Block header store} **************************************************)
module Block_header : sig
module Block : sig
type store
val get: Net.store -> store
include DATA_STORE
with type store := store
and type key = Block_hash.t
and type value = Block_header.t
and type key_set = Block_hash.Set.t
type contents = {
header: Block_header.t ;
message: string ;
operation_list_count: int ;
}
module Operation_list_count : SINGLE_STORE
module Contents : SINGLE_STORE
with type t = store * Block_hash.t
and type value = int
and type value := contents
module Operation_list : MAP_STORE
module Operation_hashes : MAP_STORE
with type t = store * Block_hash.t
and type key = int
and type value = Operation_hash.t list
module Operation_list_path : MAP_STORE
module Operation_path : MAP_STORE
with type t = store * Block_hash.t
and type key = int
and type value = Operation_list_list_hash.path
module Operations : MAP_STORE
with type t = store * Block_hash.t
and type key = int
and type value = Operation.t list
type invalid_block = {
level: int32 ;
(* errors: Error_monad.error list ; *)
}
module Invalid_block : MAP_STORE
with type t = store
and type key = Block_hash.t
and type value = invalid_block
end
@ -175,10 +130,13 @@ module Protocol : sig
type store
val get: global_store -> store
include DATA_STORE
with type store := store
and type key = Protocol_hash.t
and type value = Protocol.t
and type key_set = Protocol_hash.Set.t
module Contents : MAP_STORE
with type t := store
and type key := Protocol_hash.t
and type value := Protocol.t
module RawContents : SINGLE_STORE
with type t = store * Protocol_hash.t
and type value := MBytes.t
end

6
src/node/db/store_helpers.ml
View File

@ -23,6 +23,12 @@ module Make_value (V : ENCODED_VALUE) = struct
MBytes.create 0
end
module Raw_value = struct
type t = MBytes.t
let of_bytes b = ok b
let to_bytes b = b
end
module Make_single_store (S : STORE) (N : NAME) (V : VALUE) = struct
type t = S.t
type value = V.t

2
src/node/db/store_helpers.mli
View File

@ -11,6 +11,8 @@ open Store_sigs
module Make_value (V : ENCODED_VALUE) : VALUE with type t = V.t
module Raw_value : VALUE with type t = MBytes.t
module Make_single_store (S : STORE) (N : NAME) (V : VALUE)
: SINGLE_STORE with type t = S.t
and type value = V.t

2
src/node/net/p2p.ml
View File

@ -463,7 +463,7 @@ module RPC = struct
let connect net point timeout =
match net.pool with
| None -> fail (Unclassified "fake net")
| None -> failwith "fake net"
| Some pool ->
P2p_connection_pool.connect ~timeout pool point >>|? ignore

95
src/node/shell/chain.ml Normal file
View File

@ -0,0 +1,95 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Logging.Node.State
open State
let genesis net_state =
let genesis = Net.genesis net_state in
Block.read_exn net_state genesis.block
let known_heads net_state =
read_chain_store net_state begin fun chain_store _data ->
Store.Chain.Known_heads.elements chain_store
end >>= fun hashes ->
Lwt_list.map_p (Block.read_exn net_state) hashes
let head net_state =
read_chain_store net_state begin fun _chain_store data ->
Lwt.return data.current_head
end
let mem net_state hash =
read_chain_store net_state begin fun chain_store data ->
if Block_hash.equal (Block.hash data.current_head) hash then
Lwt.return true
else
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
if Block_hash.equal hash ancestor then
Lwt.return_unit
else
lwt_debug "pop_block %a" Block_hash.pp_short hash >>= fun () ->
Store.Chain.In_chain.remove (chain_store, hash) >>= fun () ->
Block.predecessor block >>= function
| Some predecessor ->
pop_blocks ancestor predecessor
| None -> assert false (* Cannot pop the genesis... *)
in
let push_block pred_hash block =
let hash = Block.hash block in
lwt_debug "push_block %a" Block_hash.pp_short hash >>= fun () ->
Store.Chain.In_chain.store (chain_store, pred_hash) hash >>= fun () ->
Lwt.return hash
in
Chain_traversal.new_blocks
data.current_head block >>= fun (ancestor, path) ->
let ancestor = Block.hash ancestor in
pop_blocks ancestor data.current_head >>= fun () ->
Lwt_list.fold_left_s push_block ancestor path >>= fun _ ->
Store.Chain.Current_head.store chain_store (Block.hash block)
let set_head net_state block =
update_chain_store net_state begin fun chain_store data ->
locked_set_head chain_store data block >>= fun () ->
Lwt.return (Some { current_head = block }, ())
end
let test_and_set_head net_state ~old block =
update_chain_store net_state begin fun chain_store data ->
if not (Block.equal data.current_head old) then
Lwt.return (None, false)
else
locked_set_head chain_store data block >>= fun () ->
Lwt.return (Some { current_head = block }, true)
end

37
src/node/shell/chain.mli Normal file
View File

@ -0,0 +1,37 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open State
val genesis: Net.t -> Block.t Lwt.t
(** The genesis block of the network's blockchain. On a test network,
the test protocol has been promoted as "main" protocol. *)
val head: Net.t -> Block.t Lwt.t
(** The current head of the network's blockchain. *)
val known_heads: Net.t -> Block.t list Lwt.t
val set_head: Net.t -> Block.t -> unit Lwt.t
(** Record a block as the current head of the network's blockchain. *)
val mem: Net.t -> Block_hash.t -> bool Lwt.t
val test_and_set_head:
Net.t -> old:Block.t -> Block.t -> bool Lwt.t
(** 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]. *)

134
src/node/shell/chain_traversal.ml Normal file
View File

@ -0,0 +1,134 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open State
let path (b1: Block.t) (b2: Block.t) =
if not (Net_id.equal (Block.net_id b1) (Block.net_id b2)) then
invalid_arg "Chain_traversal.path" ;
let rec loop acc current =
if Block.equal b1 current then
Lwt.return (Some acc)
else
Block.predecessor current >>= function
| Some pred -> loop (current :: acc) pred
| None -> Lwt.return_none in
loop [] b2
let common_ancestor (b1: Block.t) (b2: Block.t) =
if not ( Net_id.equal (Block.net_id b1) (Block.net_id b2)) then
invalid_arg "Chain_traversal.path" ;
let rec loop (b1: Block.t) (b2: Block.t) =
if Block.equal b1 b2 then
Lwt.return b1
else if Time.(Block.timestamp b1 <= Block.timestamp b2) then
Block.predecessor b2 >>= function
| None -> assert false
| Some b2 -> loop b1 b2
else
Block.predecessor b1 >>= function
| None -> assert false
| 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 =
match Fitness.compare (Block.fitness b1) (Block.fitness b2) with
| 0 -> begin
match Time.compare (Block.timestamp b1) (Block.timestamp b2) with
| 0 -> Block.compare b1 b2
| res -> res
end
| res -> res in
let pop, push =
(* Poor-man priority queue *)
let queue : Block.t list ref = ref [] in
let pop () =
match !queue with
| [] -> None
| b :: bs -> queue := bs ; Some b in
let push b =
let rec loop = function
| [] -> [b]
| b' :: bs' as bs ->
let cmp = compare b b' in
if cmp = 0 then
bs
else if cmp < 0 then
b' :: loop bs'
else
b :: bs in
queue := loop !queue in
pop, push in
let check_count =
match max with
| None -> (fun () -> ())
| Some max ->
let cpt = ref 0 in
fun () ->
if !cpt >= max then raise Local.Exit ;
incr cpt in
let check_fitness =
match min_fitness with
| None -> (fun _ -> true)
| Some min_fitness ->
(fun b -> Fitness.compare min_fitness (Block.fitness b) <= 0) in
let check_date =
match min_date with
| None -> (fun _ -> true)
| Some min_date ->
(fun b -> Time.(min_date <= Block.timestamp b)) in
let rec loop () =
match pop () with
| None -> Lwt.return ()
| Some b ->
check_count () ;
f b >>= fun () ->
Block.predecessor b >>= function
| None -> loop ()
| Some p ->
if check_fitness p && check_date p then push p ;
loop () in
List.iter push heads ;
try loop () with Local.Exit -> Lwt.return ()
let iter_predecessors ?max ?min_fitness ?min_date heads ~f =
match heads with
| [] -> Lwt.return_unit
| b :: _ ->
let net_id = Block.net_id b in
if not (List.for_all (fun b -> Net_id.equal net_id (Block.net_id b)) heads) then
invalid_arg "State.Helpers.iter_predecessors" ;
iter_predecessors ?max ?min_fitness ?min_date heads ~f
let new_blocks ~from_block ~to_block =
common_ancestor from_block to_block >>= fun ancestor ->
path ancestor to_block >>= function
| None -> assert false
| Some path -> Lwt.return (ancestor, path)

48
src/node/shell/chain_traversal.mli Normal file
View File

@ -0,0 +1,48 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2016. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open State
val path: Block.t -> Block.t -> Block.t list option Lwt.t
(** If [h1] is an ancestor of [h2] in the current [state],
then [path state h1 h2] returns the chain of block from
[h1] (excluded) to [h2] (included). Returns [None] otherwise. *)
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 ->
?min_date:Time.t ->
Block.t list ->
f:(Block.t -> unit Lwt.t) ->
unit Lwt.t
(** [iter_predecessors state blocks f] iter [f] on [blocks] and
their recursive predecessors. Blocks are visited with a
decreasing fitness (then decreasing timestamp). If the optional
argument [max] is provided, the iteration is stopped after [max]
visited block. If [min_fitness] id provided, blocks with a
fitness lower than [min_fitness] are ignored. If [min_date],
blocks with a fitness lower than [min_date] are ignored. *)
val new_blocks:
from_block:Block.t -> to_block:Block.t ->
(Block.t * Block.t list) Lwt.t
(** [new_blocks ~from_block ~to_block] returns a pair [(ancestor,
path)], where [ancestor] is the common ancestor of [from_block]
and [to_block] and where [path] is the chain from [ancestor]
(excluded) to [to_block] (included). The function raises an
exception when the two provided blocks do not belong the the same
[net]. *)

715
src/node/shell/distributed_db.ml
View File

@ -66,40 +66,84 @@ module Make_raw
end
module No_precheck = struct
type param = unit
let precheck _ _ _ = true
module Fake_operation_storage = struct
type store = State.Net.t
type key = Operation_hash.t
type value = Operation.t
let known _ _ = Lwt.return_false
let read _ _ = Lwt.return (Error_monad.error_exn Not_found)
let read_opt _ _ = Lwt.return_none
let read_exn _ _ = raise Not_found
end
module Raw_operation =
Make_raw
(Operation_hash)
(struct
type value = Operation.t
include State.Operation
end)
(Fake_operation_storage)
(Operation_hash.Table)
(struct
type param = Net_id.t
let forge net_id keys = Message.Get_operations (net_id, keys)
end)
(No_precheck)
(struct
type param = unit
type notified_value = Operation.t
let precheck _ _ v = Some v
end)
module Block_header_storage = struct
type store = State.Net.t
type key = Block_hash.t
type value = Block_header.t
let known = State.Block.known_valid
let read net_state h =
State.Block.read net_state h >>=? fun b ->
return (State.Block.header b)
let read_opt net_state h =
State.Block.read_opt net_state h >>= fun b ->
Lwt.return (Utils.map_option State.Block.header b)
let read_exn net_state h =
State.Block.read_exn net_state h >>= fun b ->
Lwt.return (State.Block.header b)
end
module Raw_block_header =
Make_raw
(Block_hash)
(struct
type value = Block_header.t
include State.Block_header
end)
(Block_header_storage)
(Block_hash.Table)
(struct
type param = Net_id.t
let forge net_id keys = Message.Get_block_headers (net_id, keys)
end)
(No_precheck)
(struct
type param = unit
type notified_value = Block_header.t
let precheck _ _ v = Some v
end)
module Operation_list_table =
module Operation_hashes_storage = struct
type store = State.Net.t
type key = Block_hash.t * int
type value = Operation_hash.t list
let known net_state (h, _) = State.Block.known_valid net_state h
let read net_state (h, i) =
State.Block.read net_state h >>=? fun b ->
State.Block.operation_hashes b i >>= fun (ops, _) ->
return ops
let read_opt net_state (h, i) =
State.Block.read_opt net_state h >>= function
| None -> Lwt.return_none
| Some b ->
State.Block.operation_hashes b i >>= fun (ops, _) ->
Lwt.return (Some ops)
let read_exn net_state (h, i) =
State.Block.read_exn net_state h >>= fun b ->
State.Block.operation_hashes b i >>= fun (ops, _) ->
Lwt.return ops
end
module Operations_table =
Hashtbl.Make(struct
type t = Block_hash.t * int
let hash = Hashtbl.hash
@ -107,39 +151,134 @@ module Operation_list_table =
Block_hash.equal b1 b2 && i1 = i2
end)
module Raw_operation_list =
Make_raw
(struct type t = Block_hash.t * int end)
(State.Operation_list)
(Operation_list_table)
(struct
type param = Net_id.t
let forge net_id keys =
Message.Get_operation_list (net_id, keys)
end)
(struct
type param = Operation_list_list_hash.t
let precheck (_block, expected_ofs) expected_hash (ops, path) =
let received_hash, received_ofs =
Operation_list_list_hash.check_path path
(Operation_list_hash.compute ops) in
received_ofs = expected_ofs &&
Operation_list_list_hash.compare expected_hash received_hash = 0
end)
module Raw_operation_hashes = struct
include
Make_raw
(struct type t = Block_hash.t * int end)
(Operation_hashes_storage)
(Operations_table)
(struct
type param = Net_id.t
let forge net_id keys =
Message.Get_operation_hashes_for_blocks (net_id, keys)
end)
(struct
type param = Operation_list_list_hash.t
type notified_value =
Operation_hash.t list * Operation_list_list_hash.path
let precheck (_block, expected_ofs) expected_hash (ops, path) =
let received_hash, received_ofs =
Operation_list_list_hash.check_path path
(Operation_list_hash.compute ops) in
if
received_ofs = expected_ofs &&
Operation_list_list_hash.compare expected_hash received_hash = 0
then
Some ops
else
None
end)
let inject_all table hash operations =
Lwt_list.mapi_p
(fun i ops -> Table.inject table (hash, i) ops)
operations >>= Lwt_list.for_all_s (fun x -> Lwt.return x)
let read_all table hash n =
map_p (fun i -> Table.read table (hash, i)) (0 -- (n-1))
let remove_all table hash n =
Lwt_list.iter_p (fun i -> Table.remove table (hash, i)) (0 -- (n-1))
end
module Operations_storage = struct
type store = State.Net.t
type key = Block_hash.t * int
type value = Operation.t list
let known net_state (h, _) = State.Block.known_valid net_state h
let read net_state (h, i) =
State.Block.read net_state h >>=? fun b ->
State.Block.operations b i >>= fun (ops, _) ->
return ops
let read_opt net_state (h, i) =
State.Block.read_opt net_state h >>= function
| None -> Lwt.return_none
| Some b ->
State.Block.operations b i >>= fun (ops, _) ->
Lwt.return (Some ops)
let read_exn net_state (h, i) =
State.Block.read_exn net_state h >>= fun b ->
State.Block.operations b i >>= fun (ops, _) ->
Lwt.return ops
end
module Raw_operations = struct
include
Make_raw
(struct type t = Block_hash.t * int end)
(Operations_storage)
(Operations_table)
(struct
type param = Net_id.t
let forge net_id keys =
Message.Get_operations_for_blocks (net_id, keys)
end)
(struct
type param = Operation_list_list_hash.t
type notified_value = Operation.t list * Operation_list_list_hash.path
let precheck (_block, expected_ofs) expected_hash (ops, path) =
let received_hash, received_ofs =
Operation_list_list_hash.check_path path
(Operation_list_hash.compute
(List.map Operation.hash ops)) in
if
received_ofs = expected_ofs &&
Operation_list_list_hash.compare expected_hash received_hash = 0
then
Some ops
else
None
end)
let inject_all table hash operations =
Lwt_list.mapi_p
(fun i ops -> Table.inject table (hash, i) ops)
operations >>= Lwt_list.for_all_s (fun x -> Lwt.return x)
let read_all table hash n =
map_p (fun i -> Table.read table (hash, i)) (0 -- (n-1))
let remove_all table hash n =
Lwt_list.iter_p (fun i -> Table.remove table (hash, i)) (0 -- (n-1))
end
module Protocol_storage = struct
type store = State.t
type key = Protocol_hash.t
type value = Protocol.t
let known = State.Protocol.known
let read = State.Protocol.read
let read_opt = State.Protocol.read_opt
let read_exn = State.Protocol.read_exn
end
module Raw_protocol =
Make_raw
(Protocol_hash)
(struct
type value = Protocol.t
include State.Protocol
end)
(Protocol_storage)
(Protocol_hash.Table)
(struct
type param = unit
let forge () keys = Message.Get_protocols keys
end)
(No_precheck)
(struct
type param = unit
type notified_value = Protocol.t
let precheck _ _ v = Some v
end)
type callback = {
notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ;
@ -153,18 +292,19 @@ type db = {
p2p: p2p ;
p2p_readers: p2p_reader P2p.Peer_id.Table.t ;
disk: State.t ;
active_nets: net Net_id.Table.t ;
active_nets: net_db Net_id.Table.t ;
protocol_db: Raw_protocol.t ;
block_input: (Block_hash.t * Block_header.t) Watcher.input ;
operation_input: (Operation_hash.t * Operation.t) Watcher.input ;
}
and net = {
net: State.Net.t ;
and net_db = {
net_state: State.Net.t ;
global_db: db ;
operation_db: Raw_operation.t ;
block_header_db: Raw_block_header.t ;
operation_list_db: Raw_operation_list.t ;
operation_hashes_db: Raw_operation_hashes.t ;
operations_db: Raw_operations.t ;
callback: callback ;
active_peers: P2p.Peer_id.Set.t ref ;
active_connections: p2p_reader P2p.Peer_id.Table.t ;
@ -173,14 +313,14 @@ and net = {
and p2p_reader = {
gid: P2p.Peer_id.t ;
conn: connection ;
peer_active_nets: net Net_id.Table.t ;
peer_active_nets: net_db Net_id.Table.t ;
canceler: Lwt_utils.Canceler.t ;
mutable worker: unit Lwt.t ;
}
type t = db
let state { net } = net
let state { net_state } = net_state
module P2p_reader = struct
@ -248,7 +388,12 @@ module P2p_reader = struct
| Current_branch (net_id, locator) ->
may_activate global_db state net_id @@ fun net_db ->
net_db.callback.notify_branch state.gid locator ;
Lwt_list.exists_p
(State.Block.known_invalid net_db.net_state)
locator >>= fun known_invalid ->
if not known_invalid then
net_db.callback.notify_branch state.gid locator ;
(* TODO Kickban *)
Lwt.return_unit
| Deactivate net_id ->
@ -267,22 +412,23 @@ module P2p_reader = struct
| Current_head (net_id, head, mempool) ->
may_handle state net_id @@ fun net_db ->
net_db.callback.notify_head state.gid head mempool ;
State.Block.known_invalid net_db.net_state head >>= fun known_invalid ->
if not known_invalid then
net_db.callback.notify_head state.gid head mempool ;
(* TODO Kickban *)
Lwt.return_unit
| Get_block_headers (net_id, hashes) ->
may_handle state net_id @@ fun net_db ->
(* Should we filter out invalid block ? *)
(* Should we filter out blocks whose validity is unknown ? *)
(* Should we blame request of unadvertised blocks ? *)
(* TODO: Blame request of unadvertised blocks ? *)
Lwt_list.iter_p
(fun hash ->
Raw_block_header.Table.read
net_db.block_header_db.table hash >|= function
State.Block.read_opt net_db.net_state hash >|= function
| None -> ()
| Some p ->
| Some b ->
let header = State.Block.header b in
ignore @@
P2p.try_send global_db.p2p state.conn (Block_header p))
P2p.try_send global_db.p2p state.conn (Block_header header))
hashes
| Block_header block ->
@ -294,9 +440,10 @@ module P2p_reader = struct
| Get_operations (net_id, hashes) ->
may_handle state net_id @@ fun net_db ->
(* TODO: only answers for prevalidated operations *)
Lwt_list.iter_p
(fun hash ->
Raw_operation.Table.read
Raw_operation.Table.read_opt
net_db.operation_db.table hash >|= function
| None -> ()
| Some p ->
@ -314,8 +461,7 @@ module P2p_reader = struct
| Get_protocols hashes ->
Lwt_list.iter_p
(fun hash ->
Raw_protocol.Table.read
global_db.protocol_db.table hash >|= function
State.Protocol.read_opt global_db.disk hash >|= function
| None -> ()
| Some p ->
ignore @@
@ -328,22 +474,23 @@ module P2p_reader = struct
global_db.protocol_db.table state.gid hash protocol >>= fun () ->
Lwt.return_unit
| Get_operation_list (net_id, hashes) ->
| Get_operation_hashes_for_blocks (net_id, blocks) ->
may_handle state net_id @@ fun net_db ->
(* TODO: Blame request of unadvertised blocks ? *)
Lwt_list.iter_p
(fun (block, ofs as key) ->
Raw_operation_list.Table.read
net_db.operation_list_db.table key >>= function
(fun (hash, ofs) ->
State.Block.read_opt net_db.net_state hash >>= function
| None -> Lwt.return_unit
| Some (ops, path) ->
| Some b ->
State.Block.operation_hashes b ofs >>= fun (hashes, path) ->
ignore @@
P2p.try_send
global_db.p2p state.conn
(Operation_list (net_id, block, ofs, ops, path)) ;
P2p.try_send global_db.p2p state.conn
(Operation_hashes_for_block
(net_id, hash, ofs, hashes, path)) ;
Lwt.return_unit)
hashes
blocks
| Operation_list (net_id, block, ofs, ops, path) ->
| Operation_hashes_for_block (net_id, block, ofs, ops, path) -> begin
may_handle state net_id @@ fun net_db ->
(* TODO early detection of non-requested list. *)
let found_hash, found_ofs =
@ -352,7 +499,46 @@ module P2p_reader = struct
if found_ofs <> ofs then
Lwt.return_unit
else
Raw_block_header.Table.read
Raw_block_header.Table.read_opt
net_db.block_header_db.table block >>= function
| None -> Lwt.return_unit
| Some bh ->
if Operation_list_list_hash.compare
found_hash bh.shell.operations_hash <> 0 then
Lwt.return_unit
else
Raw_operation_hashes.Table.notify
net_db.operation_hashes_db.table state.gid
(block, ofs) (ops, path) >>= fun () ->
Lwt.return_unit
end
| Get_operations_for_blocks (net_id, blocks) ->
may_handle state net_id @@ fun net_db ->
(* TODO: Blame request of unadvertised blocks ? *)
Lwt_list.iter_p
(fun (hash, ofs) ->
State.Block.read_opt net_db.net_state hash >>= function
| None -> Lwt.return_unit
| Some b ->
State.Block.operations b ofs >>= fun (hashes, path) ->
ignore @@
P2p.try_send global_db.p2p state.conn
(Operations_for_block
(net_id, hash, ofs, hashes, path)) ;
Lwt.return_unit)
blocks
| Operations_for_block (net_id, block, ofs, ops, path) ->
may_handle state net_id @@ fun net_db ->
(* TODO early detection of non-requested operations. *)
let found_hash, found_ofs =
Operation_list_list_hash.check_path
path (Operation_list_hash.compute (List.map Operation.hash ops)) in
if found_ofs <> ofs then
Lwt.return_unit
else
Raw_block_header.Table.read_opt
net_db.block_header_db.table block >>= function
| None -> Lwt.return_unit
| Some bh ->
@ -360,8 +546,8 @@ module P2p_reader = struct
found_hash bh.shell.operations_hash <> 0 then
Lwt.return_unit
else
Raw_operation_list.Table.notify
net_db.operation_list_db.table state.gid
Raw_operations.Table.notify
net_db.operations_db.table state.gid
(block, ofs) (ops, path) >>= fun () ->
Lwt.return_unit
@ -435,28 +621,30 @@ let create disk p2p =
P2p.iter_connections p2p (P2p_reader.run db) ;
db
let activate ~callback ({ p2p ; active_nets } as global_db) net =
let net_id = State.Net.id net in
let activate ~callback ({ p2p ; active_nets } as global_db) net_state =
let net_id = State.Net.id net_state in
match Net_id.Table.find active_nets net_id with
| exception Not_found ->
let active_peers = ref P2p.Peer_id.Set.empty in
let p2p_request =
let net_id = State.Net.id net in
{ data = net_id ;
active = (fun () -> !active_peers) ;
send = raw_try_send p2p ;
} in
let operation_db =
Raw_operation.create
~global_input:global_db.operation_input p2p_request net in
~global_input:global_db.operation_input p2p_request net_state in
let block_header_db =
Raw_block_header.create
~global_input:global_db.block_input p2p_request net in
let operation_list_db =
Raw_operation_list.create p2p_request net in
~global_input:global_db.block_input p2p_request net_state in
let operation_hashes_db =
Raw_operation_hashes.create p2p_request net_state in
let operations_db =
Raw_operations.create p2p_request net_state in
let net = {
global_db ; operation_db ; block_header_db ; operation_list_db ;
net ; callback ; active_peers ;
global_db ; operation_db ; block_header_db ;
operation_hashes_db ; operations_db ;
net_state ; callback ; active_peers ;
active_connections = P2p.Peer_id.Table.create 53 ;
} in
P2p.iter_connections p2p (fun _peer_id conn ->
@ -468,19 +656,19 @@ let activate ~callback ({ p2p ; active_nets } as global_db) net =
| net ->
net
let deactivate net =
let { active_nets ; p2p } = net.global_db in
let net_id = State.Net.id net.net in
let deactivate net_db =
let { active_nets ; p2p } = net_db.global_db in
let net_id = State.Net.id net_db.net_state in
Net_id.Table.remove active_nets net_id ;
P2p.Peer_id.Table.iter
(fun _peer_id reader ->
P2p_reader.deactivate reader net ;
P2p_reader.deactivate reader net_db ;
Lwt.async begin fun () ->
P2p.send p2p reader.conn (Deactivate net_id)
end)
net.active_connections ;
Raw_operation.shutdown net.operation_db >>= fun () ->
Raw_block_header.shutdown net.block_header_db >>= fun () ->
net_db.active_connections ;
Raw_operation.shutdown net_db.operation_db >>= fun () ->
Raw_block_header.shutdown net_db.block_header_db >>= fun () ->
Lwt.return_unit >>= fun () ->
Lwt.return_unit
@ -504,212 +692,133 @@ let shutdown { p2p ; p2p_readers ; active_nets } =
P2p.shutdown p2p >>= fun () ->
Lwt.return_unit
module type PARAMETRIZED_DISTRIBUTED_DB =
Distributed_db_functors.PARAMETRIZED_DISTRIBUTED_DB
module type DISTRIBUTED_DB =
Distributed_db_functors.DISTRIBUTED_DB
let read_all_operations net_db hash n =
Lwt_list.map_p
(fun i ->
Raw_operations.Table.read_opt net_db.operations_db.table (hash, i))
(0 -- (n-1)) >>= fun operations ->
mapi_p
(fun i ops ->
match ops with
| Some ops -> return ops
| None ->
Raw_operation_hashes.Table.read
net_db.operation_hashes_db.table (hash, i) >>=? fun hashes ->
map_p (Raw_operation.Table.read net_db.operation_db.table) hashes)
operations
module Make
(Table : PARAMETRIZED_DISTRIBUTED_DB with type param := unit)
(Kind : sig
type t
val proj: t -> Table.t
end) = struct
type t = Kind.t
type key = Table.key
type value = Table.value
let known t k = Table.known (Kind.proj t) k
let read t k = Table.read (Kind.proj t) k
let read_exn t k = Table.read_exn (Kind.proj t) k
let prefetch t ?peer k = Table.prefetch (Kind.proj t) ?peer k ()
let fetch t ?peer k = Table.fetch (Kind.proj t) ?peer k ()
let commit t k = Table.commit (Kind.proj t) k
let inject t k v = Table.inject (Kind.proj t) k v
let watch t = Table.watch (Kind.proj t)
end
let commit_block net_db hash n validation_result =
Raw_block_header.Table.read
net_db.block_header_db.table hash >>=? fun header ->
read_all_operations net_db hash n >>=? fun operations ->
State.Block.store
net_db.net_state header operations validation_result >>=? fun res ->
Raw_block_header.Table.remove
net_db.block_header_db.table hash >>= fun () ->
Raw_operation_hashes.remove_all
net_db.operation_hashes_db.table hash n >>= fun () ->
Raw_operations.remove_all
net_db.operations_db.table hash n >>= fun () ->
(* TODO: proper handling of the operations table by the prevalidator. *)
Lwt_list.iter_p
(Lwt_list.iter_p
(fun op -> Raw_operation.Table.remove
net_db.operation_db.table
(Operation.hash op)))
operations >>= fun () ->
return res
module Operation =
Make (Raw_operation.Table) (struct
type t = net
let proj net = net.operation_db.table
end)
let commit_invalid_block net_db hash n =
Raw_block_header.Table.read
net_db.block_header_db.table hash >>=? fun header ->
State.Block.store_invalid net_db.net_state header >>=? fun res ->
Raw_block_header.Table.remove
net_db.block_header_db.table hash >>= fun () ->
Raw_operation_hashes.remove_all
net_db.operation_hashes_db.table hash n >>= fun () ->
Raw_operations.remove_all
net_db.operations_db.table hash n >>= fun () ->
return res
module Block_header =
Make (Raw_block_header.Table) (struct
type t = net
let proj net = net.block_header_db.table
end)
let inject_operation net_db h op =
fail_unless
(Net_id.equal op.Operation.shell.net_id (State.Net.id net_db.net_state))
(failure "Inconsitent net_id in operation") >>=? fun () ->
Raw_operation.Table.inject net_db.operation_db.table h op >>= fun res ->
return res
module Protocol =
Make (Raw_protocol.Table) (struct
type t = db
let proj db = db.protocol_db.table
end)
let inject_protocol db h p =
Raw_protocol.Table.inject db.protocol_db.table h p
module Operation_list = struct
let commit_protocol db h =
Raw_protocol.Table.read db.protocol_db.table h >>=? fun p ->
State.Protocol.store db.disk p >>= fun res ->
Raw_protocol.Table.remove db.protocol_db.table h >>= fun () ->
return (res <> None)
type t = net
type key = Block_hash.t * int
type value = Operation_hash.t list
type param = Operation_list_list_hash.t
type operation =
| Blob of Operation.t
| Hash of Operation_hash.t
let proj net = net.operation_list_db.table
let resolve_operation net_db = function
| Blob op ->
fail_unless
(Net_id.equal op.shell.net_id (State.Net.id net_db.net_state))
(failure "Inconsistent net_id in operation.") >>=? fun () ->
return (Operation.hash op, op)
| Hash oph ->
Raw_operation.Table.read net_db.operation_db.table oph >>=? fun op ->
return (oph, op)
module Table = Raw_operation_list.Table
let known t k = Table.known (proj t) k
let read t k =
Table.read (proj t) k >>= function
| None -> Lwt.return_none
| Some (op, _) -> Lwt.return (Some op)
let read_exn t k = Table.read_exn (proj t) k >|= fst
let prefetch t ?peer k p = Table.prefetch (proj t) ?peer k p
let fetch t ?peer k p = Table.fetch (proj t) ?peer k p >|= fst
let rec do_read net block acc i =
if i <= 0 then
Lwt.return acc
else
read_exn net (block, i-1) >>= fun ops ->
do_read net block (ops :: acc) (i-1)
let read_all_opt net block =
State.Operation_list.read_count_opt
net.net block >>= function
| None -> Lwt.return_none
| Some len -> do_read net block [] len >>= fun ops -> Lwt.return (Some ops)
let read_all_exn net block =
State.Operation_list.read_count_exn
net.net block >>= fun len ->
do_read net block [] len
let rec do_commit net block i =
if i <= 0 then
Lwt.return_unit
else
Raw_operation_list.Table.commit
net.operation_list_db.table (block, i-1) >>= fun () ->
do_commit net block (i-1)
let commit_all net block len =
State.Operation_list.store_count net.net block len >>= fun () ->
do_commit net block len
let inject_all net block opss =
State.Operation_list.read_count_opt net.net block >>= function
| Some _ -> Lwt.return_false
| None ->
let hashes = List.map Operation_list_hash.compute opss in
Lwt_list.mapi_p
(fun i ops ->
let path = Operation_list_list_hash.compute_path hashes i in
Raw_operation_list.Table.inject
net.operation_list_db.table
(block, i) (ops, path))
opss >>= fun injected ->
Lwt.return (List.for_all (fun x -> x) injected)
end
let inject_block t bytes operations =
let inject_block db bytes operations =
let hash = Block_hash.hash_bytes [bytes] in
match
Data_encoding.Binary.of_bytes Tezos_data.Block_header.encoding bytes
with
match Block_header.of_bytes bytes with
| None ->
failwith "Cannot parse block header."
| Some block ->
match get_net t block.shell.net_id with
match get_net db block.shell.net_id with
| None ->
failwith "Unknown network."
| Some net_db ->
Block_header.known net_db hash >>= function
| true ->
failwith "Previously injected block."
map_p
(map_p (resolve_operation net_db))
operations >>=? fun operations ->
let hashes = List.map (List.map fst) operations in
let operations = List.map (List.map snd) operations in
let computed_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute hashes) in
fail_when
(Operation_list_list_hash.compare
computed_hash block.shell.operations_hash <> 0)
(Exn (Failure "Incoherent operation list")) >>=? fun () ->
Raw_block_header.Table.inject
net_db.block_header_db.table hash block >>= function
| false ->
let computed_hash =
Operation_list_list_hash.compute
(List.map Operation_list_hash.compute operations) in
fail_unless
(Operation_list_list_hash.compare
computed_hash block.shell.operations_hash = 0)
(Exn (Failure "Incoherent operation list")) >>=? fun () ->
Raw_block_header.Table.inject
net_db.block_header_db.table hash block >>= function
| false ->
failwith "Previously injected block."
| true ->
Operation_list.inject_all
net_db hash operations >>= fun _ ->
return (hash, block)
(*
let inject_operation t bytes =
let hash = Operation_hash.hash_bytes [bytes] in
match Data_encoding.Binary.of_bytes Operation.encoding bytes with
| None ->
failwith "Cannot parse operations."
| Some op ->
match get_net t op.shell.net_id with
| None ->
failwith "Unknown network."
| Some net_db ->
Operation.known net_db hash >>= function
| true ->
failwith "Previously injected block."
| false ->
Raw_operation.Table.inject
net_db.operation_db.table hash op >>= function
| false ->
failwith "Previously injected block."
| true ->
return (hash, op)
*)
| true ->
Raw_operation_hashes.inject_all
net_db.operation_hashes_db.table hash hashes >>= fun _ ->
Raw_operations.inject_all
net_db.operations_db.table hash operations >>= fun _ ->
return (hash, block)
let broadcast_head net head mempool =
let remove_block net_db hash n =
Raw_operations.remove_all
net_db.operations_db.table hash n >>= fun () ->
Raw_operation_hashes.remove_all
net_db.operation_hashes_db.table hash n >>= fun () ->
Raw_block_header.Table.remove net_db.block_header_db.table hash
let broadcast_head net_db head mempool =
let msg : Message.t =
Current_head (State.Net.id net.net, head, mempool) in
Current_head (State.Net.id net_db.net_state, head, mempool) in
P2p.Peer_id.Table.iter
(fun _peer_id state ->
ignore (P2p.try_send net.global_db.p2p state.conn msg))
net.active_connections
ignore (P2p.try_send net_db.global_db.p2p state.conn msg))
net_db.active_connections
let read_block { active_nets } hash =
Net_id.Table.fold
(fun _net_id net acc ->
acc >>= function
| Some _ -> acc
| None ->
Block_header.read net hash >>= function
| None -> acc
| Some block -> Lwt.return (Some (net, block)))
active_nets
Lwt.return_none
let read_block_exn t hash =
read_block t hash >>= function
| None -> Lwt.fail Not_found
| Some b -> Lwt.return b
let read_operation { active_nets } hash =
Net_id.Table.fold
(fun _net_id net acc ->
acc >>= function
| Some _ -> acc
| None ->
Operation.read net hash >>= function
| None -> acc
| Some block -> Lwt.return (Some (net, block)))
active_nets
Lwt.return_none
let read_operation_exn t hash =
read_operation t hash >>= function
| None -> Lwt.fail Not_found
| Some b -> Lwt.return b
let watch_block { block_input } =
let watch_block_header { block_input } =
Watcher.create_stream block_input
let watch_operation { operation_input } =
Watcher.create_stream operation_input
@ -725,3 +834,71 @@ module Raw = struct
let encoding = P2p.Raw.encoding Message.cfg.encoding
let supported_versions = Message.cfg.versions
end
module type DISTRIBUTED_DB = sig
type t
type key
type value
type param
val known: t -> key -> bool Lwt.t
type error += Missing_data of key
val read: t -> key -> value tzresult Lwt.t
val read_opt: t -> key -> value option Lwt.t
val read_exn: t -> key -> value Lwt.t
val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
end
module Make
(Table : Distributed_db_functors.DISTRIBUTED_DB)
(Kind : sig
type t
val proj: t -> Table.t
end) = struct
type t = Kind.t
type key = Table.key
type value = Table.value
type param = Table.param
let known t k = Table.known (Kind.proj t) k
type error += Missing_data of key
let read t k = Table.read (Kind.proj t) k
let read_opt t k = Table.read_opt (Kind.proj t) k
let read_exn t k = Table.read_exn (Kind.proj t) k
let prefetch t ?peer k p = Table.prefetch (Kind.proj t) ?peer k p
let fetch t ?peer k p = Table.fetch (Kind.proj t) ?peer k p
let remove t k = Table.remove (Kind.proj t) k
let inject t k v = Table.inject (Kind.proj t) k v
let watch t = Table.watch (Kind.proj t)
end
module Block_header =
Make (Raw_block_header.Table) (struct
type t = net_db
let proj net = net.block_header_db.table
end)
module Operation_hashes =
Make (Raw_operation_hashes.Table) (struct
type t = net_db
let proj net = net.operation_hashes_db.table
end)
module Operations =
Make (Raw_operations.Table) (struct
type t = net_db
let proj net = net.operations_db.table
end)
module Operation =
Make (Raw_operation.Table) (struct
type t = net_db
let proj net = net.operation_db.table
end)
module Protocol =
Make (Raw_protocol.Table) (struct
type t = db
let proj db = db.protocol_db.table
end)

136
src/node/shell/distributed_db.mli
View File

@ -18,9 +18,9 @@ type p2p = (Message.t, Metadata.t) P2p.net
val create: State.t -> p2p -> t
val shutdown: t -> unit Lwt.t
type net
type net_db
val state: net -> State.Net.t
val state: net_db -> State.Net.t
type callback = {
notify_branch: P2p.Peer_id.t -> Block_hash.t list -> unit ;
@ -30,90 +30,90 @@ type callback = {
disconnection: P2p.Peer_id.t -> unit ;
}
val activate: callback:callback -> t -> State.Net.t -> net
val deactivate: net -> unit Lwt.t
val activate: callback:callback -> t -> State.Net.t -> net_db
val deactivate: net_db -> unit Lwt.t
val broadcast_head:
net_db -> Block_hash.t -> Operation_hash.t list -> unit
type operation =
| Blob of Operation.t
| Hash of Operation_hash.t
val resolve_operation:
net_db -> operation -> (Operation_hash.t * Operation.t) tzresult Lwt.t
val commit_block:
net_db -> Block_hash.t -> int -> Updater.validation_result ->
State.Block.t option tzresult Lwt.t
val commit_invalid_block:
net_db -> Block_hash.t -> int ->
bool tzresult Lwt.t
val inject_block:
t -> MBytes.t -> operation list list ->
(Block_hash.t * Block_header.t) tzresult Lwt.t
val remove_block: net_db -> Block_hash.t -> int -> unit Lwt.t
val inject_operation:
net_db -> Operation_hash.t -> Operation.t -> bool tzresult Lwt.t
val commit_protocol:
db -> Protocol_hash.t -> bool tzresult Lwt.t
val inject_protocol:
db -> Protocol_hash.t -> Protocol.t -> bool Lwt.t
val watch_block_header:
t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Watcher.stopper
val watch_operation:
t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Watcher.stopper
val watch_protocol:
t -> (Protocol_hash.t * Protocol.t) Lwt_stream.t * Watcher.stopper
module type DISTRIBUTED_DB = sig
type t
type key
type value
type param
val known: t -> key -> bool Lwt.t
val read: t -> key -> value option Lwt.t
type error += Missing_data of key
val read: t -> key -> value tzresult Lwt.t
val read_opt: t -> key -> value option Lwt.t
val read_exn: t -> key -> value Lwt.t
val commit: t -> key -> unit Lwt.t
val inject: t -> key -> value -> bool Lwt.t
val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
end
module Operation :
DISTRIBUTED_DB with type t = net
and type key := Operation_hash.t
and type value := Operation.t
module Block_header :
DISTRIBUTED_DB with type t = net
DISTRIBUTED_DB with type t = net_db
and type key := Block_hash.t
and type value := Block_header.t
and type param := unit
module Operations :
DISTRIBUTED_DB with type t = net_db
and type key = Block_hash.t * int
and type value = Operation.t list
and type param := Operation_list_list_hash.t
module Operation_hashes :
DISTRIBUTED_DB with type t = net_db
and type key = Block_hash.t * int
and type value = Operation_hash.t list
and type param := Operation_list_list_hash.t
module Operation :
DISTRIBUTED_DB with type t = net_db
and type key := Operation_hash.t
and type value := Operation.t
and type param := unit
module Protocol :
DISTRIBUTED_DB with type t = db
and type key := Protocol_hash.t
and type value := Protocol.t
module Operation_list : sig
type t = net
type key = Block_hash.t * int
type value = Operation_hash.t list
type param = Operation_list_list_hash.t
val known: t -> key -> bool Lwt.t
val read: t -> key -> value option Lwt.t
val read_exn: t -> key -> value Lwt.t
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
val read_all_opt:
net -> Block_hash.t -> Operation_hash.t list list option Lwt.t
val read_all_exn:
net -> Block_hash.t -> Operation_hash.t list list Lwt.t
val commit_all:
net -> Block_hash.t -> int -> unit Lwt.t
val inject_all:
net -> Block_hash.t -> Operation_hash.t list list -> bool Lwt.t
end
val broadcast_head:
net -> Block_hash.t -> Operation_hash.t list -> unit
val inject_block:
t -> MBytes.t -> Operation_hash.t list list ->
(Block_hash.t * Tezos_data.Block_header.t) tzresult Lwt.t
(* val inject_operation: *)
(* t -> MBytes.t -> *)
(* (Block_hash.t * Operation.t) tzresult Lwt.t *)
val read_block:
t -> Block_hash.t -> (net * Tezos_data.Block_header.t) option Lwt.t
val read_block_exn:
t -> Block_hash.t -> (net * Tezos_data.Block_header.t) Lwt.t
val read_operation:
t -> Operation_hash.t -> (net * Tezos_data.Operation.t) option Lwt.t
val read_operation_exn:
t -> Operation_hash.t -> (net * Tezos_data.Operation.t) Lwt.t
val watch_block:
t -> (Block_hash.t * Tezos_data.Block_header.t) Lwt_stream.t * Watcher.stopper
val watch_operation:
t -> (Operation_hash.t * Tezos_data.Operation.t) Lwt_stream.t * Watcher.stopper
val watch_protocol:
t -> (Protocol_hash.t * Tezos_data.Protocol.t) Lwt_stream.t * Watcher.stopper
and type param := unit
module Raw : sig
val encoding: Message.t P2p.Raw.t Data_encoding.t

80
src/node/shell/distributed_db_functors.ml
View File

@ -7,7 +7,7 @@
(* *)
(**************************************************************************)
module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
module type DISTRIBUTED_DB = sig
type t
type key
@ -15,34 +15,21 @@ module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
type param
val known: t -> key -> bool Lwt.t
val read: t -> key -> value option Lwt.t
type error += Missing_data of key
val read: t -> key -> value tzresult Lwt.t
val read_opt: t -> key -> value option Lwt.t
val read_exn: t -> key -> value Lwt.t
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
end
module type PARAMETRIZED_DISTRIBUTED_DB = sig
include PARAMETRIZED_RO_DISTRIBUTED_DB
val commit: t -> key -> unit Lwt.t
(* val commit_invalid: t -> key -> unit Lwt.t *) (* TODO *)
val remove: t -> key -> unit Lwt.t
val inject: t -> key -> value -> bool Lwt.t
val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
end
module type DISTRIBUTED_DB = sig
include PARAMETRIZED_DISTRIBUTED_DB with type param := unit
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t
end
module type DISK_TABLE = sig
type store
type key
@ -51,8 +38,6 @@ module type DISK_TABLE = sig
val read: store -> key -> value tzresult Lwt.t
val read_opt: store -> key -> value option Lwt.t
val read_exn: store -> key -> value Lwt.t
val store: store -> key -> value -> bool Lwt.t
val remove: store -> key -> bool Lwt.t
end
module type MEMORY_TABLE = sig
@ -79,8 +64,9 @@ end
module type PRECHECK = sig
type key
type param
type notified_value
type value
val precheck: key -> param -> value -> bool
val precheck: key -> param -> notified_value -> value option
end
module Make_table
@ -91,13 +77,13 @@ module Make_table
(Precheck : PRECHECK with type key := Hash.t
and type value := Disk_table.value) : sig
include PARAMETRIZED_DISTRIBUTED_DB with type key = Hash.t
and type value = Disk_table.value
and type param = Precheck.param
include DISTRIBUTED_DB with type key = Hash.t
and type value = Disk_table.value
and type param = Precheck.param
val create:
?global_input:(key * value) Watcher.input ->
Scheduler.t -> Disk_table.store -> t
val notify: t -> P2p.Peer_id.t -> key -> value -> unit Lwt.t
val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t
end = struct
@ -123,7 +109,7 @@ end = struct
| Pending _ -> Lwt.return_false
| Found _ -> Lwt.return_true
let read s k =
let read_opt s k =
match Memory_table.find s.memory k with
| exception Not_found -> Disk_table.read_opt s.disk k
| Found v -> Lwt.return (Some v)
@ -135,6 +121,16 @@ end = struct
| Found v -> Lwt.return v
| Pending _ -> Lwt.fail Not_found
type error += Missing_data of key
let read s k =
match Memory_table.find s.memory k with
| exception Not_found ->
trace (Missing_data k) @@
Disk_table.read s.disk k
| Found v -> return v
| Pending _ -> fail (Missing_data k)
let fetch s ?peer k param =
match Memory_table.find s.memory k with
| exception Not_found -> begin
@ -162,18 +158,19 @@ end = struct
Scheduler.notify_unrequested s.scheduler p k ;
Lwt.return_unit
end
| Pending (w, param) ->
if not (Precheck.precheck k param v) then begin
Scheduler.notify_invalid s.scheduler p k ;
Lwt.return_unit
end else begin
Scheduler.notify s.scheduler p k ;
Memory_table.replace s.memory k (Found v) ;
Lwt.wakeup w v ;
iter_option s.global_input
~f:(fun input -> Watcher.notify input (k, v)) ;
Watcher.notify s.input (k, v) ;
Lwt.return_unit
| Pending (w, param) -> begin
match Precheck.precheck k param v with
| None ->
Scheduler.notify_invalid s.scheduler p k ;
Lwt.return_unit
| Some v ->
Scheduler.notify s.scheduler p k ;
Memory_table.replace s.memory k (Found v) ;
Lwt.wakeup w v ;
iter_option s.global_input
~f:(fun input -> Watcher.notify input (k, v)) ;
Watcher.notify s.input (k, v) ;
Lwt.return_unit
end
| Found _ ->
Scheduler.notify_duplicate s.scheduler p k ;
@ -193,12 +190,11 @@ end = struct
| Found _ ->
Lwt.return_false
let commit s k =
let remove s k =
match Memory_table.find s.memory k with
| exception Not_found -> Lwt.return_unit
| Pending _ -> assert false
| Found v ->
Disk_table.store s.disk k v >>= fun _ ->
| Found _ ->
Memory_table.remove s.memory k ;
Lwt.return_unit

39
src/node/shell/distributed_db_functors.mli
View File

@ -7,7 +7,7 @@
(* *)
(**************************************************************************)
module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
module type DISTRIBUTED_DB = sig
type t
type key
@ -15,36 +15,22 @@ module type PARAMETRIZED_RO_DISTRIBUTED_DB = sig
type param
val known: t -> key -> bool Lwt.t
val read: t -> key -> value option Lwt.t
type error += Missing_data of key
val read: t -> key -> value tzresult Lwt.t
val read_opt: t -> key -> value option Lwt.t
val read_exn: t -> key -> value Lwt.t
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> param -> value Lwt.t
end
module type PARAMETRIZED_DISTRIBUTED_DB = sig
include PARAMETRIZED_RO_DISTRIBUTED_DB
val commit: t -> key -> unit Lwt.t
(* val commit_invalid: t -> key -> unit Lwt.t *) (* TODO *)
val remove: t -> key -> unit Lwt.t
val inject: t -> key -> value -> bool Lwt.t
val watch: t -> (key * value) Lwt_stream.t * Watcher.stopper
end
module type DISTRIBUTED_DB = sig
include PARAMETRIZED_DISTRIBUTED_DB with type param := unit
val prefetch: t -> ?peer:P2p.Peer_id.t -> key -> unit
val fetch: t -> ?peer:P2p.Peer_id.t -> key -> value Lwt.t
end
module type DISK_TABLE = sig
(* A subtype of State.DATA_STORE *)
type store
type key
type value
@ -52,8 +38,6 @@ module type DISK_TABLE = sig
val read: store -> key -> value tzresult Lwt.t
val read_opt: store -> key -> value option Lwt.t
val read_exn: store -> key -> value Lwt.t
val store: store -> key -> value -> bool Lwt.t
val remove: store -> key -> bool Lwt.t
end
module type MEMORY_TABLE = sig
@ -81,8 +65,9 @@ end
module type PRECHECK = sig
type key
type param
type notified_value
type value
val precheck: key -> param -> value -> bool
val precheck: key -> param -> notified_value -> value option
end
module Make_table
@ -93,13 +78,13 @@ module Make_table
(Precheck : PRECHECK with type key := Hash.t
and type value := Disk_table.value) : sig
include PARAMETRIZED_DISTRIBUTED_DB with type key = Hash.t
and type value = Disk_table.value
and type param := Precheck.param
include DISTRIBUTED_DB with type key = Hash.t
and type value = Disk_table.value
and type param = Precheck.param
val create:
?global_input:(key * value) Watcher.input ->
Scheduler.t -> Disk_table.store -> t
val notify: t -> P2p.Peer_id.t -> key -> value -> unit Lwt.t
val notify: t -> P2p.Peer_id.t -> key -> Precheck.notified_value -> unit Lwt.t
end

52
src/node/shell/distributed_db_message.ml
View File

@ -25,9 +25,15 @@ type t =
| Get_protocols of Protocol_hash.t list
| Protocol of Protocol.t
| Get_operation_list of Net_id.t * (Block_hash.t * int) list
| Operation_list of Net_id.t * Block_hash.t * int *
Operation_hash.t list * Operation_list_list_hash.path
| Get_operation_hashes_for_blocks of Net_id.t * (Block_hash.t * int) list
| Operation_hashes_for_block of
Net_id.t * Block_hash.t * int *
Operation_hash.t list * Operation_list_list_hash.path
| Get_operations_for_blocks of Net_id.t * (Block_hash.t * int) list
| Operations_for_block of
Net_id.t * Block_hash.t * int *
Operation.t list * Operation_list_list_hash.path
let encoding =
let open Data_encoding in
@ -123,22 +129,44 @@ let encoding =
case ~tag:0x50
(obj2
(req "net_id" Net_id.encoding)
(req "get_operation_list" (list (tup2 Block_hash.encoding int8))))
(req "get_operation_hashes_for_blocks"
(list (tup2 Block_hash.encoding int8))))
(function
| Get_operation_list (net_id, keys) -> Some (net_id, keys)
| Get_operation_hashes_for_blocks (net_id, keys) -> Some (net_id, keys)
| _ -> None)
(fun (net_id, keys) -> Get_operation_list (net_id, keys));
(fun (net_id, keys) -> Get_operation_hashes_for_blocks (net_id, keys));
case ~tag:0x51
(obj4
(req "net_id" Net_id.encoding)
(req "operation_list" (tup2 Block_hash.encoding int8))
(req "operations" (list Operation_hash.encoding))
(req "operation_list_path" Operation_list_list_hash.path_encoding))
(function Operation_list (net_id, block, ofs, ops, path) ->
(req "operation_hashes_for_block" (tup2 Block_hash.encoding int8))
(req "operation_hashes" (list Operation_hash.encoding))
(req "operation_hashes_path" Operation_list_list_hash.path_encoding))
(function Operation_hashes_for_block (net_id, block, ofs, ops, path) ->
Some (net_id, (block, ofs), ops, path) | _ -> None)
(fun (net_id, (block, ofs), ops, path) ->
Operation_list (net_id, block, ofs, ops, path)) ;
Operation_hashes_for_block (net_id, block, ofs, ops, path)) ;
case ~tag:0x60
(obj2
(req "net_id" Net_id.encoding)
(req "get_operations_for_blocks"
(list (tup2 Block_hash.encoding int8))))
(function
| Get_operations_for_blocks (net_id, keys) -> Some (net_id, keys)
| _ -> None)
(fun (net_id, keys) -> Get_operations_for_blocks (net_id, keys));
case ~tag:0x61
(obj4
(req "net_id" Net_id.encoding)
(req "operations_for_block" (tup2 Block_hash.encoding int8))
(req "operations" (list (dynamic_size Operation.encoding)))
(req "operations_path" Operation_list_list_hash.path_encoding))
(function Operations_for_block (net_id, block, ofs, ops, path) ->
Some (net_id, (block, ofs), ops, path) | _ -> None)
(fun (net_id, (block, ofs), ops, path) ->
Operations_for_block (net_id, block, ofs, ops, path)) ;
]
@ -146,7 +174,7 @@ let versions =
let open P2p.Version in
[ { name = "TEZOS" ;
major = 0 ;
minor = 5 ;
minor = 6 ;
}
]

12
src/node/shell/distributed_db_message.mli
View File

@ -25,9 +25,15 @@ type t =
| Get_protocols of Protocol_hash.t list
| Protocol of Protocol.t
| Get_operation_list of Net_id.t * (Block_hash.t * int) list
| Operation_list of Net_id.t * Block_hash.t * int *
Operation_hash.t list * Operation_list_list_hash.path
| Get_operation_hashes_for_blocks of Net_id.t * (Block_hash.t * int) list
| Operation_hashes_for_block of
Net_id.t * Block_hash.t * int *
Operation_hash.t list * Operation_list_list_hash.path
| Get_operations_for_blocks of Net_id.t * (Block_hash.t * int) list
| Operations_for_block of
Net_id.t * Block_hash.t * int *
Operation.t list * Operation_list_list_hash.path
val cfg : t P2p.message_config

312
src/node/shell/node.ml
View File

@ -33,12 +33,12 @@ let inject_protocol state ?force:_ proto =
"Compilation failed (%a)"
Protocol_hash.pp_short hash
| true ->
State.Protocol.store state hash proto >>= function
| false ->
State.Protocol.store state proto >>= function
| None ->
failwith
"Previously registred protocol (%a)"
Protocol_hash.pp_short hash
| true -> return ()
| Some _ -> return ()
in
Lwt.return (hash, validation)
@ -52,12 +52,12 @@ type t = {
state: State.t ;
distributed_db: Distributed_db.t ;
validator: Validator.worker ;
mainnet_db: Distributed_db.net ;
mainnet_db: Distributed_db.net_db ;
mainnet_net: State.Net.t ;
mainnet_validator: Validator.t ;
inject_block:
?force:bool ->
MBytes.t -> Operation_hash.t list list ->
MBytes.t -> Distributed_db.operation list list ->
(Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t ;
inject_operation:
?force:bool -> MBytes.t ->
@ -151,21 +151,26 @@ module RPC = struct
test_network: Context.test_network;
}
let convert (block: State.Valid_block.t) =
Lazy.force block.operation_hashes >>= fun operations ->
let convert (block: State.Block.t) =
let hash = State.Block.hash block in
let header = State.Block.header block in
State.Block.all_operation_hashes block >>= fun operations ->
State.Block.context block >>= fun context ->
Context.get_protocol context >>= fun protocol ->
Context.get_test_network context >>= fun test_network ->
Lwt.return {
hash = block.hash ;
net_id = block.net_id ;
level = block.level ;
proto_level = block.proto_level ;
predecessor = block.predecessor ;
timestamp = block.timestamp ;
operations_hash = block.operations_hash ;
fitness = block.fitness ;
data = block.proto_header ;
hash ;
net_id = header.shell.net_id ;
level = header.shell.level ;
proto_level = header.shell.proto_level ;
predecessor = header.shell.predecessor ;
timestamp = header.shell.timestamp ;
operations_hash = header.shell.operations_hash ;
fitness = header.shell.fitness ;
data = header.proto ;
operations = Some operations ;
protocol = block.protocol_hash ;
test_network = block.test_network ;
protocol ;
test_network ;
}
let inject_block node = node.inject_block
@ -173,10 +178,8 @@ module RPC = struct
let inject_protocol node = node.inject_protocol
let raw_block_info node hash =
Distributed_db.read_block node.distributed_db hash >>= function
| Some (net_db, _block) ->
let net = Distributed_db.state net_db in
State.Valid_block.read_exn net hash >>= fun block ->
State.read_block node.state hash >>= function
| Some block ->
convert block
| None ->
Lwt.fail Not_found
@ -201,89 +204,74 @@ module RPC = struct
| Some (v, _) -> v
let get_validator_per_hash node hash =
Distributed_db.read_block_exn
node.distributed_db hash >>= fun (_net_db, block) ->
State.read_block_exn node.state hash >>= fun block ->
let header = State.Block.header block in
if Net_id.equal
(State.Net.id node.mainnet_net)
block.shell.net_id then
header.shell.net_id then
Lwt.return (Some (node.mainnet_validator, node.mainnet_db))
else
match Validator.test_validator node.mainnet_validator with
| Some (test_validator, net_db)
when Net_id.equal
(State.Net.id (Validator.net_state test_validator))
block.shell.net_id ->
header.shell.net_id ->
Lwt.return (Some (node.mainnet_validator, net_db))
| _ -> Lwt.return_none
let read_valid_block node h =
Distributed_db.read_block node.distributed_db h >>= function
| None -> Lwt.return_none
| Some (_net_db, block) ->
State.Net.get node.state block.shell.net_id >>= function
| Error _ -> Lwt.return_none
| Ok net ->
State.Valid_block.read_exn net h >>= fun block ->
Lwt.return (Some block)
State.read_block node.state h
let read_valid_block_exn node h =
Distributed_db.read_block_exn
node.distributed_db h >>= fun (net_db, _block) ->
let net = Distributed_db.state net_db in
State.Valid_block.read_exn net h >>= fun block ->
Lwt.return block
State.read_block_exn node.state h
let get_pred net_db n (v: State.Valid_block.t) =
let rec loop net_db n h =
if n <= 0 then
Lwt.return h
else
Distributed_db.Block_header.read net_db h >>= function
| None -> Lwt.fail Not_found
| Some { shell = { predecessor } } ->
loop net_db (n-1) predecessor in
let rec predecessor net_db n v =
if n <= 0 then
Lwt.return v
else
loop net_db n v.hash >>= fun hash ->
let net_state = Distributed_db.state net_db in
State.Valid_block.read_exn net_state hash
State.Block.predecessor v >>= function
| None -> Lwt.fail Not_found
| Some v -> predecessor net_db (n-1) v
let block_info node (block: block) =
match block with
| `Genesis ->
State.Valid_block.Current.genesis node.mainnet_net >>= convert
Chain.genesis node.mainnet_net >>= convert
| ( `Head n | `Test_head n ) as block ->
let validator = get_validator node block in
let net_db = Validator.net_db validator in
let net_state = Validator.net_state validator in
State.Valid_block.Current.head net_state >>= fun head ->
get_pred net_db n head >>= convert
Chain.head net_state >>= fun head ->
predecessor net_db n head >>= convert
| `Hash h ->
read_valid_block_exn node h >>= convert
| ( `Prevalidation | `Test_prevalidation ) as block ->
let validator = get_validator node block in
let pv = Validator.prevalidator validator in
let net_state = Validator.net_state validator in
State.Valid_block.Current.head net_state >>= fun head ->
Chain.head net_state >>= fun head ->
let head_header = State.Block.header head in
let head_hash = State.Block.hash head in
State.Block.context head >>= fun head_context ->
Context.get_protocol head_context >>= fun head_protocol ->
Prevalidator.context pv >>= function
| Error _ -> Lwt.fail Not_found
| Ok { context ; fitness } ->
Context.get_protocol context >>= fun protocol ->
Context.get_test_network context >>= fun test_network ->
let proto_level =
if Protocol_hash.equal protocol head.protocol_hash then
head.proto_level
if Protocol_hash.equal protocol head_protocol then
head_header.shell.proto_level
else
((head.proto_level + 1) mod 256) in
((head_header.shell.proto_level + 1) mod 256) in
let operations =
let pv_result, _ = Prevalidator.operations pv in
[ pv_result.applied ] in
Lwt.return
{ hash = prevalidation_hash ;
level = Int32.succ head.level ;
level = Int32.succ head_header.shell.level ;
proto_level ;
predecessor = head.hash ;
predecessor = head_hash ;
fitness ;
timestamp = Prevalidator.timestamp pv ;
protocol ;
@ -292,60 +280,61 @@ module RPC = struct
(List.map Operation_list_hash.compute operations) ;
operations = Some operations ;
data = MBytes.of_string "" ;
net_id = head.net_id ;
net_id = head_header.shell.net_id ;
test_network ;
}
let rpc_context (block : State.Valid_block.t) : Updater.rpc_context =
{ block_hash = block.hash ;
block_header = {
shell = {
net_id = block.net_id ;
level = block.level ;
proto_level = block.proto_level ;
predecessor = block.predecessor ;
timestamp = block.timestamp ;
operations_hash = block.operations_hash ;
fitness = block.fitness ;
} ;
proto = block.proto_header ;
} ;
operation_hashes = (fun () -> Lazy.force block.operation_hashes) ;
operations = (fun () -> Lazy.force block.operations) ;
context = block.context ;
let rpc_context block : Updater.rpc_context Lwt.t =
let block_hash = State.Block.hash block in
let block_header = State.Block.header block in
State.Block.context block >|= fun context ->
{ Updater.block_hash ;
block_header ;
operation_hashes = (fun () -> State.Block.all_operation_hashes block) ;
operations = (fun () -> State.Block.all_operations block) ;
context ;
}
let get_rpc_context node block =
match block with
| `Genesis ->
State.Valid_block.Current.genesis node.mainnet_net >>= fun block ->
Lwt.return (Some (rpc_context block))
Chain.genesis node.mainnet_net >>= fun block ->
rpc_context block >>= fun ctxt ->
Lwt.return (Some ctxt)
| ( `Head n | `Test_head n ) as block ->
let validator = get_validator node block in
let net_state = Validator.net_state validator in
let net_db = Validator.net_db validator in
State.Valid_block.Current.head net_state >>= fun head ->
get_pred net_db n head >>= fun block ->
Lwt.return (Some (rpc_context block))
Chain.head net_state >>= fun head ->
predecessor net_db n head >>= fun block ->
rpc_context block >>= fun ctxt ->
Lwt.return (Some ctxt)
| `Hash hash-> begin
read_valid_block node hash >|= function
| None -> None
| Some block -> Some (rpc_context block)
read_valid_block node hash >>= function
| None ->
Lwt.return_none
| Some block ->
rpc_context block >>= fun ctxt ->
Lwt.return (Some ctxt)
end
| ( `Prevalidation | `Test_prevalidation ) as block ->
let validator, net_db = get_net node block in
let pv = Validator.prevalidator validator in
let net_state = Validator.net_state validator in
State.Valid_block.Current.head net_state >>= fun head ->
Chain.head net_state >>= fun head ->
let head_header = State.Block.header head in
let head_hash = State.Block.hash head in
State.Block.context head >>= fun head_context ->
Context.get_protocol head_context >>= fun head_protocol ->
Prevalidator.context pv >>= function
| Error _ -> Lwt.fail Not_found
| Ok { context ; fitness } ->
Context.get_protocol context >>= fun protocol ->
let proto_level =
if Protocol_hash.equal protocol head.protocol_hash then
head.proto_level
if Protocol_hash.equal protocol head_protocol then
head_header.shell.proto_level
else
((head.proto_level + 1) mod 256) in
((head_header.shell.proto_level + 1) mod 256) in
let operation_hashes =
let pv_result, _ = Prevalidator.operations pv in
[ pv_result.applied ] in
@ -356,10 +345,10 @@ module RPC = struct
Updater.block_hash = prevalidation_hash ;
block_header = {
shell = {
net_id = head.net_id ;
level = Int32.succ head.level ;
net_id = head_header.shell.net_id ;
level = Int32.succ head_header.shell.level ;
proto_level ;
predecessor = head.hash ;
predecessor = head_hash ;
timestamp = Prevalidator.timestamp pv ;
operations_hash ;
fitness ;
@ -376,18 +365,16 @@ module RPC = struct
context ;
})
let operations node block =
let operation_hashes node block =
match block with
| `Genesis ->
State.Valid_block.Current.genesis node.mainnet_net >>= fun { operation_hashes } ->
Lazy.force operation_hashes
| `Genesis -> Lwt.return []
| ( `Head n | `Test_head n ) as block ->
let validator = get_validator node block in
let net_state = Validator.net_state validator in
let net_db = Validator.net_db validator in
State.Valid_block.Current.head net_state >>= fun head ->
get_pred net_db n head >>= fun { operation_hashes } ->
Lazy.force operation_hashes
Chain.head net_state >>= fun head ->
predecessor net_db n head >>= fun block ->
State.Block.all_operation_hashes block
| (`Prevalidation | `Test_prevalidation) as block ->
let validator, _net = get_net node block in
let pv = Validator.prevalidator validator in
@ -396,12 +383,31 @@ module RPC = struct
| `Hash hash ->
read_valid_block node hash >>= function
| None -> Lwt.return_nil
| Some { operation_hashes } ->
Lazy.force operation_hashes
| Some block ->
State.Block.all_operation_hashes block
let operation_content node hash =
Distributed_db.read_operation node.distributed_db hash >>= fun op ->
Lwt.return (map_option ~f:snd op)
let operations node block =
match block with
| `Genesis -> Lwt.return []
| ( `Head n | `Test_head n ) as block ->
let validator = get_validator node block in
let net_state = Validator.net_state validator in
let net_db = Validator.net_db validator in
Chain.head net_state >>= fun head ->
predecessor net_db n head >>= fun block ->
State.Block.all_operations block
| (`Prevalidation | `Test_prevalidation) as block ->
let validator, net_db = get_net node block in
let pv = Validator.prevalidator validator in
let { Prevalidation.applied }, _ = Prevalidator.operations pv in
Lwt_list.map_p
(Distributed_db.Operation.read_exn net_db) applied >>= fun applied ->
Lwt.return [applied]
| `Hash hash ->
read_valid_block node hash >>= function
| None -> Lwt.return_nil
| Some block ->
State.Block.all_operations block
let pending_operations node (block: block) =
match block with
@ -415,13 +421,13 @@ module RPC = struct
let prevalidator = Validator.prevalidator validator in
let net_state = Validator.net_state validator in
let net_db = Validator.net_db validator in
State.Valid_block.Current.head net_state >>= fun head ->
get_pred net_db n head >>= fun b ->
Chain.head net_state >>= fun head ->
predecessor net_db n head >>= fun b ->
Prevalidator.pending ~block:b prevalidator >|= fun ops ->
Prevalidation.empty_result, ops
| `Genesis ->
let net = node.mainnet_net in
State.Valid_block.Current.genesis net >>= fun b ->
Chain.genesis net >>= fun b ->
let validator = get_validator node `Genesis in
let prevalidator = Validator.prevalidator validator in
Prevalidator.pending ~block:b prevalidator >|= fun ops ->
@ -433,7 +439,7 @@ module RPC = struct
| Some (validator, net_db) ->
let net_state = Distributed_db.state net_db in
let prevalidator = Validator.prevalidator validator in
State.Valid_block.read_exn net_state h >>= fun block ->
State.Block.read_exn net_state h >>= fun block ->
Prevalidator.pending ~block prevalidator >|= fun ops ->
Prevalidation.empty_result, ops
end
@ -450,18 +456,18 @@ module RPC = struct
match block with
| `Genesis ->
let net = node.mainnet_net in
State.Valid_block.Current.genesis net >>= return
Chain.genesis net >>= return
| ( `Head 0 | `Prevalidation
| `Test_head 0 | `Test_prevalidation ) as block ->
let validator = get_validator node block in
let net_state = Validator.net_state validator in
State.Valid_block.Current.head net_state >>= return
Chain.head net_state >>= return
| `Head n | `Test_head n as block -> begin
let validator = get_validator node block in
let net_state = Validator.net_state validator in
let net_db = Validator.net_db validator in
State.Valid_block.Current.head net_state >>= fun head ->
get_pred net_db n head >>= return
Chain.head net_state >>= fun head ->
predecessor net_db n head >>= return
end
| `Hash hash ->
read_valid_block node hash >>= function
@ -469,12 +475,7 @@ module RPC = struct
| Some data -> return data
end >>=? fun predecessor ->
let net_db = Validator.net_db node.mainnet_validator in
map_p
(fun h ->
Distributed_db.Operation.read net_db h >>= function
| None -> failwith "Unknown operation %a" Operation_hash.pp h
| Some po -> return (h, po))
ops >>=? fun rops ->
map_p (Distributed_db.resolve_operation net_db) ops >>=? fun rops ->
Prevalidation.start_prevalidation
~predecessor ~timestamp >>=? fun validation_state ->
Prevalidation.prevalidate
@ -506,62 +507,57 @@ module RPC = struct
Lwt.return (Some (RPC.map (fun _ -> ()) dir))
let heads node =
State.Valid_block.known_heads node.mainnet_net >>= fun heads ->
Chain.known_heads node.mainnet_net >>= fun heads ->
begin
match Validator.test_validator node.mainnet_validator with
| None -> Lwt.return_nil
| Some (_, net_db) ->
State.Valid_block.known_heads (Distributed_db.state net_db)
Chain.known_heads (Distributed_db.state net_db)
end >>= fun test_heads ->
Lwt_list.fold_left_s
(fun map block ->
convert block >|= fun bi ->
Block_hash.Map.add
block.State.Valid_block.hash bi map)
(State.Block.hash block) bi map)
Block_hash.Map.empty (test_heads @ heads)
let predecessors node len head =
let rec loop net_db acc len hash (block: Block_header.t) =
if Block_hash.equal block.shell.predecessor hash then
let rec loop acc len block =
if len = 0 then
Lwt.return (List.rev acc)
else begin
if len = 0 then
Lwt.return (List.rev acc)
else
let hash = block.shell.predecessor in
Distributed_db.Block_header.read_exn net_db hash >>= fun block ->
loop net_db (hash :: acc) (len-1) hash block
end in
else
State.Block.predecessor block >>= function
| None -> Lwt.return (List.rev acc)
| Some block ->
loop (State.Block.hash block :: acc) (len-1) block
in
try
Distributed_db.read_block_exn
node.distributed_db head >>= fun (net_db, block) ->
loop net_db [] len head block
State.read_block_exn node.state head >>= fun block ->
loop [] len block
with Not_found -> Lwt.return_nil
let predecessors_bi state ignored len head =
let predecessors_bi ignored len head =
try
let rec loop acc len hash =
State.Valid_block.read_exn state hash >>= fun block ->
let rec loop acc len block =
convert block >>= fun bi ->
if Block_hash.equal bi.predecessor hash then
Lwt.return (List.rev (bi :: acc))
else begin
if len = 0
|| Block_hash.Set.mem hash ignored then
Lwt.return (List.rev acc)
else
loop (bi :: acc) (len-1) bi.predecessor
end in
State.Block.predecessor block >>= function
| None ->
Lwt.return (List.rev (bi :: acc))
| Some pred ->
if len = 0 ||
Block_hash.Set.mem (State.Block.hash block) ignored then
Lwt.return (List.rev acc)
else
loop (bi :: acc) (len-1) pred
in
loop [] len head
with Not_found -> Lwt.return_nil
let list node len heads =
Lwt_list.fold_left_s
(fun (ignored, acc) head ->
Distributed_db.read_block_exn
node.distributed_db head >>= fun (net_db, _block) ->
let net_state = Distributed_db.state net_db in
predecessors_bi net_state ignored len head >>= fun predecessors ->
State.read_block_exn node.state head >>= fun block ->
predecessors_bi ignored len block >>= fun predecessors ->
let ignored =
List.fold_right
(fun x s -> Block_hash.Set.add x.hash s)
@ -572,9 +568,10 @@ module RPC = struct
heads >>= fun (_, blocks) ->
Lwt.return (List.rev blocks)
let block_watcher node = Distributed_db.watch_block node.distributed_db
let block_header_watcher node =
Distributed_db.watch_block_header node.distributed_db
let valid_block_watcher node =
let block_watcher node =
let stream, shutdown = Validator.global_watcher node.validator in
Lwt_stream.map_s (fun block -> convert block) stream,
shutdown
@ -597,12 +594,15 @@ module RPC = struct
let rec next () =
if !first_run then begin
first_run := false ;
State.Valid_block.Current.head node.mainnet_net >>= fun head ->
Lwt.return (Some (head.hash, head.timestamp))
Chain.head node.mainnet_net >>= fun head ->
let head_hash = State.Block.hash head in
let head_header = State.Block.header head in
Lwt.return (Some (head_hash, head_header.shell.timestamp))
end else begin
Lwt.pick [
( Lwt_stream.get block_stream >|=
map_option ~f:(fun b -> (b.State.Valid_block.hash, b.timestamp)) ) ;
map_option ~f:(fun b ->
(State.Block.hash b, (State.Block.header b).shell.timestamp)) ) ;
(Validator.bootstrapped node.mainnet_validator >|= fun () -> None) ;
]
end in

14
src/node/shell/node.mli
View File

@ -27,7 +27,7 @@ module RPC : sig
val inject_block:
t -> ?force:bool ->
MBytes.t -> Operation_hash.t list list ->
MBytes.t -> Distributed_db.operation list list ->
(Block_hash.t * unit tzresult Lwt.t) tzresult Lwt.t
(** [inject_block node ?force bytes] tries to insert [bytes]
(supposedly the serialization of a block header) inside
@ -43,9 +43,9 @@ module RPC : sig
val raw_block_info:
t -> Block_hash.t -> block_info Lwt.t
val block_watcher:
val block_header_watcher:
t -> (Block_hash.t * Block_header.t) Lwt_stream.t * Watcher.stopper
val valid_block_watcher:
val block_watcher:
t -> (block_info Lwt_stream.t * Watcher.stopper)
val heads: t -> block_info Block_hash.Map.t Lwt.t
@ -58,10 +58,10 @@ module RPC : sig
val block_info:
t -> block -> block_info Lwt.t
val operations:
val operation_hashes:
t -> block -> Operation_hash.t list list Lwt.t
val operation_content:
t -> Operation_hash.t -> Operation.t option Lwt.t
val operations:
t -> block -> Operation.t list list Lwt.t
val operation_watcher:
t -> (Operation_hash.t * Operation.t) Lwt_stream.t * Watcher.stopper
@ -81,7 +81,7 @@ module RPC : sig
val preapply:
t -> block ->
timestamp:Time.t -> sort:bool ->
Operation_hash.t list ->
Distributed_db.operation list ->
(Fitness.t * error Prevalidation.preapply_result) tzresult Lwt.t
val validate: t -> Net_id.t -> Block_hash.t -> unit tzresult Lwt.t

87
src/node/shell/node_rpc.ml
View File

@ -16,6 +16,29 @@ let filter_bi operations (bi: Services.Blocks.block_info) =
let bi = if operations then bi else { bi with operations = None } in
bi
let monitor_operations node contents =
let stream, stopper = Node.RPC.operation_watcher node in
let shutdown () = Watcher.shutdown stopper in
let first_request = ref true in
let next () =
if not !first_request then
Lwt_stream.get stream >>= function
| None -> Lwt.return_none
| Some (h, op) when contents -> Lwt.return (Some [[h, Some op]])
| Some (h, _) -> Lwt.return (Some [[h, None]])
else begin
first_request := false ;
Node.RPC.operation_hashes node `Prevalidation >>= fun hashes ->
if contents then
Node.RPC.operations node `Prevalidation >>= fun ops ->
Lwt.return_some @@
List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops
else
Lwt.return_some @@
List.map (List.map (fun h -> h, None)) hashes
end in
RPC.Answer.return_stream { next ; shutdown }
let register_bi_dir node dir =
let dir =
let implementation b include_ops =
@ -80,9 +103,20 @@ let register_bi_dir node dir =
RPC.register1 dir
Services.Blocks.test_network implementation in
let dir =
let implementation b () =
Node.RPC.operations node b >>=
RPC.Answer.return in
let implementation b { Node_rpc_services.Blocks.contents ; monitor } =
match b with
| `Prevalidation when monitor ->
monitor_operations node contents
| _ ->
Node.RPC.operation_hashes node b >>= fun hashes ->
if contents then
Node.RPC.operations node b >>= fun ops ->
RPC.Answer.return @@
List.map2 (List.map2 (fun h op -> h, Some op)) hashes ops
else
RPC.Answer.return @@
List.map (List.map (fun h -> h, None)) hashes
in
RPC.register1 dir
Services.Blocks.operations implementation in
let dir =
@ -275,7 +309,7 @@ let list_blocks
requested_blocks in
RPC.Answer.return infos
else begin
let (bi_stream, stopper) = Node.RPC.valid_block_watcher node in
let (bi_stream, stopper) = Node.RPC.block_watcher node in
let stream =
match delay with
| None ->
@ -298,47 +332,6 @@ let list_blocks
RPC.Answer.return_stream { next ; shutdown }
end
let list_operations node {Services.Operations.monitor; contents} =
let monitor = match monitor with None -> false | Some x -> x in
let include_ops = match contents with None -> false | Some x -> x in
Node.RPC.operations node `Prevalidation >>= fun operationss ->
let fetch_operations_content operations =
if include_ops then
Lwt_list.map_s
(fun h ->
Node.RPC.operation_content node h >>= fun content ->
Lwt.return (h, content))
operations
else
Lwt.return @@ ListLabels.map operations ~f:(fun h -> h, None) in
Lwt_list.map_p fetch_operations_content operationss >>= fun operations ->
if not monitor then
RPC.Answer.return operations
else
let stream, stopper = Node.RPC.operation_watcher node in
let shutdown () = Watcher.shutdown stopper in
let first_request = ref true in
let next () =
if not !first_request then
Lwt_stream.get stream >>= function
| None -> Lwt.return_none
| Some (h, op) when include_ops -> Lwt.return (Some [[h, Some op]])
| Some (h, _) -> Lwt.return (Some [[h, None]])
else begin
first_request := false ;
Lwt.return (Some operations)
end in
RPC.Answer.return_stream { next ; shutdown }
let get_operations node hashes () =
Lwt_list.map_p
(fun h ->
Node.RPC.operation_content node h >>= function
| None -> Lwt.fail Not_found
| Some h -> Lwt.return h)
hashes >>= fun ops ->
RPC.Answer.return ops
let list_protocols node {Services.Protocols.monitor; contents} =
let monitor = match monitor with None -> false | Some x -> x in
let include_contents = match contents with None -> false | Some x -> x in
@ -391,10 +384,6 @@ let build_rpc_directory node =
~descr:
"All the RPCs which are specific to the protocol version."
dir Services.Blocks.proto_path implementation in
let dir =
RPC.register0 dir Services.Operations.list (list_operations node) in
let dir =
RPC.register1 dir Services.Operations.contents (get_operations node) in
let dir =
RPC.register0 dir Services.Protocols.list (list_protocols node) in
let dir =

115
src/node/shell/node_rpc_services.ml
View File

@ -46,6 +46,21 @@ module Error = struct
end
type operation = Distributed_db.operation =
| Blob of Operation.t
| Hash of Operation_hash.t
let operation_encoding =
let open Data_encoding in
union [
case Operation.encoding
(function Blob op -> Some op | Hash _ -> None)
(fun op -> Blob op) ;
case Operation_hash.encoding
(function Hash oph -> Some oph | Blob _ -> None)
(fun oph -> Hash oph) ;
]
module Blocks = struct
type block = [
@ -75,28 +90,28 @@ module Blocks = struct
(fun { hash ; net_id ; level ; proto_level ; predecessor ;
fitness ; timestamp ; protocol ; operations_hash ; data ;
operations ; test_network } ->
({ Block_header.shell =
((hash, operations, protocol, test_network),
{ Block_header.shell =
{ net_id ; level ; proto_level ; predecessor ;
timestamp ; operations_hash ; fitness } ;
proto = data },
(hash, operations, protocol, test_network)))
(fun ({ Block_header.shell =
proto = data }))
(fun ((hash, operations, protocol, test_network),
{ Block_header.shell =
{ net_id ; level ; proto_level ; predecessor ;
timestamp ; operations_hash ; fitness } ;
proto = data },
(hash, operations, protocol, test_network)) ->
proto = data }) ->
{ hash ; net_id ; level ; proto_level ; predecessor ;
fitness ; timestamp ; protocol ; operations_hash ; data ;
operations ; test_network })
(dynamic_size
(merge_objs
Block_header.encoding
(obj4
(req "hash" Block_hash.encoding)
(opt "operations" (list (list Operation_hash.encoding)))
(req "protocol" Protocol_hash.encoding)
(dft "test_network"
Context.test_network_encoding Context.Not_running))))
Context.test_network_encoding Context.Not_running))
Block_header.encoding))
let parse_block s =
try
@ -136,7 +151,7 @@ module Blocks = struct
RPC.Arg.make ~name ~descr ~construct ~destruct ()
type preapply_param = {
operations: Operation_hash.t list ;
operations: operation list ;
sort: bool ;
timestamp: Time.t option ;
}
@ -152,7 +167,7 @@ module Blocks = struct
| Some x -> x in
{ operations ; sort ; timestamp })
(obj3
(req "operations" (list Operation_hash.encoding))
(req "operations" (list (dynamic_size operation_encoding)))
(opt "sort" bool)
(opt "timestamp" Time.encoding)))
@ -234,11 +249,31 @@ module Blocks = struct
~output: (obj1 (req "timestamp" Time.encoding))
RPC.Path.(block_path / "timestamp")
type operations_param = {
contents: bool ;
monitor: bool ;
}
let operations_param_encoding =
let open Data_encoding in
conv
(fun { contents ; monitor } -> (contents, monitor))
(fun (contents, monitor) -> { contents ; monitor })
(obj2
(dft "contents" bool false)
(dft "monitor" bool false))
let operations =
RPC.service
~description:"List the block operations."
~input: empty
~output: (obj1 (req "operations" (list (list Operation_hash.encoding))))
~input: operations_param_encoding
~output: (obj1
(req "operations"
(list (list
(obj2
(req "hash" Operation_hash.encoding)
(opt "contents"
(dynamic_size Operation.encoding)))))))
RPC.Path.(block_path / "operations")
let protocol =
@ -393,58 +428,6 @@ module Blocks = struct
end
module Operations = struct
let operations_arg =
let name = "operation_id" in
let descr =
"A operation identifier in hexadecimal." in
let construct ops =
String.concat "," (List.map Operation_hash.to_b58check ops) in
let destruct h =
let ops = split ',' h in
try Ok (List.map Operation_hash.of_b58check_exn ops)
with _ -> Error "Can't parse hash" in
RPC.Arg.make ~name ~descr ~construct ~destruct ()
let contents =
RPC.service
~input: empty
~output: (list (dynamic_size Operation.encoding))
RPC.Path.(root / "operations" /: operations_arg)
type list_param = {
contents: bool option ;
monitor: bool option ;
}
let list_param_encoding =
conv
(fun {contents; monitor} -> (contents, monitor))
(fun (contents, monitor) -> {contents; monitor})
(obj2
(opt "contents" bool)
(opt "monitor" bool))
let list =
RPC.service
~description:
"List operations in the mempool."
~input: list_param_encoding
~output:
(obj1
(req "operations"
(list
(list
(obj2
(req "hash" Operation_hash.encoding)
(opt "contents"
(dynamic_size Operation.encoding)))
))))
RPC.Path.(root / "operations")
end
module Protocols = struct
let protocols_arg =
@ -661,7 +644,7 @@ type inject_block_param = {
raw: MBytes.t ;
blocking: bool ;
force: bool ;
operations: Operation_hash.t list list ;
operations: operation list list ;
}
let inject_block_param =
@ -689,7 +672,7 @@ let inject_block_param =
(req "operations"
(describe
~description:"..."
(list (list Operation_hash.encoding)))))
(list (list (dynamic_size operation_encoding))))))
let inject_block =
RPC.service

40
src/node/shell/node_rpc_services.mli
View File

@ -13,6 +13,12 @@ module Error : sig
val wrap: 'a Data_encoding.t -> 'a tzresult Data_encoding.encoding
end
type operation = Distributed_db.operation =
| Blob of Operation.t
| Hash of Operation_hash.t
val operation_encoding: operation Data_encoding.t
module Blocks : sig
type block = [
@ -57,8 +63,15 @@ module Blocks : sig
(unit, unit * block, unit, Time.t) RPC.service
val fitness:
(unit, unit * block, unit, MBytes.t list) RPC.service
type operations_param = {
contents: bool ;
monitor: bool ;
}
val operations:
(unit, unit * block, unit, Operation_hash.t list list) RPC.service
(unit, unit * block, operations_param,
(Operation_hash.t * Operation.t option) list list) RPC.service
val protocol:
(unit, unit * block, unit, Protocol_hash.t) RPC.service
val test_network:
@ -80,7 +93,7 @@ module Blocks : sig
(unit, unit, list_param, block_info list list) RPC.service
type preapply_param = {
operations: Operation_hash.t list ;
operations: operation list ;
sort: bool ;
timestamp: Time.t option ;
}
@ -98,25 +111,6 @@ module Blocks : sig
end
module Operations : sig
val contents:
(unit, unit * Operation_hash.t list,
unit, Operation.t list) RPC.service
type list_param = {
contents: bool option ;
monitor: bool option ;
}
val list:
(unit, unit,
list_param,
(Operation_hash.t * Operation.t option) list list) RPC.service
end
module Protocols : sig
val contents:
@ -135,6 +129,7 @@ module Protocols : sig
end
module Network : sig
val stat :
(unit, unit, unit, P2p.Stat.t) RPC.service
@ -175,6 +170,7 @@ module Network : sig
val events :
(unit, unit * P2p.Peer_id.t, bool, P2p.RPC.Peer_id.Event.t list) RPC.service
end
end
val forge_block:
@ -190,7 +186,7 @@ type inject_block_param = {
raw: MBytes.t ;
blocking: bool ;
force: bool ;
operations: Operation_hash.t list list ;
operations: operation list list ;
}
val inject_block:

18
src/node/shell/prevalidation.ml
View File

@ -131,16 +131,18 @@ and 'a proto =
with type validation_state = 'a)
let start_prevalidation
~predecessor:
{ State.Valid_block.protocol ;
hash = predecessor ;
context = predecessor_context ;
timestamp = predecessor_timestamp ;
fitness = predecessor_fitness ;
level = predecessor_level }
~predecessor
~timestamp =
let { Block_header.shell =
{ fitness = predecessor_fitness ;
timestamp = predecessor_timestamp ;
level = predecessor_level } } =
State.Block.header predecessor in
State.Block.context predecessor >>= fun predecessor_context ->
Context.get_protocol predecessor_context >>= fun protocol ->
let predecessor = State.Block.hash predecessor in
let (module Proto) =
match protocol with
match Updater.get protocol with
| None -> assert false (* FIXME, this should not happen! *)
| Some protocol -> protocol in
Context.reset_test_network

2
src/node/shell/prevalidation.mli
View File

@ -29,7 +29,7 @@ val preapply_result_encoding :
type prevalidation_state
val start_prevalidation :
predecessor: State.Valid_block.t ->
predecessor: State.Block.t ->
timestamp: Time.t ->
prevalidation_state tzresult Lwt.t

86
src/node/shell/prevalidator.ml
View File

@ -9,31 +9,31 @@
open Logging.Node.Prevalidator
let list_pendings net_db ~from_block ~to_block old_mempool =
let rec pop_blocks ancestor hash mempool =
let list_pendings ~from_block ~to_block old_mempool =
let rec pop_blocks ancestor block mempool =
let hash = State.Block.hash block in
if Block_hash.equal hash ancestor then
Lwt.return mempool
else
Distributed_db.Block_header.read_exn net_db hash >>= fun { shell } ->
Distributed_db.Operation_list.read_all_exn
net_db hash >>= fun operations ->
State.Block.all_operation_hashes block >>= fun operations ->
let mempool =
List.fold_left
(List.fold_left (fun mempool h -> Operation_hash.Set.add h mempool))
mempool operations in
pop_blocks ancestor shell.predecessor mempool
State.Block.predecessor block >>= function
| None -> assert false
| Some predecessor -> pop_blocks ancestor predecessor mempool
in
let push_block mempool (hash, _shell) =
Distributed_db.Operation_list.read_all_exn
net_db hash >|= fun operations ->
let push_block mempool block =
State.Block.all_operation_hashes block >|= fun operations ->
List.fold_left
(List.fold_left (fun mempool h -> Operation_hash.Set.remove h mempool))
mempool operations
in
let net_state = Distributed_db.state net_db in
State.Valid_block.Current.new_blocks
net_state ~from_block ~to_block >>= fun (ancestor, path) ->
pop_blocks ancestor from_block.hash old_mempool >>= fun mempool ->
Chain_traversal.new_blocks ~from_block ~to_block >>= fun (ancestor, path) ->
pop_blocks
(State.Block.hash ancestor)
from_block old_mempool >>= fun mempool ->
Lwt_list.fold_left_s push_block mempool path >>= fun new_mempool ->
Lwt.return new_mempool
@ -45,14 +45,14 @@ exception Invalid_operation of Operation_hash.t
open Prevalidation
type t = {
net_db: Distributed_db.net ;
flush: State.Valid_block.t -> unit;
net_db: Distributed_db.net_db ;
flush: State.Block.t -> unit;
notify_operations: P2p.Peer_id.t -> Operation_hash.t list -> unit ;
prevalidate_operations:
bool -> Operation.t list ->
(Operation_hash.t list * error preapply_result) tzresult Lwt.t ;
operations: unit -> error preapply_result * Operation_hash.Set.t ;
pending: ?block:State.Valid_block.t -> unit -> Operation_hash.Set.t Lwt.t ;
pending: ?block:State.Block.t -> unit -> Operation_hash.Set.t Lwt.t ;
timestamp: unit -> Time.t ;
context: unit -> Updater.validation_result tzresult Lwt.t ;
shutdown: unit -> unit Lwt.t ;
@ -71,15 +71,14 @@ let create net_db =
let cancelation, cancel, _on_cancel = Lwt_utils.canceler () in
let push_to_worker, worker_waiter = Lwt_utils.queue () in
State.Valid_block.Current.head net_state >>= fun head ->
State.Operation.list_pending net_state >>= fun initial_mempool ->
Chain.head net_state >>= fun head ->
let timestamp = ref (Time.now ()) in
(start_prevalidation head !timestamp >|= ref) >>= fun validation_state ->
let pending = Operation_hash.Table.create 53 in
let head = ref head in
let operations = ref empty_result in
let running_validation = ref Lwt.return_unit in
let unprocessed = ref initial_mempool in
let unprocessed = ref Operation_hash.Set.empty in
let broadcast_unprocessed = ref false in
let set_validation_state state =
@ -92,7 +91,8 @@ let create net_db =
Lwt.return_unit in
let broadcast_operation ops =
Distributed_db.broadcast_head net_db !head.hash ops in
let hash = State.Block.hash !head in
Distributed_db.broadcast_head net_db hash ops in
let handle_unprocessed () =
if Operation_hash.Set.is_empty !unprocessed then
@ -108,7 +108,7 @@ let create net_db =
begin
Lwt_list.map_p
(fun h ->
Distributed_db.Operation.read net_db h >>= function
Distributed_db.Operation.read_opt net_db h >>= function
| None -> Lwt.return_none
| Some po -> Lwt.return_some (h, po))
(Operation_hash.Set.elements ops) >>= fun rops ->
@ -184,28 +184,28 @@ let create net_db =
prevalidate validation_state ~sort:true rops >>=? fun (state, res) ->
let register h =
let op = Operation_hash.Map.find h ops in
Distributed_db.Operation.inject
net_db h op >>= fun _ ->
Lwt.return_unit in
Lwt_list.iter_s
Distributed_db.inject_operation
net_db h op >>=? fun (_ : bool) ->
return () in
iter_s
(fun h ->
register h >>= fun () ->
register h >>=? fun () ->
operations :=
{ !operations with
applied = h :: !operations.applied };
Lwt.return_unit )
res.applied >>= fun () ->
return () )
res.applied >>=? fun () ->
broadcast_operation res.applied ;
begin
if force then
Lwt_list.iter_p
iter_p
(fun (h, _exns) -> register h)
(Operation_hash.Map.bindings
res.branch_delayed) >>= fun () ->
Lwt_list.iter_p
res.branch_delayed) >>=? fun () ->
iter_p
(fun (h, _exns) -> register h)
(Operation_hash.Map.bindings
res.branch_refused) >>= fun () ->
res.branch_refused) >>=? fun () ->
operations :=
{ !operations with
branch_delayed =
@ -215,10 +215,10 @@ let create net_db =
Operation_hash.Map.merge merge
!operations.branch_refused res.branch_refused ;
} ;
Lwt.return_unit
return ()
else
Lwt.return_unit
end >>= fun () ->
return ()
end >>=? fun () ->
set_validation_state (Ok state) >>= fun () ->
return res
in
@ -236,7 +236,7 @@ let create net_db =
(fun op -> Operation_hash.Table.mem pending op) new_ops in
let fetch op =
Distributed_db.Operation.fetch
net_db ~peer:gid op >>= fun _op ->
net_db ~peer:gid op () >>= fun _op ->
push_to_worker (`Handle op) ;
Lwt.return_unit
in
@ -245,7 +245,7 @@ let create net_db =
unknown_ops ;
List.iter (fun op ->
Lwt.ignore_result
(Distributed_db.Operation.fetch net_db ~peer:gid op))
(Distributed_db.Operation.fetch net_db ~peer:gid op ()))
known_ops ;
Lwt.return_unit
| `Handle op ->
@ -255,12 +255,11 @@ let create net_db =
unprocessed := Operation_hash.Set.singleton op ;
lwt_debug "register %a" Operation_hash.pp_short op >>= fun () ->
Lwt.return_unit
| `Flush (new_head : State.Valid_block.t) ->
list_pendings
net_db ~from_block:!head ~to_block:new_head
| `Flush (new_head : State.Block.t) ->
list_pendings ~from_block:!head ~to_block:new_head
(preapply_result_operations !operations) >>= fun new_mempool ->
lwt_debug "flush %a (mempool: %d)"
Block_hash.pp_short new_head.hash
Block_hash.pp_short (State.Block.hash new_head)
(Operation_hash.Set.cardinal new_mempool) >>= fun () ->
(* Reset the pre-validation context *)
head := new_head ;
@ -306,8 +305,7 @@ let create net_db =
let ops = preapply_result_operations !operations in
match block with
| None -> Lwt.return ops
| Some to_block ->
list_pendings net_db ~from_block:!head ~to_block ops in
| Some to_block -> list_pendings ~from_block:!head ~to_block ops in
let context () =
Lwt.return !validation_state >>=? fun prevalidation_state ->
Prevalidation.end_prevalidation prevalidation_state in
@ -345,7 +343,7 @@ let inject_operation pv ?(force = false) (op: Operation.t) =
end >>=? fun errors ->
Lwt.return (Error errors) in
fail_unless (Net_id.equal net_id op.shell.net_id)
(Unclassified
(failure
"Prevalidator.inject_operation: invalid network") >>=? fun () ->
pv.prevalidate_operations force [op] >>=? function
| ([h], { applied = [h'] }) when Operation_hash.equal h h' ->

9
src/node/shell/prevalidator.mli
View File

@ -29,7 +29,7 @@
type t
(** Creation and destruction of a "prevalidation" worker. *)
val create: Distributed_db.net -> t Lwt.t
val create: Distributed_db.net_db -> t Lwt.t
val shutdown: t -> unit Lwt.t
val notify_operations: t -> P2p.Peer_id.t -> Operation_hash.t list -> unit
@ -38,12 +38,11 @@ val notify_operations: t -> P2p.Peer_id.t -> Operation_hash.t list -> unit
be ignored when it is (strongly) refused This is the
entry-point used by the P2P layer. The operation content has been
previously stored on disk. *)
val inject_operation:
t -> ?force:bool -> Operation.t -> unit tzresult Lwt.t
val inject_operation: t -> ?force:bool -> Operation.t -> unit tzresult Lwt.t
val flush: t -> State.Valid_block.t -> unit
val flush: t -> State.Block.t -> unit
val timestamp: t -> Time.t
val operations: t -> error Prevalidation.preapply_result * Operation_hash.Set.t
val context: t -> Updater.validation_result tzresult Lwt.t
val pending: ?block:State.Valid_block.t -> t -> Operation_hash.Set.t Lwt.t
val pending: ?block:State.Block.t -> t -> Operation_hash.Set.t Lwt.t

1698
src/node/shell/state.ml
View File

File diff suppressed because it is too large Load Diff

391
src/node/shell/state.mli
View File

@ -7,6 +7,8 @@
(* *)
(**************************************************************************)
type t
type global_state = t
(** An abstraction over all the disk storage used by the node.
It encapsulates access to:
@ -14,14 +16,7 @@
- the index of validation contexts; and
- the persistent state of the node:
- the blockchain and its alternate heads of a "network";
- the pool of pending operations of a "network".
*)
type t
type global_state = t
(** Read the internal state of the node and initialize
the blocks/operations/contexts databases. *)
- the pool of pending operations of a "network". *)
val read:
?patch_context:(Context.t -> Context.t Lwt.t) ->
@ -29,6 +24,8 @@ val read:
context_root:string ->
unit ->
global_state tzresult Lwt.t
(** Read the internal state of the node and initialize
the databases. *)
val close:
global_state -> unit Lwt.t
@ -36,17 +33,7 @@ val close:
(** {2 Errors} **************************************************************)
type error +=
| Invalid_fitness of { block: Block_hash.t ;
expected: Fitness.t ;
found: Fitness.t }
| Invalid_operations of { block: Block_hash.t ;
expected: Operation_list_list_hash.t ;
found: Operation_hash.t list list }
| Unknown_network of Net_id.t
| Unknown_operation of Operation_hash.t
| Unknown_block of Block_hash.t
| Unknown_protocol of Protocol_hash.t
| Cannot_parse
(** {2 Network} ************************************************************)
@ -55,7 +42,7 @@ type error +=
module Net : sig
type t
type net = t
type net_state = t
type genesis = {
time: Time.t ;
@ -64,329 +51,141 @@ module Net : sig
}
val genesis_encoding: genesis Data_encoding.t
(** Initialize a network for a given [genesis]. By default,
the network does accept forking test network. When
[~allow_forked_network:true] is provided, test network are allowed. *)
val create:
global_state ->
?allow_forked_network:bool ->
genesis -> net Lwt.t
genesis -> net_state Lwt.t
(** Initialize a network for a given [genesis]. By default,
the network does accept forking test network. When
[~allow_forked_network:true] is provided, test network are allowed. *)
val get: global_state -> Net_id.t -> net_state tzresult Lwt.t
(** Look up for a network by the hash of its genesis block. *)
val get: global_state -> Net_id.t -> net tzresult Lwt.t
val all: global_state -> net_state list Lwt.t
(** Returns all the known networks. *)
val all: global_state -> net list Lwt.t
val destroy: global_state -> net_state -> unit Lwt.t
(** Destroy a network: this completly removes from the local storage all
the data associated to the network (this includes blocks and
operations). *)
val destroy: global_state -> net -> unit Lwt.t
val id: net_state -> Net_id.t
val genesis: net_state -> genesis
val expiration: net_state -> Time.t option
val allow_forked_network: net_state -> bool
(** Accessors. Respectively access to;
- the network id (the hash of its genesis block)
- its optional expiration time
- the associated global state. *)
val id: net -> Net_id.t
val genesis: net -> genesis
val expiration: net -> Time.t option
val allow_forked_network: net -> bool
end
(** Shared signature for the databases of block_headers,
operations and protocols. *)
module type DATA_STORE = sig
(** {2 Block database} ********************************************************)
type store
type key
type value
module Block : sig
(** Is a value stored in the local database ? *)
val known: store -> key -> bool Lwt.t
type t
type block = t
(** Read a value in the local database. *)
val read: store -> key -> value tzresult Lwt.t
val read_opt: store -> key -> value option Lwt.t
val read_exn: store -> key -> value Lwt.t
val known_valid: Net.t -> Block_hash.t -> bool Lwt.t
val known_invalid: Net.t -> Block_hash.t -> bool Lwt.t
(** Read a value in the local database (without parsing). *)
val read_raw: store -> key -> MBytes.t tzresult Lwt.t
val read_raw_opt: store -> key -> MBytes.t option Lwt.t
val read_raw_exn: store -> key -> MBytes.t Lwt.t
val read: Net.t -> Block_hash.t -> block tzresult Lwt.t
val read_opt: Net.t -> Block_hash.t -> block option Lwt.t
val read_exn: Net.t -> Block_hash.t -> block Lwt.t
(** Read data discovery time (the time when `store` was called). *)
val read_discovery_time: store -> key -> Time.t tzresult Lwt.t
val read_discovery_time_opt: store -> key -> Time.t option Lwt.t
val read_discovery_time_exn: store -> key -> Time.t Lwt.t
(** Store a value in the local database (pre-parsed value). It
returns [false] when the value is already stored, or [true]
otherwise. For a given value, only one call to `store` (or an
equivalent call to `store_raw`) might return [true]. *)
val store: store -> key -> value -> bool Lwt.t
(** Store a value in the local database (unparsed data). It returns
[Ok None] when the data is already stored, or [Ok (Some (hash,
value))] otherwise. For a given data, only one call to
`store_raw` (or an equivalent call to `store`) might return [Ok
(Some _)]. It may return [Error] when the shell part of the value
cannot be parsed. *)
val store_raw: store -> key -> MBytes.t -> value option tzresult Lwt.t
(** Remove a value from the local database. *)
val remove: store -> key -> bool Lwt.t
end
(** {2 Block_header database} *************************************************)
module Block_header : sig
include DATA_STORE with type store = Net.t
and type key = Block_hash.t
and type value := Block_header.t
val mark_invalid: Net.t -> Block_hash.t -> error list -> bool Lwt.t
val invalid: Net.t -> Block_hash.t -> error list option Lwt.t
val pending: Net.t -> Block_hash.t -> bool Lwt.t
val list_pending: Net.t -> Block_hash.Set.t Lwt.t
val list_invalid: Net.t -> Block_hash.Set.t Lwt.t
module Helpers : sig
(** If [h1] is an ancestor of [h2] in the current [state],
then [path state h1 h2] returns the chain of block from
[h1] (excluded) to [h2] (included). *)
val path:
Net.t -> Block_hash.t -> Block_hash.t ->
(Block_hash.t * Block_header.shell_header) list tzresult Lwt.t
(** [common_ancestor state h1 h2] returns the first common ancestors
in the history of blocks [h1] and [h2]. *)
val common_ancestor:
Net.t -> Block_hash.t -> Block_hash.t ->
(Block_hash.t * Block_header.shell_header) tzresult Lwt.t
(** [block_locator state max_length h] compute the sparse block locator
(/à la/ Bitcoin) for the block [h]. *)
val block_locator:
Net.t -> int -> Block_hash.t -> Block_hash.t list tzresult Lwt.t
(** [iter_predecessors state blocks f] iter [f] on [blocks] and
their recursive (known) predecessors. Blocks are visited with a
decreasing fitness (then decreasing timestamp). If the optional
argument [max] is provided, the iteration is stopped after [max]
visited block. If [min_fitness] id provided, blocks with a
fitness lower than [min_fitness] are ignored. If [min_date],
blocks with a fitness lower than [min_date] are ignored. *)
val iter_predecessors:
Net.t ->
?max:int ->
?min_fitness:Fitness.t ->
?min_date:Time.t ->
Block_header.t list ->
f:(Block_header.t -> unit Lwt.t) ->
unit tzresult Lwt.t
end
end
module Operation_list : sig
type store = Net.t
type key = Block_hash.t * int
type value = Operation_hash.t list * Operation_list_list_hash.path
val known: store -> key -> bool Lwt.t
val read: store -> key -> value tzresult Lwt.t
val read_opt: store -> key -> value option Lwt.t
val read_exn: store -> key -> value Lwt.t
val store: store -> key -> value -> bool Lwt.t
val remove: store -> key -> bool Lwt.t
val read_count: store -> Block_hash.t -> int tzresult Lwt.t
val read_count_opt: store -> Block_hash.t -> int option Lwt.t
val read_count_exn: store -> Block_hash.t -> int Lwt.t
val store_count: store -> Block_hash.t -> int -> unit Lwt.t
val read_all:
store -> Block_hash.t -> Operation_hash.t list list tzresult Lwt.t
val store_all:
store -> Block_hash.t -> Operation_hash.t list list -> unit Lwt.t
end
(** {2 Valid block} ***********************************************************)
(** The local database of known-valid blocks. *)
module Valid_block : sig
(** A validated block. *)
type t = private {
net_id: Net_id.t ;
(** The genesis of the chain this block belongs to. *)
hash: Block_hash.t ;
(** The block hash. *)
level: Int32.t ;
(** The number of preceding block in the chain. *)
proto_level: int ;
(** The number of protocol amendment block in the chain (modulo 256) *)
predecessor: Block_hash.t ;
(** The preceding block in the chain. *)
timestamp: Time.t ;
(** The date at which this block has been forged. *)
fitness: Fitness.t ;
(** The (validated) score of the block. *)
operations_hash: Operation_list_list_hash.t ;
operation_hashes: Operation_hash.t list list Lwt.t Lazy.t ;
operations: Operation.t list list Lwt.t Lazy.t ;
(** The sequence of operations and its (Merkle-)hash. *)
discovery_time: Time.t ;
(** The data at which the block was discorevered on the P2P network. *)
protocol_hash: Protocol_hash.t ;
(** The protocol to be used for validating the following blocks. *)
protocol: (module Updater.REGISTRED_PROTOCOL) option ;
(** The actual implementation of the protocol to be used for
validating the following blocks. *)
test_network: Context.test_network ;
(** The current test network associated to the block. *)
context: Context.t ;
(** The validation context that was produced by the block validation. *)
proto_header: MBytes.t;
(** The uninterpreted protocol dependent part of the header. *)
}
type valid_block = t
val known: Net.t -> Block_hash.t -> bool Lwt.t
val read: Net.t -> Block_hash.t -> valid_block tzresult Lwt.t
val read_opt: Net.t -> Block_hash.t -> valid_block option Lwt.t
val read_exn: Net.t -> Block_hash.t -> valid_block Lwt.t
val store:
Net.t -> Block_hash.t -> Updater.validation_result ->
valid_block option tzresult Lwt.t
Net.t ->
Block_header.t ->
Operation.t list list ->
Updater.validation_result ->
block option tzresult Lwt.t
val watcher: Net.t -> valid_block Lwt_stream.t * Watcher.stopper
val store_invalid:
Net.t ->
Block_header.t ->
bool tzresult Lwt.t
(** The known valid heads of the network's blockchain. *)
val known_heads: Net.t -> valid_block list Lwt.t
val compare: t -> t -> int
val equal: t -> t -> bool
val fork_testnet:
global_state ->
Net.t -> valid_block ->
Protocol_hash.t -> Time.t ->
Net.t tzresult Lwt.t
val hash: t -> Block_hash.t
val header: t -> Block_header.t
val shell_header: t -> Block_header.shell_header
val timestamp: t -> Time.t
val fitness: t -> Fitness.t
val operation_list_count: t -> int
val net_id: t -> Net_id.t
val level: t -> Int32.t
val message: t -> string
module Current : sig
val predecessor: t -> block option Lwt.t
(** The genesis block of the network's blockchain. On a test network,
the test protocol has been promoted as "main" protocol. *)
val genesis: Net.t -> valid_block Lwt.t
val context: t -> Context.t Lwt.t
val protocol_hash: t -> Protocol_hash.t Lwt.t
val test_network: t -> Context.test_network Lwt.t
(** The current head of the network's blockchain. *)
val head: Net.t -> valid_block Lwt.t
val operation_hashes:
t -> int ->
(Operation_hash.t list * Operation_list_list_hash.path) Lwt.t
val all_operation_hashes: t -> Operation_hash.t list list Lwt.t
(** The current protocol of the network's blockchain. *)
val protocol: Net.t -> (module Updater.REGISTRED_PROTOCOL) Lwt.t
val operations:
t -> int -> (Operation.t list * Operation_list_list_hash.path) Lwt.t
val all_operations: t -> Operation.t list list Lwt.t
(** Record a block as the current head of the network's blockchain. *)
val set_head: Net.t -> valid_block -> unit Lwt.t
val mem: Net.t -> Block_hash.t -> bool Lwt.t
(** 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 test_and_set_head:
Net.t -> old:valid_block -> valid_block -> bool 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]. *)
val find_new:
Net.t -> Block_hash.t list -> int -> Block_hash.t list tzresult Lwt.t
val new_blocks:
Net.t -> from_block:valid_block -> to_block:valid_block ->
(Block_hash.t * (Block_hash.t * Tezos_data.Block_header.shell_header) list) Lwt.t
end
module Helpers : sig
(** If [h1] is an ancestor of [h2] in the current [state],
then [path state h1 h2] returns the chain of block from
[h1] (excluded) to [h2] (included). Returns [None] otherwise. *)
val path:
Net.t -> valid_block -> valid_block -> valid_block list option Lwt.t
(** [common_ancestor state h1 h2] returns the first common ancestors
in the history of blocks [h1] and [h2]. *)
val common_ancestor:
Net.t -> valid_block -> valid_block -> valid_block Lwt.t
(** [block_locator state max_length h] compute the sparse block locator
(/à la/ Bitcoin) for the block [h]. *)
val block_locator: Net.t -> int -> valid_block -> Block_hash.t list Lwt.t
(** [iter_predecessors state blocks f] iter [f] on [blocks] and
their recursive predecessors. Blocks are visited with a
decreasing fitness (then decreasing timestamp). If the optional
argument [max] is provided, the iteration is stopped after [max]
visited block. If [min_fitness] id provided, blocks with a
fitness lower than [min_fitness] are ignored. If [min_date],
blocks with a fitness lower than [min_date] are ignored. *)
val iter_predecessors:
Net.t ->
?max:int ->
?min_fitness:Fitness.t ->
?min_date:Time.t ->
valid_block list ->
f:(valid_block -> unit Lwt.t) ->
unit tzresult Lwt.t
end
val watcher: Net.t -> block Lwt_stream.t * Watcher.stopper
end
val read_block:
global_state -> Block_hash.t -> Block.t option Lwt.t
(** {2 Operation database} ****************************************************)
val read_block_exn:
global_state -> Block_hash.t -> Block.t Lwt.t
module Operation : sig
val fork_testnet:
global_state -> Block.t -> Protocol_hash.t -> Time.t ->
Net.t tzresult Lwt.t
include DATA_STORE with type store = Net.t
and type key = Operation_hash.t
and type value := Operation.t
type chain_data = {
current_head: Block.t ;
}
val mark_invalid: Net.t -> Operation_hash.t -> error list -> bool Lwt.t
val in_chain: Net.t -> Operation_hash.t -> bool Lwt.t
val pending: Net.t -> Operation_hash.t -> bool Lwt.t
val invalid: Net.t -> Operation_hash.t -> error list option Lwt.t
val list_pending: Net.t -> Operation_hash.Set.t Lwt.t
val list_invalid: Net.t -> Operation_hash.Set.t Lwt.t
end
val read_chain_store:
Net.t ->
(Store.Chain.store -> chain_data -> 'a Lwt.t) ->
'a Lwt.t
val update_chain_store:
Net.t ->
(Store.Chain.store -> chain_data -> (chain_data option * 'a) Lwt.t) ->
'a Lwt.t
(** {2 Protocol database} ***************************************************)
module Protocol : sig
include DATA_STORE with type store = global_state
and type key = Protocol_hash.t
and type value := Protocol.t
(** Is a value stored in the local database ? *)
val known: global_state -> Protocol_hash.t -> bool Lwt.t
(** Read a value in the local database. *)
val read: global_state -> Protocol_hash.t -> Protocol.t tzresult Lwt.t
val read_opt: global_state -> Protocol_hash.t -> Protocol.t option Lwt.t
val read_exn: global_state -> Protocol_hash.t -> Protocol.t Lwt.t
(** Read a value in the local database (without parsing). *)
val read_raw: global_state -> Protocol_hash.t -> MBytes.t tzresult Lwt.t
val read_raw_opt: global_state -> Protocol_hash.t -> MBytes.t option Lwt.t
val read_raw_exn: global_state -> Protocol_hash.t -> MBytes.t Lwt.t
val store: global_state -> Protocol.t -> Protocol_hash.t option Lwt.t
(** Remove a value from the local database. *)
val remove: global_state -> Protocol_hash.t -> bool Lwt.t
val list: global_state -> Protocol_hash.Set.t Lwt.t
(* val mark_invalid: Net.t -> Protocol_hash.t -> error list -> bool Lwt.t *)
(* val list_invalid: Net.t -> Protocol_hash.Set.t Lwt.t *)
end

333
src/node/shell/validator.ml
View File

@ -16,11 +16,11 @@ type worker = {
deactivate: t -> unit Lwt.t ;
inject_block:
?force:bool ->
MBytes.t -> Operation_hash.t list list ->
(Block_hash.t * State.Valid_block.t tzresult Lwt.t) tzresult Lwt.t ;
MBytes.t -> Distributed_db.operation list list ->
(Block_hash.t * State.Block.t tzresult Lwt.t) tzresult Lwt.t ;
notify_block: Block_hash.t -> Block_header.t -> unit Lwt.t ;
shutdown: unit -> unit Lwt.t ;
valid_block_input: State.Valid_block.t Watcher.input ;
valid_block_input: State.Block.t Watcher.input ;
db: Distributed_db.t ;
}
@ -30,18 +30,18 @@ and t = {
parent: t option ;
mutable child: t option ;
prevalidator: Prevalidator.t ;
net_db: Distributed_db.net ;
net_db: Distributed_db.net_db ;
notify_block: Block_hash.t -> Block_header.t -> unit Lwt.t ;
fetch_block: Block_hash.t -> State.Valid_block.t tzresult Lwt.t ;
fetch_block: Block_hash.t -> State.Block.t tzresult Lwt.t ;
create_child:
State.Valid_block.t -> Protocol_hash.t -> Time.t -> unit tzresult Lwt.t ;
State.Block.t -> Protocol_hash.t -> Time.t -> unit tzresult Lwt.t ;
check_child:
Block_hash.t -> Protocol_hash.t -> Time.t -> Time.t -> unit tzresult Lwt.t ;
deactivate_child: unit -> unit Lwt.t ;
test_validator: unit -> (t * Distributed_db.net) option ;
test_validator: unit -> (t * Distributed_db.net_db) option ;
shutdown: unit -> unit Lwt.t ;
valid_block_input: State.Valid_block.t Watcher.input ;
new_head_input: State.Valid_block.t Watcher.input ;
valid_block_input_for_net: State.Block.t Watcher.input ;
new_head_input: State.Block.t Watcher.input ;
bootstrapped: unit Lwt.t ;
}
@ -66,13 +66,12 @@ let bootstrapped v = v.bootstrapped
let fetch_protocol v hash =
lwt_log_notice "Fetching protocol %a"
Protocol_hash.pp_short hash >>= fun () ->
Distributed_db.Protocol.fetch v.worker.db hash >>= fun protocol ->
Distributed_db.Protocol.fetch v.worker.db hash () >>= fun protocol ->
Updater.compile hash protocol >>= fun valid ->
if valid then begin
lwt_log_notice "Successfully compiled protocol %a"
Protocol_hash.pp_short hash >>= fun () ->
Distributed_db.Protocol.commit
v.worker.db hash >>= fun () ->
Distributed_db.commit_protocol v.worker.db hash >>=? fun _ ->
return true
end else begin
lwt_log_error "Failed to compile protocol %a"
@ -80,43 +79,49 @@ let fetch_protocol v hash =
failwith "Cannot compile the protocol %a" Protocol_hash.pp_short hash
end
let fetch_protocols v (block: State.Valid_block.t) =
let fetch_protocols v (block: State.Block.t) =
State.Block.context block >>= fun context ->
let proto_updated =
match block.protocol with
Context.get_protocol context >>= fun protocol_hash ->
match Updater.get protocol_hash with
| Some _ -> return false
| None -> fetch_protocol v block.protocol_hash
| None -> fetch_protocol v protocol_hash
and test_proto_updated =
match block.test_network with
Context.get_test_network context >>= function
| Not_running -> return false
| Forking { protocol }
| Running { protocol } ->
Distributed_db.Protocol.known v.worker.db protocol >>= fun known ->
if known then return false
else fetch_protocol v protocol in
match Updater.get protocol with
| Some _ -> return false
| None -> fetch_protocol v protocol in
proto_updated >>=? fun proto_updated ->
test_proto_updated >>=? fun _test_proto_updated ->
if proto_updated then
State.Valid_block.read_exn v.net block.hash >>= return
else
return block
test_proto_updated >>=? fun test_proto_updated ->
return (proto_updated && test_proto_updated)
let rec may_set_head v (block: State.Valid_block.t) =
State.Valid_block.Current.head v.net >>= fun head ->
if Fitness.compare head.fitness block.fitness >= 0 then
let rec may_set_head v (block: State.Block.t) =
Chain.head v.net >>= fun head ->
let head_header = State.Block.header head
and head_hash = State.Block.hash head
and block_header = State.Block.header block
and block_hash = State.Block.hash block in
if
Fitness.compare
head_header.shell.fitness block_header.shell.fitness >= 0
then
Lwt.return_unit
else begin
State.Valid_block.Current.test_and_set_head v.net
~old:head block >>= function
Chain.test_and_set_head v.net ~old:head block >>= function
| false -> may_set_head v block
| true ->
Distributed_db.broadcast_head v.net_db block.hash [] ;
Distributed_db.broadcast_head v.net_db block_hash [] ;
Prevalidator.flush v.prevalidator block ;
begin
begin
match block.test_network with
State.Block.test_network block >>= function
| Not_running -> v.deactivate_child () >>= return
| Running { genesis ; protocol ; expiration } ->
v.check_child genesis protocol expiration block.timestamp
v.check_child genesis protocol expiration
block_header.shell.timestamp
| Forking { protocol ; expiration } ->
v.create_child block protocol expiration
end >>= function
@ -127,11 +132,11 @@ let rec may_set_head v (block: State.Valid_block.t) =
end >>= fun () ->
Watcher.notify v.new_head_input block ;
lwt_log_notice "update current head %a %a %a(%t)"
Block_hash.pp_short block.hash
Fitness.pp block.fitness
Time.pp_hum block.timestamp
Block_hash.pp_short block_hash
Fitness.pp block_header.shell.fitness
Time.pp_hum block_header.shell.timestamp
(fun ppf ->
if Block_hash.equal head.hash block.predecessor then
if Block_hash.equal head_hash block_header.shell.predecessor then
Format.fprintf ppf "same branch"
else
Format.fprintf ppf "changing branch") >>= fun () ->
@ -142,12 +147,38 @@ let rec may_set_head v (block: State.Valid_block.t) =
type error +=
| Invalid_operation of Operation_hash.t
| Invalid_fitness of { block: Block_hash.t ;
expected: Fitness.t ;
found: Fitness.t }
| Unknown_protocol
| Non_increasing_timestamp
| Non_increasing_fitness
| Wrong_level of Int32.t * Int32.t
| Wrong_proto_level of int * int
let () =
Error_monad.register_error_kind
`Permanent
~id:"validator.invalid_fitness"
~title:"Invalid fitness"
~description:"The computed fitness differs from the fitness found \
\ in the block header."
~pp:(fun ppf (block, expected, found) ->
Format.fprintf ppf
"@[<v 2>Invalid fitness for block %a@ \
\ expected %a@ \
\ found %a"
Block_hash.pp_short block
Fitness.pp expected
Fitness.pp found)
Data_encoding.(obj3
(req "block" Block_hash.encoding)
(req "expected" Fitness.encoding)
(req "found" Fitness.encoding))
(function Invalid_fitness { block ; expected ; found } ->
Some (block, expected, found) | _ -> None)
(fun (block, expected, found) ->
Invalid_fitness { block ; expected ; found }) ;
register_error_kind
`Permanent
~id:"validator.wrong_level"
@ -175,47 +206,50 @@ let () =
(function Wrong_proto_level (e, g) -> Some (e, g) | _ -> None)
(fun (e, g) -> Wrong_proto_level (e, g))
let apply_block net db
(pred: State.Valid_block.t) hash (block: Block_header.t) =
let id = State.Net.id net in
let apply_block net_state db
(pred: State.Block.t) hash (block: Block_header.t) =
let pred_header = State.Block.header pred
and pred_hash = State.Block.hash pred in
State.Block.context pred >>= fun pred_context ->
let id = State.Net.id net_state in
lwt_log_notice "validate block %a (after %a), net %a"
Block_hash.pp_short hash
Block_hash.pp_short block.shell.predecessor
Net_id.pp id
>>= fun () ->
fail_unless
(Int32.succ pred.level = block.shell.level)
(Wrong_level (Int32.succ pred.level, block.shell.level)) >>=? fun () ->
(Int32.succ pred_header.shell.level = block.shell.level)
(Wrong_level (Int32.succ pred_header.shell.level,
block.shell.level)) >>=? fun () ->
lwt_log_info "validation of %a: looking for dependencies..."
Block_hash.pp_short hash >>= fun () ->
Distributed_db.Operation_list.fetch
db (hash, 0) block.shell.operations_hash >>= fun operation_hashes ->
Lwt_list.map_p
(fun op -> Distributed_db.Operation.fetch db op)
operation_hashes >>= fun operations ->
Distributed_db.Operations.fetch
db (hash, 0) block.shell.operations_hash >>= fun operations ->
let operation_hashes = List.map Operation.hash operations in
lwt_debug "validation of %a: found operations"
Block_hash.pp_short hash >>= fun () ->
begin (* Are we validating a block in an expired test network ? *)
match State.Net.expiration net with
match State.Net.expiration net_state with
| Some eol when Time.(eol <= block.shell.timestamp) ->
failwith "This test network expired..."
| None | Some _ -> return ()
end >>=? fun () ->
begin
if Time.(pred.timestamp >= block.shell.timestamp) then
if Time.(pred_header.shell.timestamp >= block.shell.timestamp) then
fail Non_increasing_timestamp
else
return ()
end >>=? fun () ->
begin
if Fitness.compare pred.fitness block.shell.fitness >= 0 then
if Fitness.compare pred_header.shell.fitness block.shell.fitness >= 0 then
fail Non_increasing_fitness
else
return ()
end >>=? fun () ->
Context.get_protocol pred_context >>= fun pred_protocol_hash ->
begin
match pred.protocol with
| None -> fail (State.Unknown_protocol pred.protocol_hash)
match Updater.get pred_protocol_hash with
| None -> fail Unknown_protocol
| Some p -> return p
end >>=? fun (module Proto) ->
lwt_debug "validation of %a: Proto %a"
@ -234,11 +268,11 @@ let apply_block net db
lwt_debug "validation of %a: applying block..."
Block_hash.pp_short hash >>= fun () ->
Context.reset_test_network
pred.context pred.hash block.shell.timestamp >>= fun context ->
pred_context pred_hash block.shell.timestamp >>= fun context ->
Proto.begin_application
~predecessor_context:context
~predecessor_timestamp:pred.timestamp
~predecessor_fitness:pred.fitness
~predecessor_timestamp:pred_header.shell.timestamp
~predecessor_fitness:pred_header.shell.fitness
block >>=? fun state ->
fold_left_s (fun state op ->
Proto.apply_operation state op >>=? fun state ->
@ -247,13 +281,20 @@ let apply_block net db
Proto.finalize_block state >>=? fun new_context ->
Context.get_protocol new_context.context >>= fun new_protocol ->
let expected_proto_level =
if Protocol_hash.equal new_protocol pred.protocol_hash then
pred.proto_level
if Protocol_hash.equal new_protocol pred_protocol_hash then
pred_header.shell.proto_level
else
(pred.proto_level + 1) mod 256 in
(pred_header.shell.proto_level + 1) mod 256 in
fail_when (block.shell.proto_level <> expected_proto_level)
(Wrong_proto_level (block.shell.proto_level, expected_proto_level))
>>=? fun () ->
fail_unless
(Fitness.equal new_context.fitness block.shell.fitness)
(Invalid_fitness
{ block = hash ;
expected = block.shell.fitness ;
found = new_context.fitness ;
}) >>=? fun () ->
lwt_log_info "validation of %a: success"
Block_hash.pp_short hash >>= fun () ->
return new_context
@ -263,14 +304,14 @@ let apply_block net db
module Context_db = struct
type key = Block_hash.t
type value = State.Valid_block.t
type value = State.Block.t
type data =
{ validator: t ;
state: [ `Inited of Block_header.t tzresult
| `Initing of Block_header.t tzresult Lwt.t
| `Running of State.Valid_block.t tzresult Lwt.t ] ;
wakener: State.Valid_block.t tzresult Lwt.u }
| `Running of State.Block.t tzresult Lwt.t ] ;
wakener: State.Block.t tzresult Lwt.u }
type context =
{ tbl : data Block_hash.Table.t ;
@ -278,7 +319,7 @@ module Context_db = struct
worker_trigger: unit -> unit;
worker_waiter: unit -> unit Lwt.t ;
worker: unit Lwt.t ;
net_db : Distributed_db.net ;
net_db : Distributed_db.net_db ;
net_state : State.Net.t }
let pending_requests { tbl } =
@ -296,7 +337,7 @@ module Context_db = struct
assert (not (Block_hash.Table.mem tbl hash));
let waiter, wakener = Lwt.wait () in
let data =
Distributed_db.Block_header.fetch net_db hash >>= return in
Distributed_db.Block_header.fetch net_db hash () >>= return in
match Lwt.state data with
| Lwt.Return data ->
let state = `Inited data in
@ -317,71 +358,61 @@ module Context_db = struct
let prefetch validator ({ net_state ; tbl } as session) hash =
Lwt.ignore_result
(State.Valid_block.known net_state hash >>= fun exists ->
(State.Block.known_valid net_state hash >>= fun exists ->
if not exists && not (Block_hash.Table.mem tbl hash) then
request validator session hash >>= fun _ -> Lwt.return_unit
else
Lwt.return_unit)
let known { net_state } hash =
State.Valid_block.known net_state hash
State.Block.known_valid net_state hash
let read { net_state } hash =
State.Valid_block.read net_state hash
State.Block.read net_state hash
let fetch ({ net_state ; tbl } as session) validator hash =
try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
with Not_found ->
State.Valid_block.read_opt net_state hash >>= function
| Some op ->
Lwt.return (Ok op)
| None ->
try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
with Not_found -> request validator session hash
State.Block.known_invalid net_state hash >>= fun known_invalid ->
if known_invalid then
Lwt.return (Error [failure "Invalid predecessor"])
else
State.Block.read_opt net_state hash >>= function
| Some op ->
Lwt.return (Ok op)
| None ->
try Lwt.waiter_of_wakener (Block_hash.Table.find tbl hash).wakener
with Not_found -> request validator session hash
let store { net_state ; net_db ; tbl } hash data =
let store { net_db ; tbl } hash data =
begin
match data with
| Ok data ->
Distributed_db.Block_header.commit net_db hash >>= fun () ->
Distributed_db.Operation_list.commit_all
net_db hash 1 >>= fun () ->
begin
State.Valid_block.store net_state hash data >>=? function
| None ->
State.Valid_block.read net_state hash >>=? fun block ->
Lazy.force block.operation_hashes >>= fun ophs ->
Lwt_list.iter_p
(Lwt_list.iter_p (fun hash ->
Distributed_db.Operation.commit net_db hash))
ophs >>= fun () ->
return (Ok block, false)
| Some block ->
Lazy.force block.operation_hashes >>= fun ophs ->
Lwt_list.iter_p
(Lwt_list.iter_p (fun hash ->
Distributed_db.Operation.commit net_db hash))
ophs >>= fun () ->
return (Ok block, true)
| Ok data -> begin
Distributed_db.commit_block net_db hash 1 data >>=? function
| None ->
(* Should not happen if the block is not validated twice *)
assert false
| Some block ->
return (Ok block)
end
| Error err ->
State.Block_header.mark_invalid
net_state hash err >>= fun changed ->
return (Error err, changed)
Distributed_db.commit_invalid_block net_db hash 1 >>=? fun changed ->
assert changed ;
return (Error err)
end >>= function
| Ok (block, changed) ->
| Ok block ->
let wakener = (Block_hash.Table.find tbl hash).wakener in
Block_hash.Table.remove tbl hash;
Lwt.wakeup wakener block ;
Lwt.return changed
Lwt.return_unit
| Error _ as err ->
let wakener = (Block_hash.Table.find tbl hash).wakener in
Block_hash.Table.remove tbl hash;
Lwt.wakeup wakener err ;
Lwt.return false
Lwt.return_unit
let process (v:t) ~get_context ~set_context hash block =
let state = Distributed_db.state v.net_db in
let net_state = Distributed_db.state v.net_db in
get_context v block.Block_header.shell.predecessor >>= function
| Error _ as error ->
set_context v hash (Error [(* TODO *)]) >>= fun () ->
@ -389,14 +420,15 @@ module Context_db = struct
| Ok _context ->
lwt_debug "process %a" Block_hash.pp_short hash >>= fun () ->
begin
State.Valid_block.Current.genesis state >>= fun genesis ->
if Block_hash.equal genesis.hash block.shell.predecessor then
Chain.genesis net_state >>= fun genesis ->
if Block_hash.equal (State.Block.hash genesis)
block.shell.predecessor then
Lwt.return genesis
else
State.Valid_block.read_exn state block.shell.predecessor
State.Block.read_exn net_state block.shell.predecessor
end >>= fun pred ->
apply_block state v.net_db pred hash block >>= function
| Error ([State.Unknown_protocol _] as err) as error ->
apply_block net_state v.net_db pred hash block >>= function
| Error ([Unknown_protocol] as err) as error ->
lwt_log_error
"@[<v 2>Ignoring block %a@ %a@]"
Block_hash.pp_short hash
@ -411,10 +443,10 @@ module Context_db = struct
| Ok new_context ->
(* The sanity check `set_context` detects differences
between the computed fitness and the fitness announced
in the block header. Then `Valid_block.read` will
in the block header. Then `Block.read` will
return an error. *)
set_context v hash (Ok new_context) >>= fun () ->
State.Valid_block.read state hash >>= function
State.Block.read net_state hash >>= function
| Error err as error ->
lwt_log_error
"@[<v 2>Ignoring block %a@ %a@]"
@ -426,8 +458,8 @@ module Context_db = struct
"validation of %a: reevaluate current block"
Block_hash.pp_short hash >>= fun () ->
Watcher.notify v.worker.valid_block_input block ;
Watcher.notify v.valid_block_input block ;
fetch_protocols v block >>=? fun block ->
Watcher.notify v.valid_block_input_for_net block ;
fetch_protocols v block >>=? fun _fetched ->
may_set_head v block >>= fun () ->
return block
@ -523,15 +555,15 @@ let rec create_validator ?max_ttl ?parent worker state db net =
Lwt.async (fun () -> Lwt_pipe.push queue (`Branch (gid, locator)))
end ;
current_branch = begin fun size ->
State.Valid_block.Current.head net >>= fun head ->
State.Valid_block.Helpers.block_locator net size head
Chain.head net >>= fun head ->
Chain_traversal.block_locator head size
end ;
notify_head = begin fun gid block ops ->
Lwt.async (fun () -> Lwt_pipe.push queue (`Head (gid, block, ops))) ;
end ;
current_head = begin fun size ->
State.Valid_block.Current.head net >>= fun head ->
Lwt.return (head.hash, Utils.list_sub (!current_ops ()) size)
Chain.head net >>= fun head ->
Lwt.return (State.Block.hash head, Utils.list_sub (!current_ops ()) size)
end ;
disconnection = (fun _gid -> ()) ;
} in
@ -558,24 +590,24 @@ let rec create_validator ?max_ttl ?parent worker state db net =
]
in
let valid_block_input = Watcher.create_input () in
let valid_block_input_for_net = Watcher.create_input () in
let new_head_input = Watcher.create_input () in
let bootstrapped =
(* TODO improve by taking current peers count and current
locators into account... *)
let stream, stopper =
Watcher.create_stream valid_block_input in
Watcher.create_stream valid_block_input_for_net in
let rec wait () =
Lwt.pick [ ( Lwt_stream.get stream ) ;
( Lwt_unix.sleep 30. >|= fun () -> None) ] >>= function
| Some block
when Time.(block.State.Valid_block.timestamp < add (Time.now ()) (-60L)) ->
wait ()
| Some block when
Time.((State.Block.header block).shell.timestamp < add (Time.now ()) (-60L)) ->
wait ()
| _ ->
State.Valid_block.Current.head net >>= fun head ->
State.Valid_block.Current.genesis net >>= fun genesis ->
if Block_hash.equal head.hash genesis.hash then
Chain.head net >>= fun head ->
Chain.genesis net >>= fun genesis ->
if State.Block.equal head genesis then
wait ()
else
Lwt.return_unit in
@ -602,14 +634,15 @@ let rec create_validator ?max_ttl ?parent worker state db net =
test_validator ;
bootstrapped ;
new_head_input ;
valid_block_input ;
valid_block_input_for_net ;
}
and notify_block hash block =
lwt_debug "-> Validator.notify_block %a"
Block_hash.pp_short hash >>= fun () ->
State.Valid_block.Current.head net >>= fun head ->
if Fitness.compare head.fitness block.shell.fitness <= 0 then
Chain.head net >>= fun head ->
let head_header = State.Block.header head in
if Fitness.compare head_header.shell.fitness block.shell.fitness <= 0 then
Context_db.prefetch v session hash ;
Lwt.return_unit
@ -623,9 +656,9 @@ let rec create_validator ?max_ttl ?parent worker state db net =
State.Net.get state net_id >>= function
| Ok net_store -> return net_store
| Error _ ->
State.Valid_block.fork_testnet
state net block protocol expiration >>=? fun net_store ->
State.Valid_block.Current.head net_store >>= fun block ->
State.fork_testnet
state block protocol expiration >>=? fun net_store ->
Chain.head net_store >>= fun block ->
Watcher.notify v.worker.valid_block_input block ;
return net_store
end >>=? fun net_store ->
@ -654,7 +687,7 @@ let rec create_validator ?max_ttl ?parent worker state db net =
match max_ttl with
| None -> Lwt.return expiration
| Some ttl ->
Distributed_db.Block_header.fetch net_db genesis >>= fun genesis ->
Distributed_db.Block_header.fetch net_db genesis () >>= fun genesis ->
Lwt.return
(Time.min expiration
(Time.add genesis.shell.timestamp (Int64.of_int ttl)))
@ -796,29 +829,23 @@ let create_worker ?max_ttl state db =
let inject_block ?(force = false) bytes operations =
Distributed_db.inject_block db bytes operations >>=? fun (hash, block) ->
get block.shell.net_id >>=? fun net ->
(*
Lwt_list.filter_map_s
(fun bytes ->
let hash = Operation_hash.hash_bytes [bytes] in
match Data_encoding.
Distributed_db.Operation.inject net.net_db hash bytes >>= function
| false -> Lwt.return_none
| true ->
if List.exists
(List.exists (Operation_hash.equal hash))
operations then
Lwt.return (Some hash)
else
Lwt.return_none)
injected_operations >>= fun injected_operations ->
*)
let validation =
State.Valid_block.Current.head net.net >>= fun head ->
if force
|| Fitness.compare head.fitness block.shell.fitness <= 0 then
fetch_block net hash
else
failwith "Fitness is below the current one" in
protect
~on_error: begin fun err ->
Distributed_db.remove_block
net.net_db hash (List.length operations) >>= fun () ->
Lwt.return (Error err)
end
begin fun () ->
Chain.head net.net >>= fun head ->
let head_header = State.Block.header head in
if force ||
Fitness.compare head_header.shell.fitness block.shell.fitness <= 0
then
fetch_block net hash
else
failwith "Fitness is below the current one"
end in
return (hash, validation) in
let rec activate ?parent net =
@ -846,11 +873,11 @@ let create_worker ?max_ttl state db =
worker
let new_head_watcher ({ new_head_input } : t) =
let new_head_watcher { new_head_input } =
Watcher.create_stream new_head_input
let watcher ({ valid_block_input } : t) =
Watcher.create_stream valid_block_input
let watcher { valid_block_input_for_net } =
Watcher.create_stream valid_block_input_for_net
let global_watcher ({ valid_block_input } : worker) =
Watcher.create_stream valid_block_input

16
src/node/shell/validator.mli
View File

@ -26,21 +26,21 @@ val get_exn: worker -> Net_id.t -> t Lwt.t
val deactivate: t -> unit Lwt.t
val net_state: t -> State.Net.t
val net_db: t -> Distributed_db.net
val net_db: t -> Distributed_db.net_db
val fetch_block:
t -> Block_hash.t -> State.Valid_block.t tzresult Lwt.t
t -> Block_hash.t -> State.Block.t tzresult Lwt.t
val inject_block:
worker -> ?force:bool ->
MBytes.t -> Operation_hash.t list list ->
(Block_hash.t * State.Valid_block.t tzresult Lwt.t) tzresult Lwt.t
MBytes.t -> Distributed_db.operation list list ->
(Block_hash.t * State.Block.t tzresult Lwt.t) tzresult Lwt.t
val prevalidator: t -> Prevalidator.t
val test_validator: t -> (t * Distributed_db.net) option
val test_validator: t -> (t * Distributed_db.net_db) option
val watcher: t -> State.Valid_block.t Lwt_stream.t * Watcher.stopper
val new_head_watcher: t -> State.Valid_block.t Lwt_stream.t * Watcher.stopper
val global_watcher: worker -> State.Valid_block.t Lwt_stream.t * Watcher.stopper
val watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper
val new_head_watcher: t -> State.Block.t Lwt_stream.t * Watcher.stopper
val global_watcher: worker -> State.Block.t Lwt_stream.t * Watcher.stopper
val bootstrapped: t -> unit Lwt.t

27
src/utils/error_monad.ml
View File

@ -210,6 +210,17 @@ module Make() = struct
map_s f t >>=? fun rt ->
return (rh :: rt)
let mapi_s f l =
let rec mapi_s f i l =
match l with
| [] -> return []
| h :: t ->
f i h >>=? fun rh ->
mapi_s f (i+1) t >>=? fun rt ->
return (rh :: rt)
in
mapi_s f 0 l
let rec map_p f l =
match l with
| [] ->
@ -224,6 +235,22 @@ module Make() = struct
| Ok _, Error exn
| Error exn, Ok _ -> Lwt.return (Error exn)
let mapi_p f l =
let rec mapi_p f i l =
match l with
| [] ->
return []
| x :: l ->
let tx = f i x and tl = mapi_p f (i+1) l in
tx >>= fun x ->
tl >>= fun l ->
match x, l with
| Ok x, Ok l -> Lwt.return (Ok (x :: l))
| Error exn1, Error exn2 -> Lwt.return (Error (exn1 @ exn2))
| Ok _, Error exn
| Error exn, Ok _ -> Lwt.return (Error exn) in
mapi_p f 0 l
let rec map2_s f l1 l2 =
match l1, l2 with
| [], [] -> return []

2
src/utils/error_monad_sig.ml
View File

@ -122,6 +122,8 @@ module type S = sig
(** A {!List.map} in the monad *)
val map_s : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val map_p : ('a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val mapi_s : (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
val mapi_p : (int -> 'a -> 'b tzresult Lwt.t) -> 'a list -> 'b list tzresult Lwt.t
(** A {!List.map2} in the monad *)
val map2 :

39
test/Makefile.shared
View File

@ -52,11 +52,38 @@ CLIENTLIB := ${SRCDIR}/client.cmxa \
${MINUTILSLIB} ${UTILSLIB} ${COMPILERLIB} ${NODELIB} ${CLIENTLIB}:
${MAKE} -C ${SRCDIR} $@
${SRCDIR}/minutils/%: ${MINUTILSLIB}
${SRCDIR}/utils/%: ${UTILSLIB}
${SRCDIR}/compiler/%: ${COMPILERLIB}
${SRCDIR}/node/%: ${NODELIB}
${SRCDIR}/client/%: ${CLIENTLIB}
${SRCDIR}/minutils/%.cmi: ${SRCDIR}/minutils/%.mli
${MAKE} -C ${SRCDIR} minutils.cmxa
${SRCDIR}/minutils/%.cmx : ${SRCDIR}/minutils/%.ml
${MAKE} -C ${SRCDIR} minutils.cmxa
${SRCDIR}/utils/%.cmi: ${SRCDIR}/utils/%.mli
${MAKE} -C ${SRCDIR} utils.cmxa
${SRCDIR}/utils/%.cmx : ${SRCDIR}/utils/%.ml
${MAKE} -C ${SRCDIR} utils.cmxa
${SRCDIR}/compiler/%.cmi: ${SRCDIR}/compiler/%.mli
${MAKE} -C ${SRCDIR} compiler.cmxa
${SRCDIR}/compiler/%.cmx : ${SRCDIR}/compiler/%.ml
${MAKE} -C ${SRCDIR} compiler.cmxa
${SRCDIR}/node/db/%.cmi: ${SRCDIR}/node/db/%.mli
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/db/%.cmx : ${SRCDIR}/node/db/%.ml
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/net/%.cmi: ${SRCDIR}/node/net/%.mli
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/net/%.cmx : ${SRCDIR}/node/net/%.ml
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/shell/%.cmi: ${SRCDIR}/node/shell/%.mli
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/shell/%.cmx : ${SRCDIR}/node/shell/%.ml
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/updater/%.cmi: ${SRCDIR}/node/updater/%.mli
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/node/updater/%.cmx : ${SRCDIR}/node/updater/%.ml
${MAKE} -C ${SRCDIR} node.cmxa
${SRCDIR}/client/%.cmi: ${SRCDIR}/client/%.mli
${MAKE} -C ${SRCDIR} client.cmxa
${SRCDIR}/client/%.cmx : ${SRCDIR}/client/%.ml
${MAKE} -C ${SRCDIR} client.cmxa
############################################################################
## Generic rules
@ -82,7 +109,7 @@ partial-clean::
-find . \( -name \*.cm\* -or -name \*.cmp -or -name \*.out -or -name \*~ -or -name \*.o -or -name \*.a \) -delete
-include .depend
.depend: $(shell find . -name \*.ml -or -name \*.ml)
.depend: $(shell find . -name \*.mli -or -name \*.ml)
@echo OCAMLDEP "(test/$(notdir $(shell echo $$PWD)))"
@$(OCAMLDEP) -native $(INCLUDES) $^ > .depend

25
test/proto_alpha/Makefile
View File

@ -29,6 +29,15 @@ OPENED_MODULES := \
${CLIENT_OPENED_MODULES} \
Environment Client_embedded_proto_alpha Tezos_context
${SRCDIR}/client/embedded/alpha/_tzbuild/%.cmi: ${SRCDIR}/proto/alpha/%.mli
${MAKE} -C ${SRCDIR} proto/client_embedded_proto_alpha.cmxa
${SRCDIR}/client/embedded/alpha/_tzbuild/%.cmx: ${SRCDIR}/proto/alpha/%.ml
${MAKE} -C ${SRCDIR} proto/client_embedded_proto_alpha.cmxa
${SRCDIR}/client/embedded/alpha/%.cmi: ${SRCDIR}/client/embedded/alpha/%.mli
${MAKE} -C ${SRCDIR} client/embedded/client_alpha.cmx
${SRCDIR}/client/embedded/alpha/%.cmx: ${SRCDIR}/client/embedded/alpha/%.ml
${MAKE} -C ${SRCDIR} client/embedded/client_alpha.cmx
############################################################################
## Transactions
@ -37,11 +46,11 @@ run-test-transaction:
@echo
./test-transaction
TEST_CONNECTION_IMPLS := \
TEST_TRANSACTION_IMPLS := \
proto_alpha_helpers.ml \
test_transaction.ml
test-transaction: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
test-transaction: ${LIB} ${TEST_TRANSACTION_IMPLS:.ml=.cmx}
@echo COMPILE $(notdir $@)
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
@ -56,11 +65,11 @@ run-test-origination:
@echo
./test-origination
TEST_CONNECTION_IMPLS := \
TEST_ORIGINATION_IMPLS := \
proto_alpha_helpers.ml \
test_origination.ml
test-origination: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
test-origination: ${LIB} ${TEST_ORIGINATION_IMPLS:.ml=.cmx}
@echo COMPILE $(notdir $@)
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
@ -75,11 +84,11 @@ run-test-endorsement:
@echo
./test-endorsement
TEST_CONNECTION_IMPLS := \
TEST_ENDORSEMENT_IMPLS := \
proto_alpha_helpers.ml \
test_endorsement.ml
test-endorsement: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
test-endorsement: ${LIB} ${TEST_ENDORSEMENT_IMPLS:.ml=.cmx}
@echo COMPILE $(notdir $@)
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^
@ -94,11 +103,11 @@ run-test-vote:
@echo
./test-vote
TEST_CONNECTION_IMPLS := \
TEST_VOTE_IMPLS := \
proto_alpha_helpers.ml \
test_vote.ml
test-vote: ${LIB} ${TEST_CONNECTION_IMPLS:.ml=.cmx}
test-vote: ${LIB} ${TEST_VOTE_IMPLS:.ml=.cmx}
@echo COMPILE $(notdir $@)
@${OCAMLOPT} -linkall -linkpkg ${OCAMLFLAGS} -o $@ $^

4
test/proto_alpha/proto_alpha_helpers.ml
View File

@ -15,7 +15,7 @@ let (//) = Filename.concat
let rpc_config : Client_rpcs.config = {
host = "localhost" ;
port = 18732 ;
port = 8192 + Random.int 8192 ;
tls = false ;
logger = Client_rpcs.null_logger ;
}
@ -476,7 +476,7 @@ module Mining = struct
() >>=? fun unsigned_header ->
let signed_header = Environment.Ed25519.Signature.append src_sk unsigned_header in
Client_node_rpcs.inject_block rpc_config
?force signed_header [operation_list] >>=? fun block_hash ->
?force signed_header [List.map (fun h -> Client_node_rpcs.Hash h) operation_list] >>=? fun block_hash ->
return block_hash
let mine

461
test/shell/test_state.ml
View File

@ -102,81 +102,42 @@ let equal_block ?msg st1 st2 =
Hash.Block_hash.to_hex (Block_header.hash st) in
Assert.equal ?msg ~prn ~eq st1 st2
let build_chain state tbl otbl pred names =
Lwt_list.fold_left_s
(fun (pred_hash, pred) name ->
begin
let oph, op, _bytes = operation name in
State.Operation.store state oph op >>= fun created ->
Assert.is_true ~msg:__LOC__ created ;
State.Operation.read_opt state oph >>= fun op' ->
equal_operation ~msg:__LOC__ (Some op) op' ;
State.Operation.mark_invalid state oph [] >>= fun store_invalid ->
Assert.is_true ~msg:__LOC__ store_invalid ;
Hashtbl.add otbl name (oph, Error []) ;
let block = block ~operations:[oph] state pred_hash pred name in
let hash = Block_header.hash block in
State.Block_header.store state hash block >>= fun created ->
Assert.is_true ~msg:__LOC__ created ;
State.Block_header.read_opt state hash >>= fun block' ->
equal_block ~msg:__LOC__ (Some block) block' ;
State.Block_header.mark_invalid state hash [] >>= fun store_invalid ->
Assert.is_true ~msg:__LOC__ store_invalid ;
Hashtbl.add tbl name (hash, block) ;
return (hash, block)
end >>= function
| Ok v -> Lwt.return v
| Error err ->
Error_monad.pp_print_error Format.err_formatter err ;
assert false)
pred
names >>= fun _ ->
Lwt.return ()
let block _state ?(operations = []) (pred: State.Valid_block.t) name
let block _state ?(operations = []) (pred: State.Block.t) name
: Block_header.t =
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute operations] in
let fitness = incr_fitness pred.fitness in
let timestamp = incr_timestamp pred.timestamp in
{ shell = { net_id = pred.net_id ;
level = Int32.succ pred.level ;
proto_level = pred.proto_level ;
predecessor = pred.hash ;
let pred_header = State.Block.shell_header pred in
let fitness = incr_fitness pred_header.fitness in
let timestamp = incr_timestamp pred_header.timestamp in
{ shell = { net_id = pred_header.net_id ;
level = Int32.succ pred_header.level ;
proto_level = pred_header.proto_level ;
predecessor = State.Block.hash pred ;
timestamp ; operations_hash ; fitness } ;
proto = MBytes.of_string name ;
}
let build_valid_chain state tbl vtbl otbl pred names =
let build_valid_chain state vtbl pred names =
Lwt_list.fold_left_s
(fun pred name ->
begin
let oph, op, _bytes = operation name in
State.Operation.store state oph op >>= fun created ->
Assert.is_true ~msg:__LOC__ created ;
State.Operation.read_opt state oph >>= fun op' ->
equal_operation ~msg:__LOC__ (Some op) op' ;
Hashtbl.add otbl name (oph, Ok op) ;
let block = block state ~operations:[oph] pred name in
let hash = Tezos_data.Block_header.hash block in
State.Block_header.store state hash block >>= fun created ->
Assert.is_true ~msg:__LOC__ created ;
State.Operation_list.store_all state hash [[oph]] >>= fun () ->
State.Block_header.read_opt state hash >>= fun block' ->
equal_block ~msg:__LOC__ (Some block) block' ;
Hashtbl.add tbl name (hash, block) ;
let hash = Block_header.hash block in
let pred_header = State.Block.header pred in
State.Block.context pred >>= fun predecessor_context ->
begin
Proto.begin_application
~predecessor_context: pred.context
~predecessor_timestamp: pred.timestamp
~predecessor_fitness: pred.fitness
~predecessor_context
~predecessor_timestamp: pred_header.shell.timestamp
~predecessor_fitness: pred_header.shell.fitness
block >>=? fun vstate ->
(* no operations *)
Proto.finalize_block vstate
end >>=? fun ctxt ->
State.Valid_block.store state hash ctxt >>=? fun _vblock ->
State.Valid_block.read state hash >>=? fun vblock ->
State.Block.store state block [[op]] ctxt >>=? fun _vblock ->
State.Block.read state hash >>=? fun vblock ->
Hashtbl.add vtbl name vblock ;
return vblock
end >>= function
@ -189,63 +150,31 @@ let build_valid_chain state tbl vtbl otbl pred names =
Lwt.return ()
let build_example_tree net =
let tbl = Hashtbl.create 23 in
let vtbl = Hashtbl.create 23 in
let otbl = Hashtbl.create 23 in
State.Valid_block.Current.genesis net >>= fun genesis ->
State.Block_header.read_exn net genesis.hash >>= fun genesis_header ->
Chain.genesis net >>= fun genesis ->
Hashtbl.add vtbl "Genesis" genesis ;
Hashtbl.add tbl "Genesis" (genesis.hash, genesis_header ) ;
let chain = [ "A1" ; "A2" ; "A3" ; "A4" ; "A5" ; "A6" ; "A7" ; "A8" ] in
build_valid_chain net tbl vtbl otbl genesis chain >>= fun () ->
build_valid_chain net vtbl genesis chain >>= fun () ->
let a3 = Hashtbl.find vtbl "A3" in
let chain = [ "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] in
build_valid_chain net tbl vtbl otbl a3 chain >>= fun () ->
let b7 = Hashtbl.find tbl "B7" in
let chain = [ "C1" ; "C2" ; "C3" ; "C4" ; "C5" ; "C6" ; "C7" ; "C8" ] in
build_chain net tbl otbl b7 chain >>= fun () ->
let pending_op = "PP" in
let oph, op, _bytes = operation pending_op in
State.Operation.store net oph op >>= fun _ ->
State.Operation.read_opt net oph >>= fun op' ->
equal_operation ~msg:__LOC__ (Some op) op' ;
Hashtbl.add otbl pending_op (oph, Ok op) ;
Lwt.return (tbl, vtbl, otbl)
build_valid_chain net vtbl a3 chain >>= fun () ->
Lwt.return vtbl
type state = {
block: (string, Block_hash.t * Block_header.t) Hashtbl.t ;
operation: (string, Operation_hash.t * Operation.t tzresult) Hashtbl.t ;
vblock: (string, State.Valid_block.t) Hashtbl.t ;
vblock: (string, State.Block.t) Hashtbl.t ;
state: State.t ;
net: State.Net.t ;
init: unit -> State.t tzresult Lwt.t;
}
let block s = Hashtbl.find s.block
let vblock s = Hashtbl.find s.vblock
let operation s = Hashtbl.find s.operation
exception Found of string
let rev_find s h =
try
Hashtbl.iter (fun k (bh,_) ->
if Block_hash.equal bh h then raise (Found k))
s.block ;
Format.asprintf "genesis(%a)" Block_hash.pp_short h
with Found s -> s
let blocks s =
Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.block []
|> List.sort Pervasives.compare
let vblocks s =
Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.vblock []
|> List.sort Pervasives.compare
let operations s =
Hashtbl.fold (fun k v acc -> (k,v) :: acc) s.operation []
|> List.sort Pervasives.compare
let wrap_state_init f base_dir =
begin
let store_root = base_dir // "store" in
@ -257,81 +186,36 @@ let wrap_state_init f base_dir =
() in
init () >>=? fun state ->
State.Net.create state genesis >>= fun net ->
build_example_tree net >>= fun (block, vblock, operation) ->
f { state ; net ; block ; vblock ; operation ; init } >>=? fun () ->
build_example_tree net >>= fun vblock ->
f { state ; net ; vblock ; init } >>=? fun () ->
return ()
end
let test_init (_ : state) =
return ()
let test_read_operation (s: state) =
Lwt_list.iter_s (fun (name, (oph, op)) ->
State.Operation.invalid s.net oph >>= function
| Some err ->
begin match op with
| Ok _ ->
Assert.fail_msg "Incorrect invalid operation read %s" name
| Error e ->
if e <> err then
Assert.fail_msg "Incorrect operation read %s" name ;
Lwt.return_unit
end
| None ->
State.Operation.read_opt s.net oph >>= function
| None ->
Assert.fail_msg "Cannot read block %s" name
| Some data ->
begin match op with
| Error _ ->
Assert.fail_msg "Incorrect valid operation read %s" name
| Ok op ->
if op.Operation.proto <> data.proto then
Assert.fail_msg "Incorrect operation read %s %s" name
(MBytes.to_string data.Operation.proto) ;
Lwt.return_unit
end)
(operations s) >>= fun () ->
return ()
(****************************************************************************)
(** State. *)
(** State.Block.read *)
let test_read_block (s: state) =
Lwt_list.iter_s (fun (name, (hash, block)) ->
begin
State.Block_header.read_opt s.net hash >>= function
| None ->
Assert.fail_msg "Cannot read block %s" name
| Some block' ->
if not (Block_header.equal block block') then
Assert.fail_msg "Error while reading block %s" name ;
Lwt.return_unit
end >>= fun () ->
let vblock =
try Some (vblock s name)
with Not_found -> None in
State.Valid_block.read s.net hash >>= function
Lwt_list.iter_s (fun (name, vblock) ->
let hash = State.Block.hash vblock in
State.Block.read s.net hash >>= function
| Error _ ->
if vblock <> None then
Assert.fail_msg "Error while reading valid block %s" name ;
Lwt.return_unit
Assert.fail_msg "Error while reading valid block %s" name
| Ok _vblock' ->
match vblock with
| None ->
Assert.fail_msg "Error while reading invalid block %s" name
| Some _vblock ->
Lwt.return_unit
) (blocks s) >>= fun () ->
(* FIXME COMPARE read operations ??? *)
Lwt.return_unit
) (vblocks s) >>= fun () ->
return ()
(****************************************************************************)
(** State.path *)
(** Chain_traversal.path *)
let rec compare_path p1 p2 = match p1, p2 with
| [], [] -> true
@ -340,32 +224,12 @@ let rec compare_path p1 p2 = match p1, p2 with
let test_path (s: state) =
let check_path h1 h2 p2 =
State.Block_header.Helpers.path s.net (fst @@ block s h1) (fst @@ block s h2) >>= function
| Error _ ->
Assert.fail_msg "cannot compute path %s -> %s" h1 h2
| Ok p1 ->
let p1 = List.map (fun b -> fst b) p1 in
let p2 = List.map (fun b -> fst (block s b)) p2 in
if not (compare_path p1 p2) then
Assert.fail_msg "bad path %s -> %s" h1 h2 ;
Lwt.return_unit in
check_path "Genesis" "Genesis" [] >>= fun () ->
check_path "A1" "A1" [] >>= fun () ->
check_path "A2" "A6" ["A3"; "A4"; "A5"; "A6"] >>= fun () ->
check_path "B2" "B6" ["B3"; "B4"; "B5"; "B6"] >>= fun () ->
check_path "A1" "B3" ["A2"; "A3"; "B1"; "B2"; "B3"] >>= fun () ->
check_path "A1" "C2" ["A2"; "A3"; "B1"; "B2"; "B3" ; "B4" ;
"B5" ; "B6" ; "B7" ; "C1" ; "C2" ] >>= fun () ->
return ()
let test_valid_path (s: state) =
let check_path h1 h2 p2 =
State.Valid_block.Helpers.path s.net (vblock s h1) (vblock s h2) >>= function
Chain_traversal.path (vblock s h1) (vblock s h2) >>= function
| None ->
Assert.fail_msg "cannot compute path %s -> %s" h1 h2 ;
| Some (p: State.Valid_block.t list) ->
let p = List.map (fun b -> b.State.Valid_block.hash) p in
let p2 = List.map (fun b -> (vblock s b).hash) p2 in
| Some (p: State.Block.t list) ->
let p = List.map State.Block.hash p in
let p2 = List.map (fun b -> State.Block.hash (vblock s b)) p2 in
if not (compare_path p p2) then
Assert.fail_msg "bad path %s -> %s" h1 h2 ;
Lwt.return_unit in
@ -379,107 +243,59 @@ let test_valid_path (s: state) =
(****************************************************************************)
(** State.ancestor *)
(** Chain_traversal.common_ancestor *)
let test_ancestor s =
let check_ancestor h1 h2 expected =
State.Block_header.Helpers.common_ancestor
s.net (fst @@ block s h1) (fst @@ block s h2) >>= function
| Error _ ->
Assert.fail_msg "Cannot compure ancestor for %s %s" h1 h2 ;
| Ok (a, _) ->
if not (Block_hash.equal a (fst expected)) then
Assert.fail_msg
"bad ancestor %s %s: found %s, expected %s"
h1 h2 (rev_find s a) (rev_find s @@ fst expected) ;
Lwt.return_unit in
let check_valid_ancestor h1 h2 expected =
State.Valid_block.Helpers.common_ancestor
s.net (vblock s h1) (vblock s h2) >>= fun a ->
if not (Block_hash.equal a.hash expected.State.Valid_block.hash) then
Chain_traversal.common_ancestor
(vblock s h1) (vblock s h2) >>= fun a ->
if not (Block_hash.equal (State.Block.hash a) (State.Block.hash expected)) then
Assert.fail_msg "bad ancestor %s %s" h1 h2 ;
Lwt.return_unit in
check_ancestor "Genesis" "Genesis" (block s "Genesis") >>= fun () ->
check_ancestor "Genesis" "A3" (block s "Genesis") >>= fun () ->
check_ancestor "A3" "Genesis" (block s "Genesis") >>= fun () ->
check_ancestor "A1" "A1" (block s "A1") >>= fun () ->
check_ancestor "A1" "A3" (block s "A1") >>= fun () ->
check_ancestor "A3" "A1" (block s "A1") >>= fun () ->
check_ancestor "A6" "B6" (block s "A3") >>= fun () ->
check_ancestor "B6" "A6" (block s "A3") >>= fun () ->
check_ancestor "A4" "B1" (block s "A3") >>= fun () ->
check_ancestor "B1" "A4" (block s "A3") >>= fun () ->
check_ancestor "A3" "B1" (block s "A3") >>= fun () ->
check_ancestor "B1" "A3" (block s "A3") >>= fun () ->
check_ancestor "A2" "B1" (block s "A2") >>= fun () ->
check_ancestor "B1" "A2" (block s "A2") >>= fun () ->
check_ancestor "C4" "B8" (block s "B7") >>= fun () ->
check_ancestor "B8" "C4" (block s "B7") >>= fun () ->
check_ancestor "C4" "A8" (block s "A3") >>= fun () ->
check_ancestor "A8" "C4" (block s "A3") >>= fun () ->
check_valid_ancestor "A6" "B6" (vblock s "A3") >>= fun () ->
check_valid_ancestor "B6" "A6" (vblock s "A3") >>= fun () ->
check_valid_ancestor "A4" "B1" (vblock s "A3") >>= fun () ->
check_valid_ancestor "B1" "A4" (vblock s "A3") >>= fun () ->
check_valid_ancestor "A3" "B1" (vblock s "A3") >>= fun () ->
check_valid_ancestor "B1" "A3" (vblock s "A3") >>= fun () ->
check_valid_ancestor "A2" "B1" (vblock s "A2") >>= fun () ->
check_valid_ancestor "B1" "A2" (vblock s "A2") >>= fun () ->
check_ancestor "Genesis" "Genesis" (vblock s "Genesis") >>= fun () ->
check_ancestor "Genesis" "A3" (vblock s "Genesis") >>= fun () ->
check_ancestor "A3" "Genesis" (vblock s "Genesis") >>= fun () ->
check_ancestor "A1" "A1" (vblock s "A1") >>= fun () ->
check_ancestor "A1" "A3" (vblock s "A1") >>= fun () ->
check_ancestor "A3" "A1" (vblock s "A1") >>= fun () ->
check_ancestor "A6" "B6" (vblock s "A3") >>= fun () ->
check_ancestor "B6" "A6" (vblock s "A3") >>= fun () ->
check_ancestor "A4" "B1" (vblock s "A3") >>= fun () ->
check_ancestor "B1" "A4" (vblock s "A3") >>= fun () ->
check_ancestor "A3" "B1" (vblock s "A3") >>= fun () ->
check_ancestor "B1" "A3" (vblock s "A3") >>= fun () ->
check_ancestor "A2" "B1" (vblock s "A2") >>= fun () ->
check_ancestor "B1" "A2" (vblock s "A2") >>= fun () ->
return ()
(****************************************************************************)
(** State.locator *)
(** Chain_traversal.block_locator *)
let test_locator s =
let check_locator h1 expected =
State.Block_header.Helpers.block_locator
s.net (List.length expected) (fst @@ block s h1) >>= function
| Error _ ->
Assert.fail_msg "Cannot compute locator for %s" h1
| Ok l ->
if List.length l <> List.length expected then
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h1 (List.length l) (List.length expected) ;
List.iter2
(fun h h2 ->
if not (Block_hash.equal h (fst @@ block s h2)) then
Assert.fail_msg "Invalid locator %s (expectd: %s)" h1 h2)
l expected;
Lwt.return_unit in
let check_valid_locator h1 expected =
State.Valid_block.Helpers.block_locator
s.net (List.length expected) (vblock s h1) >>= fun l ->
Chain_traversal.block_locator
(vblock s h1) (List.length expected) >>= fun l ->
if List.length l <> List.length expected then
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h1 (List.length l) (List.length expected) ;
List.iter2
(fun h h2 ->
if not (Block_hash.equal h (fst @@ block s h2)) then
if not (Block_hash.equal h (State.Block.hash @@ vblock s h2)) then
Assert.fail_msg "Invalid locator %s (expectd: %s)" h1 h2)
l expected ;
Lwt.return_unit in
check_locator "A8" ["A8";"A7";"A6";"A5";"A4";"A3";"A2";"A1"] >>= fun () ->
check_locator "B8"
["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
check_locator "C8"
["C8";"C7";"C6";"C5";"C4";"C3";"C2";"C1";
"B7";"B6";"B4";"B2";"A3";"A1"] >>= fun () ->
check_locator "C8" ["C8";"C7";"C6";"C5";"C4"] >>= fun () ->
check_valid_locator "A8"
["A8";"A7";"A6";"A5";"A4";"A3";"A2"] >>= fun () ->
check_valid_locator "B8"
["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
check_valid_locator "B8" ["B8";"B7";"B6";"B5";"B4"] >>= fun () ->
check_locator "A8" ["A8";"A7";"A6";"A5";"A4";"A3";"A2"] >>= fun () ->
check_locator "B8" ["B8";"B7";"B6";"B5";"B4";"B3";"B2";"B1";"A3"] >>= fun () ->
check_locator "B8" ["B8";"B7";"B6";"B5";"B4"] >>= fun () ->
return ()
(****************************************************************************)
(** State.known_heads *)
(** Chain.known_heads *)
let compare s name heads l =
if List.length heads <> List.length l then
@ -488,39 +304,39 @@ let compare s name heads l =
name (List.length heads) (List.length l) ;
List.iter
(fun bname ->
let hash = (vblock s bname).hash in
if not (List.exists (fun b -> Block_hash.equal hash b.State.Valid_block.hash) heads) then
let hash = State.Block.hash (vblock s bname) in
if not (List.exists (fun b -> Block_hash.equal hash (State.Block.hash b)) heads) then
Assert.fail_msg "missing block in known_heads (%s: %s)" name bname)
l
let test_known_heads s =
State.Valid_block.known_heads s.net >>= fun heads ->
Chain.known_heads s.net >>= fun heads ->
compare s "initial" heads ["A8";"B8"] ;
return ()
(****************************************************************************)
(** State.head/set_head *)
(** Chain.head/set_head *)
let test_head s =
State.Valid_block.Current.head s.net >>= fun head ->
if not (Block_hash.equal head.hash genesis_block) then
Chain.head s.net >>= fun head ->
if not (Block_hash.equal (State.Block.hash head) genesis_block) then
Assert.fail_msg "unexpected head" ;
State.Valid_block.Current.set_head s.net (vblock s "A6") >>= fun _ ->
State.Valid_block.Current.head s.net >>= fun head ->
if not (Block_hash.equal head.hash (vblock s "A6").hash) then
Chain.set_head s.net (vblock s "A6") >>= fun _ ->
Chain.head s.net >>= fun head ->
if not (Block_hash.equal (State.Block.hash head) (State.Block.hash @@ vblock s "A6")) then
Assert.fail_msg "unexpected head" ;
return ()
(****************************************************************************)
(** State.mem *)
(** Chain.mem *)
let test_mem s =
let mem s x =
State.Valid_block.Current.mem s.net (fst @@ block s x) in
Chain.mem s.net (State.Block.hash @@ vblock s x) in
let test_mem s x =
mem s x >>= function
| true -> Lwt.return_unit
@ -535,21 +351,21 @@ let test_mem s =
test_not_mem s "B1" >>= fun () ->
test_not_mem s "B6" >>= fun () ->
test_not_mem s "B8" >>= fun () ->
State.Valid_block.Current.set_head s.net (vblock s "A8") >>= fun _ ->
Chain.set_head s.net (vblock s "A8") >>= fun _ ->
test_mem s "A3" >>= fun () ->
test_mem s "A6" >>= fun () ->
test_mem s "A8" >>= fun () ->
test_not_mem s "B1" >>= fun () ->
test_not_mem s "B6" >>= fun () ->
test_not_mem s "B8" >>= fun () ->
State.Valid_block.Current.set_head s.net (vblock s "A6") >>= fun _ ->
Chain.set_head s.net (vblock s "A6") >>= fun _ ->
test_mem s "A3" >>= fun () ->
test_mem s "A6" >>= fun () ->
test_not_mem s "A8" >>= fun () ->
test_not_mem s "B1" >>= fun () ->
test_not_mem s "B6" >>= fun () ->
test_not_mem s "B8" >>= fun () ->
State.Valid_block.Current.set_head s.net (vblock s "B6") >>= fun _ ->
Chain.set_head s.net (vblock s "B6") >>= fun _ ->
test_mem s "A3" >>= fun () ->
test_not_mem s "A4" >>= fun () ->
test_not_mem s "A6" >>= fun () ->
@ -557,7 +373,7 @@ let test_mem s =
test_mem s "B1" >>= fun () ->
test_mem s "B6" >>= fun () ->
test_not_mem s "B8" >>= fun () ->
State.Valid_block.Current.set_head s.net (vblock s "B8") >>= fun _ ->
Chain.set_head s.net (vblock s "B8") >>= fun _ ->
test_mem s "A3" >>= fun () ->
test_not_mem s "A4" >>= fun () ->
test_not_mem s "A6" >>= fun () ->
@ -570,28 +386,53 @@ let test_mem s =
(****************************************************************************)
(** State.new *)
(** Chain_traversal.new_blocks *)
let test_new s =
let test_new_blocks s =
let test s head h expected_ancestor expected =
let to_block = vblock s head
and from_block = vblock s h in
Chain_traversal.new_blocks ~from_block ~to_block >>= fun (ancestor, blocks) ->
if not (Block_hash.equal (State.Block.hash ancestor) (State.Block.hash @@ vblock s expected_ancestor)) then
Assert.fail_msg "Invalid locator %s (expected: %s)" h expected_ancestor ;
if List.length blocks <> List.length expected then
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h (List.length blocks) (List.length expected) ;
List.iter2
(fun h1 h2 ->
if not (Block_hash.equal (State.Block.hash h1) (State.Block.hash @@ vblock s h2)) then
Assert.fail_msg "Invalid locator %s (expected: %s)" h h2)
blocks expected ;
Lwt.return_unit
in
test s "A6" "A6" "A6" [] >>= fun () ->
test s "A8" "A6" "A6" ["A7";"A8"] >>= fun () ->
test s "A8" "B7" "A3" ["A4";"A5";"A6";"A7";"A8"] >>= fun () ->
return ()
(****************************************************************************)
(** Chain.find_new *)
let test_find_new s =
let test s h expected =
State.Valid_block.Helpers.block_locator s.net 50 (vblock s h) >>= fun loc ->
State.Valid_block.Current.find_new s.net loc (List.length expected) >>= function
| Error _ ->
Assert.fail_msg "Failed to compute new blocks %s" h
| Ok blocks ->
if List.length blocks <> List.length expected then
Assert.fail_msg
"Invalid locator length %s (found: %d, expected: %d)"
h (List.length blocks) (List.length expected) ;
List.iter2
(fun h1 h2 ->
if not (Block_hash.equal h1 (vblock s h2).hash) then
Assert.fail_msg "Invalid locator %s (expected: %s)" h h2)
blocks expected ;
Lwt.return_unit
Chain_traversal.block_locator (vblock s h) 50 >>= fun loc ->
Chain.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)"
h (List.length blocks) (List.length expected) ;
List.iter2
(fun h1 h2 ->
if not (Block_hash.equal h1 (State.Block.hash @@ vblock s h2)) then
Assert.fail_msg "Invalid locator %s (expected: %s)" h h2)
blocks expected ;
Lwt.return_unit
in
test s "A6" [] >>= fun () ->
State.Valid_block.Current.set_head s.net (vblock s "A8") >>= fun _ ->
Chain.set_head s.net (vblock s "A8") >>= fun _ ->
test s "A6" ["A7";"A8"] >>= fun () ->
test s "A6" ["A7"] >>= fun () ->
test s "B4" ["A4"] >>= fun () ->
@ -601,74 +442,18 @@ let test_new s =
(****************************************************************************)
(** State.mempool *)
let compare s name mempool l =
let mempool_sz = Operation_hash.Set.cardinal mempool in
let l_sz = List.length l in
if mempool_sz <> l_sz then
Assert.fail
(string_of_int mempool_sz)
(string_of_int l_sz)
"unexpected mempool size (%s)" name ;
List.iter
(fun oname ->
try
let oph = fst @@ operation s oname in
if not (Operation_hash.Set.mem oph mempool) then
Assert.fail_msg "missing operation in mempool (%s: %s)" name oname
with Not_found ->
Assert.fail_msg "Read value not found in mempool (%s: %s)" name oname)
l
let test_mempool s =
State.Operation.list_pending s.net >>= fun mempool ->
compare s "initial" mempool
["PP";
"A1" ; "A2" ; "A3" ; "A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
"B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ;
State.Valid_block.Current.set_head s.net (vblock s "A8") >>= fun _ ->
State.Operation.list_pending s.net >>= fun mempool ->
compare s "A8" mempool
["PP"; "B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ;
State.Valid_block.Current.set_head s.net (vblock s "A6") >>= fun _ ->
State.Operation.list_pending s.net >>= fun mempool ->
compare s "A6" mempool
["PP";
"A7" ; "A8" ;
"B1" ; "B2" ; "B3" ; "B4" ; "B5" ; "B6" ; "B7" ; "B8" ] ;
State.Valid_block.Current.set_head s.net (vblock s "B6") >>= fun _ ->
State.Operation.list_pending s.net >>= fun mempool ->
compare s "B6" mempool
["PP";
"A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
"B7" ; "B8" ] ;
State.Operation.mark_invalid s.net (fst @@ operation s "PP") [] >>= fun rm_status ->
Assert.is_true ~msg:__LOC__ rm_status ;
State.Operation.mark_invalid s.net (fst @@ operation s "PP") [] >>= fun rm_status ->
Assert.is_false ~msg:__LOC__ rm_status ;
State.Operation.list_pending s.net >>= fun mempool ->
compare s "B6.remove" mempool
["A4" ; "A5" ; "A6" ; "A7" ; "A8" ;
"B7" ; "B8" ] ;
return ()
(****************************************************************************)
let tests : (string * (state -> unit tzresult Lwt.t)) list = [
"init", test_init ;
"read_operation", test_read_operation;
"read_block", test_read_block ;
"path", test_path ;
"valid_path", test_valid_path ;
"ancestor", test_ancestor ;
"locator", test_locator ;
"known_heads", test_known_heads ;
"head", test_head ;
"mem", test_mem ;
"new", test_new ;
"mempool", test_mempool;
"new_blocks", test_new_blocks ;
"find_new", test_find_new ;
]
let () =

81
test/shell/test_store.ml
View File

@ -70,21 +70,6 @@ let oph1 = Tezos_data.Operation.hash op1
let op2 = make (MBytes.of_string "Kivu")
let oph2 = Tezos_data.Operation.hash op2
let check_operation s h b =
Operation.Contents.read (s, h) >>= function
| Ok b' when Tezos_data.Operation.equal b b' -> Lwt.return_unit
| _ ->
Printf.eprintf "Error while reading operation %s\n%!"
(Operation_hash.to_hex h);
exit 1
let test_operation s =
let s = Store.Net.get s net_id in
let s = Store.Operation.get s in
Operation.Contents.store (s, oph1) op1 >>= fun () ->
Operation.Contents.store (s, oph2) op2 >>= fun () ->
check_operation s oph1 op1 >>= fun () ->
check_operation s oph2 op2
(** Block store *)
@ -92,57 +77,67 @@ let lolblock ?(operations = []) header =
let operations_hash =
Operation_list_list_hash.compute
[Operation_list_hash.compute operations] in
{ Tezos_data.Block_header.shell =
{ timestamp = Time.of_seconds (Random.int64 1500L) ;
level = 0l ; (* dummy *)
proto_level = 0 ; (* dummy *)
net_id ;
predecessor = genesis_block ; operations_hash ;
fitness = [MBytes.of_string @@ string_of_int @@ String.length header;
MBytes.of_string @@ string_of_int @@ 12] } ;
proto = MBytes.of_string header ;
{ Store.Block.header =
{ Block_header.shell =
{ timestamp = Time.of_seconds (Random.int64 1500L) ;
level = 0l ; (* dummy *)
proto_level = 0 ; (* dummy *)
net_id ;
predecessor = genesis_block ; operations_hash ;
fitness = [MBytes.of_string @@ string_of_int @@ String.length header;
MBytes.of_string @@ string_of_int @@ 12] } ;
proto = MBytes.of_string header ;
} ;
operation_list_count = Random.int 32 ;
message = ""
}
let b1 = lolblock "Blop !"
let bh1 = Tezos_data.Block_header.hash b1
let bh1 = Block_header.hash b1.header
let b2 = lolblock "Tacatlopo"
let bh2 = Tezos_data.Block_header.hash b2
let bh2 = Block_header.hash b2.header
let b3 = lolblock ~operations:[oph1;oph2] "Persil"
let bh3 = Tezos_data.Block_header.hash b3
let bh3 = Block_header.hash b3.header
let bh3' =
let raw = Bytes.of_string @@ Block_hash.to_string bh3 in
Bytes.set raw 31 '\000' ;
Bytes.set raw 30 '\000' ;
Block_hash.of_string_exn @@ Bytes.to_string raw
let equal (b1: Store.Block.contents) (b2: Store.Block.contents) =
Block_header.equal b1.header b2.header &&
b1.message = b2.message &&
b1.operation_list_count = b2.operation_list_count
let check_block s h b =
Block_header.Contents.read_opt (s, h) >>= function
| Some b' when Tezos_data.Block_header.equal b b' -> Lwt.return_unit
| Some _ ->
Store.Block.Contents.read (s, h) >>= function
| Ok b' when equal b b' -> Lwt.return_unit
| Ok _ ->
Printf.eprintf "Error while reading block %s\n%!" (Block_hash.to_hex h);
exit 1
| None ->
Printf.eprintf "Error while reading block %s (not found)\n%!"
(Block_hash.to_hex h);
| Error err ->
Format.eprintf "@[Error while reading block %s:@ %a\n@]"
(Block_hash.to_hex h)
pp_print_error err;
exit 1
let test_block s =
let s = Store.Net.get s net_id in
let s = Store.Block_header.get s in
Block_header.Contents.store (s, bh1) b1 >>= fun () ->
Block_header.Contents.store (s, bh2) b2 >>= fun () ->
Block_header.Contents.store (s, bh3) b3 >>= fun () ->
let s = Store.Block.get s in
Block.Contents.store (s, bh1) b1 >>= fun () ->
Block.Contents.store (s, bh2) b2 >>= fun () ->
Block.Contents.store (s, bh3) b3 >>= fun () ->
check_block s bh1 b1 >>= fun () ->
check_block s bh2 b2 >>= fun () ->
check_block s bh3 b3
let test_expand s =
let s = Store.Net.get s net_id in
let s = Store.Block_header.get s in
Block_header.Contents.store (s, bh1) b1 >>= fun () ->
Block_header.Contents.store (s, bh2) b2 >>= fun () ->
Block_header.Contents.store (s, bh3) b3 >>= fun () ->
Block_header.Contents.store (s, bh3') b3 >>= fun () ->
let s = Store.Block.get s in
Block.Contents.store (s, bh1) b1 >>= fun () ->
Block.Contents.store (s, bh2) b2 >>= fun () ->
Block.Contents.store (s, bh3) b3 >>= fun () ->
Block.Contents.store (s, bh3') b3 >>= fun () ->
Base58.complete (Block_hash.to_short_b58check bh1) >>= fun res ->
Assert.equal_string_list ~msg:__LOC__ res [Block_hash.to_b58check bh1] ;
Base58.complete (Block_hash.to_short_b58check bh2) >>= fun res ->
@ -434,10 +429,8 @@ let tests_raw : (string * (Raw_store.t -> unit Lwt.t)) list = [
]
let tests : (string * (Store.t -> unit Lwt.t)) list = [
"expand", test_expand ;
"operation", test_operation ;
"block", test_block ;
]

2
test/utils/Makefile
View File

@ -9,7 +9,7 @@ TESTS := \
include ../Makefile.shared
SOURCE_DIRECTORIES := ${UTILS_SOURCE_DIRECTORIES} ../lib
SOURCE_DIRECTORIES := ${COMPILER_SOURCE_DIRECTORIES} ../lib
LIB := ${MINUTILSLIB} ${UTILSLIB} ${TESTLIB}