From f39eca214a7aea459ad75c3faa065d7d0a5334cc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Wed, 19 Apr 2017 21:46:10 +0200 Subject: [PATCH] Shell: remove the on-disk index of operations 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//proto/operations --- scripts/alphanet_version | 2 +- src/Makefile.files | 4 + src/client/client_node_rpcs.ml | 23 +- src/client/client_node_rpcs.mli | 23 +- src/client/client_rpcs.ml | 9 +- src/client/client_rpcs.mli | 5 + .../alpha/baker/client_mining_forge.ml | 17 +- .../alpha/baker/client_mining_forge.mli | 4 +- .../alpha/baker/client_mining_operations.ml | 5 +- src/client/embedded/demo/client_proto_main.ml | 2 +- src/minutils/data_encoding.ml | 9 +- src/node/db/store.ml | 267 +-- src/node/db/store.mli | 114 +- src/node/db/store_helpers.ml | 6 + src/node/db/store_helpers.mli | 2 + src/node/net/p2p.ml | 2 +- src/node/shell/chain.ml | 95 + src/node/shell/chain.mli | 37 + src/node/shell/chain_traversal.ml | 134 ++ src/node/shell/chain_traversal.mli | 48 + src/node/shell/distributed_db.ml | 715 ++++--- src/node/shell/distributed_db.mli | 136 +- src/node/shell/distributed_db_functors.ml | 80 +- src/node/shell/distributed_db_functors.mli | 39 +- src/node/shell/distributed_db_message.ml | 52 +- src/node/shell/distributed_db_message.mli | 12 +- src/node/shell/node.ml | 312 +-- src/node/shell/node.mli | 14 +- src/node/shell/node_rpc.ml | 87 +- src/node/shell/node_rpc_services.ml | 115 +- src/node/shell/node_rpc_services.mli | 40 +- src/node/shell/prevalidation.ml | 18 +- src/node/shell/prevalidation.mli | 2 +- src/node/shell/prevalidator.ml | 86 +- src/node/shell/prevalidator.mli | 9 +- src/node/shell/state.ml | 1698 ++++------------- src/node/shell/state.mli | 391 +--- src/node/shell/validator.ml | 333 ++-- src/node/shell/validator.mli | 16 +- src/utils/error_monad.ml | 27 + src/utils/error_monad_sig.ml | 2 + test/Makefile.shared | 39 +- test/proto_alpha/Makefile | 25 +- test/proto_alpha/proto_alpha_helpers.ml | 4 +- test/shell/test_state.ml | 461 ++--- test/shell/test_store.ml | 81 +- test/utils/Makefile | 2 +- 47 files changed, 2358 insertions(+), 3246 deletions(-) create mode 100644 src/node/shell/chain.ml create mode 100644 src/node/shell/chain.mli create mode 100644 src/node/shell/chain_traversal.ml create mode 100644 src/node/shell/chain_traversal.mli diff --git a/scripts/alphanet_version b/scripts/alphanet_version index 12f9784c5..cccb26563 100644 --- a/scripts/alphanet_version +++ b/scripts/alphanet_version @@ -1 +1 @@ -2017-04-17 +2017-04-19 diff --git a/src/Makefile.files b/src/Makefile.files index c6b7d04fc..e56a65853 100644 --- a/src/Makefile.files +++ b/src/Makefile.files @@ -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 \ diff --git a/src/client/client_node_rpcs.ml b/src/client/client_node_rpcs.ml index 696bc6eb1..fa038ff45 100644 --- a/src/client/client_node_rpcs.ml +++ b/src/client/client_node_rpcs.ml @@ -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 diff --git a/src/client/client_node_rpcs.mli b/src/client/client_node_rpcs.mli index ac454a74b..b879c006e 100644 --- a/src/client/client_node_rpcs.mli +++ b/src/client/client_node_rpcs.mli @@ -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 diff --git a/src/client/client_rpcs.ml b/src/client/client_rpcs.ml index c05323dc4..314f7e1ee 100644 --- a/src/client/client_rpcs.ml +++ b/src/client/client_rpcs.ml @@ -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 *) diff --git a/src/client/client_rpcs.mli b/src/client/client_rpcs.mli index f56b9a43c..237e928c9 100644 --- a/src/client/client_rpcs.mli +++ b/src/client/client_rpcs.mli @@ -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 -> diff --git a/src/client/embedded/alpha/baker/client_mining_forge.ml b/src/client/embedded/alpha/baker/client_mining_forge.ml index bf0f81615..babc6584d 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.ml +++ b/src/client/embedded/alpha/baker/client_mining_forge.ml @@ -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 () -> diff --git a/src/client/embedded/alpha/baker/client_mining_forge.mli b/src/client/embedded/alpha/baker/client_mining_forge.mli index 9c9ce10db..58624c6a4 100644 --- a/src/client/embedded/alpha/baker/client_mining_forge.mli +++ b/src/client/embedded/alpha/baker/client_mining_forge.mli @@ -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 -> diff --git a/src/client/embedded/alpha/baker/client_mining_operations.ml b/src/client/embedded/alpha/baker/client_mining_operations.ml index 10c9d50f3..575aa1b55 100644 --- a/src/client/embedded/alpha/baker/client_mining_operations.ml +++ b/src/client/embedded/alpha/baker/client_mining_operations.ml @@ -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 -> diff --git a/src/client/embedded/demo/client_proto_main.ml b/src/client/embedded/demo/client_proto_main.ml index 2dc1c5394..bf9fdf01d 100644 --- a/src/client/embedded/demo/client_proto_main.ml +++ b/src/client/embedded/demo/client_proto_main.ml @@ -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 diff --git a/src/minutils/data_encoding.ml b/src/minutils/data_encoding.ml index b29d29d13..47b60411a 100644 --- a/src/minutils/data_encoding.ml +++ b/src/minutils/data_encoding.ml @@ -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. \ diff --git a/src/node/db/store.ml b/src/node/db/store.ml index 416a0a6c5..84b726b1d 100644 --- a/src/node/db/store.ml +++ b/src/node/db/store.ml @@ -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//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//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 diff --git a/src/node/db/store.mli b/src/node/db/store.mli index bd667e360..c056a69a0 100644 --- a/src/node/db/store.mli +++ b/src/node/db/store.mli @@ -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 diff --git a/src/node/db/store_helpers.ml b/src/node/db/store_helpers.ml index a3bcb435b..ad429296b 100644 --- a/src/node/db/store_helpers.ml +++ b/src/node/db/store_helpers.ml @@ -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 diff --git a/src/node/db/store_helpers.mli b/src/node/db/store_helpers.mli index 0e831f46a..2c465fa36 100644 --- a/src/node/db/store_helpers.mli +++ b/src/node/db/store_helpers.mli @@ -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 diff --git a/src/node/net/p2p.ml b/src/node/net/p2p.ml index c7975ca48..e5a8033d0 100644 --- a/src/node/net/p2p.ml +++ b/src/node/net/p2p.ml @@ -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 diff --git a/src/node/shell/chain.ml b/src/node/shell/chain.ml new file mode 100644 index 000000000..0a4b56b6f --- /dev/null +++ b/src/node/shell/chain.ml @@ -0,0 +1,95 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/src/node/shell/chain.mli b/src/node/shell/chain.mli new file mode 100644 index 000000000..ba3c8b7b7 --- /dev/null +++ b/src/node/shell/chain.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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]. *) diff --git a/src/node/shell/chain_traversal.ml b/src/node/shell/chain_traversal.ml new file mode 100644 index 000000000..02f88ab17 --- /dev/null +++ b/src/node/shell/chain_traversal.ml @@ -0,0 +1,134 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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) diff --git a/src/node/shell/chain_traversal.mli b/src/node/shell/chain_traversal.mli new file mode 100644 index 000000000..67680038f --- /dev/null +++ b/src/node/shell/chain_traversal.mli @@ -0,0 +1,48 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2016. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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]. *) diff --git a/src/node/shell/distributed_db.ml b/src/node/shell/distributed_db.ml index 3922b9309..8349ff078 100644 --- a/src/node/shell/distributed_db.ml +++ b/src/node/shell/distributed_db.ml @@ -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) + diff --git a/src/node/shell/distributed_db.mli b/src/node/shell/distributed_db.mli index 1a753e310..e47a01b90 100644 --- a/src/node/shell/distributed_db.mli +++ b/src/node/shell/distributed_db.mli @@ -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 diff --git a/src/node/shell/distributed_db_functors.ml b/src/node/shell/distributed_db_functors.ml index df4a1e960..b8eed341a 100644 --- a/src/node/shell/distributed_db_functors.ml +++ b/src/node/shell/distributed_db_functors.ml @@ -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 diff --git a/src/node/shell/distributed_db_functors.mli b/src/node/shell/distributed_db_functors.mli index 1a57848f6..370d484b1 100644 --- a/src/node/shell/distributed_db_functors.mli +++ b/src/node/shell/distributed_db_functors.mli @@ -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 diff --git a/src/node/shell/distributed_db_message.ml b/src/node/shell/distributed_db_message.ml index 9ac5b1eb2..5b75b205e 100644 --- a/src/node/shell/distributed_db_message.ml +++ b/src/node/shell/distributed_db_message.ml @@ -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 ; } ] diff --git a/src/node/shell/distributed_db_message.mli b/src/node/shell/distributed_db_message.mli index 900d061d3..68ab57ab6 100644 --- a/src/node/shell/distributed_db_message.mli +++ b/src/node/shell/distributed_db_message.mli @@ -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 diff --git a/src/node/shell/node.ml b/src/node/shell/node.ml index 31bb01a4a..72e153683 100644 --- a/src/node/shell/node.ml +++ b/src/node/shell/node.ml @@ -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 diff --git a/src/node/shell/node.mli b/src/node/shell/node.mli index 06808daf1..7846113c6 100644 --- a/src/node/shell/node.mli +++ b/src/node/shell/node.mli @@ -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 diff --git a/src/node/shell/node_rpc.ml b/src/node/shell/node_rpc.ml index 348d3bdbe..270bf5927 100644 --- a/src/node/shell/node_rpc.ml +++ b/src/node/shell/node_rpc.ml @@ -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 = diff --git a/src/node/shell/node_rpc_services.ml b/src/node/shell/node_rpc_services.ml index e0d1355d7..c88b3a25b 100644 --- a/src/node/shell/node_rpc_services.ml +++ b/src/node/shell/node_rpc_services.ml @@ -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 diff --git a/src/node/shell/node_rpc_services.mli b/src/node/shell/node_rpc_services.mli index d8b490023..46ab2b380 100644 --- a/src/node/shell/node_rpc_services.mli +++ b/src/node/shell/node_rpc_services.mli @@ -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: diff --git a/src/node/shell/prevalidation.ml b/src/node/shell/prevalidation.ml index c033b5eed..413da7fdb 100644 --- a/src/node/shell/prevalidation.ml +++ b/src/node/shell/prevalidation.ml @@ -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 diff --git a/src/node/shell/prevalidation.mli b/src/node/shell/prevalidation.mli index d21d6e402..b5e6282ea 100644 --- a/src/node/shell/prevalidation.mli +++ b/src/node/shell/prevalidation.mli @@ -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 diff --git a/src/node/shell/prevalidator.ml b/src/node/shell/prevalidator.ml index 89ca1dd23..86a5c43f5 100644 --- a/src/node/shell/prevalidator.ml +++ b/src/node/shell/prevalidator.ml @@ -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' -> diff --git a/src/node/shell/prevalidator.mli b/src/node/shell/prevalidator.mli index 9e06bb9cf..311b9f026 100644 --- a/src/node/shell/prevalidator.mli +++ b/src/node/shell/prevalidator.mli @@ -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 diff --git a/src/node/shell/state.ml b/src/node/shell/state.ml index 4f800ef39..30dbe1228 100644 --- a/src/node/shell/state.ml +++ b/src/node/shell/state.ml @@ -10,42 +10,9 @@ open Logging.Node.State 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_context of Block_hash.t - | Unknown_protocol of Protocol_hash.t - | Cannot_parse let () = - Error_monad.register_error_kind - `Permanent - ~id:"state.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 - "@[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 }) ; Error_monad.register_error_kind `Temporary ~id:"state.unknown_network" @@ -59,11 +26,7 @@ let () = (** *) -module Shared : sig - type 'a t - val create: 'a -> 'a t - val use: 'a t -> ('a -> 'b Lwt.t) -> 'b Lwt.t -end = struct +module Shared = struct type 'a t = { data: 'a ; lock: Lwt_mutex.t ; @@ -79,20 +42,20 @@ type global_state = { } and global_data = { - nets: net Net_id.Table.t ; + nets: net_state Net_id.Table.t ; global_store: Store.t ; - init_index: Net_id.t -> Context.index Lwt.t ; + context_index: Context.index ; } -and net = { - id: Net_id.t ; - state: net_state Shared.t ; +and net_state = { + net_id: Net_id.t ; genesis: genesis ; expiration: Time.t option ; allow_forked_network: bool ; - operation_store: Store.Operation.store Shared.t ; - block_header_store: Store.Block_header.store Shared.t ; - valid_block_watcher: valid_block Watcher.input ; + block_store: Store.Block.store Shared.t ; + context_index: Context.index Shared.t ; + block_watcher: block Watcher.input ; + chain_state: chain_state Shared.t ; } and genesis = { @@ -101,442 +64,38 @@ and genesis = { protocol: Protocol_hash.t ; } -and net_state = { - mutable current_head: valid_block ; +and chain_state = { + mutable data: chain_data ; chain_store: Store.Chain.store ; - context_index: Context.index ; } -and valid_block = { - net_id: Net_id.t ; +and chain_data = { + current_head: block ; +} + +and block = { + net_state: net_state ; hash: Block_hash.t ; - level: Int32.t ; - proto_level: int ; - predecessor: Block_hash.t ; - timestamp: Time.t ; - fitness: Fitness.t ; - 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 ; - discovery_time: Time.t ; - protocol_hash: Protocol_hash.t ; - protocol: (module Updater.REGISTRED_PROTOCOL) option ; - test_network: Context.test_network ; - context: Context.t ; - proto_header: MBytes.t ; + contents: Store.Block.contents ; } -let build_valid_block - hash header operation_hashes operations - context discovery_time = - Context.get_protocol context >>= fun protocol_hash -> - Context.get_test_network context >>= fun test_network -> - let protocol = Updater.get protocol_hash in - let valid_block = { - net_id = header.Block_header.shell.net_id ; - hash ; - level = header.shell.level ; - proto_level = header.shell.proto_level ; - predecessor = header.shell.predecessor ; - timestamp = header.shell.timestamp ; - discovery_time ; - operations_hash = header.shell.operations_hash ; - operation_hashes ; - operations ; - fitness = header.shell.fitness ; - protocol_hash ; - protocol ; - test_network ; - context ; - proto_header = header.Block_header.proto ; - } in - Lwt.return valid_block +let read_chain_store { chain_state } f = + Shared.use chain_state begin fun state -> + f state.chain_store state.data + end + +let update_chain_store { chain_state } f = + Shared.use chain_state begin fun state -> + f state.chain_store state.data >>= fun (data, res) -> + Utils.iter_option data ~f:(fun data -> state.data <- data) ; + Lwt.return res + end type t = global_state -module type DATA_STORE = sig +module Locked_block = struct - type store - type key - type value - - val known: store -> key -> bool Lwt.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 - - (** 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 - - (** 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 - - val store: store -> key -> value -> bool Lwt.t - val store_raw: store -> key -> MBytes.t -> value option tzresult Lwt.t - val remove: store -> key -> bool Lwt.t - -end - -module type INTERNAL_DATA_STORE = sig - - include DATA_STORE - - val read_full: store -> key -> value tzresult Time.timed_data option Lwt.t - - val mark_valid: store -> key -> bool Lwt.t - val mark_invalid: store -> key -> error list -> bool Lwt.t - val unmark: store -> key -> bool Lwt.t - - val pending: store -> key -> bool Lwt.t - val valid: store -> key -> bool Lwt.t - val invalid: store -> key -> error list option Lwt.t - - type key_set - val list_invalid: store -> key_set Lwt.t - val list_pending: store -> key_set Lwt.t - - val list: store -> key_set Lwt.t - -end - -let wrap_not_found f s k = - f s k >>= function - | None -> Lwt.fail Not_found - | Some v -> Lwt.return v - -module Make_data_store - (S : sig - include Store.DATA_STORE - val encoding: value Data_encoding.t - end) - (U : sig - type store - val use: store -> (S.store -> 'a Lwt.t) -> 'a Lwt.t - val unknown: S.key -> 'a tzresult Lwt.t - end) - (Set : Set.S with type elt = S.key and type t = S.key_set) : sig - include INTERNAL_DATA_STORE with type store = U.store - and type key = S.key - and type key_set := Set.t - and type value := S.value - module Locked : INTERNAL_DATA_STORE with type store = S.store - and type key = S.key - and type key_set := Set.t - and type value = S.value -end = struct - - type store = U.store - type value = S.value - type key = S.key - type key_set = Set.t - - let of_bytes = Data_encoding.Binary.of_bytes S.encoding - let to_bytes = Data_encoding.Binary.to_bytes S.encoding - - (* FIXME Document and check with a clear mind the invariant in the - storage... *) - - module Locked = struct - type store = S.store - type value = S.value - type key = S.key - type key_set = Set.t - let known s k = S.Discovery_time.known s k - let read s k = S.Contents.read (s, k) - let read_opt s k = S.Contents.read_opt (s, k) - let read_exn s k = S.Contents.read_exn (s, k) - let read_raw s k = S.RawContents.read (s, k) - let read_raw_opt s k = S.RawContents.read_opt (s, k) - let read_raw_exn s k = S.RawContents.read_exn (s, k) - let read_discovery_time s k = S.Discovery_time.read s k - let read_discovery_time_opt s k = S.Discovery_time.read_opt s k - let read_discovery_time_exn s k = S.Discovery_time.read_exn s k - let read_full s k = - S.Discovery_time.read_opt s k >>= function - | None -> Lwt.return_none - | Some time -> - S.Errors.read_opt s k >>= function - | Some exns -> Lwt.return (Some { Time.data = Error exns ; time }) - | None -> - S.Contents.read_opt (s, k) >>= function - | None -> Lwt.return_none - | Some v -> Lwt.return (Some { Time.data = Ok v ; time }) - let store s k v = - S.Discovery_time.known s k >>= function - | true -> Lwt.return_false - | false -> - let time = Time.now () in - S.Contents.store (s, k) v >>= fun () -> - S.Discovery_time.store s k time >>= fun () -> - S.Pending.store s k >>= fun () -> - Lwt.return_true - let store_raw s k b = - S.Discovery_time.known s k >>= function - | true -> return None - | false -> - match Data_encoding.Binary.of_bytes S.encoding b with - | None -> - S.Errors.store s k [Cannot_parse] >>= fun () -> - fail Cannot_parse - | Some v -> - let time = Time.now () in - S.RawContents.store (s, k) b >>= fun () -> - S.Discovery_time.store s k time >>= fun () -> - return (Some v) - let remove s k = - S.Discovery_time.known s k >>= function - | false -> Lwt.return_false - | true -> - S.Discovery_time.remove s k >>= fun () -> - S.Contents.remove (s, k) >>= fun () -> - S.Validation_time.remove (s, k) >>= fun () -> - S.Errors.remove s k >>= fun () -> - S.Pending.remove s k >>= fun () -> - Lwt.return_true - let pending s k = S.Pending.known s k - let valid s k = - S.Validation_time.known (s, k) >>= fun validated -> - S.Errors.known s k >>= fun invalid -> - Lwt.return (validated && not invalid) - let invalid s k = - S.Validation_time.known (s, k) >>= fun validated -> - if validated then - S.Errors.read_opt s k - else - Lwt.return None - let mark_valid s k = - S.Pending.known s k >>= fun pending -> - if not pending then - Lwt.return_false - else - S.Pending.remove s k >>= fun () -> - S.Validation_time.store (s, k) (Time.now ()) >>= fun () -> - Lwt.return_true - let mark_invalid s k e = - S.Discovery_time.known s k >>= fun pending -> - if not pending then - let now = Time.now () in - S.Discovery_time.store s k now >>= fun () -> - S.Validation_time.store (s, k) now >>= fun () -> - S.Errors.store s k e >>= fun () -> - Lwt.return_true - else - S.Errors.known s k >>= fun invalid -> - if invalid then - Lwt.return_false - else - S.Pending.remove s k >>= fun () -> - S.Validation_time.store (s, k) (Time.now ()) >>= fun () -> - S.Errors.store s k e >>= fun () -> - Lwt.return_true - let list_invalid s = - S.Errors.fold_keys s ~init:Set.empty - ~f:(fun k acc -> Lwt.return (Set.add k acc)) - let unmark s k = - S.Pending.known s k >>= fun pending -> - if not pending then - S.Validation_time.remove (s, k) >>= fun () -> - S.Errors.remove s k >>= fun () -> - S.Pending.store s k >>= fun () -> - Lwt.return_true - else - Lwt.return_false - let list_pending = S.Pending.read_all - let list s = - S.Discovery_time.fold_keys s ~init:Set.empty - ~f:(fun k acc -> Lwt.return (Set.add k acc)) - end - - let atomic1 f s = U.use s f - let atomic2 f s k = U.use s (fun s -> f s k) - let atomic3 f s k v = U.use s (fun s -> f s k v) - - let known = atomic2 Locked.known - let read = atomic2 Locked.read - let read_opt = atomic2 Locked.read_opt - let read_exn = atomic2 Locked.read_exn - let read_raw = atomic2 Locked.read_raw - let read_raw_opt = atomic2 Locked.read_raw_opt - let read_raw_exn = atomic2 Locked.read_raw_exn - let read_full = atomic2 Locked.read_full - let read_discovery_time = atomic2 Locked.read_discovery_time - let read_discovery_time_opt = atomic2 Locked.read_discovery_time_opt - let read_discovery_time_exn = atomic2 Locked.read_discovery_time_exn - let store = atomic3 Locked.store - let store_raw = atomic3 Locked.store_raw - let remove = atomic2 Locked.remove - let mark_valid = atomic2 Locked.mark_valid - let mark_invalid = atomic3 Locked.mark_invalid - let unmark = atomic2 Locked.unmark - let pending = atomic2 Locked.pending - let valid = atomic2 Locked.valid - let invalid = atomic2 Locked.invalid - let list_invalid = atomic1 Locked.list_invalid - let list_pending = atomic1 Locked.list_pending - let list = atomic1 Locked.list - -end - -module Raw_operation = - Make_data_store - (struct - include Operation - include Store.Operation - end) - (struct - type store = Store.Operation.store Shared.t - let use s = Shared.use s - let unknown k = fail (Unknown_operation k) - end) - (Operation_hash.Set) - -module Raw_operation_list = struct - - module Locked = struct - - let known store (hash, ofs) = - Store.Block_header.Operation_list.known (store, hash) ofs - let read store (hash, ofs) = - Store.Block_header.Operation_list.read - (store, hash) ofs >>=? fun ops -> - Store.Block_header.Operation_list_path.read - (store, hash) ofs >>=? fun path -> - return (ops, path) - let read_opt store (hash, ofs) = - Store.Block_header.Operation_list.read_opt - (store, hash) ofs >>= function - | None -> Lwt.return_none - | Some ops -> - Store.Block_header.Operation_list_path.read_exn - (store, hash) ofs >>= fun path -> - Lwt.return (Some (ops, path)) - let read_exn store (hash, ofs) = - read_opt store (hash, ofs) >>= function - | None -> Lwt.fail Not_found - | Some (ops, path) -> Lwt.return (ops, path) - let store store (hash, ofs) (ops, path) = - Store.Block_header.Operation_list.known - (store, hash) ofs >>= function - | false -> - Store.Block_header.Operation_list.store - (store, hash) ofs ops >>= fun () -> - Store.Block_header.Operation_list_path.store - (store, hash) ofs path >>= fun () -> - Lwt.return_true - | true -> - Lwt.return_false - - let remove store (hash, ofs) = - Store.Block_header.Operation_list.known - (store, hash) ofs >>= function - | false -> - Lwt.return_false - | true -> - Store.Block_header.Operation_list.remove - (store, hash) ofs >>= fun () -> - Store.Block_header.Operation_list_path.remove - (store, hash) ofs >>= fun () -> - Lwt.return_true - - let read_count store hash = - Store.Block_header.Operation_list_count.read (store, hash) - - let read_count_opt store hash = - read_count store hash >>= function - | Ok cpt -> Lwt.return (Some cpt) - | Error _ -> Lwt.return_none - - let read_count_exn store hash = - read_count store hash >>= function - | Ok cpt -> Lwt.return cpt - | Error _ -> Lwt.fail Not_found - - let store_count store hash count = - Store.Block_header.Operation_list_count.store (store, hash) count - - let read_all store hash = - Store.Block_header.Operation_list_count.read (store, hash) - >>=? fun operation_list_count -> - let rec read acc i = - if i <= 0 then return acc - else - Store.Block_header.Operation_list.read - (store, hash) (i-1) >>=? fun ops -> - read (ops :: acc) (i-1) in - read [] operation_list_count - - let read_all_exn store hash = - read_all store hash >>= function - | Error _ -> Lwt.fail Not_found - | Ok ops -> Lwt.return ops - - let store_all store hash op_hashes operations = - Store.Block_header.Operation_list_count.store (store, hash) - (List.length operations) >>= fun () -> - Lwt_list.iteri_p - (fun i ops -> - Store.Block_header.Operation_list.store - (store, hash) i ops >>= fun () -> - Store.Block_header.Operation_list_path.store - (store, hash) i - (Operation_list_list_hash.compute_path op_hashes i) - >>= fun () -> - Lwt.return_unit) - operations >>= fun () -> - Lwt.return_unit - - end - - let atomic1 f s = Shared.use s f - let atomic2 f s k = Shared.use s (fun s -> f s k) - let atomic3 f s k v = Shared.use s (fun s -> f s k v) - let atomic4 f s k v1 v2 = Shared.use s (fun s -> f s k v1 v2) - - let known = atomic2 Locked.known - let read = atomic2 Locked.read - let read_opt = atomic2 Locked.read_opt - let read_exn = atomic2 Locked.read_exn - let store = atomic3 Locked.store - let remove = atomic2 Locked.remove - - let store_all = atomic4 Locked.store_all - let read_all = atomic2 Locked.read_all - let read_all_exn = atomic2 Locked.read_all_exn - -end - -module Raw_block_header = struct - - include - Make_data_store - (struct - include Block_header - include Store.Block_header - end) - (struct - type store = Store.Block_header.store Shared.t - let use s = Shared.use s - let unknown k = fail (Unknown_block k) - end) - (Block_hash.Set) - - let read_pred store k = - read_opt store k >>= function - | None -> Lwt.return_none - | Some { shell = { predecessor } } -> - if Block_hash.equal predecessor k then - Lwt.return_none - else - Lwt.return (Some predecessor) - let read_pred_exn = wrap_not_found read_pred - - let store_genesis store genesis = + let store_genesis context_index store genesis = let shell : Block_header.shell_header = { net_id = Net_id.of_block_hash genesis.block; level = 0l ; @@ -546,753 +105,21 @@ module Raw_block_header = struct fitness = [] ; operations_hash = Operation_list_list_hash.empty ; } in - let header = - { Block_header.shell ; proto = MBytes.create 0 } in - let bytes = - Data_encoding.Binary.to_bytes Block_header.encoding header in - Locked.store_raw store genesis.block bytes >>= fun _created -> - Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> - Lwt.return header - - (* let store_testnet_genesis store genesis = *) - (* let shell : Store.Block_header.shell_header = { *) - (* net_id = Net_id.of_block_hash genesis.block; *) - (* level = 0l ; *) - (* predecessor = genesis.block ; *) - (* timestamp = genesis.time ; *) - (* fitness = [] ; *) - (* operations = Operation_list_list_hash.empty ; *) - (* } in *) - (* let bytes = *) - (* Data_encoding.Binary.to_bytes Store.Block_header.encoding { *) - (* shell ; *) - (* proto = MBytes.create 0 ; *) - (* } in *) - (* Locked.store_raw store genesis.block bytes >>= fun _created -> *) - (* Raw_operation_list.Locked.store_all store genesis.block [] [] >>= fun () -> *) - (* Lwt.return shell *) - -end - -module Raw_helpers = struct - - let path store h1 h2 = - let rec loop acc h = - if Block_hash.equal h h1 then - Lwt.return (Some acc) - else - Raw_block_header.read_opt store h >>= function - | Some { shell = header } - when not (Block_hash.equal header.predecessor h) -> - loop ((h, header) :: acc) header.predecessor - | Some _ | None -> Lwt.return_none in - loop [] h2 - - let rec common_ancestor store hash1 header1 hash2 header2 = - if Block_hash.equal hash1 hash2 then - Lwt.return (Some (hash1, header1)) - else if - Time.compare - header1.Block_header.timestamp - header2.Block_header.timestamp <= 0 - then begin - if Block_hash.equal header2.predecessor hash2 then - Lwt.return_none - else - let hash2 = header2.predecessor in - Raw_block_header.read_opt store hash2 >>= function - | Some { shell = header2 } -> - common_ancestor store hash1 header1 hash2 header2 - | None -> Lwt.return_none - end else begin - if Block_hash.equal header1.predecessor hash1 then - Lwt.return_none - else - let hash1 = header1.predecessor in - Raw_block_header.read_opt store hash1 >>= function - | Some { shell = header1 } -> - common_ancestor store hash1 header1 hash2 header2 - | None -> Lwt.return_none - end - - let block_locator store sz h = - let rec loop acc sz step cpt h = - if sz = 0 then Lwt.return (List.rev acc) else - Raw_block_header.read_pred store h >>= function - | None -> Lwt.return (List.rev (h :: acc)) - | Some pred -> - if cpt = 0 then - loop (h :: acc) (sz - 1) (step * 2) (step * 20 - 1) pred - else if cpt mod step = 0 then - loop (h :: acc) (sz - 1) step (cpt - 1) pred - else - loop acc sz step (cpt - 1) pred in - loop [] sz 1 9 h - - let iter_predecessors - (type state) - (type t) - (compare: t -> t -> int) - (predecessor: state -> t -> t option Lwt.t) - (date: t -> Time.t) - (fitness: t -> Fitness.t) - state ?max ?min_fitness ?min_date heads ~f = - let module Local = struct exception Exit end in - let pop, push = - (* Poor-man priority queue *) - let queue : 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 (fitness b) <= 0) in - let check_date = - match min_date with - | None -> (fun _ -> true) - | Some min_date -> (fun b -> Time.compare min_date (date b) <= 0) in - let rec loop () = - match pop () with - | None -> return () - | Some b -> - check_count () ; - f b >>= fun () -> - predecessor state 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 -> return () - -end - -module Block_header = struct - - type shell_header = Block_header.shell_header = { - net_id: Net_id.t ; - level: Int32.t ; - proto_level: int ; (* uint8 *) - predecessor: Block_hash.t ; - timestamp: Time.t ; - operations_hash: Operation_list_list_hash.t ; - fitness: MBytes.t list ; - } - - type t = Block_header.t = { - shell: shell_header ; - proto: MBytes.t ; - } - - type block_header = t - - include - Make_data_store - (struct - include Block_header - include Store.Block_header - end) - (struct - type store = net - let use s = Shared.use s.block_header_store - let unknown k = fail (Unknown_block k) - end) - (Block_hash.Set) - - let read_pred_opt store k = - read_opt store k >>= function - | Some { shell = { predecessor } } - when not (Block_hash.equal predecessor k) -> - Lwt.return (Some predecessor) - | Some _ | None -> Lwt.return_none - let read_pred_exn = wrap_not_found read_pred_opt - - let read_operations s k = - Raw_operation_list.read_all s.block_header_store k - - let read_operations_exn s k = - Raw_operation_list.read_all_exn s.block_header_store k - - module Helpers = struct - - let check_block state h = - known state h >>= function - | true -> return () - | false -> failwith "Unknown block %a" Block_hash.pp_short h - - let path state h1 h2 = - trace_exn (Failure "State.path") begin - check_block state h1 >>=? fun () -> - check_block state h2 >>=? fun () -> - Raw_helpers.path state.block_header_store h1 h2 >>= function - | None -> failwith "not an ancestor" - | Some x -> return x - end - - let common_ancestor state hash1 hash2 = - trace_exn (Failure "State.common_ancestor") begin - read_opt state hash1 >>= function - | None -> failwith "Unknown_block %a" Block_hash.pp_short hash1 - | Some { shell = header1 } -> - read_opt state hash2 >>= function - | None -> failwith "Unknown_block %a" Block_hash.pp_short hash1 - | Some { shell = header2 } -> - Raw_helpers.common_ancestor state.block_header_store - hash1 header1 hash2 header2 >>= function - | None -> failwith "No common ancestor found" - | Some (hash, header) -> return (hash, header) - end - - let block_locator state sz h = - trace_exn (Failure "State.block_locator") begin - check_block state h >>=? fun () -> - Raw_helpers.block_locator - state.block_header_store sz h >>= fun locator -> - return locator - end - - let iter_predecessors = - let compare b1 b2 = - match Fitness.compare b1.shell.fitness b2.shell.fitness with - | 0 -> begin - match Time.compare b1.shell.timestamp b2.shell.timestamp with - | 0 -> - Block_hash.compare - (Block_header.hash b1) (Block_header.hash b2) - | res -> res - end - | res -> res in - let predecessor net b = - if Block_hash.equal net.genesis.block b.shell.predecessor then - Lwt.return_none - else - Raw_block_header.read_opt - net.block_header_store b.shell.predecessor in - Raw_helpers.iter_predecessors compare predecessor - (fun b -> b.shell.timestamp) (fun b -> b.shell.fitness) - - end - -end - -module Operation_list = struct - - type store = net - type key = Block_hash.t * int - type value = Operation_hash.t list * Operation_list_list_hash.path - - module Locked = Raw_operation_list.Locked - - let atomic1 f s = - Shared.use s.block_header_store f - let atomic2 f s k = - Shared.use s.block_header_store (fun s -> f s k) - let atomic3 f s k v = - Shared.use s.block_header_store (fun s -> f s k v) - let atomic4 f s k v1 v2 = - Shared.use s.block_header_store (fun s -> f s k v1 v2) - - let known = atomic2 Locked.known - let read = atomic2 Locked.read - let read_opt = atomic2 Locked.read_opt - let read_exn = atomic2 Locked.read_exn - let store = atomic3 Locked.store - let remove = atomic2 Locked.remove - - let store_all s k v = - Shared.use s.block_header_store begin fun s -> - let h = List.map Operation_list_hash.compute v in - Locked.store_all s k h v - end - let read_all = atomic2 Locked.read_all - let read_all_exn = atomic2 Locked.read_all_exn - - let read_count = atomic2 Locked.read_count - let read_count_opt = atomic2 Locked.read_count_opt - let read_count_exn = atomic2 Locked.read_count_exn - let store_count = atomic3 Locked.store_count - -end - -module Raw_net = struct - - let build - ~genesis - ~genesis_block - ~expiration - ~allow_forked_network - context_index - chain_store - block_header_store - operation_store = - let net_state = { - current_head = genesis_block ; - chain_store ; - context_index ; - } in - let net = { - id = Net_id.of_block_hash genesis.block ; - state = Shared.create net_state ; - genesis ; - expiration ; - allow_forked_network ; - operation_store = Shared.create operation_store ; - block_header_store = Shared.create block_header_store ; - valid_block_watcher = Watcher.create_input (); - } in - net - - let locked_create - data ?initial_context ?expiration ?(allow_forked_network = false) - net_id genesis = - let net_store = Store.Net.get data.global_store net_id in - let operation_store = Store.Operation.get net_store - and block_header_store = Store.Block_header.get net_store - and chain_store = Store.Chain.get net_store in - Store.Net.Genesis_hash.store net_store genesis.block >>= fun () -> - Store.Net.Genesis_time.store net_store genesis.time >>= fun () -> - Store.Net.Genesis_protocol.store net_store genesis.protocol >>= fun () -> - Store.Chain.Current_head.store chain_store genesis.block >>= fun () -> - Store.Chain.Known_heads.store chain_store genesis.block >>= fun () -> - data.init_index net_id >>= fun context_index -> - begin - match expiration with - | None -> Lwt.return_unit - | Some time -> Store.Net.Expiration.store net_store time - end >>= fun () -> - begin - if allow_forked_network then - Store.Net.Allow_forked_network.store data.global_store net_id - else - Lwt.return_unit - end >>= fun () -> - Raw_block_header.store_genesis - block_header_store genesis >>= fun header -> - begin - match initial_context with - | None -> - Context.commit_genesis - context_index - ~id:genesis.block - ~time:genesis.time - ~protocol:genesis.protocol - | Some context -> - Lwt.return context - end >>= fun context -> - build_valid_block - genesis.block header (lazy Lwt.return_nil) (lazy Lwt.return_nil) - context genesis.time >>= fun genesis_block -> - Lwt.return @@ - build - ~genesis - ~genesis_block - ~expiration - ~allow_forked_network + let header : Block_header.t = { shell ; proto = MBytes.create 0 } in + Store.Block.Contents.store (store, genesis.block) + { Store.Block.header ; message = "Genesis" ; + operation_list_count = 0 } >>= fun () -> + Context.commit_genesis context_index - chain_store - block_header_store - operation_store - -end - - -module Valid_block = struct - - type t = valid_block = { - net_id: Net_id.t ; - hash: Block_hash.t ; - level: Int32.t ; - proto_level: int ; - predecessor: Block_hash.t ; - timestamp: Time.t ; - fitness: Fitness.t ; - 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 ; - discovery_time: Time.t ; - protocol_hash: Protocol_hash.t ; - protocol: (module Updater.REGISTRED_PROTOCOL) option ; - test_network: Context.test_network ; - context: Context.t ; - proto_header: MBytes.t ; - } - type valid_block = t - - module Locked = struct - - let known { context_index } hash = - Context.exists context_index hash - - let raw_read - block operations operation_hashes - time context_index hash = - Context.checkout context_index hash >>= function - | None -> - fail (Unknown_context hash) - | Some context -> - build_valid_block - hash block operation_hashes operations - context time >>= fun block -> - return block - - let raw_read_exn - block operations operation_hashes - time context_index hash = - raw_read block operations operation_hashes - time context_index hash >>= function - | Error _ -> Lwt.fail Not_found - | Ok data -> Lwt.return data - - let read net net_state hash = - Block_header.read_full net hash >>= function - | None | Some { Time.data = Error _ } -> - fail (Unknown_block hash) - | Some { Time.data = Ok block ; time } -> - let operation_hashes = - lazy (Block_header.read_operations_exn net hash) in - let operations = - lazy ( - Lazy.force operation_hashes >>= fun operations -> - Lwt_list.map_p - (Lwt_list.map_p - (Raw_operation.read_exn net.operation_store )) - operations) - in - raw_read block operations operation_hashes - time net_state.context_index hash - - let read_opt net net_state hash = - read net net_state hash >>= function - | Error _ -> Lwt.return_none - | Ok data -> Lwt.return (Some data) - - let read_exn net net_state hash = - read net net_state hash >>= function - | Error _ -> Lwt.fail Not_found - | Ok data -> Lwt.return data - - let store - operation_store - block_header_store - (net_state: net_state) - valid_block_watcher - hash { Updater.context ; message ; fitness } = - (* Read the block header. *) - Raw_block_header.Locked.read - block_header_store hash >>=? fun block -> - Raw_block_header.Locked.read_discovery_time - block_header_store hash >>=? fun discovery_time -> - (* Check fitness coherency. *) - fail_unless - (Fitness.equal fitness block.Block_header.shell.fitness) - (Invalid_fitness - { block = hash ; - expected = block.Block_header.shell.fitness ; - found = fitness ; - }) >>=? fun () -> - Raw_block_header.Locked.mark_valid - block_header_store hash >>= fun _marked -> - (* TODO fail if the block was previsouly stored ... ??? *) - (* Let's commit the context. *) - let message = - match message with - | Some message -> message - | None -> - Format.asprintf "%a(%ld): %a" - Block_hash.pp_short hash - block.shell.level - Fitness.pp fitness in - Context.commit hash block.shell.timestamp message context >>= fun () -> - (* Update the chain state. *) - let store = net_state.chain_store in - let predecessor = block.shell.predecessor in - Store.Chain.Known_heads.remove store predecessor >>= fun () -> - Store.Chain.Known_heads.store store hash >>= fun () -> - (* Build the `valid_block` value. *) - let operation_hashes = - lazy (Operation_list.Locked.read_all_exn block_header_store hash) in - let operations = - lazy ( - Lazy.force operation_hashes >>= fun operations -> - Lwt_list.map_p - (Lwt_list.map_p - (Raw_operation.read_exn operation_store )) - operations) in - raw_read_exn - block operations operation_hashes discovery_time - net_state.context_index hash >>= fun valid_block -> - Watcher.notify valid_block_watcher valid_block ; - Lwt.return (Ok valid_block) - - end - - let atomic1 f net = Shared.use net.state f - let atomic2 f net k = Shared.use net.state (fun s -> f s k) - let atomic3 f net k v = Shared.use net.state (fun s -> f s k v) - - let known = atomic2 Locked.known - let read net hash = - Shared.use net.state begin fun state -> - Locked.read net state hash - end - let read_opt net hash = - read net hash >>= function - | Error _ -> Lwt.return_none - | Ok b -> Lwt.return (Some b) - let read_exn net hash = - read net hash >>= function - | Error _ -> Lwt.fail Not_found - | Ok b -> Lwt.return b - - let store net hash vcontext = - Shared.use net.state begin fun net_state -> - Shared.use net.block_header_store begin fun block_header_store -> - Context.exists net_state.context_index hash >>= function - | true -> return None (* Previously stored context. *) - | false -> - Raw_block_header.Locked.invalid - block_header_store hash >>= function - | Some _ -> return None (* Previously invalidated block. *) - | None -> - Locked.store net.operation_store - block_header_store net_state net.valid_block_watcher - hash vcontext >>=? fun valid_block -> - return (Some valid_block) - end - end - - let watcher net = - Watcher.create_stream net.valid_block_watcher - - let fork_testnet state net block protocol expiration = - assert (Net_id.equal block.net_id (Net_id.of_block_hash net.genesis.block)) ; - Shared.use state.global_data begin fun data -> - let context = block.context in - Context.set_test_network context Not_running >>= fun context -> - Context.set_protocol context protocol >>= fun context -> - Context.commit_test_network_genesis - block.hash block.timestamp context >>=? fun (net_id, genesis) -> - let genesis = { - block = genesis ; - time = Time.add block.timestamp 1L ; - protocol ; - } in - Raw_net.locked_create data - net_id ~initial_context:context ~expiration genesis >>= fun net -> - return net - end - - module Helpers = struct - - let path net b1 b2 = - let net_id = Net_id.of_block_hash net.genesis.block in - if not ( Net_id.equal b1.net_id net_id - && Net_id.equal b2.net_id net_id ) then - invalid_arg "State.path" ; - Raw_helpers.path net.block_header_store b1.hash b2.hash >>= function - | None -> Lwt.return_none - | Some blocks -> - Lwt_list.map_p - (fun (hash, _header) -> read_exn net hash) blocks >>= fun path -> - Lwt.return (Some path) - - let common_ancestor net b1 b2 = - let net_id = Net_id.of_block_hash net.genesis.block in - if not ( Net_id.equal b1.net_id net_id - && Net_id.equal b2.net_id net_id ) then - invalid_arg "State.path" ; - Raw_block_header.read_exn (* The blocks are known valid. *) - net.block_header_store b1.hash >>= fun { shell = header1 } -> - Raw_block_header.read_exn (* The blocks are known valid. *) - net.block_header_store b2.hash >>= fun { shell = header2 } -> - Raw_helpers.common_ancestor net.block_header_store - b1.hash header1 b2.hash header2 >>= function - | None -> assert false (* The blocks are known valid. *) - | Some (hash, _header) -> read_exn net hash - - let block_locator state sz b = - Raw_helpers.block_locator state.block_header_store sz b.hash - - let iter_predecessors = - let compare b1 b2 = - match Fitness.compare b1.fitness b2.fitness with - | 0 -> begin - match Time.compare b1.timestamp b2.timestamp with - | 0 -> Block_hash.compare b1.hash b2.hash - | res -> res - end - | res -> res in - let predecessor state b = - if Block_hash.equal b.hash b.predecessor then - Lwt.return None - else - read_opt state b.predecessor in - Raw_helpers.iter_predecessors compare predecessor - (fun b -> b.timestamp) (fun b -> b.fitness) - - end - - let known_heads net = - Shared.use net.state begin fun net_state -> - Store.Chain.Known_heads.elements net_state.chain_store >>= fun hashes -> - Lwt_list.map_p (Locked.read_exn net net_state) hashes - end - - module Current = struct - - let genesis net = read_exn net net.genesis.block - - let head net = - Shared.use net.state begin fun { current_head } -> - Lwt.return current_head - end - - let protocol net = - Shared.use net.state begin fun { current_head } -> - match current_head.protocol with - | None -> assert false (* TODO PROPER ERROR *) - | Some proto -> Lwt.return proto - end - - let mem net hash = - Shared.use net.state begin fun { chain_store } -> - Store.Chain.In_chain_insertion_time.known (chain_store, hash) - end - - let find_new net hist sz = - let rec common_ancestor hist = - match hist with - | [] -> Lwt.return net.genesis.block - | h :: hist -> - mem net h >>= function - | false -> common_ancestor hist - | true -> Lwt.return h in - let rec path sz acc h = - if sz <= 0 then return (List.rev acc) - else - Shared.use net.state begin fun { chain_store } -> - Store.Chain.Successor_in_chain.read_opt (chain_store, h) - end >>= function - | None -> return (List.rev acc) - | Some s -> path (sz-1) (s :: acc) s in - common_ancestor hist >>= fun ancestor -> - path sz [] ancestor - - let new_blocks store old_block new_block = - Raw_block_header.read_exn (* valid block *) - store old_block.hash >>= fun { shell = old_header } -> - Raw_block_header.read_exn (* valid block *) - store new_block.hash >>= fun { shell = new_header } -> - Raw_helpers.common_ancestor store - old_block.hash old_header - new_block.hash new_header >>= function - | None -> assert false (* valid block *) - | Some (ancestor, _header) -> - Raw_helpers.path store ancestor new_block.hash >>= function - | None -> assert false (* valid block *) - | Some path -> Lwt.return (ancestor, path) - - let locked_set_head block_header_store operation_store state block = - let rec pop_blocks ancestor hash = - if Block_hash.equal hash ancestor then - Lwt.return_unit - else - lwt_debug "pop_block %a" Block_hash.pp_short hash >>= fun () -> - Raw_block_header.read_exn - block_header_store hash >>= fun { shell } -> - Raw_operation_list.read_all_exn - block_header_store hash >>= fun operations -> - let operations = List.concat operations in - Lwt_list.iter_p - (fun h -> - Raw_operation.Locked.unmark operation_store h >>= fun _ -> - Lwt.return_unit) - operations >>= fun () -> - Store.Chain.In_chain_insertion_time.remove - (state.chain_store, hash) >>= fun () -> - Store.Chain.Successor_in_chain.remove - (state.chain_store, shell.predecessor) >>= fun () -> - pop_blocks ancestor shell.predecessor - in - let push_block time (hash, shell) = - lwt_debug "push_block %a" Block_hash.pp_short hash >>= fun () -> - Store.Chain.In_chain_insertion_time.store - (state.chain_store, hash) time >>= fun () -> - Store.Chain.Successor_in_chain.store - (state.chain_store, - shell.Block_header.predecessor) hash >>= fun () -> - Raw_operation_list.read_all_exn - block_header_store hash >>= fun operations -> - let operations = List.concat operations in - Lwt_list.iter_p - (fun h -> - Raw_operation.Locked.mark_valid operation_store h >>= fun _ -> - Lwt.return_unit) - operations - in - let time = Time.now () in - new_blocks - block_header_store state.current_head block >>= fun (ancestor, path) -> - pop_blocks ancestor state.current_head.hash >>= fun () -> - Lwt_list.iter_p (push_block time) path >>= fun () -> - state.current_head <- block ; - Store.Chain.Current_head.store state.chain_store block.hash - - let set_head net block = - Shared.use net.state begin fun state -> - Shared.use net.operation_store begin fun operation_store -> - locked_set_head net.block_header_store operation_store state block - end - end - - let test_and_set_head net ~old block = - Shared.use net.state begin fun state -> - if not (Block_hash.equal state.current_head.hash old.hash) then - Lwt.return_false - else - Shared.use net.operation_store begin fun operation_store -> - locked_set_head - net.block_header_store operation_store state block >>= fun () -> - Lwt.return_true - end - end - - let new_blocks net ~from_block ~to_block = - new_blocks net.block_header_store from_block to_block - - end + ~id:genesis.block + ~time:genesis.time + ~protocol:genesis.protocol >>= fun _context -> + Lwt.return header end module Net = struct - type t = net - type net = t - type nonrec genesis = genesis = { time: Time.t ; block: Block_hash.t ; @@ -1308,13 +135,77 @@ module Net = struct (req "block" Block_hash.encoding) (req "protocol" Protocol_hash.encoding)) + type t = net_state + type net_state = t + + let allocate + ~genesis ~expiration ~allow_forked_network + ~current_head + context_index chain_store block_store = + Store.Block.Contents.read_exn + (block_store, current_head) >>= fun current_block -> + let rec chain_state = { + data = { + current_head = { + net_state ; + hash = current_head ; + contents = current_block ; + } + } ; + chain_store ; + } + and net_state = { + net_id = Net_id.of_block_hash genesis.block ; + chain_state = { Shared.data = chain_state ; lock = Lwt_mutex.create () } ; + genesis ; + expiration ; + allow_forked_network ; + block_store = Shared.create block_store ; + context_index = Shared.create context_index ; + block_watcher = Watcher.create_input () ; + } in + Lwt.return net_state + + let locked_create + data ?expiration ?(allow_forked_network = false) + net_id genesis = + let net_store = Store.Net.get data.global_store net_id in + let block_store = Store.Block.get net_store + and chain_store = Store.Chain.get net_store in + Store.Net.Genesis_hash.store net_store genesis.block >>= fun () -> + Store.Net.Genesis_time.store net_store genesis.time >>= fun () -> + Store.Net.Genesis_protocol.store net_store genesis.protocol >>= fun () -> + Store.Chain.Current_head.store chain_store genesis.block >>= fun () -> + Store.Chain.Known_heads.store chain_store genesis.block >>= fun () -> + begin + match expiration with + | None -> Lwt.return_unit + | Some time -> Store.Net.Expiration.store net_store time + end >>= fun () -> + begin + if allow_forked_network then + Store.Net.Allow_forked_network.store data.global_store net_id + else + Lwt.return_unit + end >>= fun () -> + Locked_block.store_genesis + data.context_index block_store genesis >>= fun _genesis_header -> + allocate + ~genesis + ~current_head:genesis.block + ~expiration + ~allow_forked_network + data.context_index + chain_store + block_store + let create state ?allow_forked_network genesis = let net_id = Net_id.of_block_hash genesis.block in Shared.use state.global_data begin fun data -> if Net_id.Table.mem data.nets net_id then Pervasives.failwith "State.Net.create" else - Raw_net.locked_create + locked_create data ?allow_forked_network net_id genesis >>= fun net -> Net_id.Table.add data.nets net_id net ; Lwt.return net @@ -1322,8 +213,7 @@ module Net = struct let locked_read data id = let net_store = Store.Net.get data.global_store id in - let operation_store = Store.Operation.get net_store - and block_header_store = Store.Block_header.get net_store + let block_store = Store.Block.get net_store and chain_store = Store.Chain.get net_store in Store.Net.Genesis_hash.read net_store >>=? fun genesis_hash -> Store.Net.Genesis_time.read net_store >>=? fun time -> @@ -1332,26 +222,15 @@ module Net = struct Store.Net.Allow_forked_network.known data.global_store id >>= fun allow_forked_network -> let genesis = { time ; protocol ; block = genesis_hash } in - Store.Chain.Current_head.read chain_store >>=? fun genesis_hash -> - data.init_index id >>= fun context_index -> - Block_header.Locked.read block_header_store - genesis_hash >>=? fun genesis_shell_header -> - Block_header.Locked.read_discovery_time block_header_store - genesis_hash >>=? fun genesis_discovery_time -> - Valid_block.Locked.raw_read - genesis_shell_header (lazy Lwt.return_nil) (lazy Lwt.return_nil) - genesis_discovery_time - context_index genesis_hash >>=? fun genesis_block -> - return @@ - Raw_net.build + Store.Chain.Current_head.read chain_store >>=? fun current_head -> + allocate ~genesis - ~genesis_block + ~current_head ~expiration ~allow_forked_network - context_index + data.context_index chain_store - block_header_store - operation_store + block_store >>= return let locked_read_all data = Store.Net.list data.global_store >>= fun ids -> @@ -1379,7 +258,7 @@ module Net = struct Net_id.Table.fold (fun _ net acc -> net :: acc) nets [] end - let id { id } = id + let id { net_id } = net_id let genesis { genesis } = genesis let expiration { expiration } = expiration let allow_forked_network { allow_forked_network } = allow_forked_network @@ -1394,83 +273,298 @@ module Net = struct end +module Block = struct -(* -let () = - let open Data_encoding in - register_error_kind `Permanent - ~id:"refusedOperation" - ~title: "Refused operation" - ~description: - "An operation that will never be accepted (by any protocol version)." - ~pp:(fun ppf hash -> - Format.fprintf ppf "Refused operation %a" - Operation_hash.pp_short hash) - (obj1 (req "operation_hash" Operation_hash.encoding)) - (function Exn (Operation.Invalid (hash, _)) -> Some hash | _ -> None) - (fun hash -> Exn (Operation.Invalid (hash, [(* TODO *)]))) - -let () = - let open Data_encoding in - register_error_kind `Permanent - ~id: "invalidBlock" - ~title: "Invalid block" - ~description: - "The economic protocol refused to validate the block." - ~pp:(fun ppf block_hash -> - Format.fprintf ppf "Cannot validate the block %a" - Block_hash.pp_short block_hash) - (obj1 (req "block_hash" Block_hash.encoding)) - (function Exn (Valid_block.Invalid (block_hash, _)) -> Some block_hash - | _ -> None) - (fun block_hash -> Exn (Valid_block.Invalid (block_hash, [(* TODO *)]))) - -*) - -module Operation = struct - - type shell_header = Operation.shell_header = { - net_id: Net_id.t ; + type t = block = { + net_state: Net.t ; + hash: Block_hash.t ; + contents: Store.Block.contents ; } + type block = t - type t = Operation.t = { - shell: shell_header ; - proto: MBytes.t ; - } + let compare b1 b2 = Block_hash.compare b1.hash b2.hash + let equal b1 b2 = Block_hash.equal b1.hash b2.hash - include Make_data_store - (struct - include Operation - include Store.Operation - end) - (struct - type store = net - let use s = Shared.use s.operation_store - let unknown k = fail (Unknown_operation k) - end) - (Operation_hash.Set) + let hash { hash } = hash + let header { contents = { header } } = header + let shell_header { contents = { header = { shell } } } = shell + let net_id b = (shell_header b).net_id + let timestamp b = (shell_header b).timestamp + let fitness b = (shell_header b).fitness + let level b = (shell_header b).level + let proto_level b = (shell_header b).proto_level + let message { contents = { message } } = message + let operation_list_count { contents = { operation_list_count } } = + operation_list_count - let in_chain = valid + let known_valid net_state hash = + Shared.use net_state.block_store begin fun store -> + Store.Block.Contents.known (store, hash) + end + let known_invalid net_state hash = + Shared.use net_state.block_store begin fun store -> + Store.Block.Invalid_block.known store hash + end + + let read net_state hash = + Shared.use net_state.block_store begin fun store -> + Store.Block.Contents.read (store, hash) >>=? fun contents -> + return { net_state ; hash ; contents } + end + let read_opt net_state hash = + read net_state hash >>= function + | Error _ -> Lwt.return None + | Ok v -> Lwt.return (Some v) + let read_exn net_state hash = + Shared.use net_state.block_store begin fun store -> + Store.Block.Contents.read_exn (store, hash) >>= fun contents -> + Lwt.return { net_state ; hash ; contents } + end + + (* Quick accessor to be optimized ?? *) + let read_predecessor net_state hash = + read net_state hash >>=? fun { contents = { header } } -> + return header.shell.predecessor + let read_predecessor_opt net_state hash = + read_predecessor net_state hash >>= function + | Error _ -> Lwt.return None + | Ok v -> Lwt.return (Some v) + let read_predecessor_exn net_state hash = + read_exn net_state hash >>= fun { contents = { header } } -> + Lwt.return header.shell.predecessor + + let predecessor { net_state ; contents = { header } ; hash } = + if Block_hash.equal hash header.shell.predecessor then + Lwt.return_none + else + read_exn net_state header.shell.predecessor >>= fun block -> + Lwt.return (Some block) + + let store + net_state block_header operations + { Updater.context ; fitness ; message } = + let bytes = Block_header.to_bytes block_header in + let hash = Block_header.hash_raw bytes in + (* let's the validator check the consistency... of fitness, level, ... *) + let message = + match message with + | Some message -> message + | None -> + Format.asprintf "%a(%ld): %a" + Block_hash.pp_short hash + block_header.shell.level + Fitness.pp fitness in + let contents = { + Store.Block.header = block_header ; + message ; + operation_list_count = List.length operations ; + } in + Shared.use net_state.block_store begin fun store -> + Store.Block.Invalid_block.known store hash >>= fun known_invalid -> + fail_when known_invalid (failure "Known invalid") >>=? fun () -> + Store.Block.Contents.known (store, hash) >>= fun known -> + if known then + return false + else begin + Store.Block.Contents.store (store, hash) contents >>= fun () -> + let hashes = List.map (List.map Operation.hash) operations in + let list_hashes = List.map Operation_list_hash.compute hashes in + Lwt_list.iteri_p + (fun i hashes -> + let path = Operation_list_list_hash.compute_path list_hashes i in + Store.Block.Operation_hashes.store + (store, hash) i hashes >>= fun () -> + Store.Block.Operation_path.store (store, hash) i path) + hashes >>= fun () -> + Lwt_list.iteri_p + (fun i ops -> Store.Block.Operations.store (store, hash) i ops) + operations >>= fun () -> + Context.commit + hash block_header.shell.timestamp message context >>= fun () -> + return true + end + end >>=? fun commited -> + if not commited then + return None + else + (* Update the chain state. *) + Shared.use net_state.chain_state begin fun chain_state -> + let store = chain_state.chain_store in + let predecessor = block_header.shell.predecessor in + Store.Chain.Known_heads.remove store predecessor >>= fun () -> + Store.Chain.Known_heads.store store hash + end >>= fun () -> + let block = { net_state ; hash ; contents } in + Watcher.notify net_state.block_watcher block ; + return (Some block) + + let store_invalid net_state block_header = + let bytes = Block_header.to_bytes block_header in + let hash = Block_header.hash_raw bytes in + Shared.use net_state.block_store begin fun store -> + Store.Block.Contents.known (store, hash) >>= fun known_valid -> + fail_when known_valid (failure "Known valid") >>=? fun () -> + Store.Block.Invalid_block.known store hash >>= fun known_invalid -> + if known_invalid then + return false + else + Store.Block.Invalid_block.store store hash + { level = block_header.shell.level } >>= fun () -> + return true + end + + let watcher net_state = + Watcher.create_stream net_state.block_watcher + + let operation_hashes { net_state ; hash ; contents } i = + if i < 0 || contents.operation_list_count <= i then + invalid_arg "State.Block.operations" ; + Shared.use net_state.block_store begin fun store -> + Store.Block.Operation_hashes.read_exn (store, hash) i >>= fun hashes -> + Store.Block.Operation_path.read_exn (store, hash) i >>= fun path -> + Lwt.return (hashes, path) + end + + let all_operation_hashes { net_state ; hash ; contents } = + Shared.use net_state.block_store begin fun store -> + Lwt_list.map_p + (Store.Block.Operation_hashes.read_exn (store, hash)) + (0 -- (contents.operation_list_count - 1)) + end + + let operations { net_state ; hash ; contents } i = + if i < 0 || contents.operation_list_count <= i then + invalid_arg "State.Block.operations" ; + Shared.use net_state.block_store begin fun store -> + Store.Block.Operation_path.read_exn (store, hash) i >>= fun path -> + Store.Block.Operations.read_exn (store, hash) i >>= fun ops -> + Lwt.return (ops, path) + end + + let all_operations { net_state ; hash ; contents } = + Shared.use net_state.block_store begin fun store -> + Lwt_list.map_p + (fun i -> Store.Block.Operations.read_exn (store, hash) i) + (0 -- (contents.operation_list_count - 1)) + end + + let context { net_state ; hash } = + Shared.use net_state.context_index begin fun context_index -> + Context.checkout_exn context_index hash + end + + let protocol_hash { net_state ; hash } = + Shared.use net_state.context_index begin fun context_index -> + Context.checkout_exn context_index hash >>= fun context -> + Context.get_protocol context + end + + let test_network { net_state ; hash } = + Shared.use net_state.context_index begin fun context_index -> + Context.checkout_exn context_index hash >>= fun context -> + Context.get_test_network context + end end +let read_block { global_data } hash = + Shared.use global_data begin fun { nets } -> + Net_id.Table.fold + (fun _net_id net_state acc -> + acc >>= function + | Some _ -> acc + | None -> + Block.read_opt net_state hash >>= function + | None -> acc + | Some block -> Lwt.return (Some block)) + nets + Lwt.return_none + end + +let read_block_exn t hash = + read_block t hash >>= function + | None -> Lwt.fail Not_found + | Some b -> Lwt.return b + +let fork_testnet state block protocol expiration = + Shared.use state.global_data begin fun data -> + Block.context block >>= fun context -> + Context.set_test_network context Not_running >>= fun context -> + Context.set_protocol context protocol >>= fun context -> + Context.commit_test_network_genesis + block.hash block.contents.header.shell.timestamp + context >>=? fun (net_id, genesis) -> + let genesis = { + block = genesis ; + time = Time.add block.contents.header.shell.timestamp 1L ; + protocol ; + } in + Net.locked_create data + net_id ~expiration genesis >>= fun net -> + return net + end + module Protocol = struct - type t = Protocol.t + let known global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.known store hash + end - include Make_data_store - (struct - include Protocol - include Store.Protocol - end) - (struct - type store = global_state - let use s = Shared.use s.protocol_store - let unknown k = fail (Unknown_protocol k) - end) - (Protocol_hash.Set) + let read global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.read store hash + end + let read_opt global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.read_opt store hash + end + let read_exn global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.read_exn store hash + end - (* TODO somehow export `mark_invalid`. *) + let read_raw global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.RawContents.read (store, hash) + end + let read_raw_opt global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.RawContents.read_opt (store, hash) + end + let read_raw_exn global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.RawContents.read_exn (store, hash) + end + + let store global_state p = + let bytes = Protocol.to_bytes p in + let hash = Protocol.hash_raw bytes in + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.known store hash >>= fun known -> + if known then + Lwt.return None + else + Store.Protocol.RawContents.store (store, hash) bytes >>= fun () -> + Lwt.return (Some hash) + end + + let remove global_state hash = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.known store hash >>= fun known -> + if known then + Lwt.return_false + else + Store.Protocol.Contents.remove store hash >>= fun () -> + Lwt.return_true + end + + let list global_state = + Shared.use global_state.protocol_store begin fun store -> + Store.Protocol.Contents.fold_keys store + ~init:Protocol_hash.Set.empty + ~f:(fun x acc -> Lwt.return (Protocol_hash.Set.add x acc)) + end end @@ -1479,16 +573,16 @@ let read ~store_root ~context_root () = - Store.init store_root >>=? fun store -> + Store.init store_root >>=? fun global_store -> Context.init ?patch_context ~root:context_root >>= fun context_index -> let global_data = { nets = Net_id.Table.create 17 ; - global_store = store ; - init_index = (fun _ -> Lwt.return context_index) ; + global_store ; + context_index ; } in let state = { global_data = Shared.create global_data ; - protocol_store = Shared.create @@ Store.Protocol.get store ; + protocol_store = Shared.create @@ Store.Protocol.get global_store ; } in Net.read_all state >>=? fun () -> return state diff --git a/src/node/shell/state.mli b/src/node/shell/state.mli index 537ba4c5f..d494abbdd 100644 --- a/src/node/shell/state.mli +++ b/src/node/shell/state.mli @@ -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 - diff --git a/src/node/shell/validator.ml b/src/node/shell/validator.ml index 910690935..e780ed6f2 100644 --- a/src/node/shell/validator.ml +++ b/src/node/shell/validator.ml @@ -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 + "@[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 "@[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 "@[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 diff --git a/src/node/shell/validator.mli b/src/node/shell/validator.mli index 93da889d2..ace11895b 100644 --- a/src/node/shell/validator.mli +++ b/src/node/shell/validator.mli @@ -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 diff --git a/src/utils/error_monad.ml b/src/utils/error_monad.ml index 37f669f51..e7bf7774d 100644 --- a/src/utils/error_monad.ml +++ b/src/utils/error_monad.ml @@ -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 [] diff --git a/src/utils/error_monad_sig.ml b/src/utils/error_monad_sig.ml index 477a81991..7b757bc53 100644 --- a/src/utils/error_monad_sig.ml +++ b/src/utils/error_monad_sig.ml @@ -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 : diff --git a/test/Makefile.shared b/test/Makefile.shared index 8aad0b82c..aa7fce942 100644 --- a/test/Makefile.shared +++ b/test/Makefile.shared @@ -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 diff --git a/test/proto_alpha/Makefile b/test/proto_alpha/Makefile index 90f02bb23..cdcb96728 100644 --- a/test/proto_alpha/Makefile +++ b/test/proto_alpha/Makefile @@ -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 $@ $^ diff --git a/test/proto_alpha/proto_alpha_helpers.ml b/test/proto_alpha/proto_alpha_helpers.ml index 96cc56a9f..672c44975 100644 --- a/test/proto_alpha/proto_alpha_helpers.ml +++ b/test/proto_alpha/proto_alpha_helpers.ml @@ -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 diff --git a/test/shell/test_state.ml b/test/shell/test_state.ml index cf71df5b7..2b76818fa 100644 --- a/test/shell/test_state.ml +++ b/test/shell/test_state.ml @@ -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 () = diff --git a/test/shell/test_store.ml b/test/shell/test_store.ml index 986535095..a7aa50dbb 100644 --- a/test/shell/test_store.ml +++ b/test/shell/test_store.ml @@ -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 ; ] diff --git a/test/utils/Makefile b/test/utils/Makefile index 83ef42744..d072879fa 100644 --- a/test/utils/Makefile +++ b/test/utils/Makefile @@ -9,7 +9,7 @@ TESTS := \ include ../Makefile.shared -SOURCE_DIRECTORIES := ${UTILS_SOURCE_DIRECTORIES} ../lib +SOURCE_DIRECTORIES := ${COMPILER_SOURCE_DIRECTORIES} ../lib LIB := ${MINUTILSLIB} ${UTILSLIB} ${TESTLIB}