...
 
Commits (6)
......@@ -218,6 +218,12 @@ module type PROTOCOL = sig
receives the header of the block that triggered the amendment. *)
val init :
Context.t -> Block_header.shell_header -> validation_result tzresult Lwt.t
val reveal :
Context.t ->
Block_header.shell_header ->
Protocol_hash.t ->
Protocol.t tzresult Lwt.t
end
(** Activates a given protocol version from a given context. This
......
......@@ -221,6 +221,12 @@ module type T = sig
val init :
context -> Block_header.shell_header -> validation_result tzresult Lwt.t
val reveal :
context ->
Block_header.shell_header ->
Protocol_hash.t ->
Protocol.t tzresult Lwt.t
end
module type PROTOCOL =
......@@ -276,7 +282,9 @@ module type V1 = sig
and type (+'m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t =
('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t
and type Error_monad.shell_error = Error_monad.error
and type Z.t = Z.t
and type Protocol.component = Protocol.component
and type Protocol.env_version = Protocol.env_version
and type Protocol.t = Protocol.t
type error += Ecoproto_error of Error_monad.error
......@@ -947,6 +955,8 @@ struct
let finalize_block c = finalize_block c >|= wrap_error
let init c bh = init c bh >|= wrap_error
let reveal c bh h = reveal c bh h >|= wrap_error
end
class ['chain, 'block] proto_rpc_context (t : Tezos_rpc.RPC_context.t)
......
......@@ -180,6 +180,12 @@ module type T = sig
val init :
context -> Block_header.shell_header -> validation_result tzresult Lwt.t
val reveal :
context ->
Block_header.shell_header ->
Protocol_hash.t ->
Protocol.t tzresult Lwt.t
end
module type PROTOCOL =
......@@ -236,6 +242,9 @@ module type V1 = sig
('m, 'pr, 'p, 'q, 'i, 'o) RPC_service.t
and type Error_monad.shell_error = Error_monad.error
and type Z.t = Z.t
and type Protocol.component = Protocol.component
and type Protocol.env_version = Protocol.env_version
and type Protocol.t = Protocol.t
type error += Ecoproto_error of Error_monad.error
......
......@@ -164,6 +164,7 @@ let on_request : type r. t -> r Request.t -> r tzresult Lwt.t =
?peer
~timeout:bv.limits.protocol_timeout
protocol
pred
>>=? fun _ ->
Block_validator_process.apply_block
bv.validation_process
......
......@@ -54,6 +54,7 @@ val fetch_and_compile_protocol :
?peer:P2p_peer.Id.t ->
?timeout:Time.System.Span.t ->
Protocol_hash.t ->
State.Block.t ->
Registered_protocol.t tzresult Lwt.t
val shutdown : t -> unit Lwt.t
......
......@@ -266,6 +266,7 @@ let may_switch_test_chain w active_chains spawn_child block =
Block_validator.fetch_and_compile_protocol
nv.parameters.block_validator
missing_protocol
block
>>=? fun _ -> cont ()
| Error _ as error ->
Lwt.return error
......
......@@ -27,7 +27,7 @@
module Bounded_encoding = struct
open Data_encoding
let block_header_max_size = ref (Some (8 * 1024 * 1024))
let block_header_max_size = ref (Some (4096 * 1024 * 1024))
(* FIXME: arbitrary *)
......@@ -54,13 +54,15 @@ module Bounded_encoding = struct
let block_locator = delayed (fun () -> !block_locator_cache)
(* FIXME: all constants below are arbitrary high bounds until we
have the mechanism to update them properly *)
let operation_max_size = ref (Some (128 * 1024)) (* FIXME: arbitrary *)
(* FIXME: all constants below are arbitrary high bounds until we have the
mechanism to update them properly *)
let operation_max_size = ref (Some (4096 * 1024)) (* FIXME: arbitrary *)
let operation_list_max_size = ref (Some (1024 * 1024)) (* FIXME: arbitrary *)
let operation_list_max_size = ref (Some (4048 * 1024)) (* FIXME: arbitrary *)
let operation_list_max_length = ref None (* FIXME: arbitrary *)
let operation_list_max_length = ref (Some (4048 * 1024))
(* FIXME: arbitrary *)
let operation_max_pass = ref (Some 8) (* FIXME: arbitrary *)
......@@ -128,7 +130,9 @@ module Bounded_encoding = struct
let operation_hash_list = delayed (fun () -> !operation_hash_list_cache)
let protocol_max_size = ref (Some (2 * 1024 * 1024)) (* FIXME: arbitrary *)
let protocol_max_size = ref (Some (4096 * 1024 * 1024))
(* FIXME: arbitrary *)
let protocol_cache =
ref (Protocol.bounded_encoding ?max_size:!protocol_max_size ())
......
......@@ -405,31 +405,30 @@ let on_error w r st err =
| Block_validator_errors.System_error _ :: _ ->
Worker.record_event w (Event.Request (r, st, Some err)) ;
return_unit
| Block_validator_errors.Unavailable_protocol {protocol; _} :: _ -> (
Block_validator.fetch_and_compile_protocol
pv.parameters.block_validator
~peer:pv.peer_id
~timeout:pv.parameters.limits.protocol_timeout
protocol
>>= function
| Ok _ ->
Distributed_db.Request.current_head
pv.parameters.chain_db
~peer:pv.peer_id
() ;
return_unit
| Error _ ->
(* TODO: punish *)
debug
w
"Terminating the validation worker for peer %a (missing protocol \
%a)."
P2p_peer.Id.pp_short
pv.peer_id
Protocol_hash.pp_short
protocol ;
Worker.record_event w (Event.Request (r, st, Some err)) ;
Lwt.return_error err )
| Block_validator_errors.Unavailable_protocol {protocol; _} :: _ ->
(* Block_validator.fetch_and_compile_protocol
* pv.parameters.block_validator
* ~peer:pv.peer_id
* ~timeout:pv.parameters.limits.protocol_timeout
* protocol
* >>= function
* | Ok _ ->
* Distributed_db.Request.current_head
* pv.parameters.chain_db
* ~peer:pv.peer_id
* () ;
* return_unit
* | Error _ -> *)
(* TODO: punish *)
debug
w
"Terminating the validation worker for peer %a (missing protocol %a)."
P2p_peer.Id.pp_short
pv.peer_id
Protocol_hash.pp_short
protocol ;
Worker.record_event w (Event.Request (r, st, Some err)) ;
Lwt.return_error err
| Validation_errors.Too_short_locator _ :: _ ->
debug
w
......
......@@ -23,7 +23,7 @@
(* *)
(*****************************************************************************)
let build_rpc_directory block_validator state =
let build_rpc_directory _block_validator state =
let dir : unit RPC_directory.t ref = ref RPC_directory.empty in
let gen_register0 s f =
dir := RPC_directory.gen_register !dir s (fun () p q -> f p q)
......@@ -47,7 +47,7 @@ let build_rpc_directory block_validator state =
return p
| None ->
State.Protocol.read state hash) ;
register1 Protocol_services.S.fetch (fun hash () () ->
Block_validator.fetch_and_compile_protocol block_validator hash
>>=? fun _proto -> return_unit) ;
(* register1 Protocol_services.S.fetch (fun hash () () ->
* Block_validator.fetch_and_compile_protocol block_validator hash
* >>=? fun _proto -> return_unit) ; *)
!dir
......@@ -133,29 +133,53 @@ let validate state hash protocol =
| Some (_, res, _) ->
res )
let fetch_and_compile_protocol pv ?peer ?timeout hash =
match Registered_protocol.get hash with
let fetch_protocol pv ?peer ?timeout protocol_hash =
Distributed_db.Protocol.read_opt pv.db protocol_hash
>>= function
| Some protocol ->
return protocol
| None ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Fetching protocol %a%a"
-% t event "fetching_protocol"
-% a Protocol_hash.Logging.tag protocol_hash
-% a P2p_peer.Id.Logging.tag_source peer)
>>= fun () ->
Distributed_db.Protocol.fetch pv.db ?peer ?timeout protocol_hash ()
let reveal_protocol protocol_hash block =
State.Block.context block
>>=? fun context ->
Context.get_protocol context
>>= fun pred_protocol_hash ->
let (module Pred_protocol) =
Option.unopt_exn
(Failure "Protocol_validator.no_source")
(Registered_protocol.get pred_protocol_hash)
in
let ({shell; _} : Block_header.t) = State.Block.header block in
let context = Shell_context.wrap_disk_context context in
Pred_protocol.reveal context shell protocol_hash
>>=? fun protocol -> return_some protocol
let retreive_and_compile_protocol pv ?peer ?timeout protocol_hash block =
match Registered_protocol.get protocol_hash with
| Some proto ->
return proto
| None ->
Distributed_db.Protocol.read_opt pv.db hash
>>= (function
| Some protocol ->
return protocol
| None ->
lwt_log_notice
Tag.DSL.(
fun f ->
f "Fetching protocol %a%a"
-% t event "fetching_protocol"
-% a Protocol_hash.Logging.tag hash
-% a P2p_peer.Id.Logging.tag_source peer)
>>= fun () ->
Distributed_db.Protocol.fetch pv.db ?peer ?timeout hash ())
>>=? fun protocol ->
validate pv hash protocol >>=? fun proto -> return proto
reveal_protocol protocol_hash block
>>=? (function
| Some p ->
return p
| None ->
fetch_protocol pv ?peer ?timeout protocol_hash)
>>=? fun protocol -> validate pv protocol_hash protocol
let fetch_and_compile_protocol = retreive_and_compile_protocol
let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) =
let fetch_and_compile_protocols pv ?peer ?timeout block =
let protocol_level = State.Block.protocol_level block in
let chain_state = State.Block.chain_state block in
State.Block.context block
......@@ -163,7 +187,7 @@ let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) =
let protocol =
Context.get_protocol context
>>= fun protocol_hash ->
fetch_and_compile_protocol pv ?peer ?timeout protocol_hash
retreive_and_compile_protocol pv ?peer ?timeout protocol_hash block
>>=? fun _p ->
let chain_id = State.Chain.id chain_state in
State.Chain.update_level_indexed_protocol_store
......@@ -179,8 +203,8 @@ let fetch_and_compile_protocols pv ?peer ?timeout (block : State.Block.t) =
| Not_running ->
return_unit
| Forking {protocol; _} | Running {protocol; _} ->
fetch_and_compile_protocol pv ?peer ?timeout protocol
>>=? fun _ ->
retreive_and_compile_protocol pv ?peer ?timeout protocol block
>>=? fun _p ->
State.Chain.test chain_state
>>= (function
| None ->
......
......@@ -37,6 +37,7 @@ val fetch_and_compile_protocol :
?peer:P2p_peer.Id.t ->
?timeout:Ptime.Span.t ->
Protocol_hash.t ->
State.Block.t ->
Registered_protocol.t tzresult Lwt.t
val fetch_and_compile_protocols :
......
......@@ -491,7 +491,7 @@ let () =
~pp:(fun ppf error ->
Format.fprintf
ppf
"Failed to validate block using exteranl validation process. %a"
"Failed to validate block using external validation process. %a"
pp_validation_process_error
error)
Data_encoding.(obj1 (req "error" validation_process_error_encoding))
......
......@@ -147,3 +147,5 @@ let init context block_header =
}
let rpc_services = RPC_directory.empty
let reveal _ _ = assert false
......@@ -213,3 +213,5 @@ let init ctxt block_header =
max_operations_ttl = 0 ;
last_allowed_fork_level = block_header.level ;
}
let reveal _ _ = assert false