diff --git a/src/proto_alpha/lib_delegate/client_baking_forge.ml b/src/proto_alpha/lib_delegate/client_baking_forge.ml index 82c9ae3e1..69fc4acb2 100644 --- a/src/proto_alpha/lib_delegate/client_baking_forge.ml +++ b/src/proto_alpha/lib_delegate/client_baking_forge.ml @@ -12,6 +12,25 @@ open Alpha_context include Logging.Make(struct let name = "client.baking" end) +type state = { + genesis: Block_hash.t ; + index : Context.index ; + mutable delegates: public_key_hash list ; + constants : Constants.t ; + mutable best: Client_baking_blocks.block_info ; + mutable future_slots: + (Time.t * (Client_baking_blocks.block_info * int * public_key_hash)) list ; +} + +let create_state genesis index delegates constants best = + { genesis ; + index ; + delegates ; + constants ; + best ; + future_slots = [] ; + } + let generate_proof_of_work_nonce () = Rand.generate Constants.proof_of_work_nonce_size @@ -55,12 +74,10 @@ let forge_block_header loop () in loop () - let empty_proof_of_work_nonce = MBytes.of_string (String.make Constants_repr.proof_of_work_nonce_size '\000') - let forge_faked_protocol_data ~priority ~seed_nonce_hash = Alpha_context.Block_header.{ contents = { priority ; seed_nonce_hash ; @@ -68,7 +85,6 @@ let forge_faked_protocol_data ~priority ~seed_nonce_hash = signature = Signature.zero } - let assert_valid_operations_hash shell_header operations = let operations_hash = Operation_list_list_hash.compute @@ -115,6 +131,43 @@ let () = | _ -> None) (fun (hash, err) -> Failed_to_preapply (hash, err)) +let get_operation_fee op = + let { protocol_data = Operation_data { contents } ; _ } = op in + let open Operation in + let l = to_list (Contents_list contents) in + fold_left_s (fun total_fee -> function + | Contents (Manager_operation { fee ; _ }) + when Tez.(fee > zero) -> + Lwt.return @@ Alpha_environment.wrap_error @@ + Tez.(total_fee +? fee) + | _ -> return total_fee) Tez.zero l + +let sort_operations_by_fee (operations : Proto_alpha.operation list) = + (* There is no sort_s, so : *) + map_s (fun op -> get_operation_fee op >>=? fun fee -> return (op, fee)) + operations >>=? fun operations -> + let compare_fee (_, fee1) (_, fee2) = + Tez.compare fee1 fee2 * -1 + in + (* Should we keep operations without fee ? *) + return @@ List.map fst (List.sort compare_fee operations) + +let retain_operations_up_to_quota operations max_quota = + let exception Full of packed_operation list in + let operations = try + List.fold_left (fun (ops, size) op -> + let operation_size = + Data_encoding.Binary.length Alpha_context.Operation.encoding op + in + let new_size = size + operation_size in + if new_size > max_quota then + raise (Full ops) + else + (op :: ops, new_size) + ) ([], 0) operations |> fst + with + | Full ops -> ops in + List.rev operations let classify_operations (ops: Proto_alpha.operation list) = let t = Array.make (List.length Proto_alpha.Main.validation_passes) [] in @@ -124,26 +177,33 @@ let classify_operations (ops: Proto_alpha.operation list) = (fun pass -> t.(pass) <- op :: t.(pass)) (Proto_alpha.Main.acceptable_passes op)) ops ; - Array.fold_right (fun ops acc -> List.rev ops :: acc) t [] - + let t = Array.map List.rev t in + (* Retrieve the maximum paying manager operations *) + let manager_operations = t.(3) in + let { Alpha_environment.Updater.max_size } = List.nth Proto_alpha.Main.validation_passes 3 in + sort_operations_by_fee manager_operations >>=? fun ordered_operations -> + let max_operations = + retain_operations_up_to_quota ordered_operations max_size + in + (* TODO ? : should preserve mempool order *) + t.(3) <- max_operations; + return @@ Array.fold_right (fun ops acc -> ops :: acc) t [] let parse (op : Operation.raw) : Operation.packed = let protocol_data = Data_encoding.Binary.of_bytes_exn Alpha_context.Operation.protocol_data_encoding op.proto in - { - shell = op.shell ; + { shell = op.shell ; protocol_data ; } -let forge (op : Operation.packed) : Operation.raw = { - shell = op.shell ; - proto = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Operation.protocol_data_encoding - op.protocol_data -} +let forge (op : Operation.packed) : Operation.raw = + { shell = op.shell ; + proto = Data_encoding.Binary.to_bytes_exn + Alpha_context.Operation.protocol_data_encoding + op.protocol_data + } let ops_of_mempool (ops : Alpha_block_services.Mempool.t) = List.map (fun (_, op) -> op) ops.applied @ @@ -233,7 +293,6 @@ let error_of_op (result: error Preapply_result.t) op = try Some (Failed_to_preapply (op, snd @@ Operation_hash.Map.find h result.branch_delayed)) with Not_found -> None - let forge_block cctxt ?(chain = `Main) block ?force ?operations ?(best_effort = operations = None) ?(sort = best_effort) @@ -248,7 +307,7 @@ let forge_block cctxt ?(chain = `Main) block (* get basic building blocks *) let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in - let operations = classify_operations operations_arg in + classify_operations operations_arg >>=? fun operations -> Alpha_block_services.Helpers.Preapply.block cctxt ~block ~timestamp ~sort ~protocol_data operations >>=? fun (shell_header, result) -> @@ -380,23 +439,6 @@ let rec insert_baking_slot slot = function slot :: slots | slot' :: slots -> slot' :: insert_baking_slot slot slots -type state = { - genesis: Block_hash.t ; - index : Context.index ; - mutable delegates: public_key_hash list ; - mutable best: Client_baking_blocks.block_info ; - mutable future_slots: - (Time.t * (Client_baking_blocks.block_info * int * public_key_hash)) list ; -} - -let create_state genesis index delegates best = - { genesis ; - index ; - delegates ; - best ; - future_slots = [] ; - } - let drop_old_slots ~before state = state.future_slots <- List.filter @@ -514,32 +556,54 @@ let filter_invalid_operations (cctxt : #full) state block_info (operations : pac let votes = List.nth operations 1 in let anonymous = List.nth operations 2 in let managers = List.nth operations 3 in - (* TODO log *) let validate_operation inc op = add_operation inc op >>= function - | Error _ -> return None + | Error errs -> + lwt_log_info "Client-side validation: invalid operation filtered %a\n%a" + Operation_hash.pp (Operation.hash_packed op) + pp_print_error errs + >>= fun () -> + return None | Ok inc -> return (Some inc) in let filter_valid_operations inc ops = fold_left_s (fun (inc, acc) op -> validate_operation inc op >>=? function | None -> return (inc, acc) - | Some inc -> return (inc, op :: acc) + | Some inc' -> return (inc', op :: acc) ) (inc, []) ops in - let is_valid_endorsement endorsement = - validate_operation initial_inc endorsement >>=? function + (* Invalid endorsements are detected during block finalization *) + let is_valid_endorsement inc endorsement = + validate_operation inc endorsement >>=? function | None -> return None - | Some inc -> finalize_construction inc >>= begin function + | Some inc' -> finalize_construction inc' >>= begin function | Ok _ -> return (Some endorsement) | Error _ -> return None end in - filter_map_s is_valid_endorsement endorsements >>=? fun _endorsements -> filter_valid_operations initial_inc votes >>=? fun (inc, votes) -> filter_valid_operations inc anonymous >>=? fun (inc, anonymous) -> - filter_valid_operations inc managers >>=? fun (_, managers) -> - return @@ List.map List.rev [ endorsements ; votes ; anonymous ; managers ] + filter_valid_operations inc managers >>=? 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 >>= function + | Error errs -> + lwt_log_error "Client-side validation: invalid block built. Building an empty block...\n%a" + pp_print_error errs >>= fun () -> + return [ [] ; [] ; [] ; [] ] + | Ok () -> + let quota : Alpha_environment.Updater.quota list = Main.validation_passes in + (* This shouldn't happen *) + let endorsements = + List.sub (List.rev endorsements) state.constants.Constants.parametric.endorsers_per_block + in + let votes = + retain_operations_up_to_quota (List.rev votes) (List.nth quota 1).max_size in + let anonymous = + retain_operations_up_to_quota (List.rev anonymous) (List.nth quota 2).max_size in + (* manager operations size check already occured in classify operations *) + return @@ List.map List.rev [ endorsements ; votes ; anonymous ; managers ] let bake_slot cctxt @@ -562,7 +626,6 @@ let bake_slot priority name Time.pp_hum timestamp >>= fun () -> - (* get and process operations *) Alpha_block_services.Mempool.pending_operations cctxt ~chain () >>=? fun mpool -> let operations = ops_of_mempool mpool in @@ -574,17 +637,16 @@ let bake_slot None in let protocol_data = forge_faked_protocol_data ~priority ~seed_nonce_hash in - let operations = classify_operations operations in - (* Don't validate if current block is genesis *) + classify_operations operations >>=? fun operations -> begin - (* Don't load an alpha context if still in genesis *) + (* Don't load an alpha context if the chain is still in genesis *) if Protocol_hash.(bi.protocol = bi.next_protocol) then filter_invalid_operations cctxt state bi operations else return operations end >>= function | Error errs -> - lwt_log_error "Error while filtering invalid operations (client-side) :@\n%a" + lwt_log_error "Client-side validation: error while filtering invalid operations :@\n%a" pp_print_error errs >>= fun () -> return None @@ -607,7 +669,8 @@ let bake_slot Block_hash.pp_short bi.hash priority (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf "+") - (fun ppf operations -> Format.fprintf ppf "%d" (List.length operations.Preapply_result.applied))) + (fun ppf operations -> Format.fprintf ppf "%d" + (List.length operations.Preapply_result.applied))) operations total_op_count Fitness.pp shell_header.fitness >>= fun () -> @@ -722,7 +785,8 @@ let create | Some t -> t in lwt_debug "Opening shell context" >>= fun () -> Client_baking_simulator.load_context ~context_path >>= fun index -> - let state = create_state genesis_hash index delegates bi in + Alpha_services.Constants.all cctxt (`Main, `Head 0) >>=? fun constants -> + let state = create_state genesis_hash index delegates constants bi in check_error @@ insert_block cctxt ?max_priority state bi >>= fun () -> (* main loop *) diff --git a/src/proto_alpha/lib_delegate/client_baking_simulator.ml b/src/proto_alpha/lib_delegate/client_baking_simulator.ml index af9a06979..f06db4d4d 100644 --- a/src/proto_alpha/lib_delegate/client_baking_simulator.ml +++ b/src/proto_alpha/lib_delegate/client_baking_simulator.ml @@ -28,15 +28,13 @@ let begin_construction (_cctxt : #Proto_alpha.full) index predecessor = Context.checkout_exn index context >>= fun context -> let timestamp = Time.now () in let predecessor_hash = predecessor.hash in - (* Shell_services.Blocks.header cctxt ~chain:`Main ~block:(`Hash (predecessor_hash, 0)) () - * >>=? fun { shell ; _ } -> *) let header : Tezos_base.Block_header.shell_header = Tezos_base.Block_header.{ predecessor = predecessor_hash ; - proto_level = 0 (* shell.proto_level *) ; - validation_passes = 0 (* shell.validation_passes *) ; - fitness = predecessor.fitness (* shell.fitness *) ; + proto_level = 0 ; + validation_passes = 0 ; + fitness = predecessor.fitness ; timestamp ; - level = 0l (* shell.level *) ; + level = Raw_level.to_int32 predecessor.level ; context = Context_hash.zero ; operations_hash = Operation_list_list_hash.zero ; } in diff --git a/src/proto_alpha/lib_delegate/delegate_commands.ml b/src/proto_alpha/lib_delegate/delegate_commands.ml index db886dd35..bea84ba14 100644 --- a/src/proto_alpha/lib_delegate/delegate_commands.ml +++ b/src/proto_alpha/lib_delegate/delegate_commands.ml @@ -14,6 +14,13 @@ let group = { Clic.name = "delegate" ; title = "Commands related to delegate operations." } +let directory_parameter = + Clic.parameter (fun _ p -> + if not (Sys.file_exists p && Sys.is_directory p) then + failwith "Directory doesn't exist: '%s'" p + else + return p) + let delegate_commands () = let open Clic in [ @@ -57,9 +64,10 @@ let baker_commands () = command ~group ~desc: "Launch the baker daemon." (args1 max_priority_arg) (prefixes [ "launch" ; "with" ; "context" ] - @@ string - ~name:"Context path" - ~desc:"Path to the shell context" + @@ param + ~name:"context_path" + ~desc:"Path to the shell context (e.g. tezos-node.XXXXX/context/)" + directory_parameter @@ seq_of_param Client_keys.Public_key_hash.alias_param) (fun max_priority context_path delegates cctxt -> Client_daemon.Baker.run cctxt