Proto_alpha/forge: simplify error management

This commit is contained in:
Raphaël Proust 2018-11-27 17:25:20 +08:00 committed by Grégoire Henry
parent 5ed2ac3f90
commit e956c1f7bf
No known key found for this signature in database
GPG Key ID: 50D984F20BD445D2

View File

@ -478,34 +478,34 @@ let filter_and_apply_operations
-% a Operation_hash.Logging.tag (Operation.hash_packed op) -% a Operation_hash.Logging.tag (Operation.hash_packed op)
-% a errs_tag errs) -% a errs_tag errs)
>>= fun () -> >>= fun () ->
return_none Lwt.return_none
| Ok (resulting_state, _receipt) -> | Ok (resulting_state, _receipt) ->
return_some resulting_state Lwt.return_some resulting_state
in in
let filter_valid_operations inc ops = let filter_valid_operations inc ops =
fold_left_s (fun (inc, acc) op -> Lwt_list.fold_left_s (fun (inc, acc) op ->
validate_operation inc op >>=? function validate_operation inc op >>= function
| None -> return (inc, acc) | None -> Lwt.return (inc, acc)
| Some inc' -> return (inc', op :: acc) | Some inc' -> Lwt.return (inc', op :: acc)
) (inc, []) ops ) (inc, []) ops
in in
(* Invalid endorsements are detected during block finalization *) (* Invalid endorsements are detected during block finalization *)
let is_valid_endorsement inc endorsement = let is_valid_endorsement inc endorsement =
validate_operation inc endorsement >>=? function validate_operation inc endorsement >>= function
| None -> return_none | None -> Lwt.return_none
| Some inc' -> finalize_construction inc' >>= begin function | Some inc' -> finalize_construction inc' >>= begin function
| Ok _ -> return_some endorsement | Ok _ -> Lwt.return_some endorsement
| Error _ -> return_none | Error _ -> Lwt.return_none
end end
in in
filter_valid_operations initial_inc votes >>=? fun (inc, votes) -> filter_valid_operations initial_inc votes >>= fun (inc, votes) ->
filter_valid_operations inc anonymous >>=? fun (inc, anonymous) -> filter_valid_operations inc anonymous >>= fun (inc, anonymous) ->
(* Retrieve the correct index order *) (* Retrieve the correct index order *)
let managers = List.sort Proto_alpha.compare_operations managers in let managers = List.sort Proto_alpha.compare_operations managers in
let overflowing_operations = List.sort Proto_alpha.compare_operations overflowing_operations in let overflowing_operations = List.sort Proto_alpha.compare_operations overflowing_operations in
filter_valid_operations inc (managers @ overflowing_operations) >>=? fun (inc, managers) -> filter_valid_operations inc (managers @ overflowing_operations) >>= fun (inc, managers) ->
(* Gives a chance to the endorser to fund their deposit in the current block *) (* Gives a chance to the endorser to fund their deposit in the current block *)
filter_map_s (is_valid_endorsement inc) endorsements >>=? fun endorsements -> Lwt_list.filter_map_s (is_valid_endorsement inc) endorsements >>= fun endorsements ->
finalize_construction inc >>=? fun _ -> finalize_construction inc >>=? fun _ ->
let quota : Alpha_environment.Updater.quota list = Main.validation_passes in let quota : Alpha_environment.Updater.quota list = Main.validation_passes in
tzforce state.constants >>=? fun tzforce state.constants >>=? fun
@ -531,17 +531,17 @@ let filter_and_apply_operations
(* Retrieve the correct index order *) (* Retrieve the correct index order *)
let accepted_managers = List.sort Proto_alpha.compare_operations accepted_managers in let accepted_managers = List.sort Proto_alpha.compare_operations accepted_managers in
(* Make sure we only keep valid operations *) (* Make sure we only keep valid operations *)
filter_valid_operations initial_inc votes >>=? fun (inc, votes) -> filter_valid_operations initial_inc votes >>= fun (inc, votes) ->
filter_valid_operations inc anonymous >>=? fun (inc, anonymous) -> filter_valid_operations inc anonymous >>= fun (inc, anonymous) ->
filter_valid_operations inc accepted_managers >>=? fun (inc, accepted_managers) -> filter_valid_operations inc accepted_managers >>= fun (inc, accepted_managers) ->
filter_map_s (is_valid_endorsement inc) endorsements >>=? fun endorsements -> Lwt_list.filter_map_s (is_valid_endorsement inc) endorsements >>= fun endorsements ->
(* Endorsements won't fail now *) (* Endorsements won't fail now *)
fold_left_s (fun inc op -> fold_left_s (fun inc op ->
add_operation inc op >>=? fun (inc, _receipt) -> add_operation inc op >>=? fun (inc, _receipt) ->
return inc) inc endorsements >>=? fun inc -> return inc) inc endorsements >>=? fun inc ->
(* Endorsement and double baking/endorsement evidence do not commute: (* Endorsement and double baking/endorsement evidence do not commute:
we apply denunciation operations after endorsements. *) we apply denunciation operations after endorsements. *)
filter_valid_operations inc evidences >>=? fun (final_inc, evidences) -> filter_valid_operations inc evidences >>= fun (final_inc, evidences) ->
let operations = List.map List.rev [ endorsements ; votes ; anonymous @ evidences ; accepted_managers ] in let operations = List.map List.rev [ endorsements ; votes ; anonymous @ evidences ; accepted_managers ] in
finalize_construction final_inc >>=? fun (validation_result, metadata) -> finalize_construction final_inc >>=? fun (validation_result, metadata) ->
return (final_inc, (validation_result, metadata), operations) return (final_inc, (validation_result, metadata), operations)
@ -743,7 +743,7 @@ let next_baking_delay state priority =
return span return span
let count_slots_endorsements inc (_timestamp, (head, _priority, _delegate)) operations = let count_slots_endorsements inc (_timestamp, (head, _priority, _delegate)) operations =
fold_left_s (fun acc -> function Lwt_list.fold_left_s (fun acc -> function
| { Alpha_context.protocol_data = | { Alpha_context.protocol_data =
Operation_data { contents = Single (Endorsement { level }) }} as op Operation_data { contents = Single (Endorsement { level }) }} as op
when Raw_level.(level = head.Client_baking_blocks.level) -> when Raw_level.(level = head.Client_baking_blocks.level) ->
@ -753,12 +753,12 @@ let count_slots_endorsements inc (_timestamp, (head, _priority, _delegate)) oper
| Ok (_inc, | Ok (_inc,
Operation_metadata Operation_metadata
{ contents = Single_result (Endorsement_result { slots })} ) -> { contents = Single_result (Endorsement_result { slots })} ) ->
return (acc + List.length slots) Lwt.return (acc + List.length slots)
| Error _ | _ -> | Error _ | _ ->
(* We do not handle errors here *) (* We do not handle errors here *)
return acc Lwt.return acc
end end
| _ -> return acc | _ -> Lwt.return acc
) 0 operations ) 0 operations
let rec filter_limits tnow limits = let rec filter_limits tnow limits =
@ -786,7 +786,7 @@ let fetch_operations
| Some current_mempool -> | Some current_mempool ->
let operations = ref (filter_outdated_endorsements head.Client_baking_blocks.level current_mempool) in let operations = ref (filter_outdated_endorsements head.Client_baking_blocks.level current_mempool) in
Client_baking_simulator.begin_construction ~timestamp state.index head >>=? fun inc -> Client_baking_simulator.begin_construction ~timestamp state.index head >>=? fun inc ->
count_slots_endorsements inc slot !operations >>=? fun nb_arrived_endorsements -> count_slots_endorsements inc slot !operations >>= fun nb_arrived_endorsements ->
tzforce state.constants >>=? fun { Constants.parametric = { endorsers_per_block }} -> tzforce state.constants >>=? fun { Constants.parametric = { endorsers_per_block }} ->
(* If 100% of the endorsements arrived, we don't need to wait *) (* If 100% of the endorsements arrived, we don't need to wait *)
if (not state.await_endorsements) || nb_arrived_endorsements = endorsers_per_block then if (not state.await_endorsements) || nb_arrived_endorsements = endorsers_per_block then
@ -832,7 +832,7 @@ let fetch_operations
| `Event (Some op_list) -> begin | `Event (Some op_list) -> begin
last_get_event := None ; last_get_event := None ;
operations := op_list @ !operations ; operations := op_list @ !operations ;
count_slots_endorsements inc slot op_list >>=? fun new_endorsements -> count_slots_endorsements inc slot op_list >>= fun new_endorsements ->
let nb_arrived_endorsements = nb_arrived_endorsements + new_endorsements in let nb_arrived_endorsements = nb_arrived_endorsements + new_endorsements in
let limits = filter_limits (Time.now ()) limits in let limits = filter_limits (Time.now ()) limits in
let required = let required =