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}