diff --git a/src/proto_alpha/lib_protocol/bootstrap_storage.ml b/src/proto_alpha/lib_protocol/bootstrap_storage.ml index c17ba46ad3469979b4258cd168d700c3e5560725..97e1c516e6619fcde1d7bba11a9f60db352fc048 100644 --- a/src/proto_alpha/lib_protocol/bootstrap_storage.ml +++ b/src/proto_alpha/lib_protocol/bootstrap_storage.ml @@ -44,95 +44,108 @@ let () = let init_account (ctxt, balance_updates) ({public_key_hash; public_key; amount; delegate_to; consensus_key} : Parameters_repr.bootstrap_account) = + let open Lwt_result_syntax in let contract = Contract_repr.Implicit public_key_hash in - Token.transfer - ~origin:Protocol_migration - ctxt - `Bootstrap - (`Contract contract) - amount - >>=? fun (ctxt, new_balance_updates) -> - (match public_key with - | Some public_key -> ( - Contract_manager_storage.reveal_manager_key - ctxt - public_key_hash - public_key - >>=? fun ctxt -> - Delegate_storage.Contract.set - ctxt - contract - (Some (Option.value ~default:public_key_hash delegate_to)) - >>=? fun ctxt -> - (match consensus_key with - | None -> return ctxt - | Some consensus_key -> - Delegate_consensus_key.init ctxt public_key_hash consensus_key) - >>=? fun ctxt -> - match delegate_to with - | Some delegate - when Signature.Public_key_hash.(delegate <> public_key_hash) -> - return (ctxt, []) - | _ -> - (* Self-delegated => contract is a delegate. - Freeze the largest amount of tokens to avoid over-delegation - according to the [limit_of_delegation_over_baking]. - This is necessary so that the network (in tests too) starts with - accounts with baking rights. *) - let limit_of_delegation_over_baking = - Constants_storage.limit_of_delegation_over_baking ctxt - in - let amount_to_freeze = - let minimal_to_bake = - let minimal_stake = Constants_storage.minimal_stake ctxt in - let minimal_frozen_stake = - Constants_storage.minimal_frozen_stake ctxt - in - Tez_repr.max minimal_stake minimal_frozen_stake + let* ctxt, new_balance_updates = + Token.transfer + ~origin:Protocol_migration + ctxt + `Bootstrap + (`Contract contract) + amount + in + let+ ctxt, freeze_balance_updates = + match public_key with + | Some public_key -> ( + let* ctxt = + Contract_manager_storage.reveal_manager_key + ctxt + public_key_hash + public_key + in + let* ctxt = + Delegate_storage.Contract.set + ctxt + contract + (Some (Option.value ~default:public_key_hash delegate_to)) + in + let* ctxt = + match consensus_key with + | None -> return ctxt + | Some consensus_key -> + Delegate_consensus_key.init ctxt public_key_hash consensus_key + in + match delegate_to with + | Some delegate + when Signature.Public_key_hash.(delegate <> public_key_hash) -> + return (ctxt, []) + | _ -> + (* Self-delegated => contract is a delegate. + Freeze the largest amount of tokens to avoid over-delegation + according to the [limit_of_delegation_over_baking]. + This is necessary so that the network (in tests too) starts with + accounts with baking rights. *) + let limit_of_delegation_over_baking = + Constants_storage.limit_of_delegation_over_baking ctxt in - let minimal_to_not_be_overdelegated = - Tez_repr.div_exn amount (limit_of_delegation_over_baking + 1) + let amount_to_freeze = + let minimal_to_bake = + let minimal_stake = Constants_storage.minimal_stake ctxt in + let minimal_frozen_stake = + Constants_storage.minimal_frozen_stake ctxt + in + Tez_repr.max minimal_stake minimal_frozen_stake + in + let minimal_to_not_be_overdelegated = + Tez_repr.div_exn amount (limit_of_delegation_over_baking + 1) + in + Tez_repr.( + min amount (max minimal_to_bake minimal_to_not_be_overdelegated)) in - Tez_repr.( - min amount (max minimal_to_bake minimal_to_not_be_overdelegated)) - in - Token.transfer - ~origin:Protocol_migration - ctxt - (`Contract contract) - (`Frozen_deposits - (Stake_repr.Single - (Contract_repr.Implicit public_key_hash, public_key_hash))) - amount_to_freeze) - | None -> - fail_when - (Option.is_some delegate_to) - (Unrevealed_public_key public_key_hash) - >>=? fun () -> return (ctxt, [])) - >|=? fun (ctxt, freeze_balance_updates) -> + Token.transfer + ~origin:Protocol_migration + ctxt + (`Contract contract) + (`Frozen_deposits + (Stake_repr.Single + (Contract_repr.Implicit public_key_hash, public_key_hash))) + amount_to_freeze) + | None -> + let* () = + fail_when + (Option.is_some delegate_to) + (Unrevealed_public_key public_key_hash) + in + return (ctxt, []) + in (ctxt, freeze_balance_updates @ new_balance_updates @ balance_updates) let init_contract ~typecheck_smart_contract (ctxt, balance_updates) ({delegate; amount; script; hash} : Parameters_repr.bootstrap_contract) = - (match hash with - | None -> Contract_storage.fresh_contract_from_current_nonce ctxt - | Some hash -> Result.return (ctxt, hash)) - >>?= fun (ctxt, contract_hash) -> - typecheck_smart_contract ctxt script >>=? fun (script, ctxt) -> - Contract_storage.raw_originate - ctxt - ~prepaid_bootstrap_storage:true - contract_hash - ~script - >>=? fun ctxt -> + let open Lwt_result_syntax in + let*? ctxt, contract_hash = + match hash with + | None -> Contract_storage.fresh_contract_from_current_nonce ctxt + | Some hash -> Result.return (ctxt, hash) + in + let* script, ctxt = typecheck_smart_contract ctxt script in + let* ctxt = + Contract_storage.raw_originate + ctxt + ~prepaid_bootstrap_storage:true + contract_hash + ~script + in let contract = Contract_repr.Originated contract_hash in - (match delegate with - | None -> return ctxt - | Some delegate -> Delegate_storage.Contract.init ctxt contract delegate) - >>=? fun ctxt -> + let* ctxt = + match delegate with + | None -> return ctxt + | Some delegate -> Delegate_storage.Contract.init ctxt contract delegate + in let origin = Receipt_repr.Protocol_migration in - Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount - >|=? fun (ctxt, new_balance_updates) -> + let+ ctxt, new_balance_updates = + Token.transfer ~origin ctxt `Bootstrap (`Contract contract) amount + in (ctxt, new_balance_updates @ balance_updates) let init_smart_rollup ~typecheck_smart_rollup ctxt @@ -172,63 +185,74 @@ let init_smart_rollup ~typecheck_smart_rollup ctxt let init ctxt ~typecheck_smart_contract ~typecheck_smart_rollup ?no_reward_cycles accounts contracts smart_rollups = + let open Lwt_result_syntax in let nonce = Operation_hash.hash_string ["Un festival de GADT."] in let ctxt = Raw_context.init_origination_nonce ctxt nonce in - List.fold_left_es init_account (ctxt, []) accounts - >>=? fun (ctxt, balance_updates) -> - List.fold_left_es - (init_contract ~typecheck_smart_contract) - (ctxt, balance_updates) - contracts - >>=? fun (ctxt, balance_updates) -> - List.fold_left_es - (init_smart_rollup ~typecheck_smart_rollup) - ctxt - smart_rollups - >>=? fun ctxt -> - (match no_reward_cycles with - | None -> return ctxt - | Some cycles -> - (* Store pending ramp ups. *) - let constants = Raw_context.constants ctxt in - (* Start without rewards *) - Raw_context.patch_constants ctxt (fun c -> - { - c with - issuance_weights = + let* ctxt, balance_updates = + List.fold_left_es init_account (ctxt, []) accounts + in + let* ctxt, balance_updates = + List.fold_left_es + (init_contract ~typecheck_smart_contract) + (ctxt, balance_updates) + contracts + in + let* ctxt = + List.fold_left_es + (init_smart_rollup ~typecheck_smart_rollup) + ctxt + smart_rollups + in + let+ ctxt = + match no_reward_cycles with + | None -> return ctxt + | Some cycles -> + (* Store pending ramp ups. *) + let constants = Raw_context.constants ctxt in + (* Start without rewards *) + let*! ctxt = + Raw_context.patch_constants ctxt (fun c -> { - c.issuance_weights with - base_total_issued_per_minute = Tez_repr.zero; - }; - }) - >>= fun ctxt -> - (* Store the final reward. *) - Storage.Ramp_up.( - Rewards.init - ctxt - (Cycle_repr.of_int32_exn (Int32.of_int cycles)) - { - (* Hack: we store the rewards here *) - baking_reward_fixed_portion = - constants.issuance_weights.base_total_issued_per_minute; - baking_reward_bonus_per_slot = Tez_repr.zero; - attesting_reward_per_slot = Tez_repr.zero; - })) - >|=? fun ctxt -> (ctxt, balance_updates) + c with + issuance_weights = + { + c.issuance_weights with + base_total_issued_per_minute = Tez_repr.zero; + }; + }) + in + (* Store the final reward. *) + Storage.Ramp_up.( + Rewards.init + ctxt + (Cycle_repr.of_int32_exn (Int32.of_int cycles)) + { + (* Hack: we store the rewards here *) + baking_reward_fixed_portion = + constants.issuance_weights.base_total_issued_per_minute; + baking_reward_bonus_per_slot = Tez_repr.zero; + attesting_reward_per_slot = Tez_repr.zero; + }) + in + (ctxt, balance_updates) let cycle_end ctxt last_cycle = + let open Lwt_result_syntax in let next_cycle = Cycle_repr.succ last_cycle in - Storage.Ramp_up.Rewards.find ctxt next_cycle >>=? function + let* result = Storage.Ramp_up.Rewards.find ctxt next_cycle in + match result with | None -> return ctxt | Some Storage.Ramp_up.{baking_reward_fixed_portion; _} -> - Storage.Ramp_up.Rewards.remove_existing ctxt next_cycle >>=? fun ctxt -> - Raw_context.patch_constants ctxt (fun c -> - { - c with - issuance_weights = - { - c.issuance_weights with - base_total_issued_per_minute = baking_reward_fixed_portion; - }; - }) - >|= ok + let* ctxt = Storage.Ramp_up.Rewards.remove_existing ctxt next_cycle in + let*! ctxt = + Raw_context.patch_constants ctxt (fun c -> + { + c with + issuance_weights = + { + c.issuance_weights with + base_total_issued_per_minute = baking_reward_fixed_portion; + }; + }) + in + return ctxt diff --git a/src/proto_alpha/lib_protocol/commitment_storage.ml b/src/proto_alpha/lib_protocol/commitment_storage.ml index 272702a4ae6798fa43c38c045af1bfac659b6931..bd884edc870ba887275f118d1f2ea2ddba92b6ce 100644 --- a/src/proto_alpha/lib_protocol/commitment_storage.ml +++ b/src/proto_alpha/lib_protocol/commitment_storage.ml @@ -26,19 +26,26 @@ let exists = Storage.Commitments.mem let committed_amount ctxt bpkh = - Storage.Commitments.find ctxt bpkh >>=? fun balance -> - return (Option.value ~default:Tez_repr.zero balance) + let open Lwt_result_syntax in + let+ balance = Storage.Commitments.find ctxt bpkh in + Option.value ~default:Tez_repr.zero balance let increase_commitment_only_call_from_token ctxt bpkh amount = + let open Lwt_result_syntax in if Tez_repr.(amount = zero) then return ctxt else - committed_amount ctxt bpkh >>=? fun balance -> - Tez_repr.(amount +? balance) >>?= fun new_balance -> - Storage.Commitments.add ctxt bpkh new_balance >|= ok + let* balance = committed_amount ctxt bpkh in + let*? new_balance = Tez_repr.(amount +? balance) in + let*! result = Storage.Commitments.add ctxt bpkh new_balance in + return result let decrease_commitment_only_call_from_token ctxt bpkh amount = - committed_amount ctxt bpkh >>=? fun balance -> - Tez_repr.(balance -? amount) >>?= fun new_balance -> - if Tez_repr.(new_balance = Tez_repr.zero) then - Storage.Commitments.remove ctxt bpkh >|= ok - else Storage.Commitments.add ctxt bpkh new_balance >|= ok + let open Lwt_result_syntax in + let* balance = committed_amount ctxt bpkh in + let*? new_balance = Tez_repr.(balance -? amount) in + let*! result = + if Tez_repr.(new_balance = Tez_repr.zero) then + Storage.Commitments.remove ctxt bpkh + else Storage.Commitments.add ctxt bpkh new_balance + in + return result diff --git a/src/proto_alpha/lib_protocol/fees_storage.ml b/src/proto_alpha/lib_protocol/fees_storage.ml index 30c23caba88fc8d9457d7d6f13526f60704a0248..05d0a1121408902d8042ddccbcf89c2c2e83159d 100644 --- a/src/proto_alpha/lib_protocol/fees_storage.ml +++ b/src/proto_alpha/lib_protocol/fees_storage.ml @@ -79,14 +79,17 @@ let record_global_constant_storage_space context size = (context, to_be_paid) let record_paid_storage_space ctxt contract_hash = + let open Lwt_result_syntax in let contract = Contract_repr.Originated contract_hash in (* Get the new size of the contract's storage. *) - Contract_storage.used_storage_space ctxt contract >>=? fun new_storage_size -> - Contract_storage.set_paid_storage_space_and_return_fees_to_pay - ctxt - contract - new_storage_size - >>=? fun (to_be_paid, c) -> return (c, new_storage_size, to_be_paid) + let* new_storage_size = Contract_storage.used_storage_space ctxt contract in + let+ to_be_paid, c = + Contract_storage.set_paid_storage_space_and_return_fees_to_pay + ctxt + contract + new_storage_size + in + (c, new_storage_size, to_be_paid) let source_must_exist c src = match src with @@ -95,11 +98,12 @@ let source_must_exist c src = let burn_storage_fees ?(origin = Receipt_repr.Block_application) c ~storage_limit ~payer consumed = + let open Lwt_result_syntax in let remaining = Z.sub storage_limit consumed in if Compare.Z.(remaining < Z.zero) then tzfail Operation_quota_exceeded else let cost_per_byte = Constants_storage.cost_per_byte c in - Tez_repr.(cost_per_byte *? Z.to_int64 consumed) >>?= fun to_burn -> + let*? to_burn = Tez_repr.(cost_per_byte *? Z.to_int64 consumed) in (* Burning the fees... *) if Tez_repr.(to_burn = Tez_repr.zero) then (* If the payer was deleted by transferring all its balance, and no space @@ -108,22 +112,24 @@ let burn_storage_fees ?(origin = Receipt_repr.Block_application) c else trace Cannot_pay_storage_fee - ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn - >>=? fun (ctxt, balance_updates) -> - return (ctxt, remaining, balance_updates) ) + (let* () = source_must_exist c payer in + let+ ctxt, balance_updates = + Token.transfer ~origin c payer `Storage_fees to_burn + in + (ctxt, remaining, balance_updates)) let burn_storage_increase_fees ?(origin = Receipt_repr.Block_application) c ~payer amount_in_bytes = + let open Lwt_result_syntax in if Compare.Z.(amount_in_bytes <= Z.zero) then tzfail Negative_storage_input else let cost_per_byte = Constants_storage.cost_per_byte c in - Tez_repr.(cost_per_byte *? Z.to_int64 amount_in_bytes) >>?= fun to_burn -> + let*? to_burn = Tez_repr.(cost_per_byte *? Z.to_int64 amount_in_bytes) in (* Burning the fees... *) trace Cannot_pay_storage_fee - ( source_must_exist c payer >>=? fun () -> - Token.transfer ~origin c payer `Storage_fees to_burn ) + (let* () = source_must_exist c payer in + Token.transfer ~origin c payer `Storage_fees to_burn) let burn_origination_fees ?(origin = Receipt_repr.Block_application) c ~storage_limit ~payer = @@ -139,9 +145,10 @@ let burn_zk_rollup_origination_fees ?(origin = Receipt_repr.Block_application) c burn_storage_fees ~origin c ~storage_limit ~payer consumed let check_storage_limit c ~storage_limit = + let open Result_syntax in if Compare.Z.( storage_limit > (Raw_context.constants c).hard_storage_limit_per_operation) || Compare.Z.(storage_limit < Z.zero) - then error Storage_limit_too_high - else Result.return_unit + then tzfail Storage_limit_too_high + else return_unit diff --git a/src/proto_alpha/lib_protocol/global_constants_storage.ml b/src/proto_alpha/lib_protocol/global_constants_storage.ml index e34c04c0bb081fd03904e8dfd471126b81f17a53..a7da8fca876d90733150c8897624057f369e3b2a 100644 --- a/src/proto_alpha/lib_protocol/global_constants_storage.ml +++ b/src/proto_alpha/lib_protocol/global_constants_storage.ml @@ -138,18 +138,24 @@ let () = (fun () -> Expression_too_large) let get context hash = - Storage.Global_constants.Map.find context hash >>=? fun (context, value) -> + let open Lwt_result_syntax in + let* context, value = Storage.Global_constants.Map.find context hash in match value with | None -> tzfail Nonexistent_global | Some value -> return (context, value) let expr_to_address_in_context context expr = + let open Result_syntax in let lexpr = Script_repr.lazy_expr expr in - Raw_context.consume_gas context @@ Script_repr.force_bytes_cost lexpr - >>? fun context -> - Script_repr.force_bytes lexpr >>? fun b -> - Raw_context.consume_gas context @@ Gas_costs.expr_to_address_in_context_cost b - >|? fun context -> (context, Script_expr_hash.hash_bytes [b]) + let* context = + Raw_context.consume_gas context @@ Script_repr.force_bytes_cost lexpr + in + let* b = Script_repr.force_bytes lexpr in + let+ context = + Raw_context.consume_gas context + @@ Gas_costs.expr_to_address_in_context_cost b + in + (context, Script_expr_hash.hash_bytes [b]) let node_too_large node = let node_size = Script_repr.Micheline_size.of_node node in @@ -164,50 +170,60 @@ let expand_node context node = (* We charge for traversing the top-level node at the beginning. Inside the loop, we charge for traversing each new constant that gets expanded. *) - Raw_context.consume_gas - context - (Gas_costs.expand_no_constants_branch_cost node) - >>?= fun context -> - bottom_up_fold_cps - (* We carry a Boolean representing whether we - had to do any expansions or not. *) - (context, Expr_hash_map.empty, false) - node - (fun (context, _, did_expansion) node -> - return (context, node, did_expansion)) - (fun (context, map, did_expansion) node k -> - match node with - | Prim (_, H_constant, args, annot) -> ( - (* Charge for validating the b58check hash. *) - Raw_context.consume_gas context Gas_costs.expand_constants_branch_cost - >>?= fun context -> - match (args, annot) with - (* A constant Prim should always have a single String argument, - being a properly formatted hash. *) - | [String (_, address)], [] -> ( - match Script_expr_hash.of_b58check_opt address with - | None -> tzfail Badly_formed_constant_expression - | Some hash -> ( - match Expr_hash_map.find hash map with - | Some node -> - (* Charge traversing the newly retrieved node *) - Raw_context.consume_gas - context - (Gas_costs.expand_no_constants_branch_cost node) - >>?= fun context -> k (context, map, true) node - | None -> - get context hash >>=? fun (context, expr) -> - (* Charge traversing the newly retrieved node *) - let node = root expr in - Raw_context.consume_gas - context - (Gas_costs.expand_no_constants_branch_cost node) - >>?= fun context -> - k (context, Expr_hash_map.add hash node map, true) node)) - | _ -> tzfail Badly_formed_constant_expression) - | Int _ | String _ | Bytes _ | Prim _ | Seq _ -> - k (context, map, did_expansion) node) - >>=? fun (context, node, did_expansion) -> + let open Lwt_result_syntax in + let*? context = + Raw_context.consume_gas + context + (Gas_costs.expand_no_constants_branch_cost node) + in + let* context, node, did_expansion = + bottom_up_fold_cps + (* We carry a Boolean representing whether we + had to do any expansions or not. *) + (context, Expr_hash_map.empty, false) + node + (fun (context, _, did_expansion) node -> + return (context, node, did_expansion)) + (fun (context, map, did_expansion) node k -> + match node with + | Prim (_, H_constant, args, annot) -> ( + (* Charge for validating the b58check hash. *) + let*? context = + Raw_context.consume_gas + context + Gas_costs.expand_constants_branch_cost + in + match (args, annot) with + (* A constant Prim should always have a single String argument, + being a properly formatted hash. *) + | [String (_, address)], [] -> ( + match Script_expr_hash.of_b58check_opt address with + | None -> tzfail Badly_formed_constant_expression + | Some hash -> ( + match Expr_hash_map.find hash map with + | Some node -> + (* Charge traversing the newly retrieved node *) + let*? context = + Raw_context.consume_gas + context + (Gas_costs.expand_no_constants_branch_cost node) + in + k (context, map, true) node + | None -> + let* context, expr = get context hash in + (* Charge traversing the newly retrieved node *) + let node = root expr in + let*? context = + Raw_context.consume_gas + context + (Gas_costs.expand_no_constants_branch_cost node) + in + k (context, Expr_hash_map.add hash node map, true) node) + ) + | _ -> tzfail Badly_formed_constant_expression) + | Int _ | String _ | Bytes _ | Prim _ | Seq _ -> + k (context, map, did_expansion) node) + in if did_expansion then (* Gas charged during expansion is at least proportional to the size of the resulting node so the execution time of [node_too_large] is already @@ -217,7 +233,8 @@ let expand_node context node = else return (context, node) let expand context expr = - expand_node context (root expr) >|=? fun (context, node) -> + let open Lwt_result_syntax in + let+ context, node = expand_node context (root expr) in (context, strip_locations node) (** Computes the maximum depth of a Micheline node. Fails @@ -226,7 +243,7 @@ let expand context expr = let check_depth node = let rec advance node depth k = if Compare.Int.(depth > Constants_repr.max_allowed_global_constant_depth) - then error Expression_too_deep + then Result_syntax.tzfail Expression_too_deep else match node with | Int _ | String _ | Bytes _ | Prim (_, _, [], _) | Seq (_, []) -> @@ -249,16 +266,19 @@ let register context value = Though the stored expression is the unexpanded version. *) - expand_node context (root value) >>=? fun (context, node) -> + let open Lwt_result_syntax in + let* context, node = expand_node context (root value) in (* We do not need to carbonate [check_depth]. [expand_node] and [Storage.Global_constants.Map.init] are already carbonated with gas at least proportional to the size of the expanded node and the computation cost of [check_depth] is of the same order. *) - check_depth node >>?= fun (_depth : int) -> - expr_to_address_in_context context value >>?= fun (context, key) -> - trace Expression_already_registered - @@ Storage.Global_constants.Map.init context key value - >|=? fun (context, size) -> (context, key, Z.of_int size) + let*? (_depth : int) = check_depth node in + let*? context, key = expr_to_address_in_context context value in + let+ context, size = + trace Expression_already_registered + @@ Storage.Global_constants.Map.init context key value + in + (context, key, Z.of_int size) module Internal_for_tests = struct let node_too_large = node_too_large diff --git a/src/proto_alpha/lib_protocol/init_storage.ml b/src/proto_alpha/lib_protocol/init_storage.ml index 5bf24654482761a804a1bebfaef2a2b23ff4793a..27d7e71e24324d09b7a59ad4be9fd35847068f76 100644 --- a/src/proto_alpha/lib_protocol/init_storage.ml +++ b/src/proto_alpha/lib_protocol/init_storage.ml @@ -37,19 +37,20 @@ *) let invoice_contract ctxt ~address ~amount_mutez = + let open Lwt_result_syntax in match Tez_repr.of_mutez amount_mutez with | None -> Lwt.return (ctxt, []) | Some amount -> ( - ( Contract_repr.of_b58check address >>?= fun recipient -> + let*! result = + let*? recipient = Contract_repr.of_b58check address in Token.transfer ~origin:Protocol_migration ctxt `Invoice (`Contract recipient) - amount ) - >|= function - | Ok res -> res - | Error _ -> (ctxt, [])) + amount + in + Lwt.return @@ match result with Ok res -> res | Error _ -> (ctxt, [])) *) (* @@ -60,8 +61,9 @@ let invoice_contract ctxt ~address ~amount_mutez = *) let patch_script ctxt (address, hash, patched_code) = - Contract_repr.of_b58check address >>?= fun contract -> - Storage.Contract.Code.find ctxt contract >>=? fun (ctxt, code_opt) -> + let open Lwt_result_syntax in + let*? contract = Contract_repr.of_b58check address in + let* ctxt, code_opt = Storage.Contract.Code.find ctxt contract in Logging.log Notice "Patching %s... " address ; match code_opt with | Some old_code -> @@ -69,18 +71,22 @@ let patch_script ctxt (address, hash, patched_code) = let old_hash = Script_expr_hash.hash_bytes [old_bin] in if Script_expr_hash.equal old_hash hash then ( let new_code = Script_repr.lazy_expr patched_code in - Storage.Contract.Code.update ctxt contract new_code - >>=? fun (ctxt, size_diff) -> + let* ctxt, size_diff = + Storage.Contract.Code.update ctxt contract new_code + in Logging.log Notice "Contract %s successfully patched" address ; let size_diff = Z.of_int size_diff in - Storage.Contract.Used_storage_space.get ctxt contract - >>=? fun prev_size -> + let* prev_size = + Storage.Contract.Used_storage_space.get ctxt contract + in let new_size = Z.add prev_size size_diff in - Storage.Contract.Used_storage_space.update ctxt contract new_size - >>=? fun ctxt -> + let* ctxt = + Storage.Contract.Used_storage_space.update ctxt contract new_size + in if Z.(gt size_diff zero) then - Storage.Contract.Paid_storage_space.get ctxt contract - >>=? fun prev_paid_size -> + let* prev_paid_size = + Storage.Contract.Paid_storage_space.get ctxt contract + in let paid_size = Z.add prev_paid_size size_diff in Storage.Contract.Paid_storage_space.update ctxt contract paid_size else return ctxt) @@ -105,92 +111,119 @@ let patch_script ctxt (address, hash, patched_code) = let prepare_first_block chain_id ctxt ~typecheck_smart_contract ~typecheck_smart_rollup ~level ~timestamp ~predecessor = - Raw_context.prepare_first_block ~level ~timestamp chain_id ctxt - >>=? fun (previous_protocol, ctxt) -> + let open Lwt_result_syntax in + let* previous_protocol, ctxt = + Raw_context.prepare_first_block ~level ~timestamp chain_id ctxt + in let parametric = Raw_context.constants ctxt in - ( Raw_context.Cache.set_cache_layout - ctxt - (Constants_repr.cache_layout parametric) - >|= fun ctxt -> Raw_context.Cache.clear ctxt ) - >>= fun ctxt -> - (match previous_protocol with - | Genesis param -> - (* This is the genesis protocol: initialise the state *) - Raw_level_repr.of_int32 level >>?= fun level -> - Storage.Tenderbake.First_level_of_protocol.init ctxt level - >>=? fun ctxt -> - Storage.Tenderbake.Forbidden_delegates.init - ctxt - Signature.Public_key_hash.Set.empty - >>=? fun ctxt -> - Storage.Contract.Total_supply.add ctxt Tez_repr.zero >>= fun ctxt -> - Storage.Block_round.init ctxt Round_repr.zero >>=? fun ctxt -> - let init_commitment (ctxt, balance_updates) - Commitment_repr.{blinded_public_key_hash; amount} = - Token.transfer - ctxt - `Initial_commitments - (`Collected_commitments blinded_public_key_hash) - amount - >>=? fun (ctxt, new_balance_updates) -> - return (ctxt, new_balance_updates @ balance_updates) - in - List.fold_left_es init_commitment (ctxt, []) param.commitments - >>=? fun (ctxt, commitments_balance_updates) -> - Storage.Stake.Last_snapshot.init ctxt 0 >>=? fun ctxt -> - Seed_storage.init ?initial_seed:param.constants.initial_seed ctxt - >>=? fun ctxt -> - Contract_storage.init ctxt >>=? fun ctxt -> - Bootstrap_storage.init + let*! ctxt = + let*! ctxt = + Raw_context.Cache.set_cache_layout ctxt - ~typecheck_smart_contract - ~typecheck_smart_rollup - ?no_reward_cycles:param.no_reward_cycles - param.bootstrap_accounts - param.bootstrap_contracts - param.bootstrap_smart_rollups - >>=? fun (ctxt, bootstrap_balance_updates) -> - Delegate_cycles.init_first_cycles ctxt >>=? fun ctxt -> - Vote_storage.init - ctxt - ~start_position:(Level_storage.current ctxt).level_position - >>=? fun ctxt -> - Vote_storage.update_listings ctxt >>=? fun ctxt -> - (* Must be called after other originations since it unsets the origination nonce. *) - Liquidity_baking_migration.init ctxt ~typecheck:typecheck_smart_contract - >>=? fun (ctxt, operation_results) -> - Storage.Pending_migration.Operation_results.init ctxt operation_results - >>=? fun ctxt -> - Sc_rollup_inbox_storage.init_inbox ~predecessor ctxt >>=? fun ctxt -> - Adaptive_issuance_storage.init ctxt >>=? fun ctxt -> - return (ctxt, commitments_balance_updates @ bootstrap_balance_updates) - | Oxford_018 - (* Please update [next_protocol] and [previous_protocol] in - [tezt/lib_tezos/protocol.ml] when you update this value. *) -> - (* TODO (#2704): possibly handle attestations for migration block (in bakers); - if that is done, do not set Storage.Tenderbake.First_level_of_protocol. - /!\ this storage is also use to add the smart rollup - inbox migration message. see `sc_rollup_inbox_storage`. *) - Raw_level_repr.of_int32 level >>?= fun level -> - Storage.Tenderbake.First_level_of_protocol.update ctxt level - >>=? fun ctxt -> - (* Migration of refutation games needs to be kept for each protocol. *) - Sc_rollup_refutation_storage.migrate_clean_refutation_games ctxt - >>=? fun ctxt -> return (ctxt, [])) - >>=? fun (ctxt, balance_updates) -> - List.fold_left_es patch_script ctxt Legacy_script_patches.addresses_to_patch - >>=? fun ctxt -> - Receipt_repr.group_balance_updates balance_updates >>?= fun balance_updates -> - Storage.Pending_migration.Balance_updates.add ctxt balance_updates - >>= fun ctxt -> return ctxt + (Constants_repr.cache_layout parametric) + in + Lwt.return (Raw_context.Cache.clear ctxt) + in + let* ctxt, balance_updates = + match previous_protocol with + | Genesis param -> + (* This is the genesis protocol: initialise the state *) + let*? level = Raw_level_repr.of_int32 level in + let* ctxt = + Storage.Tenderbake.First_level_of_protocol.init ctxt level + in + let* ctxt = + Storage.Tenderbake.Forbidden_delegates.init + ctxt + Signature.Public_key_hash.Set.empty + in + let*! ctxt = Storage.Contract.Total_supply.add ctxt Tez_repr.zero in + let* ctxt = Storage.Block_round.init ctxt Round_repr.zero in + let init_commitment (ctxt, balance_updates) + Commitment_repr.{blinded_public_key_hash; amount} = + let* ctxt, new_balance_updates = + Token.transfer + ctxt + `Initial_commitments + (`Collected_commitments blinded_public_key_hash) + amount + in + return (ctxt, new_balance_updates @ balance_updates) + in + let* ctxt, commitments_balance_updates = + List.fold_left_es init_commitment (ctxt, []) param.commitments + in + let* ctxt = Storage.Stake.Last_snapshot.init ctxt 0 in + let* ctxt = + Seed_storage.init ?initial_seed:param.constants.initial_seed ctxt + in + let* ctxt = Contract_storage.init ctxt in + let* ctxt, bootstrap_balance_updates = + Bootstrap_storage.init + ctxt + ~typecheck_smart_contract + ~typecheck_smart_rollup + ?no_reward_cycles:param.no_reward_cycles + param.bootstrap_accounts + param.bootstrap_contracts + param.bootstrap_smart_rollups + in + let* ctxt = Delegate_cycles.init_first_cycles ctxt in + let* ctxt = + Vote_storage.init + ctxt + ~start_position:(Level_storage.current ctxt).level_position + in + let* ctxt = Vote_storage.update_listings ctxt in + (* Must be called after other originations since it unsets the origination nonce. *) + let* ctxt, operation_results = + Liquidity_baking_migration.init + ctxt + ~typecheck:typecheck_smart_contract + in + let* ctxt = + Storage.Pending_migration.Operation_results.init + ctxt + operation_results + in + let* ctxt = Sc_rollup_inbox_storage.init_inbox ~predecessor ctxt in + let* ctxt = Adaptive_issuance_storage.init ctxt in + return (ctxt, commitments_balance_updates @ bootstrap_balance_updates) + | Oxford_018 + (* Please update [next_protocol] and [previous_protocol] in + [tezt/lib_tezos/protocol.ml] when you update this value. *) -> + (* TODO (#2704): possibly handle attestations for migration block (in bakers); + if that is done, do not set Storage.Tenderbake.First_level_of_protocol. + /!\ this storage is also use to add the smart rollup + inbox migration message. see `sc_rollup_inbox_storage`. *) + let*? level = Raw_level_repr.of_int32 level in + let* ctxt = + Storage.Tenderbake.First_level_of_protocol.update ctxt level + in + (* Migration of refutation games needs to be kept for each protocol. *) + let* ctxt = + Sc_rollup_refutation_storage.migrate_clean_refutation_games ctxt + in + return (ctxt, []) + in + let* ctxt = + List.fold_left_es patch_script ctxt Legacy_script_patches.addresses_to_patch + in + let*? balance_updates = Receipt_repr.group_balance_updates balance_updates in + let*! ctxt = + Storage.Pending_migration.Balance_updates.add ctxt balance_updates + in + return ctxt let prepare ctxt ~level ~predecessor_timestamp ~timestamp = - Raw_context.prepare - ~level - ~predecessor_timestamp - ~timestamp - ~adaptive_issuance_enable:false - ctxt - >>=? fun ctxt -> - Adaptive_issuance_storage.set_adaptive_issuance_enable ctxt >>=? fun ctxt -> + let open Lwt_result_syntax in + let* ctxt = + Raw_context.prepare + ~level + ~predecessor_timestamp + ~timestamp + ~adaptive_issuance_enable:false + ctxt + in + let* ctxt = Adaptive_issuance_storage.set_adaptive_issuance_enable ctxt in Storage.Pending_migration.remove ctxt diff --git a/src/proto_alpha/lib_protocol/nonce_storage.ml b/src/proto_alpha/lib_protocol/nonce_storage.ml index feb0b2edebf68804a58161abe2f5e852ea7b5c53..5d372183dc81a98fe7fa4d35372f8c668ad0c3b2 100644 --- a/src/proto_alpha/lib_protocol/nonce_storage.ml +++ b/src/proto_alpha/lib_protocol/nonce_storage.ml @@ -84,6 +84,7 @@ let () = current context and that a nonce has not been already revealed for that level. Also checks that we are not past the nonce revelation period. *) let get_unrevealed ctxt (level : Level_repr.t) = + let open Lwt_result_syntax in let current_level = Level_storage.current ctxt in match Cycle_repr.pred current_level.cycle with | None -> tzfail Too_early_revelation (* no revelations during cycle 0 *) @@ -97,7 +98,8 @@ let get_unrevealed ctxt (level : Level_repr.t) = >= Constants_storage.nonce_revelation_threshold ctxt) then tzfail Too_late_revelation else - Storage.Seed.Nonce.get ctxt level >>=? function + let* status = Storage.Seed.Nonce.get ctxt level in + match status with | Revealed _ -> tzfail Already_revealed_nonce | Unrevealed status -> return status) @@ -106,7 +108,8 @@ let record_hash ctxt unrevealed = Storage.Seed.Nonce.init ctxt level (Unrevealed unrevealed) let check_unrevealed ctxt (level : Level_repr.t) nonce = - get_unrevealed ctxt level >>=? fun unrevealed -> + let open Lwt_result_syntax in + let* unrevealed = get_unrevealed ctxt level in fail_unless (Seed_repr.check_hash nonce unrevealed.nonce_hash) Inconsistent_nonce @@ -128,9 +131,11 @@ let get = Storage.Seed.Nonce.get type nonce_presence = No_nonce_expected | Nonce_expected of status let check ctxt level = - Storage.Seed.Nonce.find ctxt level >>=? function - | None -> return No_nonce_expected - | Some status -> return (Nonce_expected status) + let open Lwt_result_syntax in + let+ status_opt = Storage.Seed.Nonce.find ctxt level in + match status_opt with + | None -> No_nonce_expected + | Some status -> Nonce_expected status let of_bytes = Seed_repr.make_nonce diff --git a/src/proto_alpha/lib_protocol/stake_storage.ml b/src/proto_alpha/lib_protocol/stake_storage.ml index 0890e6b8f6338d2a6abb78b83abc127d020666fd..97a3f1ceda559740d72bab1ee37177cdf1c31d5b 100644 --- a/src/proto_alpha/lib_protocol/stake_storage.ml +++ b/src/proto_alpha/lib_protocol/stake_storage.ml @@ -41,27 +41,35 @@ module Selected_distribution_for_cycle = struct let identifier_of_cycle cycle = Format.asprintf "%a" Cycle_repr.pp cycle let init ctxt cycle stakes = + let open Lwt_result_syntax in let id = identifier_of_cycle cycle in - Storage.Stake.Selected_distribution_for_cycle.init ctxt cycle stakes - >>=? fun ctxt -> + let* ctxt = + Storage.Stake.Selected_distribution_for_cycle.init ctxt cycle stakes + in let size = 1 (* that's symbolic: 1 cycle = 1 entry *) in - Cache.update ctxt id (Some (stakes, size)) >>?= fun ctxt -> return ctxt + let*? ctxt = Cache.update ctxt id (Some (stakes, size)) in + return ctxt let get ctxt cycle = + let open Lwt_result_syntax in let id = identifier_of_cycle cycle in - Cache.find ctxt id >>=? function + let* value_opt = Cache.find ctxt id in + match value_opt with | None -> Storage.Stake.Selected_distribution_for_cycle.get ctxt cycle | Some v -> return v let find ctxt cycle = + let open Lwt_result_syntax in let id = identifier_of_cycle cycle in - Cache.find ctxt id >>=? function + let* value_opt = Cache.find ctxt id in + match value_opt with | None -> Storage.Stake.Selected_distribution_for_cycle.find ctxt cycle | Some _ as some_v -> return some_v let remove_existing ctxt cycle = + let open Lwt_result_syntax in let id = identifier_of_cycle cycle in - Cache.update ctxt id None >>?= fun ctxt -> + let*? ctxt = Cache.update ctxt id None in Storage.Stake.Selected_distribution_for_cycle.remove_existing ctxt cycle end @@ -71,11 +79,13 @@ let get_full_staking_balance ctxt delegate = Option.value staking_balance_opt ~default:Stake_repr.Full.zero let get_initialized_stake ctxt delegate = - Storage.Stake.Staking_balance.find ctxt delegate >>=? function + let open Lwt_result_syntax in + let* balance_opt = Storage.Stake.Staking_balance.find ctxt delegate in + match balance_opt with | Some staking_balance -> return (staking_balance, ctxt) | None -> let balance = Stake_repr.Full.zero in - Storage.Stake.Staking_balance.init ctxt delegate balance >>=? fun ctxt -> + let* ctxt = Storage.Stake.Staking_balance.init ctxt delegate balance in return (balance, ctxt) let has_minimal_stake ctxt @@ -96,10 +106,12 @@ let has_minimal_stake ctxt | Ok staking_balance -> Tez_repr.(staking_balance >= minimal_stake) let update_stake ~f ctxt delegate = - get_initialized_stake ctxt delegate >>=? fun (staking_balance_before, ctxt) -> - f staking_balance_before >>?= fun staking_balance -> - Storage.Stake.Staking_balance.update ctxt delegate staking_balance - >>=? fun ctxt -> + let open Lwt_result_syntax in + let* staking_balance_before, ctxt = get_initialized_stake ctxt delegate in + let*? staking_balance = f staking_balance_before in + let* ctxt = + Storage.Stake.Staking_balance.update ctxt delegate staking_balance + in (* Since the staking balance has changed, the delegate might have moved across the minimal stake barrier. If so we may need to update the set of active delegates with minimal stake. *) @@ -110,24 +122,28 @@ let update_stake ~f ctxt delegate = match (had_minimal_stake_before, has_minimal_stake_after) with | true, false -> (* Decrease below the minimal stake. *) - Delegate_activation_storage.is_inactive ctxt delegate >>=? fun inactive -> + let* inactive = Delegate_activation_storage.is_inactive ctxt delegate in if inactive then (* The delegate is inactive so it wasn't in the set and we don't need to update it. *) return ctxt else - Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate - >>= fun ctxt -> return ctxt + let*! ctxt = + Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate + in + return ctxt | false, true -> (* Increase above the minimal stake. *) - Delegate_activation_storage.is_inactive ctxt delegate >>=? fun inactive -> + let* inactive = Delegate_activation_storage.is_inactive ctxt delegate in if inactive then (* The delegate is inactive so we don't need to add it to the set. *) return ctxt else - Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate () - >>= fun ctxt -> return ctxt + let*! ctxt = + Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate () + in + return ctxt | false, false | true, true -> return ctxt let remove_delegated_stake ctxt delegate amount = @@ -222,59 +238,73 @@ let add_frozen_stake ctxt staker amount = | Shared delegate -> add_shared_frozen_stake ctxt delegate amount let set_inactive ctxt delegate = - Delegate_activation_storage.set_inactive ctxt delegate >>= fun ctxt -> + let open Lwt_syntax in + let* ctxt = Delegate_activation_storage.set_inactive ctxt delegate in Storage.Stake.Active_delegates_with_minimal_stake.remove ctxt delegate let set_active ctxt delegate = - Delegate_activation_storage.set_active ctxt delegate - >>=? fun (ctxt, inactive) -> + let open Lwt_result_syntax in + let* ctxt, inactive = Delegate_activation_storage.set_active ctxt delegate in if not inactive then return ctxt else - get_initialized_stake ctxt delegate >>=? fun (staking_balance, ctxt) -> + let* staking_balance, ctxt = get_initialized_stake ctxt delegate in if has_minimal_stake ctxt staking_balance then - Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate () - >>= fun ctxt -> return ctxt + let*! ctxt = + Storage.Stake.Active_delegates_with_minimal_stake.add ctxt delegate () + in + return ctxt else return ctxt let snapshot ctxt = - Storage.Stake.Last_snapshot.get ctxt >>=? fun index -> - Storage.Stake.Last_snapshot.update ctxt (index + 1) >>=? fun ctxt -> - Storage.Stake.Staking_balance.snapshot ctxt index >>=? fun ctxt -> + let open Lwt_result_syntax in + let* index = Storage.Stake.Last_snapshot.get ctxt in + let* ctxt = Storage.Stake.Last_snapshot.update ctxt (index + 1) in + let* ctxt = Storage.Stake.Staking_balance.snapshot ctxt index in Storage.Stake.Active_delegates_with_minimal_stake.snapshot ctxt index let max_snapshot_index = Storage.Stake.Last_snapshot.get let set_selected_distribution_for_cycle ctxt cycle stakes total_stake = + let open Lwt_result_syntax in let stakes = List.sort (fun (_, x) (_, y) -> Stake_context.compare ctxt y x) stakes in - Selected_distribution_for_cycle.init ctxt cycle stakes >>=? fun ctxt -> - Storage.Stake.Total_active_stake.add ctxt cycle total_stake >>= fun ctxt -> + let* ctxt = Selected_distribution_for_cycle.init ctxt cycle stakes in + let*! ctxt = Storage.Stake.Total_active_stake.add ctxt cycle total_stake in (* cleanup snapshots *) - Storage.Stake.Staking_balance.Snapshot.clear ctxt >>= fun ctxt -> - Storage.Stake.Active_delegates_with_minimal_stake.Snapshot.clear ctxt - >>= fun ctxt -> Storage.Stake.Last_snapshot.update ctxt 0 + let*! ctxt = Storage.Stake.Staking_balance.Snapshot.clear ctxt in + let*! ctxt = + Storage.Stake.Active_delegates_with_minimal_stake.Snapshot.clear ctxt + in + Storage.Stake.Last_snapshot.update ctxt 0 let clear_cycle ctxt cycle = - Storage.Stake.Total_active_stake.remove_existing ctxt cycle >>=? fun ctxt -> + let open Lwt_result_syntax in + let* ctxt = Storage.Stake.Total_active_stake.remove_existing ctxt cycle in Selected_distribution_for_cycle.remove_existing ctxt cycle let fold ctxt ~f ~order init = + let open Lwt_result_syntax in Storage.Stake.Active_delegates_with_minimal_stake.fold ctxt ~order ~init:(Ok init) - ~f:(fun delegate () acc -> acc >>?= fun acc -> f delegate acc) + ~f:(fun delegate () acc -> + let*? acc in + f delegate acc) let fold_snapshot ctxt ~index ~f ~init = + let open Lwt_result_syntax in Storage.Stake.Active_delegates_with_minimal_stake.fold_snapshot ctxt index ~order:`Sorted ~init ~f:(fun delegate () acc -> - Storage.Stake.Staking_balance.Snapshot.get ctxt (index, delegate) - >>=? fun stake -> f (delegate, stake) acc) + let* stake = + Storage.Stake.Staking_balance.Snapshot.get ctxt (index, delegate) + in + f (delegate, stake) acc) let clear_at_cycle_end ctxt ~new_cycle = let max_slashing_period = Constants_storage.max_slashing_period ctxt in @@ -290,8 +320,9 @@ let get_selected_distribution = Selected_distribution_for_cycle.get let find_selected_distribution = Selected_distribution_for_cycle.find let prepare_stake_distribution ctxt = + let open Lwt_result_syntax in let level = Level_storage.current ctxt in - Selected_distribution_for_cycle.get ctxt level.cycle >>=? fun stakes -> + let* stakes = Selected_distribution_for_cycle.get ctxt level.cycle in let stake_distribution = List.fold_left (fun map (pkh, stake) -> Signature.Public_key_hash.Map.add pkh stake map) @@ -306,12 +337,16 @@ let prepare_stake_distribution ctxt = let get_total_active_stake = Storage.Stake.Total_active_stake.get let remove_contract_delegated_stake ctxt contract amount = - Contract_delegate_storage.find ctxt contract >>=? function + let open Lwt_result_syntax in + let* delegate_opt = Contract_delegate_storage.find ctxt contract in + match delegate_opt with | None -> return ctxt | Some delegate -> remove_delegated_stake ctxt delegate amount let add_contract_delegated_stake ctxt contract amount = - Contract_delegate_storage.find ctxt contract >>=? function + let open Lwt_result_syntax in + let* delegate_opt = Contract_delegate_storage.find ctxt contract in + match delegate_opt with | None -> return ctxt | Some delegate -> add_delegated_stake ctxt delegate amount @@ -328,8 +363,11 @@ end module Internal_for_tests = struct let get ctxt delegate = - Storage.Stake.Active_delegates_with_minimal_stake.mem ctxt delegate - >>= function + let open Lwt_result_syntax in + let*! result = + Storage.Stake.Active_delegates_with_minimal_stake.mem ctxt delegate + in + match result with | true -> For_RPC.get_staking_balance ctxt delegate | false -> return Tez_repr.zero end