diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 68b24606a..275f53b79 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -240,12 +240,14 @@ let trim_manager_operations ~max_size ~hard_gas_limit_per_block manager_operatio (* We classify operations, sort managers operation by interest and add bad ones at the end *) (* Hypothesis : we suppose that the received manager operations have a valid gas_limit *) -(** [classify_operations] classify the operation in 5 lists indexed as such : +(** [classify_operations] classify the operation in 4 lists indexed as such : - 0 -> Endorsements - 1 -> Votes and proposals - 2 -> Anonymous operations - - 3 -> High-priority manager operations - - 4 -> Low-priority manager operations *) + - 3 -> High-priority manager operations. + Returns two list : + - A desired set of operations to be included + - Potentially overflowing operations *) let classify_operations (cctxt : #Proto_alpha.full) ~block @@ -261,7 +263,7 @@ let classify_operations ) ops in let validation_passes_len = List.length Proto_alpha.Main.validation_passes in - let t = Array.make (validation_passes_len + 1) [] in + let t = Array.make validation_passes_len [] in List.iter (fun (op: Proto_alpha.operation) -> List.iter @@ -269,7 +271,6 @@ let classify_operations (Main.acceptable_passes op)) ops ; let t = Array.map List.rev t in - (* Retrieve the optimist maximum paying manager operations *) let manager_operations = t.(managers_index) in let { Alpha_environment.Updater.max_size } = @@ -280,8 +281,7 @@ let classify_operations trim_manager_operations ~max_size ~hard_gas_limit_per_block (List.map fst ordered_operations) >>=? fun (desired_manager_operations, overflowing_manager_operations) -> t.(managers_index) <- desired_manager_operations ; - t.(validation_passes_len) <- overflowing_manager_operations ; - return (Array.to_list t) + return ((Array.to_list t), overflowing_manager_operations) let parse (op : Operation.raw) : Operation.packed = let protocol_data = @@ -401,7 +401,7 @@ let filter_and_apply_operations block_info ~timestamp ?protocol_data - (operations : packed_operation list list) = + ((operations : packed_operation list list), overflowing_operations) = let open Client_baking_simulator in lwt_debug Tag.DSL.(fun f -> f "Starting client-side validation %a" @@ -424,11 +424,6 @@ let filter_and_apply_operations let votes = List.nth operations votes_index in let anonymous = List.nth operations anonymous_index in let managers = List.nth operations managers_index in - let bad_managers = - if List.length operations > managers_index + 1 then - List.nth operations (managers_index + 1) - else [] - in let validate_operation inc op = add_operation inc op >>= function | Error errs -> @@ -461,8 +456,8 @@ let filter_and_apply_operations filter_valid_operations inc anonymous >>=? fun (inc, anonymous) -> (* Retrieve the correct index order *) let managers = List.sort Proto_alpha.compare_operations managers in - let bad_managers = List.sort Proto_alpha.compare_operations bad_managers in - filter_valid_operations inc (managers @ bad_managers) >>=? fun (inc, managers) -> + let overflowing_operations = List.sort Proto_alpha.compare_operations overflowing_operations in + filter_valid_operations inc (managers @ overflowing_operations) >>=? fun (inc, managers) -> (* Gives a chance to the endorser to fund their deposit in the current block *) filter_map_s (is_valid_endorsement inc) endorsements >>=? fun endorsements -> finalize_construction inc >>=? fun _ -> @@ -554,7 +549,8 @@ let forge_block let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in Alpha_services.Constants.all cctxt (`Main, block) >>=? fun Constants.{ parametric = { hard_gas_limit_per_block ; endorsers_per_block } } -> - classify_operations cctxt ~hard_gas_limit_per_block ~block:block ~fee_threshold operations_arg >>=? fun operations -> + classify_operations cctxt ~hard_gas_limit_per_block ~block:block ~fee_threshold operations_arg + >>=? fun (operations, overflowing_ops) -> (* Ensure that we retain operations up to the quota *) let quota : Alpha_environment.Updater.quota list = Main.validation_passes in let endorsements = List.sub @@ -603,7 +599,7 @@ let forge_block max_waiting_time = 0 ; fee_threshold = Tez.zero ; } in - filter_and_apply_operations ~timestamp ~protocol_data state bi operations + filter_and_apply_operations ~timestamp ~protocol_data state bi (operations, overflowing_ops) >>=? fun (final_context, validation_result, operations) -> finalize_block_header final_context ~timestamp validation_result operations >>=? fun shell_header -> return (shell_header, List.map (List.map forge) operations) @@ -756,8 +752,8 @@ let build_block | Some operations -> tzforce state.constants >>=? fun Constants.{ parametric = { hard_gas_limit_per_block } } -> classify_operations cctxt - ~hard_gas_limit_per_block ~fee_threshold:state.fee_threshold ~block operations >>=? fun operations -> - + ~hard_gas_limit_per_block ~fee_threshold:state.fee_threshold ~block operations + >>=? fun (operations, overflowing_ops) -> let next_version = match Tezos_base.Block_header.get_forced_protocol_upgrade ~level:(Raw_level.to_int32 next_level.Level.level) with | None -> bi.next_protocol @@ -766,12 +762,13 @@ let build_block if Protocol_hash.(Proto_alpha.hash <> next_version) then (* Let the shell validate this *) shell_prevalidation cctxt ~chain ~block seed_nonce_hash - (List.sub operations 4) slot + operations slot else let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in - filter_and_apply_operations ~timestamp ~protocol_data state bi operations >>= function + filter_and_apply_operations ~timestamp ~protocol_data state bi (operations, overflowing_ops) + >>= function | Error errs -> - lwt_log_info Tag.DSL.(fun f -> + lwt_log_error Tag.DSL.(fun f -> f "Client-side validation: error while filtering invalid operations :@\n@[%a@]" -% t event "client_side_validation_error" -% a errs_tag errs) >>= fun () -> @@ -779,7 +776,7 @@ let build_block f "Building a block using shell validation" -% t event "shell_prevalidation_notice") >>= fun () -> shell_prevalidation cctxt ~chain ~block seed_nonce_hash - (List.sub operations 4) slot + operations slot | Ok (final_context, validation_result, operations) -> lwt_debug Tag.DSL.(fun f -> f "Try forging locally the block header for %a (slot %d) for %s (%a)"