From d6b347f22889d4eb0c22e441c0ba302ae77d900f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 11 Aug 2022 18:14:08 +0200 Subject: [PATCH 1/2] Alpha/Client-commands: convert to `let*` syntax --- manifest/main.ml | 10 +- .../client_proto_context_commands.ml | 2488 +++++++++-------- .../client_proto_contracts_commands.ml | 39 +- .../client_proto_fa12_commands.ml | 444 +-- .../client_proto_mockup_commands.ml | 31 +- .../client_proto_multisig_commands.ml | 786 +++--- .../client_proto_programs_commands.ml | 838 +++--- .../client_proto_stresstest_commands.ml | 668 +++-- .../client_proto_stresstest_contracts.ml | 92 +- .../client_proto_utils_commands.ml | 73 +- src/proto_alpha/lib_client_commands/dune | 2 - 11 files changed, 3050 insertions(+), 2421 deletions(-) diff --git a/manifest/main.ml b/manifest/main.ml index 098e9d300992..5c4d4f5eff58 100644 --- a/manifest/main.ml +++ b/manifest/main.ml @@ -4074,8 +4074,11 @@ module Protocol = Protocol ~path:(path // "lib_client_commands") ~deps: [ - octez_base |> open_ ~m:"TzPervasives" + octez_base + |> if_ N.(number <= 14) + |> open_ ~m:"TzPervasives" |> open_ ~m:"TzPervasives.Error_monad.Legacy_monad_globals"; + octez_base |> if_ N.(number >= 15) |> open_ ~m:"TzPervasives"; main |> open_; parameters |> if_some |> if_ N.(number >= 013) |> open_; octez_stdlib_unix |> open_; @@ -4126,8 +4129,11 @@ module Protocol = Protocol ~opam:(sf "tezos-client-%s" name_dash) ~deps: [ - octez_base |> open_ ~m:"TzPervasives" + octez_base + |> if_ N.(number <= 14) + |> open_ ~m:"TzPervasives" |> open_ ~m:"TzPervasives.Error_monad.Legacy_monad_globals"; + octez_base |> if_ N.(number >= 15) |> open_ ~m:"TzPervasives"; main |> open_; parameters |> if_some |> if_ N.(number >= 013) |> open_; octez_protocol_environment; diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index b1dc3001f43b..ee20652e495e 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -34,8 +34,9 @@ open Client_keys open Client_proto_args let save_tx_rollup ~force (cctxt : #Client_context.full) alias_name tx_rollup = - TxRollupAlias.add ~force cctxt alias_name tx_rollup >>=? fun () -> - cctxt#message "Transaction rollup memorized as %s" alias_name >>= fun () -> + let open Lwt_result_syntax in + let* () = TxRollupAlias.add ~force cctxt alias_name tx_rollup in + let*! () = cctxt#message "Transaction rollup memorized as %s" alias_name in return_unit let encrypted_switch = @@ -50,29 +51,34 @@ let normalize_types_switch = () let report_michelson_errors ?(no_print_source = false) ~msg - (cctxt : #Client_context.full) = function + (cctxt : #Client_context.full) = + let open Lwt_syntax in + function | Error errs -> - Michelson_v1_error_reporter.enrich_runtime_errors - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~parsed:None - errs - >>= fun errs -> - cctxt#warning - "%a" - (Michelson_v1_error_reporter.report_errors - ~details:(not no_print_source) - ~show_source:(not no_print_source) - ?parsed:None) - errs - >>= fun () -> - cctxt#error "%s" msg >>= fun () -> Lwt.return_none - | Ok data -> Lwt.return_some data + let* errs = + Michelson_v1_error_reporter.enrich_runtime_errors + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~parsed:None + errs + in + let* () = + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:(not no_print_source) + ~show_source:(not no_print_source) + ?parsed:None) + errs + in + let* () = cctxt#error "%s" msg in + return_none + | Ok data -> return_some data let block_hash_param = Clic.parameter (fun _ s -> - try return (Block_hash.of_b58check_exn s) + try Lwt_result_syntax.return (Block_hash.of_b58check_exn s) with _ -> failwith "Parameter '%s' is an invalid block hash" s) let group = @@ -87,6 +93,7 @@ let binary_description = {Clic.name = "description"; title = "Binary Description"} let tez_of_string_exn index field s = + let open Lwt_result_syntax in match Tez.of_string s with | Some t -> return t | None -> @@ -97,9 +104,12 @@ let tez_of_string_exn index field s = s let tez_of_opt_string_exn index field s = + let open Lwt_result_syntax in match s with - | None -> return None - | Some s -> tez_of_string_exn index field s >>=? fun s -> return (Some s) + | None -> return_none + | Some s -> + let* s = tez_of_string_exn index field s in + return_some s let commands_ro () = let open Clic in @@ -111,39 +121,51 @@ let commands_ro () = (switch ~doc:"output time in seconds" ~short:'s' ~long:"seconds" ())) (fixed ["get"; "timestamp"]) (fun seconds (cctxt : Protocol_client_context.full) -> - Shell_services.Blocks.Header.shell_header - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - () - >>=? fun {timestamp = v; _} -> - (if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) - else cctxt#message "%s" (Time.Protocol.to_notation v)) - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* {timestamp = v; _} = + Shell_services.Blocks.Header.shell_header + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + () + in + let*! () = + if seconds then cctxt#message "%Ld" (Time.Protocol.to_seconds v) + else cctxt#message "%s" (Time.Protocol.to_notation v) + in + return_unit); command ~group ~desc:"Lists all non empty contracts of the block." no_options (fixed ["list"; "contracts"]) (fun () (cctxt : Protocol_client_context.full) -> - list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block - >>=? fun contracts -> - List.iter_s - (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) - contracts - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* contracts = + list_contract_labels cctxt ~chain:cctxt#chain ~block:cctxt#block + in + let*! () = + List.iter_s + (fun (alias, hash, kind) -> cctxt#message "%s%s%s" hash kind alias) + contracts + in + return_unit); command ~group ~desc:"Lists cached contracts and their age in LRU ordering." no_options (prefixes ["list"; "cached"; "contracts"] @@ stop) (fun () (cctxt : Protocol_client_context.full) -> - cached_contracts cctxt ~chain:cctxt#chain ~block:cctxt#block - >>=? fun keys -> - List.iter_s - (fun (key, size) -> cctxt#message "%a %d" Contract_hash.pp key size) - keys - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* keys = + cached_contracts cctxt ~chain:cctxt#chain ~block:cctxt#block + in + let*! () = + List.iter_s + (fun (key, size) -> cctxt#message "%a %d" Contract_hash.pp key size) + keys + in + return_unit); command ~group ~desc:"Get the key rank of a cache key." @@ -152,31 +174,40 @@ let commands_ro () = @@ OriginatedContractAlias.destination_param ~name:"src" ~desc:"contract" @@ stop) (fun () contract (cctxt : Protocol_client_context.full) -> - contract_rank cctxt ~chain:cctxt#chain ~block:cctxt#block contract - >>=? fun rank -> - match rank with - | None -> - cctxt#error "Invalid contract: %a" Contract_hash.pp contract - >>= fun () -> return_unit - | Some rank -> cctxt#message "%d" rank >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* rank = + contract_rank cctxt ~chain:cctxt#chain ~block:cctxt#block contract + in + let*! () = + match rank with + | None -> cctxt#error "Invalid contract: %a" Contract_hash.pp contract + | Some rank -> cctxt#message "%d" rank + in + return_unit); command ~group ~desc:"Get cache contract size." no_options (prefixes ["get"; "cache"; "contract"; "size"] @@ stop) (fun () (cctxt : Protocol_client_context.full) -> - contract_cache_size cctxt ~chain:cctxt#chain ~block:cctxt#block - >>=? fun t -> - cctxt#message "%d" t >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* t = + contract_cache_size cctxt ~chain:cctxt#chain ~block:cctxt#block + in + let*! () = cctxt#message "%d" t in + return_unit); command ~group ~desc:"Get cache contract size limit." no_options (prefixes ["get"; "cache"; "contract"; "size"; "limit"] @@ stop) (fun () (cctxt : Protocol_client_context.full) -> - contract_cache_size_limit cctxt ~chain:cctxt#chain ~block:cctxt#block - >>=? fun t -> - cctxt#message "%d" t >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* t = + contract_cache_size_limit cctxt ~chain:cctxt#chain ~block:cctxt#block + in + let*! () = cctxt#message "%d" t in + return_unit); command ~group ~desc:"Get the balance of a contract." @@ -185,10 +216,14 @@ let commands_ro () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun () contract (cctxt : Protocol_client_context.full) -> - get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract - >>=? fun amount -> - cctxt#answer "%a %s" Tez.pp amount Operation_result.tez_sym - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* amount = + get_balance cctxt ~chain:cctxt#chain ~block:cctxt#block contract + in + let*! () = + cctxt#answer "%a %s" Tez.pp amount Operation_result.tez_sym + in + return_unit); command ~group ~desc:"Get the storage of a contract." @@ -199,17 +234,25 @@ let commands_ro () = ~desc:"source contract" @@ stop) (fun unparsing_mode contract (cctxt : Protocol_client_context.full) -> - get_storage - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~unparsing_mode - contract - >>=? function + let open Lwt_result_syntax in + let* v = + get_storage + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode + contract + in + match v with | None -> cctxt#error "This is not a smart contract." | Some storage -> - cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped storage - >>= fun () -> return_unit); + let*! () = + cctxt#answer + "%a" + Michelson_v1_printer.print_expr_unwrapped + storage + in + return_unit); command ~group ~desc: @@ -226,17 +269,22 @@ let commands_ro () = ~desc:"source contract" @@ stop) (fun () key key_type contract (cctxt : Protocol_client_context.full) -> - get_contract_big_map_value - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - contract - (key.expanded, key_type.expanded) - >>=? function + let open Lwt_result_syntax in + let* v = + get_contract_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + (key.expanded, key_type.expanded) + in + match v with | None -> cctxt#error "No value associated to this key." | Some value -> - cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value - >>= fun () -> return_unit); + let*! () = + cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value + in + return_unit); command ~group ~desc:"Get a value in a big map." @@ -246,7 +294,7 @@ let commands_ro () = ~name:"key" ~desc:"the key to look for" (Clic.parameter (fun _ s -> - return (Script_expr_hash.of_b58check_exn s))) + Lwt_result_syntax.return (Script_expr_hash.of_b58check_exn s))) @@ prefixes ["of"; "big"; "map"] @@ Clic.param ~name:"big_map" @@ -254,16 +302,20 @@ let commands_ro () = int_parameter @@ stop) (fun unparsing_mode key id (cctxt : Protocol_client_context.full) -> - get_big_map_value - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~unparsing_mode - (Big_map.Id.parse_z (Z.of_int id)) - key - >>=? fun value -> - cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* value = + get_big_map_value + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode + (Big_map.Id.parse_z (Z.of_int id)) + key + in + let*! () = + cctxt#answer "%a" Michelson_v1_printer.print_expr_unwrapped value + in + return_unit); command ~group ~desc:"Get the code of a contract." @@ -276,14 +328,17 @@ let commands_ro () = (fun (unparsing_mode, normalize_types) contract (cctxt : Protocol_client_context.full) -> - get_script - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~unparsing_mode - ~normalize_types - contract - >>=? function + let open Lwt_result_syntax in + let* v = + get_script + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~unparsing_mode + ~normalize_types + contract + in + match v with | None -> cctxt#error "This is not a smart contract." | Some {code; storage = _} -> ( match Script_repr.force_decode code with @@ -293,7 +348,8 @@ let commands_ro () = let {Michelson_v1_parser.source; _} = Michelson_v1_printer.unparse_toplevel code in - cctxt#answer "%s" source >>= return)); + let*! a = cctxt#answer "%s" source in + return a)); command ~group ~desc:"Get the `BLAKE2B` script hash of a contract." @@ -304,11 +360,16 @@ let commands_ro () = ~desc:"source contract" @@ stop) (fun () contract (cctxt : Protocol_client_context.full) -> - get_script_hash cctxt ~chain:cctxt#chain ~block:cctxt#block contract - >>= function + let open Lwt_syntax in + let* r = + get_script_hash cctxt ~chain:cctxt#chain ~block:cctxt#block contract + in + match r with | Error errs -> cctxt#error "%a" pp_print_trace errs | Ok None -> cctxt#error "This is not a smart contract." - | Ok (Some hash) -> cctxt#answer "%a" Script_expr_hash.pp hash >|= ok); + | Ok (Some hash) -> + let* a = cctxt#answer "%a" Script_expr_hash.pp hash in + return_ok a); command ~group ~desc:"Get the type of an entrypoint of a contract." @@ -327,18 +388,22 @@ let commands_ro () = entrypoint contract (cctxt : Protocol_client_context.full) -> - Michelson_v1_entrypoints.contract_entrypoint_type + let open Lwt_syntax in + let* t = + Michelson_v1_entrypoints.contract_entrypoint_type + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~entrypoint + ~normalize_types + in + Michelson_v1_entrypoints.print_entrypoint_type cctxt - ~chain:cctxt#chain - ~block:cctxt#block + ~emacs:false ~contract ~entrypoint - ~normalize_types - >>= Michelson_v1_entrypoints.print_entrypoint_type - cctxt - ~emacs:false - ~contract - ~entrypoint); + t); command ~group ~desc:"Get the entrypoint list of a contract." @@ -349,16 +414,20 @@ let commands_ro () = ~desc:"source contract" @@ stop) (fun normalize_types contract (cctxt : Protocol_client_context.full) -> - Michelson_v1_entrypoints.list_contract_entrypoints + let open Lwt_syntax in + let* es = + Michelson_v1_entrypoints.list_contract_entrypoints + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~normalize_types + in + Michelson_v1_entrypoints.print_entrypoints_list cctxt - ~chain:cctxt#chain - ~block:cctxt#block + ~emacs:false ~contract - ~normalize_types - >>= Michelson_v1_entrypoints.print_entrypoints_list - cctxt - ~emacs:false - ~contract); + es); command ~group ~desc:"Get the list of unreachable paths in a contract's parameter type." @@ -369,15 +438,19 @@ let commands_ro () = ~desc:"source contract" @@ stop) (fun () contract (cctxt : Protocol_client_context.full) -> - Michelson_v1_entrypoints.list_contract_unreachables + let open Lwt_syntax in + let* u = + Michelson_v1_entrypoints.list_contract_unreachables + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + in + Michelson_v1_entrypoints.print_unreachables cctxt - ~chain:cctxt#chain - ~block:cctxt#block + ~emacs:false ~contract - >>= Michelson_v1_entrypoints.print_unreachables - cctxt - ~emacs:false - ~contract); + u); command ~group ~desc:"Get the delegate of a contract." @@ -386,21 +459,28 @@ let commands_ro () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source contract" @@ stop) (fun () contract (cctxt : Protocol_client_context.full) -> - Client_proto_contracts.get_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - contract - >>=? function - | None -> cctxt#message "none" >>= fun () -> return_unit + let open Lwt_result_syntax in + let* v = + Client_proto_contracts.get_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + contract + in + match v with + | None -> + let*! () = cctxt#message "none" in + return_unit | Some delegate -> - Public_key_hash.rev_find cctxt delegate >>=? fun mn -> - Public_key_hash.to_source delegate >>=? fun m -> - cctxt#message - "%s (%s)" - m - (match mn with None -> "unknown" | Some n -> "known as " ^ n) - >>= fun () -> return_unit); + let* mn = Public_key_hash.rev_find cctxt delegate in + let* m = Public_key_hash.to_source delegate in + let*! () = + cctxt#message + "%s (%s)" + m + (match mn with None -> "unknown" | Some n -> "known as " ^ n) + in + return_unit); command ~desc:"Get receipt for past operation" (args1 @@ -417,34 +497,41 @@ let commands_ro () = (parameter (fun _ x -> match Operation_hash.of_b58check_opt x with | None -> Error_monad.failwith "Invalid operation hash: '%s'" x - | Some hash -> return hash)) + | Some hash -> Lwt_result_syntax.return hash)) @@ stop) (fun predecessors operation_hash (ctxt : Protocol_client_context.full) -> - display_receipt_for_operation - ctxt - ~chain:ctxt#chain - ~predecessors - operation_hash - >>=? fun _ -> return_unit); + let open Lwt_result_syntax in + let* _ = + display_receipt_for_operation + ctxt + ~chain:ctxt#chain + ~predecessors + operation_hash + in + return_unit); command ~group ~desc:"Summarize the current voting period" no_options (fixed ["show"; "voting"; "period"]) (fun () (cctxt : Protocol_client_context.full) -> - get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt - >>=? fun info -> - cctxt#message - "Current period: %a\nBlocks remaining until end of period: %ld" - Data_encoding.Json.pp - (Data_encoding.Json.construct - Alpha_context.Voting_period.kind_encoding - info.current_period_kind) - info.remaining - >>= fun () -> - Shell_services.Protocol.list cctxt >>=? fun known_protos -> - get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt - >>=? fun props -> + let open Lwt_result_syntax in + let* info = + get_period_info ~chain:cctxt#chain ~block:cctxt#block cctxt + in + let*! () = + cctxt#message + "Current period: %a\nBlocks remaining until end of period: %ld" + Data_encoding.Json.pp + (Data_encoding.Json.construct + Alpha_context.Voting_period.kind_encoding + info.current_period_kind) + info.remaining + in + let* known_protos = Shell_services.Protocol.list cctxt in + let* props = + get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt + in let ranks = Environment.Protocol_hash.Map.bindings props |> List.sort (fun (_, v1) (_, v2) -> Int64.(compare v2 v1)) @@ -463,93 +550,111 @@ let commands_ro () = (* the current proposals are cleared on the last block of the proposal period *) if info.remaining <> 0l then - cctxt#answer - "Current proposals:%t" - Format.( - fun ppf -> - pp_print_cut ppf () ; - pp_open_vbox ppf 0 ; - List.iter - (fun (p, w) -> - fprintf - ppf - "* %a %a %s (%sknown by the node)@." - Protocol_hash.pp - p - Tez.pp - (Tez.of_mutez_exn w) - Operation_result.tez_sym - (if List.mem ~equal:Protocol_hash.equal p known_protos - then "" - else "not ")) - ranks ; - pp_close_box ppf ()) - >>= fun () -> return_unit + let*! () = + cctxt#answer + "Current proposals:%t" + Format.( + fun ppf -> + pp_print_cut ppf () ; + pp_open_vbox ppf 0 ; + List.iter + (fun (p, w) -> + fprintf + ppf + "* %a %a %s (%sknown by the node)@." + Protocol_hash.pp + p + Tez.pp + (Tez.of_mutez_exn w) + Operation_result.tez_sym + (if + List.mem ~equal:Protocol_hash.equal p known_protos + then "" + else "not ")) + ranks ; + pp_close_box ppf ()) + in + return_unit else - cctxt#message "The proposals have already been cleared." - >>= fun () -> return_unit + let*! () = + cctxt#message "The proposals have already been cleared." + in + return_unit | Exploration | Promotion -> - print_proposal info.current_proposal >>= fun () -> + let*! () = print_proposal info.current_proposal in (* the ballots are cleared on the last block of these periods *) if info.remaining <> 0l then - get_ballots_info ~chain:cctxt#chain ~block:cctxt#block cctxt - >>=? fun ballots_info -> - cctxt#answer - "@[Ballots:@,\ - \ Yay: %a %s@,\ - \ Nay: %a %s@,\ - \ Pass: %a %s@,\ - Current participation %.2f%%, necessary quorum %.2f%%@,\ - Current in favor %a %s, needed supermajority %a %s@]" - Tez.pp - (Tez.of_mutez_exn ballots_info.ballots.yay) - Operation_result.tez_sym - Tez.pp - (Tez.of_mutez_exn ballots_info.ballots.nay) - Operation_result.tez_sym - Tez.pp - (Tez.of_mutez_exn ballots_info.ballots.pass) - Operation_result.tez_sym - (Int32.to_float ballots_info.participation /. 100.) - (Int32.to_float ballots_info.current_quorum /. 100.) - Tez.pp - (Tez.of_mutez_exn ballots_info.ballots.yay) - Operation_result.tez_sym - Tez.pp - (Tez.of_mutez_exn ballots_info.supermajority) - Operation_result.tez_sym - >>= fun () -> return_unit + let* ballots_info = + get_ballots_info ~chain:cctxt#chain ~block:cctxt#block cctxt + in + let*! () = + cctxt#answer + "@[Ballots:@,\ + \ Yay: %a %s@,\ + \ Nay: %a %s@,\ + \ Pass: %a %s@,\ + Current participation %.2f%%, necessary quorum %.2f%%@,\ + Current in favor %a %s, needed supermajority %a %s@]" + Tez.pp + (Tez.of_mutez_exn ballots_info.ballots.yay) + Operation_result.tez_sym + Tez.pp + (Tez.of_mutez_exn ballots_info.ballots.nay) + Operation_result.tez_sym + Tez.pp + (Tez.of_mutez_exn ballots_info.ballots.pass) + Operation_result.tez_sym + (Int32.to_float ballots_info.participation /. 100.) + (Int32.to_float ballots_info.current_quorum /. 100.) + Tez.pp + (Tez.of_mutez_exn ballots_info.ballots.yay) + Operation_result.tez_sym + Tez.pp + (Tez.of_mutez_exn ballots_info.supermajority) + Operation_result.tez_sym + in + return_unit else - cctxt#message "The ballots have already been cleared." - >>= fun () -> return_unit + let*! () = + cctxt#message "The ballots have already been cleared." + in + return_unit | Cooldown -> - print_proposal info.current_proposal >>= fun () -> return_unit + let*! () = print_proposal info.current_proposal in + return_unit | Adoption -> - print_proposal info.current_proposal >>= fun () -> return_unit); + let*! () = print_proposal info.current_proposal in + return_unit); command ~group:binary_description ~desc:"Describe unsigned block header" no_options (fixed ["describe"; "unsigned"; "block"; "header"]) (fun () (cctxt : Protocol_client_context.full) -> - cctxt#message - "%a" - Data_encoding.Binary_schema.pp - (Data_encoding.Binary.describe - Alpha_context.Block_header.unsigned_encoding) - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let*! () = + cctxt#message + "%a" + Data_encoding.Binary_schema.pp + (Data_encoding.Binary.describe + Alpha_context.Block_header.unsigned_encoding) + in + return_unit); command ~group:binary_description ~desc:"Describe unsigned operation" no_options (fixed ["describe"; "unsigned"; "operation"]) (fun () (cctxt : Protocol_client_context.full) -> - cctxt#message - "%a" - Data_encoding.Binary_schema.pp - (Data_encoding.Binary.describe - Alpha_context.Operation.unsigned_encoding) - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let*! () = + cctxt#message + "%a" + Data_encoding.Binary_schema.pp + (Data_encoding.Binary.describe + Alpha_context.Operation.unsigned_encoding) + in + return_unit); command ~group ~desc:"Get the frozen deposits limit of a delegate." @@ -558,6 +663,7 @@ let commands_ro () = @@ ContractAlias.destination_param ~name:"src" ~desc:"source delegate" @@ stop) (fun () contract (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in match contract with | Originated _ -> cctxt#error @@ -565,17 +671,21 @@ let commands_ro () = invalid on originated contracts." Contract.pp contract - | Implicit delegate -> ( - get_frozen_deposits_limit - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - delegate - >>=? function - | None -> cctxt#answer "unlimited" >>= return - | Some limit -> - cctxt#answer "%a %s" Tez.pp limit Operation_result.tez_sym - >>= return)); + | Implicit delegate -> + let* o = + get_frozen_deposits_limit + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + delegate + in + let*! () = + match o with + | None -> cctxt#answer "unlimited" + | Some limit -> + cctxt#answer "%a %s" Tez.pp limit Operation_result.tez_sym + in + return_unit); ] (* ----------------------------------------------------------------------------*) @@ -647,6 +757,7 @@ let transfer_command amount (source : Contract.t) destination entrypoint, replace_by_fees, successor_level ) = + let open Lwt_result_syntax in (* When --force is used we want to inject the transfer even if it fails. In that case we cannot rely on simulation to compute limits and fees so we require the corresponding options to be set. *) @@ -657,113 +768,123 @@ let transfer_command amount (source : Contract.t) destination name | _ -> Lwt.return_unit in - (if force && not simulation then - check_force_dependency "--gas-limit" gas_limit >>= fun () -> - check_force_dependency "--storage-limit" storage_limit >>= fun () -> - check_force_dependency "--fee" fee - else Lwt.return_unit) - >>= fun () -> - (match source with - | Originated contract_hash -> - let contract = source in - Managed_contract.get_contract_manager cctxt contract_hash - >>=? fun source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Managed_contract.transfer - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~simulation - ~force - ~fee_parameter - ?fee - ~contract - ~source - ~src_pk - ~src_sk - ~destination - ?entrypoint - ?arg - ~amount - ?gas_limit - ?storage_limit - ?counter - () - | Implicit source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - transfer - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~simulation - ~force - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~destination - ?entrypoint - ?arg - ~amount - ?gas_limit - ?storage_limit - ?counter - ~replace_by_fees - ~successor_level - ()) - >>= report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function - | None -> return_unit - | Some (_res, _contracts) -> return_unit + let*! () = + if force && not simulation then + let*! () = check_force_dependency "--gas-limit" gas_limit in + let*! () = check_force_dependency "--storage-limit" storage_limit in + check_force_dependency "--fee" fee + else Lwt.return_unit + in + let*! r = + match source with + | Originated contract_hash -> + let contract = source in + let* source = + Managed_contract.get_contract_manager cctxt contract_hash + in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + Managed_contract.transfer + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~simulation + ~force + ~fee_parameter + ?fee + ~contract + ~source + ~src_pk + ~src_sk + ~destination + ?entrypoint + ?arg + ~amount + ?gas_limit + ?storage_limit + ?counter + () + | Implicit source -> + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + transfer + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~simulation + ~force + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~destination + ?entrypoint + ?arg + ~amount + ?gas_limit + ?storage_limit + ?counter + ~replace_by_fees + ~successor_level + () + in + let*! o = + report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + r + in + match o with None -> return_unit | Some (_res, _contracts) -> return_unit let prepare_batch_operation cctxt ?arg ?fee ?gas_limit ?storage_limit ?entrypoint (source : Contract.t) index batch = - Client_proto_contracts.ContractAlias.find_destination cctxt batch.destination - >>=? fun destination -> - tez_of_string_exn index "amount" batch.amount >>=? fun amount -> - tez_of_opt_string_exn index "fee" batch.fee >>=? fun batch_fee -> + let open Lwt_result_syntax in + let* destination = + Client_proto_contracts.ContractAlias.find_destination + cctxt + batch.destination + in + let* amount = tez_of_string_exn index "amount" batch.amount in + let* batch_fee = tez_of_opt_string_exn index "fee" batch.fee in let fee = Option.either batch_fee fee in let arg = Option.either batch.arg arg in let gas_limit = Option.either batch.gas_limit gas_limit in let storage_limit = Option.either batch.storage_limit storage_limit in let entrypoint = Option.either batch.entrypoint entrypoint in - parse_arg_transfer arg >>=? fun parameters -> - (match source with - | Originated _ -> - Managed_contract.build_transaction_operation - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract:source - ~destination - ?entrypoint - ?arg - ~amount - ?fee - ?gas_limit - ?storage_limit - () - | Implicit _ -> - return - (build_transaction_operation - ~amount - ~parameters - ?entrypoint - ?fee - ?gas_limit - ?storage_limit - destination)) - >>=? fun operation -> + let* parameters = parse_arg_transfer arg in + let* operation = + match source with + | Originated _ -> + Managed_contract.build_transaction_operation + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract:source + ~destination + ?entrypoint + ?arg + ~amount + ?fee + ?gas_limit + ?storage_limit + () + | Implicit _ -> + return + (build_transaction_operation + ~amount + ~parameters + ?entrypoint + ?fee + ?gas_limit + ?storage_limit + destination) + in return (Annotated_manager_operation.Annotated_manager_operation operation) let commands_network network () = @@ -785,7 +906,8 @@ let commands_network network () = json_parameter @@ stop) (fun (force, encrypted) name activation_json cctxt -> - Secret_key.of_fresh cctxt force name >>=? fun name -> + let open Lwt_result_syntax in + let* name = Secret_key.of_fresh cctxt force name in match Data_encoding.Json.destruct Client_proto_context.activation_key_encoding @@ -800,16 +922,18 @@ let commands_network network () = Data_encoding.Json.pp activation_json | key -> - activate_account - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~encrypted - ~force - key - name - >>=? fun _res -> return_unit); + let* _res = + activate_account + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~encrypted + ~force + key + name + in + return_unit); ] | Some `Mainnet -> [ @@ -825,20 +949,23 @@ let commands_network network () = match Blinded_public_key_hash.activation_code_of_hex code with - | Some c -> return c + | Some c -> Lwt_result_syntax.return c | None -> failwith "Hexadecimal parsing failure")) ~desc:"Activation code obtained from the Tezos foundation." @@ stop) (fun dry_run (name, _pkh) code cctxt -> - activate_existing_account - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - name - code - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _res = + activate_existing_account + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + name + code + in + return_unit); ] let commands_rw () = @@ -866,50 +993,57 @@ let commands_rw () = contract delegate (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in match contract with | Originated contract -> - Managed_contract.get_contract_manager cctxt contract - >>=? fun source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Managed_contract.set_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~simulation - ~fee_parameter - ?fee - ~source - ~src_pk - ~src_sk - contract - (Some delegate) - >>= fun errors -> - report_michelson_errors - ~no_print_source:true - ~msg:"Setting delegate through entrypoints failed." - cctxt - errors - >>= fun _ -> return_unit + let* source = + Managed_contract.get_contract_manager cctxt contract + in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + Managed_contract.set_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~simulation + ~fee_parameter + ?fee + ~source + ~src_pk + ~src_sk + contract + (Some delegate) + in + let*! _ = + report_michelson_errors + ~no_print_source:true + ~msg:"Setting delegate through entrypoints failed." + cctxt + errors + in + return_unit | Implicit mgr -> - Client_keys.get_key cctxt mgr >>=? fun (_, src_pk, manager_sk) -> - set_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~simulation - ~fee_parameter - ?fee - mgr - (Some delegate) - ~src_pk - ~manager_sk - >>=? fun _ -> return_unit); + let* _, src_pk, manager_sk = Client_keys.get_key cctxt mgr in + let* _ = + set_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~simulation + ~fee_parameter + ?fee + mgr + (Some delegate) + ~src_pk + ~manager_sk + in + return_unit); command ~group ~desc:"Withdraw the delegate from a contract." @@ -920,48 +1054,55 @@ let commands_rw () = (fun (fee, dry_run, verbose_signing, fee_parameter) contract (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in match contract with | Originated contract -> - Managed_contract.get_contract_manager cctxt contract - >>=? fun source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Managed_contract.set_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ?fee - ~source - ~src_pk - ~src_sk - contract - None - >>= fun errors -> - report_michelson_errors - ~no_print_source:true - ~msg:"Withdrawing delegate through entrypoints failed." - cctxt - errors - >>= fun _ -> return_unit + let* source = + Managed_contract.get_contract_manager cctxt contract + in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + Managed_contract.set_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ?fee + ~source + ~src_pk + ~src_sk + contract + None + in + let*! _ = + report_michelson_errors + ~no_print_source:true + ~msg:"Withdrawing delegate through entrypoints failed." + cctxt + errors + in + return_unit | Implicit mgr -> - Client_keys.get_key cctxt mgr >>=? fun (_, src_pk, manager_sk) -> - set_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - mgr - None - ?fee - ~src_pk - ~manager_sk - >>= fun _ -> return_unit); + let* _, src_pk, manager_sk = Client_keys.get_key cctxt mgr in + let*! _ = + set_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + mgr + None + ?fee + ~src_pk + ~manager_sk + in + return_unit); command ~group ~desc:"Launch a smart contract on the blockchain." @@ -1008,36 +1149,41 @@ let commands_rw () = source program (cctxt : Protocol_client_context.full) -> - RawContractAlias.of_fresh cctxt force alias_name >>=? fun alias_name -> - Lwt.return (Micheline_parser.no_parsing_error program) - >>=? fun {expanded = code; _} -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - originate_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ?gas_limit - ?storage_limit - ~delegate - ~initial_storage - ~balance - ~source - ~src_pk - ~src_sk - ~code - ~fee_parameter - () - >>= fun errors -> - report_michelson_errors - ~no_print_source - ~msg:"origination simulation failed" - cctxt - errors - >>= function + let open Lwt_result_syntax in + let* alias_name = RawContractAlias.of_fresh cctxt force alias_name in + let* {expanded = code; _} = + Lwt.return (Micheline_parser.no_parsing_error program) + in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + originate_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ?gas_limit + ?storage_limit + ~delegate + ~initial_storage + ~balance + ~source + ~src_pk + ~src_sk + ~code + ~fee_parameter + () + in + let*! o = + report_michelson_errors + ~no_print_source + ~msg:"origination simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, contract) -> if dry_run then return_unit @@ -1096,6 +1242,7 @@ let commands_rw () = (* When --force is used we want to inject the transfer even if it fails. In that case we cannot rely on simulation to compute limits and fees so we require the corresponding options to be set. *) + let open Lwt_result_syntax in let check_force_dependency name = function | None -> cctxt#error @@ -1103,12 +1250,13 @@ let commands_rw () = name | _ -> Lwt.return_unit in - (if force && not simulation then - check_force_dependency "--gas-limit" gas_limit >>= fun () -> - check_force_dependency "--storage-limit" storage_limit >>= fun () -> - check_force_dependency "--fee" fee - else Lwt.return_unit) - >>= fun () -> + let*! () = + if force && not simulation then + let*! () = check_force_dependency "--gas-limit" gas_limit in + let*! () = check_force_dependency "--storage-limit" storage_limit in + check_force_dependency "--fee" fee + else Lwt.return_unit + in let prepare i = prepare_batch_operation cctxt @@ -1128,44 +1276,51 @@ let commands_rw () = with | [] -> failwith "Empty operation list" | operations -> - (match source with - | Originated contract -> - Managed_contract.get_contract_manager cctxt contract - >>=? fun source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - return (source, src_pk, src_sk) - | Implicit source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - return (source, src_pk, src_sk)) - >>=? fun (source, src_pk, src_sk) -> - List.mapi_ep prepare operations >>=? fun contents -> + let* source, src_pk, src_sk = + match source with + | Originated contract -> + let* source = + Managed_contract.get_contract_manager cctxt contract + in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + return (source, src_pk, src_sk) + | Implicit source -> + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + return (source, src_pk, src_sk) + in + let* contents = List.mapi_ep prepare operations in let (Manager_list contents) = Annotated_manager_operation.manager_of_list contents in - Injection.inject_manager_operation - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~simulation - ~force - ~source - ~fee:(Limit.of_option fee) - ~gas_limit:(Limit.of_option gas_limit) - ~storage_limit:(Limit.of_option storage_limit) - ?counter - ~src_pk - ~src_sk - ~replace_by_fees - ~fee_parameter - contents - >>= report_michelson_errors - ~no_print_source - ~msg:"multiple transfers simulation failed" - cctxt - >>= fun _ -> return_unit + let*! errors = + Injection.inject_manager_operation + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~simulation + ~force + ~source + ~fee:(Limit.of_option fee) + ~gas_limit:(Limit.of_option gas_limit) + ~storage_limit:(Limit.of_option storage_limit) + ?counter + ~src_pk + ~src_sk + ~replace_by_fees + ~fee_parameter + contents + in + let*! _ = + report_michelson_errors + ~no_print_source + ~msg:"multiple transfers simulation failed" + cctxt + errors + in + return_unit | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with @@ -1290,31 +1445,35 @@ let commands_rw () = global_constant_str source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - register_global_constant - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~constant:global_constant_str - () - >>= fun errors -> - report_michelson_errors - ~no_print_source:false - ~msg:"register global constant simulation failed" - cctxt - errors - >>= fun _ -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + register_global_constant + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~constant:global_constant_str + () + in + let*! _ = + report_michelson_errors + ~no_print_source:false + ~msg:"register global constant simulation failed" + cctxt + errors + in + return_unit); command ~group ~desc:"Call a smart contract (same as 'transfer 0')." @@ -1389,21 +1548,24 @@ let commands_rw () = ~desc:"name of the source contract" @@ stop) (fun (fee, dry_run, verbose_signing, fee_parameter) source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - reveal - cctxt - ~dry_run - ~verbose_signing - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~source - ?fee - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + reveal + cctxt + ~dry_run + ~verbose_signing + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~source + ?fee + ~src_pk + ~src_sk + ~fee_parameter + () + in + return_unit); command ~group ~desc:"Register the public key hash as a delegate." @@ -1413,22 +1575,25 @@ let commands_rw () = @@ prefixes ["as"; "delegate"] @@ stop) (fun (fee, dry_run, verbose_signing, fee_parameter) src_pkh cctxt -> - Client_keys.get_key cctxt src_pkh >>=? fun (_, src_pk, src_sk) -> - register_as_delegate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~fee_parameter - ~verbose_signing - ?fee - ~manager_sk:src_sk - src_pk - >>= function + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt src_pkh in + let*! r = + register_as_delegate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~fee_parameter + ~verbose_signing + ?fee + ~manager_sk:src_sk + src_pk + in + match r with | Ok _ -> return_unit | Error [Environment.Ecoproto_error Delegate_storage.Active_delegate] -> - cctxt#message "Delegate already activated." >>= fun () -> + let*! () = cctxt#message "Delegate already activated." in return_unit | Error el -> Lwt.return_error el); command @@ -1461,20 +1626,23 @@ let commands_rw () = (parameter (fun _ x -> match Operation_hash.of_b58check_opt x with | None -> Error_monad.failwith "Invalid operation hash: '%s'" x - | Some hash -> return hash)) + | Some hash -> Lwt_result_syntax.return hash)) @@ prefixes ["to"; "be"; "included"] @@ stop) (fun (confirmations, predecessors, branch) operation_hash (ctxt : Protocol_client_context.full) -> - Client_confirmations.wait_for_operation_inclusion - ctxt - ~chain:ctxt#chain - ~confirmations - ~predecessors - ?branch - operation_hash - >>=? fun _ -> return_unit); + let open Lwt_result_syntax in + let* _ = + Client_confirmations.wait_for_operation_inclusion + ctxt + ~chain:ctxt#chain + ~confirmations + ~predecessors + ?branch + operation_hash + in + return_unit); command ~group ~desc:"Submit protocol proposals" @@ -1499,48 +1667,54 @@ let commands_rw () = match Protocol_hash.of_b58check_opt x with | None -> Error_monad.failwith "Invalid proposal hash: '%s'" x - | Some hash -> return hash)))) + | Some hash -> Lwt_result_syntax.return hash)))) (fun (dry_run, verbose_signing, force) src_pkh proposals (cctxt : Protocol_client_context.full) -> - Client_keys.get_key cctxt src_pkh - >>=? fun (src_name, _src_pk, src_sk) -> - get_period_info - (* Find period info of the successor, because the operation will - be injected on the next block at the earliest *) - ~successor:true - ~chain:cctxt#chain - ~block:cctxt#block - cctxt - >>=? fun info -> - (match info.current_period_kind with - | Proposal -> Lwt.return_unit - | _ -> - (if force then cctxt#warning else cctxt#error) - "Not in a proposal period") - >>= fun () -> - Shell_services.Protocol.list cctxt >>=? fun known_protos -> - get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt - >>=? fun known_proposals -> - (Alpha_services.Delegate.voting_power - cctxt - (cctxt#chain, cctxt#block) - src_pkh - >>= function - | Ok voting_power -> return (voting_power <> 0L) - | Error - (Environment.Ecoproto_error (Delegate_storage.Not_registered _) - :: _) -> - return false - | Error _ as err -> Lwt.return err) - >>=? fun has_voting_power -> - (* for a proposal to be valid it must either a protocol that was already - proposed by somebody else or a protocol known by the node, because - the user is the first proposer and just injected it with - tezos-admin-client *) - let check_proposals proposals : bool tzresult Lwt.t = - let errors = ref [] in + let open Lwt_result_syntax in + let* src_name, _src_pk, src_sk = Client_keys.get_key cctxt src_pkh in + let* info = + get_period_info + (* Find period info of the successor, because the operation will + be injected on the next block at the earliest *) + ~successor:true + ~chain:cctxt#chain + ~block:cctxt#block + cctxt + in + let*! () = + match info.current_period_kind with + | Proposal -> Lwt.return_unit + | _ -> + (if force then cctxt#warning else cctxt#error) + "Not in a proposal period" + in + let* known_protos = Shell_services.Protocol.list cctxt in + let* known_proposals = + get_proposals ~chain:cctxt#chain ~block:cctxt#block cctxt + in + let* has_voting_power = + let*! r = + Alpha_services.Delegate.voting_power + cctxt + (cctxt#chain, cctxt#block) + src_pkh + in + match r with + | Ok voting_power -> return (voting_power <> 0L) + | Error + (Environment.Ecoproto_error (Delegate_storage.Not_registered _) + :: _) -> + return false + | Error _ as err -> Lwt.return err + in + (* for a proposal to be valid it must either a protocol that was already + proposed by somebody else or a protocol known by the node, because + the user is the first proposer and just injected it with + tezos-admin-client *) + let check_proposals proposals : bool tzresult Lwt.t = + let errors = ref [] in let error ppf = Format.kasprintf (fun s -> errors := s :: !errors) ppf in @@ -1585,58 +1759,66 @@ let commands_rw () = src_pkh src_name ; if !errors <> [] then - cctxt#message - "There %s with the submission:%t" - (if Compare.List_length_with.(!errors = 1) then "is an issue" - else "are issues") - Format.( - fun ppf -> - pp_print_cut ppf () ; - pp_open_vbox ppf 0 ; - List.iter - (fun msg -> - pp_open_hovbox ppf 2 ; - pp_print_string ppf "* " ; - pp_print_text ppf msg ; - pp_close_box ppf () ; - pp_print_cut ppf ()) - !errors ; - pp_close_box ppf ()) - >>= fun () -> return_false + let*! () = + cctxt#message + "There %s with the submission:%t" + (if Compare.List_length_with.(!errors = 1) then "is an issue" + else "are issues") + Format.( + fun ppf -> + pp_print_cut ppf () ; + pp_open_vbox ppf 0 ; + List.iter + (fun msg -> + pp_open_hovbox ppf 2 ; + pp_print_string ppf "* " ; + pp_print_text ppf msg ; + pp_close_box ppf () ; + pp_print_cut ppf ()) + !errors ; + pp_close_box ppf ()) + in + return_false else return_true in - check_proposals proposals >>=? fun all_valid -> - (if all_valid then cctxt#message "All proposals are valid." - else if force then - cctxt#message "Some proposals are not valid, but `--force` was used." - else cctxt#error "Submission failed because of invalid proposals.") - >>= fun () -> - submit_proposals - ~dry_run - ~verbose_signing - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~src_sk - src_pkh - proposals - >>= function + let* all_valid = check_proposals proposals in + let*! () = + if all_valid then cctxt#message "All proposals are valid." + else if force then + cctxt#message + "Some proposals are not valid, but `--force` was used." + else cctxt#error "Submission failed because of invalid proposals." + in + let*! r = + submit_proposals + ~dry_run + ~verbose_signing + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~src_sk + src_pkh + proposals + in + match r with | Ok _res -> return_unit | Error errs -> - (match errs with - | [ - Unregistered_error - (`O [("kind", `String "generic"); ("error", `String msg)]); - ] -> - cctxt#message - "Error:@[@.%a@]" - Format.pp_print_text - (String.split_on_char ' ' msg - |> List.filter (function "" | "\n" -> false | _ -> true) - |> String.concat " " - |> String.map (function '\n' | '\t' -> ' ' | c -> c)) - | el -> cctxt#message "Error:@ %a" pp_print_trace el) - >>= fun () -> failwith "Failed to submit proposals"); + let*! () = + match errs with + | [ + Unregistered_error + (`O [("kind", `String "generic"); ("error", `String msg)]); + ] -> + cctxt#message + "Error:@[@.%a@]" + Format.pp_print_text + (String.split_on_char ' ' msg + |> List.filter (function "" | "\n" -> false | _ -> true) + |> String.concat " " + |> String.map (function '\n' | '\t' -> ' ' | c -> c)) + | el -> cctxt#message "Error:@ %a" pp_print_trace el + in + failwith "Failed to submit proposals"); command ~group ~desc:"Submit a ballot" @@ -1659,13 +1841,15 @@ let commands_rw () = (parameter (fun _ x -> match Protocol_hash.of_b58check_opt x with | None -> failwith "Invalid proposal hash: '%s'" x - | Some hash -> return hash)) + | Some hash -> Lwt_result_syntax.return hash)) @@ param ~name:"ballot" ~desc:"the ballot value (yea/yay, nay, or pass)" (parameter - ~autocomplete:(fun _ -> return ["yea"; "nay"; "pass"]) + ~autocomplete:(fun _ -> + Lwt_result_syntax.return ["yea"; "nay"; "pass"]) (fun _ s -> + let open Lwt_result_syntax in (* We should have [Vote.of_string]. *) match String.lowercase_ascii s with | "yay" | "yea" -> return Vote.Yay @@ -1678,64 +1862,77 @@ let commands_rw () = proposal ballot (cctxt : Protocol_client_context.full) -> - Client_keys.get_key cctxt src_pkh - >>=? fun (src_name, _src_pk, src_sk) -> - get_period_info - (* Find period info of the successor, because the operation will - be injected on the next block at the earliest *) - ~successor:true - ~chain:cctxt#chain - ~block:cctxt#block - cctxt - >>=? fun info -> - Alpha_services.Voting.current_proposal cctxt (cctxt#chain, cctxt#block) - >>=? fun current_proposal -> - (match (info.current_period_kind, current_proposal) with - | (Exploration | Promotion), Some current_proposal -> - if Protocol_hash.equal proposal current_proposal then return_unit - else - (if force then cctxt#warning else cctxt#error) - "Unexpected proposal, expected: %a" - Protocol_hash.pp - current_proposal - >>= fun () -> return_unit - | _ -> + let open Lwt_result_syntax in + let* src_name, _src_pk, src_sk = Client_keys.get_key cctxt src_pkh in + let* info = + get_period_info + (* Find period info of the successor, because the operation will + be injected on the next block at the earliest *) + ~successor:true + ~chain:cctxt#chain + ~block:cctxt#block + cctxt + in + let* current_proposal = + Alpha_services.Voting.current_proposal cctxt (cctxt#chain, cctxt#block) + in + let* () = + match (info.current_period_kind, current_proposal) with + | (Exploration | Promotion), Some current_proposal -> + if Protocol_hash.equal proposal current_proposal then return_unit + else + let*! () = + (if force then cctxt#warning else cctxt#error) + "Unexpected proposal, expected: %a" + Protocol_hash.pp + current_proposal + in + return_unit + | _ -> + let*! () = + (if force then cctxt#warning else cctxt#error) + "Not in Exploration or Promotion period" + in + return_unit + in + let* has_voting_power = + let*! r = + Alpha_services.Delegate.voting_power + cctxt + (cctxt#chain, cctxt#block) + src_pkh + in + match r with + | Ok voting_power -> return (voting_power <> 0L) + | Error + (Environment.Ecoproto_error (Delegate_storage.Not_registered _) + :: _) -> + return false + | Error _ as err -> Lwt.return err + in + let*! () = + if has_voting_power then Lwt.return_unit + else (if force then cctxt#warning else cctxt#error) - "Not in Exploration or Promotion period" - >>= fun () -> return_unit) - >>=? fun () -> - (Alpha_services.Delegate.voting_power - cctxt - (cctxt#chain, cctxt#block) - src_pkh - >>= function - | Ok voting_power -> return (voting_power <> 0L) - | Error - (Environment.Ecoproto_error (Delegate_storage.Not_registered _) - :: _) -> - return false - | Error _ as err -> Lwt.return err) - >>=? fun has_voting_power -> - (if has_voting_power then Lwt.return_unit - else - (if force then cctxt#warning else cctxt#error) - "Public-key-hash `%a` from account `%s` does not appear to have \ - voting rights." - Signature.Public_key_hash.pp + "Public-key-hash `%a` from account `%s` does not appear to have \ + voting rights." + Signature.Public_key_hash.pp + src_pkh + src_name + in + let* _res = + submit_ballot + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~src_sk src_pkh - src_name) - >>= fun () -> - submit_ballot - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~src_sk - src_pkh - ~verbose_signing - ~dry_run - proposal - ballot - >>=? fun _res -> return_unit); + ~verbose_signing + ~dry_run + proposal + ballot + in + return_unit); command ~group ~desc:"Set the deposits limit of a registered delegate." @@ -1756,6 +1953,7 @@ let commands_rw () = contract limit (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in match contract with | Originated _ -> cctxt#error @@ -1765,22 +1963,24 @@ let commands_rw () = Contract.pp contract | Implicit mgr -> - Client_keys.get_key cctxt mgr >>=? fun (_, src_pk, manager_sk) -> - set_deposits_limit - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~simulation - ~fee_parameter - ?fee - mgr - ~src_pk - ~manager_sk - (Some limit) - >>=? fun _ -> return_unit); + let* _, src_pk, manager_sk = Client_keys.get_key cctxt mgr in + let* _ = + set_deposits_limit + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~simulation + ~fee_parameter + ?fee + mgr + ~src_pk + ~manager_sk + (Some limit) + in + return_unit); command ~group ~desc:"Remove the deposits limit of a registered delegate." @@ -1796,6 +1996,7 @@ let commands_rw () = (fun (fee, dry_run, verbose_signing, simulation, fee_parameter) contract (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in match contract with | Originated _ -> cctxt#error @@ -1805,22 +2006,24 @@ let commands_rw () = Contract.pp contract | Implicit mgr -> - Client_keys.get_key cctxt mgr >>=? fun (_, src_pk, manager_sk) -> - set_deposits_limit - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~simulation - ~fee_parameter - ?fee - mgr - ~src_pk - ~manager_sk - None - >>=? fun _ -> return_unit); + let* _, src_pk, manager_sk = Client_keys.get_key cctxt mgr in + let* _ = + set_deposits_limit + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~simulation + ~fee_parameter + ?fee + mgr + ~src_pk + ~manager_sk + None + in + return_unit); command ~group ~desc:"Increase the paid storage of a smart contract." @@ -1847,25 +2050,28 @@ let commands_rw () = amount_in_bytes payer (cctxt : Protocol_client_context.full) -> - Client_keys.get_key cctxt payer >>=? fun (_, src_pk, manager_sk) -> - increase_paid_storage - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~force - ~dry_run - ~verbose_signing - ?fee - ?confirmations:cctxt#confirmations - ~simulation - ~source:payer - ~src_pk - ~manager_sk - ~destination:contract - ~fee_parameter - ~amount_in_bytes - () - >>=? fun _ -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, manager_sk = Client_keys.get_key cctxt payer in + let* _ = + increase_paid_storage + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~force + ~dry_run + ~verbose_signing + ?fee + ?confirmations:cctxt#confirmations + ~simulation + ~source:payer + ~src_pk + ~manager_sk + ~destination:contract + ~fee_parameter + ~amount_in_bytes + () + in + return_unit); command ~group ~desc:"Launch a new transaction rollup." @@ -1898,39 +2104,43 @@ let commands_rw () = alias source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - originate_tx_rollup - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun res -> - TxRollupAlias.of_fresh cctxt force alias >>=? fun alias_name -> - (match res with - | ( _, - _, - Apply_results.Manager_operation_result - { - operation_result = - Apply_operation_result.Applied - (Apply_results.Tx_rollup_origination_result - {originated_tx_rollup; _}); - _; - } ) -> - ok originated_tx_rollup - | _ -> error_with "transaction rollup was not correctly originated") - >>?= fun res -> save_tx_rollup ~force cctxt alias_name res); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* res = + originate_tx_rollup + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + () + in + let* alias_name = TxRollupAlias.of_fresh cctxt force alias in + let*? res = + match res with + | ( _, + _, + Apply_results.Manager_operation_result + { + operation_result = + Apply_operation_result.Applied + (Apply_results.Tx_rollup_origination_result + {originated_tx_rollup; _}); + _; + } ) -> + Ok originated_tx_rollup + | _ -> error_with "transaction rollup was not correctly originated" + in + save_tx_rollup ~force cctxt alias_name res); command ~group ~desc:"Submit a batch of transaction rollup operations." @@ -1968,26 +2178,29 @@ let commands_rw () = tx_rollup source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - submit_tx_rollup_batch - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~tx_rollup - ~content:(Bytes.to_string content) - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + submit_tx_rollup_batch + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~tx_rollup + ~content:(Bytes.to_string content) + () + in + return_unit); command ~group ~desc: @@ -2038,29 +2251,32 @@ let commands_rw () = inbox_merkle_root messages cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - submit_tx_rollup_commitment - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~tx_rollup - ~level - ~inbox_merkle_root - ~messages - ~predecessor - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + submit_tx_rollup_commitment + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~tx_rollup + ~level + ~inbox_merkle_root + ~messages + ~predecessor + () + in + return_unit); command ~group ~desc:"Finalize a commitment of a transaction rollup." @@ -2090,25 +2306,28 @@ let commands_rw () = tx_rollup source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - submit_tx_rollup_finalize_commitment - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~tx_rollup - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + submit_tx_rollup_finalize_commitment + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~tx_rollup + () + in + return_unit); command ~group ~desc:"Recover commitment bond from a transaction rollup." @@ -2137,25 +2356,28 @@ let commands_rw () = source tx_rollup cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - submit_tx_rollup_return_bond - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~tx_rollup - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + submit_tx_rollup_return_bond + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~tx_rollup + () + in + return_unit); command ~group ~desc:"Remove a commitment from a transaction rollup." @@ -2185,25 +2407,28 @@ let commands_rw () = tx_rollup source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - submit_tx_rollup_remove_commitment - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~tx_rollup - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + submit_tx_rollup_remove_commitment + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~tx_rollup + () + in + return_unit); command ~group ~desc:"Reject a commitment of a transaction rollup." @@ -2287,35 +2512,38 @@ let commands_rw () = proof source cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - submit_tx_rollup_rejection - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~tx_rollup - ~level - ~message:conflicting_message - ~message_position:conflicting_message_position - ~message_path:conflicting_message_path - ~message_result_hash:rejected_message_result_hash - ~message_result_path:rejected_message_result_path - ~proof - ~previous_context_hash - ~previous_withdraw_list_hash - ~previous_message_result_path - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + submit_tx_rollup_rejection + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~tx_rollup + ~level + ~message:conflicting_message + ~message_position:conflicting_message_position + ~message_path:conflicting_message_path + ~message_result_hash:rejected_message_result_hash + ~message_result_path:rejected_message_result_path + ~proof + ~previous_context_hash + ~previous_withdraw_list_hash + ~previous_message_result_path + () + in + return_unit); command ~group ~desc: @@ -2379,30 +2607,33 @@ let commands_rw () = message_result_path tickets_info cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - tx_rollup_dispatch_tickets - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~level - ~context_hash - ~message_position - ~message_result_path - ~tickets_info - ~tx_rollup - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + tx_rollup_dispatch_tickets + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~level + ~context_hash + ~message_position + ~message_result_path + ~tickets_info + ~tx_rollup + () + in + return_unit); command ~group ~desc:"Transfer tickets from an implicit account to a contract." @@ -2459,30 +2690,33 @@ let commands_rw () = ty ticketer cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - transfer_ticket - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~contents - ~ty - ~ticketer - ~amount - ~destination - ~entrypoint - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + transfer_ticket + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~contents + ~ty + ~ticketer + ~amount + ~destination + ~entrypoint + () + in + return_unit); command ~group ~desc:"Originate a new smart-contract rollup." @@ -2528,31 +2762,34 @@ let commands_rw () = parameters_ty boot_sector cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in let (module R : Alpha_context.Sc_rollup.PVM.S) = pvm in let Michelson_v1_parser.{expanded; _} = parameters_ty in let parameters_ty = Script.lazy_expr expanded in - boot_sector pvm >>=? fun boot_sector -> - sc_rollup_originate - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~kind:(Sc_rollup.Kind.of_pvm pvm) - ~boot_sector - ~parameters_ty - () - >>=? fun _res -> return_unit); + let* boot_sector = boot_sector pvm in + let* _res = + sc_rollup_originate + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~kind:(Sc_rollup.Kind.of_pvm pvm) + ~boot_sector + ~parameters_ty + () + in + return_unit); command ~group ~desc:"Send one or more messages to a smart-contract rollup." @@ -2593,35 +2830,39 @@ let commands_rw () = source rollup cctxt -> - (match messages with - | `Bin message -> return [message] - | `Json messages -> ( - match Data_encoding.(Json.destruct (list string) messages) with - | exception _ -> - failwith - "Could not read list of messages (expected list of bytes)" - | messages -> return messages)) - >>=? fun messages -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - sc_rollup_add_messages - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?dry_run:(Some dry_run) - ?verbose_signing:(Some verbose_signing) - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~rollup - ~messages - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* messages = + match messages with + | `Bin message -> return [message] + | `Json messages -> ( + match Data_encoding.(Json.destruct (list string) messages) with + | exception _ -> + failwith + "Could not read list of messages (expected list of bytes)" + | messages -> return messages) + in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + sc_rollup_add_messages + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?dry_run:(Some dry_run) + ?verbose_signing:(Some verbose_signing) + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~rollup + ~messages + ~src_pk + ~src_sk + ~fee_parameter + () + in + return_unit); command ~group ~desc:"Publish a commitment for a sc rollup" @@ -2680,29 +2921,32 @@ let commands_rw () = predecessor number_of_ticks cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in let commitment : Alpha_context.Sc_rollup.Commitment.t = {compressed_state; inbox_level; predecessor; number_of_ticks} in - sc_rollup_publish - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~rollup - ~commitment - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun _res -> return_unit); + let* _res = + sc_rollup_publish + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~rollup + ~commitment + ~src_pk + ~src_sk + ~fee_parameter + () + in + return_unit); command ~group ~desc:"Cement a commitment for a sc rollup." @@ -2742,38 +2986,46 @@ let commands_rw () = source rollup cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - sc_rollup_cement - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~rollup - ~commitment - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + sc_rollup_cement + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~rollup + ~commitment + ~src_pk + ~src_sk + ~fee_parameter + () + in + return_unit); command ~group ~desc:"List originated smart-contract rollups." no_options (prefixes ["list"; "sc"; "rollups"] @@ stop) (fun () (cctxt : Protocol_client_context.full) -> - Plugin.RPC.Sc_rollup.list cctxt (cctxt#chain, cctxt#block) - >>=? fun rollups -> - List.iter_s - (fun addr -> cctxt#message "%s" (Sc_rollup.Address.to_b58check addr)) - rollups - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* rollups = + Plugin.RPC.Sc_rollup.list cctxt (cctxt#chain, cctxt#block) + in + let*! () = + List.iter_s + (fun addr -> + cctxt#message "%s" (Sc_rollup.Address.to_b58check addr)) + rollups + in + return_unit); command ~group ~desc: @@ -2822,27 +3074,30 @@ let commands_rw () = cemented_commitment output_proof cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - sc_rollup_execute_outbox_message - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~rollup - ~cemented_commitment - ~output_proof - ~src_pk - ~src_sk - ~fee_parameter - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + sc_rollup_execute_outbox_message + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~rollup + ~cemented_commitment + ~output_proof + ~src_pk + ~src_sk + ~fee_parameter + () + in + return_unit); command ~group ~desc:"Recover commitment bond from a smart contract rollup." @@ -2874,25 +3129,28 @@ let commands_rw () = source sc_rollup cctxt -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - sc_rollup_recover_bond - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~dry_run - ~verbose_signing - ?fee - ?storage_limit - ?counter - ?confirmations:cctxt#confirmations - ~simulation - ~source - ~src_pk - ~src_sk - ~fee_parameter - ~sc_rollup - () - >>=? fun _res -> return_unit); + let open Lwt_result_syntax in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* _res = + sc_rollup_recover_bond + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~dry_run + ~verbose_signing + ?fee + ?storage_limit + ?counter + ?confirmations:cctxt#confirmations + ~simulation + ~source + ~src_pk + ~src_sk + ~fee_parameter + ~sc_rollup + () + in + return_unit); ] let commands network () = diff --git a/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml index e23e8ad821e2..29d4b1f63a06 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_contracts_commands.ml @@ -44,7 +44,8 @@ let commands () = @@ RawContractAlias.fresh_alias_param @@ RawContractAlias.source_param @@ stop) (fun force name hash cctxt -> - RawContractAlias.of_fresh cctxt force name >>=? fun name -> + let open Lwt_result_syntax in + let* name = RawContractAlias.of_fresh cctxt force name in RawContractAlias.add ~force cctxt name hash); command ~group @@ -58,24 +59,32 @@ let commands () = no_options (fixed ["list"; "known"; "contracts"]) (fun () (cctxt : Protocol_client_context.full) -> - list_contracts cctxt >>=? fun contracts -> - List.iter_es - (fun (prefix, alias, contract) -> - cctxt#message - "%s%s: %s" - prefix - alias - (Contract.to_b58check contract) - >>= return) - contracts); + let open Lwt_result_syntax in + let* contracts = list_contracts cctxt in + let*! () = + List.iter_s + (fun (prefix, alias, contract) -> + cctxt#message + "%s%s: %s" + prefix + alias + (Contract.to_b58check contract)) + contracts + in + return_unit); command ~group ~desc:"Forget the entire wallet of known contracts." (args1 (RawContractAlias.force_switch ())) (fixed ["forget"; "all"; "contracts"]) (fun force cctxt -> - fail_unless force (error_of_fmt "this can only used with option -force") - >>=? fun () -> RawContractAlias.set cctxt []); + let open Lwt_result_syntax in + let* () = + fail_unless + force + (error_of_fmt "this can only used with option -force") + in + RawContractAlias.set cctxt []); command ~group ~desc:"Display a contract from the wallet." @@ -83,5 +92,7 @@ let commands () = (prefixes ["show"; "known"; "contract"] @@ RawContractAlias.alias_param @@ stop) (fun () (_, contract) (cctxt : Protocol_client_context.full) -> - cctxt#message "%a\n%!" Contract.pp contract >>= fun () -> return_unit); + let open Lwt_result_syntax in + let*! () = cctxt#message "%a\n%!" Contract.pp contract in + return_unit); ] diff --git a/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml index e647c63f2f4e..7aa7eb5d8907 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_fa12_commands.ml @@ -53,7 +53,7 @@ let amount_param () = try let v = Z.of_string s in assert (Compare.Z.(v >= Z.zero)) ; - return v + Lwt_result_syntax.return v with _ -> failwith "invalid amount (must be a non-negative number)")) let tez_amount_arg = @@ -112,11 +112,12 @@ let view_options = let dummy_callback = Contract.Implicit Signature.Public_key_hash.zero let get_contract_caller_keys cctxt (caller : Contract.t) = + let open Lwt_result_syntax in match caller with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> - Client_keys.get_key cctxt source >>=? fun (_, caller_pk, caller_sk) -> + let* _, caller_pk, caller_sk = Client_keys.get_key cctxt source in return (source, caller_pk, caller_sk) let commands_ro () : #Protocol_client_context.full Clic.command list = @@ -131,13 +132,15 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = @@ prefixes ["implements"; "fa1.2"] @@ stop) (fun () contract (cctxt : #Protocol_client_context.full) -> - Client_proto_fa12.contract_has_fa12_interface - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - () - >>=? fun _ -> + let open Lwt_result_syntax in + let* _ = + Client_proto_fa12.contract_has_fa12_interface + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + () + in Format.printf "Contract %a has an FA1.2 interface.\n%!" Contract_hash.pp @@ -160,21 +163,24 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = contract addr (cctxt : #Protocol_client_context.full) -> + let open Lwt_syntax in let action = Client_proto_fa12.Get_balance (addr, (dummy_callback, None)) in - Client_proto_fa12.run_view_action - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ~source:addr - ?gas - ?payer - ~unparsing_mode - () - >>= fun res -> Client_proto_programs.print_view_result cctxt res); + let* res = + Client_proto_fa12.run_view_action + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ~source:addr + ?gas + ?payer + ~unparsing_mode + () + in + Client_proto_programs.print_view_result cctxt res); command ~group ~desc:"Ask for an address's allowance offchain" @@ -195,22 +201,25 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = source destination (cctxt : #Protocol_client_context.full) -> + let open Lwt_syntax in let action = Client_proto_fa12.Get_allowance (source, destination, (dummy_callback, None)) in - Client_proto_fa12.run_view_action - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ~source - ?gas - ?payer - ~unparsing_mode - () - >>= fun res -> Client_proto_programs.print_view_result cctxt res); + let* res = + Client_proto_fa12.run_view_action + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ~source + ?gas + ?payer + ~unparsing_mode + () + in + Client_proto_programs.print_view_result cctxt res); command ~group ~desc:"Ask for the contract's total token supply offchain" @@ -222,20 +231,23 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = (fun (gas, payer, unparsing_mode) contract (cctxt : #Protocol_client_context.full) -> + let open Lwt_syntax in let action = Client_proto_fa12.Get_total_supply (dummy_callback, None) in - Client_proto_fa12.run_view_action - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ?gas - ?payer - ~unparsing_mode - () - >>= fun res -> Client_proto_programs.print_view_result cctxt res); + let* res = + Client_proto_fa12.run_view_action + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ?gas + ?payer + ~unparsing_mode + () + in + Client_proto_programs.print_view_result cctxt res); command ~group ~desc:"Ask for an address's balance using a callback contract" @@ -267,35 +279,40 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = addr callback (cctxt : #Protocol_client_context.full) -> - get_contract_caller_keys cctxt addr - >>=? fun (source, src_pk, src_sk) -> + let open Lwt_result_syntax in + let* source, src_pk, src_sk = get_contract_caller_keys cctxt addr in let action = Client_proto_fa12.Get_balance (addr, (callback, callback_entrypoint)) in - Client_proto_fa12.call_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ~source - ~src_pk - ~src_sk - ~tez_amount - ?gas_limit - ?storage_limit - ?counter - ~fee_parameter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= fun _ -> return_unit); + let*! errors = + Client_proto_fa12.call_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ~source + ~src_pk + ~src_sk + ~tez_amount + ?gas_limit + ?storage_limit + ?counter + ~fee_parameter + () + in + let*! _ = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + return_unit); command ~group ~desc:"Ask for an address's allowance using a callback contract" @@ -330,36 +347,41 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = dst callback (cctxt : #Protocol_client_context.full) -> - get_contract_caller_keys cctxt src - >>=? fun (source, src_pk, src_sk) -> + let open Lwt_result_syntax in + let* source, src_pk, src_sk = get_contract_caller_keys cctxt src in let action = Client_proto_fa12.Get_allowance (src, dst, (callback, callback_entrypoint)) in - Client_proto_fa12.call_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ~source - ~src_pk - ~src_sk - ~tez_amount - ?gas_limit - ?storage_limit - ?counter - ~fee_parameter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= fun _ -> return_unit); + let*! errors = + Client_proto_fa12.call_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ~source + ~src_pk + ~src_sk + ~tez_amount + ?gas_limit + ?storage_limit + ?counter + ~fee_parameter + () + in + let*! _ = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + return_unit); command ~group ~desc: @@ -390,35 +412,40 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = addr callback (cctxt : #Protocol_client_context.full) -> - get_contract_caller_keys cctxt addr - >>=? fun (source, src_pk, src_sk) -> + let open Lwt_result_syntax in + let* source, src_pk, src_sk = get_contract_caller_keys cctxt addr in let action = Client_proto_fa12.Get_total_supply (callback, callback_entrypoint) in - Client_proto_fa12.call_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ~source - ~src_pk - ~src_sk - ~tez_amount - ?gas_limit - ?storage_limit - ?counter - ~fee_parameter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= fun _ -> return_unit); + let*! errors = + Client_proto_fa12.call_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ~source + ~src_pk + ~src_sk + ~tez_amount + ?gas_limit + ?storage_limit + ?counter + ~fee_parameter + () + in + let*! _ = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + return_unit); ] let commands_rw () : #Protocol_client_context.full Clic.command list = @@ -458,34 +485,41 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src dst (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in let caller = Option.value ~default:src as_address in - get_contract_caller_keys cctxt caller - >>=? fun (source, caller_pk, caller_sk) -> + let* source, caller_pk, caller_sk = + get_contract_caller_keys cctxt caller + in let action = Client_proto_fa12.Transfer (src, dst, amount) in - Client_proto_fa12.call_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ~source - ~src_pk:caller_pk - ~src_sk:caller_sk - ~tez_amount - ?gas_limit - ?storage_limit - ?counter - ~fee_parameter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= fun _ -> return_unit); + let*! errors = + Client_proto_fa12.call_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ~source + ~src_pk:caller_pk + ~src_sk:caller_sk + ~tez_amount + ?gas_limit + ?storage_limit + ?counter + ~fee_parameter + () + in + let*! _ = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + return_unit); command ~group ~desc:"Allow account to transfer an amount of token" @@ -512,33 +546,38 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = amount dst (cctxt : #Protocol_client_context.full) -> - get_contract_caller_keys cctxt source - >>=? fun (source, src_pk, src_sk) -> + let open Lwt_result_syntax in + let* source, src_pk, src_sk = get_contract_caller_keys cctxt source in let action = Client_proto_fa12.Approve (dst, amount) in - Client_proto_fa12.call_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~action - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ?fee - ~source - ~src_pk - ~src_sk - ~tez_amount - ?gas_limit - ?storage_limit - ?counter - ~fee_parameter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= fun _ -> return_unit); + let*! errors = + Client_proto_fa12.call_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~action + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ?fee + ~source + ~src_pk + ~src_sk + ~tez_amount + ?gas_limit + ?storage_limit + ?counter + ~fee_parameter + () + in + let*! _ = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + return_unit); command ~group ~desc: @@ -587,6 +626,7 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = src operations_json cctxt -> + let open Lwt_result_syntax in let caller = Option.value ~default:src as_address in match Data_encoding.Json.destruct @@ -595,31 +635,37 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = with | [] -> failwith "Empty operation list" | operations -> - get_contract_caller_keys cctxt caller - >>=? fun (source, src_pk, src_sk) -> - Client_proto_fa12.inject_token_transfer_batch - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~sender:src - ~source - ~src_pk - ~src_sk - ~token_transfers:operations - ~fee_parameter - ?counter - ?default_fee:fee - ?default_gas_limit:gas_limit - ?default_storage_limit:storage_limit - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"multiple transfers simulation failed" - cctxt - >>= fun _ -> return_unit + let* source, src_pk, src_sk = + get_contract_caller_keys cctxt caller + in + let*! errors = + Client_proto_fa12.inject_token_transfer_batch + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~sender:src + ~source + ~src_pk + ~src_sk + ~token_transfers:operations + ~fee_parameter + ?counter + ?default_fee:fee + ?default_gas_limit:gas_limit + ?default_storage_limit:storage_limit + () + in + let*! _ = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"multiple transfers simulation failed" + cctxt + errors + in + return_unit | exception (Data_encoding.Json.Cannot_destruct (path, exn2) as exn) -> ( match (path, operations_json) with diff --git a/src/proto_alpha/lib_client_commands/client_proto_mockup_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_mockup_commands.ml index 47c00a38eebf..eeadfa1e82b1 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_mockup_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_mockup_commands.ml @@ -30,7 +30,7 @@ let protocol_constants_arg = ~doc:"a JSON file that contains protocol constants to set." ~long:"protocol-constants" ~placeholder:"path" - (Clic.parameter (fun _ x -> return x)) + (Clic.parameter (fun _ x -> Lwt_result_syntax.return x)) let bootstrap_accounts_arg = Clic.arg @@ -38,7 +38,7 @@ let bootstrap_accounts_arg = "a JSON file that contains definitions of bootstrap accounts to create." ~long:"bootstrap-accounts" ~placeholder:"path" - (Clic.parameter (fun _ x -> return x)) + (Clic.parameter (fun _ x -> Lwt_result_syntax.return x)) let asynchronous_flag = Clic.switch @@ -47,26 +47,29 @@ let asynchronous_flag = () let load_json_file (cctxt : Protocol_client_context.full) json_file = + let open Lwt_result_syntax in match json_file with | None -> return None | Some filename -> - cctxt#read_file filename >>=? fun json_string -> + let* json_string = cctxt#read_file filename in return (Some (Ezjsonm.from_string json_string :> Data_encoding.json)) let create_mockup_command_handler (constants_overrides_file, bootstrap_accounts_file, asynchronous) (cctxt : Protocol_client_context.full) = - load_json_file cctxt constants_overrides_file - >>=? fun constants_overrides_json -> - load_json_file cctxt bootstrap_accounts_file - >>=? fun bootstrap_accounts_json -> - Tezos_mockup.Persistence.create_mockup - ~cctxt:(cctxt :> Tezos_client_base.Client_context.full) - ~protocol_hash:Protocol.hash - ~constants_overrides_json - ~bootstrap_accounts_json - ~asynchronous - >>=? fun () -> + let open Lwt_result_syntax in + let* constants_overrides_json = + load_json_file cctxt constants_overrides_file + in + let* bootstrap_accounts_json = load_json_file cctxt bootstrap_accounts_file in + let* () = + Tezos_mockup.Persistence.create_mockup + ~cctxt:(cctxt :> Tezos_client_base.Client_context.full) + ~protocol_hash:Protocol.hash + ~constants_overrides_json + ~bootstrap_accounts_json + ~asynchronous + in Tezos_mockup_commands.Mockup_wallet.populate cctxt bootstrap_accounts_file let create_mockup_command : Protocol_client_context.full Clic.command = diff --git a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml index f3ed1dbf2ade..4cb223e9d4a2 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_multisig_commands.ml @@ -132,19 +132,22 @@ let prepare_command_display prepared_command bytes_only = let get_parameter_type (cctxt : #Protocol_client_context.full) ~(destination : Contract.t) ~entrypoint = + let open Lwt_result_syntax in match destination with | Implicit _ -> let open Micheline in return @@ strip_locations @@ Prim (0, Script.T_unit, [], []) | Originated contract -> ( - Michelson_v1_entrypoints.contract_entrypoint_type - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~contract - ~entrypoint - ~normalize_types:true - >>=? function + let* o = + Michelson_v1_entrypoints.contract_entrypoint_type + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~contract + ~entrypoint + ~normalize_types:true + in + match o with | None -> cctxt#error "Contract %a has no entrypoint named %a" @@ -167,7 +170,7 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = List.iter (fun h -> Format.printf "%a@." Script_expr_hash.pp h) Client_proto_multisig.known_multisig_hashes ; - return_unit); + Lwt_result_syntax.return_unit); command ~group ~desc:"Show the script of the recommended multisig contract." @@ -179,7 +182,7 @@ let commands_ro () : #Protocol_client_context.full Clic.command list = Client_proto_multisig.multisig_script in Format.printf "%s@." source ; - return_unit); + Lwt_result_syntax.return_unit); ] let commands_rw () : #Protocol_client_context.full Clic.command list = @@ -229,57 +232,65 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = threshold keys (cctxt : #Protocol_client_context.full) -> - Client_proto_contracts.RawContractAlias.of_fresh - cctxt - force - alias_name - >>=? fun alias_name -> + let open Lwt_result_syntax in + let* alias_name = + Client_proto_contracts.RawContractAlias.of_fresh + cctxt + force + alias_name + in match source with | Originated _ -> failwith "only implicit accounts can be the source of an origination" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - List.map_es - (fun (pk_uri, _) -> Client_keys.public_key pk_uri) - keys - >>=? fun keys -> - Client_proto_multisig.originate_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ?fee - ?gas_limit - ?storage_limit - ~verbose_signing - ~delegate - ~threshold:(Z.of_int threshold) - ~keys - ~balance - ~source - ~src_pk - ~src_sk - ~fee_parameter - () - >>= fun errors -> - Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"multisig origination simulation failed" - cctxt - errors - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* keys = + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + keys + in + let*! errors = + Client_proto_multisig.originate_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ?fee + ?gas_limit + ?storage_limit + ~verbose_signing + ~delegate + ~threshold:(Z.of_int threshold) + ~keys + ~balance + ~source + ~src_pk + ~src_sk + ~fee_parameter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"multisig origination simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, contract) -> if dry_run then return_unit else - Client_proto_context.save_contract - ~force - cctxt - alias_name - contract - >>=? fun () -> return_unit)); + let* () = + Client_proto_context.save_contract + ~force + cctxt + alias_name + contract + in + return_unit)); command ~group ~desc:"Sign a transaction for a multisig contract." @@ -304,27 +315,32 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = destination sk (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in let entrypoint = Option.value ~default:Entrypoint.default entrypoint in let parameter = Option.value ~default:"Unit" parameter in - Lwt.return @@ Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression parameter - >>=? fun {expanded = parameter; _} -> - get_parameter_type cctxt ~destination ~entrypoint - >>=? fun parameter_type -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action: - (Client_proto_multisig.Transfer - {amount; destination; entrypoint; parameter_type; parameter}) - () - >>=? fun prepared_command -> - Client_keys.sign cctxt sk prepared_command.bytes >>=? fun signature -> - return @@ Format.printf "%a@." Signature.pp signature); + let*? {expanded = parameter; _} = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression parameter + in + let* parameter_type = + get_parameter_type cctxt ~destination ~entrypoint + in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action: + (Client_proto_multisig.Transfer + {amount; destination; entrypoint; parameter_type; parameter}) + () + in + let* signature = Client_keys.sign cctxt sk prepared_command.bytes in + Format.printf "%a@." Signature.pp signature ; + return_unit); command ~group ~desc:"Sign a lambda for a generic multisig contract." @@ -342,19 +358,23 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = lambda sk (cctxt : #Protocol_client_context.full) -> - Lwt.return @@ Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression lambda - >>=? fun {expanded = lambda; _} -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action:(Lambda lambda) - () - >>=? fun prepared_command -> - Client_keys.sign cctxt sk prepared_command.bytes >>=? fun signature -> - return @@ Format.printf "%a@." Signature.pp signature); + let open Lwt_result_syntax in + let*? {expanded = lambda; _} = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression lambda + in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action:(Lambda lambda) + () + in + let* signature = Client_keys.sign cctxt sk prepared_command.bytes in + Format.printf "%a@." Signature.pp signature ; + return_unit); command ~group ~desc:"Sign a delegate change for a multisig contract." @@ -374,16 +394,19 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = delegate sk (cctxt : #Protocol_client_context.full) -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate (Some delegate)) - () - >>=? fun prepared_command -> - Client_keys.sign cctxt sk prepared_command.bytes >>=? fun signature -> - return @@ Format.printf "%a@." Signature.pp signature); + let open Lwt_result_syntax in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action:(Client_proto_multisig.Change_delegate (Some delegate)) + () + in + let* signature = Client_keys.sign cctxt sk prepared_command.bytes in + Format.printf "%a@." Signature.pp signature ; + return_unit); command ~group ~desc:"Sign a delegate withdraw for a multisig contract." @@ -396,16 +419,19 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = @@ prefixes ["using"; "secret"; "key"] @@ secret_key_param () @@ stop) (fun () multisig_contract sk (cctxt : #Protocol_client_context.full) -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate None) - () - >>=? fun prepared_command -> - Client_keys.sign cctxt sk prepared_command.bytes >>=? fun signature -> - return @@ Format.printf "%a@." Signature.pp signature); + let open Lwt_result_syntax in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action:(Client_proto_multisig.Change_delegate None) + () + in + let* signature = Client_keys.sign cctxt sk prepared_command.bytes in + Format.printf "%a@." Signature.pp signature ; + return_unit); command ~group ~desc: @@ -427,21 +453,25 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - List.map_es - (fun (pk_uri, _) -> Client_keys.public_key pk_uri) - new_keys - >>=? fun keys -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action: - (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys)) - () - >>=? fun prepared_command -> - Client_keys.sign cctxt sk prepared_command.bytes >>=? fun signature -> - return @@ Format.printf "%a@." Signature.pp signature); + let open Lwt_result_syntax in + let* keys = + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys + in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action: + (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys)) + () + in + let* signature = Client_keys.sign cctxt sk prepared_command.bytes in + Format.printf "%a@." Signature.pp signature ; + return_unit); command ~group ~desc:"Transfer tokens using a multisig contract." @@ -480,54 +510,62 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = source signatures (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in let entrypoint = Option.value ~default:Entrypoint.default entrypoint in let parameter = Option.value ~default:"Unit" parameter in - Lwt.return @@ Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression parameter - >>=? fun {expanded = parameter; _} -> - get_parameter_type cctxt ~destination ~entrypoint - >>=? fun parameter_type -> + let*? {expanded = parameter; _} = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression parameter + in + let* parameter_type = + get_parameter_type cctxt ~destination ~entrypoint + in match source with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action: - (Client_proto_multisig.Transfer - { - amount; - destination; - entrypoint; - parameter_type; - parameter; - }) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + Client_proto_multisig.call_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action: + (Client_proto_multisig.Transfer + { + amount; + destination; + entrypoint; + parameter_type; + parameter; + }) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, _contracts) -> return_unit)); command @@ -559,40 +597,47 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = source signatures (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in match source with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Lwt.return @@ Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression lambda - >>=? fun {expanded = lambda; _} -> - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action:(Client_proto_multisig.Lambda lambda) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*? {expanded = lambda; _} = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression lambda + in + let*! errors = + Client_proto_multisig.call_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action:(Client_proto_multisig.Lambda lambda) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, _contracts) -> return_unit)); command @@ -626,37 +671,44 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = source signatures (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in match source with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate (Some delegate)) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + Client_proto_multisig.call_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action: + (Client_proto_multisig.Change_delegate (Some delegate)) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, _contracts) -> return_unit)); command @@ -685,37 +737,43 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = source signatures (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in match source with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate None) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + Client_proto_multisig.call_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action:(Client_proto_multisig.Change_delegate None) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, _contracts) -> return_unit)); command @@ -748,43 +806,50 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = source signatures (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in match source with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - List.map_es - (fun (pk_uri, _) -> Client_keys.public_key pk_uri) - new_keys - >>=? fun keys -> - Client_proto_multisig.call_multisig - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~action: - (Client_proto_multisig.Change_keys - (Z.of_int new_threshold, keys)) - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let* keys = + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys + in + let*! errors = + Client_proto_multisig.call_multisig + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~action: + (Client_proto_multisig.Change_keys + (Z.of_int new_threshold, keys)) + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, _contracts) -> return_unit)); (* This command is no longer necessary as Clic now supports non terminal @@ -825,37 +890,43 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = source signatures (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in match source with | Originated _ -> failwith "only implicit accounts can be the source of a contract call" | Implicit source -> ( - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> - Client_proto_multisig.call_multisig_on_bytes - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ?confirmations:cctxt#confirmations - ~dry_run - ~verbose_signing - ~fee_parameter - ~source - ?fee - ~src_pk - ~src_sk - ~multisig_contract - ~bytes - ~signatures - ~amount:Tez.zero - ?gas_limit - ?storage_limit - ?counter - () - >>= Client_proto_context_commands.report_michelson_errors - ~no_print_source - ~msg:"transfer simulation failed" - cctxt - >>= function + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in + let*! errors = + Client_proto_multisig.call_multisig_on_bytes + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ?confirmations:cctxt#confirmations + ~dry_run + ~verbose_signing + ~fee_parameter + ~source + ?fee + ~src_pk + ~src_sk + ~multisig_contract + ~bytes + ~signatures + ~amount:Tez.zero + ?gas_limit + ?storage_limit + ?counter + () + in + let*! o = + Client_proto_context_commands.report_michelson_errors + ~no_print_source + ~msg:"transfer simulation failed" + cctxt + errors + in + match o with | None -> return_unit | Some (_res, _contracts) -> return_unit)); command @@ -882,25 +953,29 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = amount destination (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in let entrypoint = Option.value ~default:Entrypoint.default entrypoint in let parameter = Option.value ~default:"Unit" parameter in - Lwt.return @@ Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression parameter - >>=? fun {expanded = parameter; _} -> - get_parameter_type cctxt ~destination ~entrypoint - >>=? fun parameter_type -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action: - (Client_proto_multisig.Transfer - {amount; destination; entrypoint; parameter_type; parameter}) - () - >>=? fun prepared_command -> + let*? {expanded = parameter; _} = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression parameter + in + let* parameter_type = + get_parameter_type cctxt ~destination ~entrypoint + in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action: + (Client_proto_multisig.Transfer + {amount; destination; entrypoint; parameter_type; parameter}) + () + in return @@ prepare_command_display prepared_command bytes_only); command ~group @@ -918,17 +993,20 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = multisig_contract lambda (cctxt : #Protocol_client_context.full) -> - Lwt.return @@ Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression lambda - >>=? fun {expanded = lambda; _} -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action:(Client_proto_multisig.Lambda lambda) - () - >>=? fun prepared_command -> + let open Lwt_result_syntax in + let*? {expanded = lambda; _} = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression lambda + in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action:(Client_proto_multisig.Lambda lambda) + () + in return @@ prepare_command_display prepared_command bytes_only); command ~group @@ -949,14 +1027,17 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = multisig_contract new_delegate (cctxt : #Protocol_client_context.full) -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate (Some new_delegate)) - () - >>=? fun prepared_command -> + let open Lwt_result_syntax in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action: + (Client_proto_multisig.Change_delegate (Some new_delegate)) + () + in return @@ prepare_command_display prepared_command bytes_only); command ~group @@ -973,14 +1054,16 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = (fun bytes_only multisig_contract (cctxt : #Protocol_client_context.full) -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action:(Client_proto_multisig.Change_delegate None) - () - >>=? fun prepared_command -> + let open Lwt_result_syntax in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action:(Client_proto_multisig.Change_delegate None) + () + in return @@ prepare_command_display prepared_command bytes_only); command ~group @@ -1001,19 +1084,22 @@ let commands_rw () : #Protocol_client_context.full Clic.command list = new_threshold new_keys (cctxt : #Protocol_client_context.full) -> - List.map_es - (fun (pk_uri, _) -> Client_keys.public_key pk_uri) - new_keys - >>=? fun keys -> - Client_proto_multisig.prepare_multisig_transaction - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~multisig_contract - ~action: - (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys)) - () - >>=? fun prepared_command -> + let open Lwt_result_syntax in + let* keys = + List.map_es + (fun (pk_uri, _) -> Client_keys.public_key pk_uri) + new_keys + in + let* prepared_command = + Client_proto_multisig.prepare_multisig_transaction + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~multisig_contract + ~action: + (Client_proto_multisig.Change_keys (Z.of_int new_threshold, keys)) + () + in return @@ prepare_command_display prepared_command bytes_only); ] diff --git a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml index 876437f76fb4..ab5f1cb6ff11 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_programs_commands.ml @@ -48,7 +48,7 @@ let safe_decode_json (cctxt : Protocol_client_context.full) encoding json = | exception ((Stack_overflow | Out_of_memory) as exc) -> raise exc | exception exc -> cctxt#error "could not decode json (%s)" (Printexc.to_string exc) - | expr -> return expr + | expr -> Lwt_result_syntax.return expr let commands () = let open Clic in @@ -109,10 +109,13 @@ let commands () = in let now_arg = Client_proto_args.now_arg in let level_arg = Client_proto_args.level_arg in - let resolve_max_gas cctxt block = function + let resolve_max_gas cctxt block = + let open Lwt_result_syntax in + function | None -> - Alpha_services.Constants.all cctxt (cctxt#chain, block) - >>=? fun {parametric = {hard_gas_limit_per_operation; _}; _} -> + let* {parametric = {hard_gas_limit_per_operation; _}; _} = + Alpha_services.Constants.all cctxt (cctxt#chain, block) + in return hard_gas_limit_per_operation | Some gas -> return gas in @@ -134,10 +137,11 @@ let commands () = let signature_parameter = parameter (fun _cctxt s -> match Signature.of_b58check_opt s with - | Some s -> return s + | Some s -> Lwt_result_syntax.return s | None -> failwith "Not given a valid signature") in let convert_input_format_param = + let open Lwt_result_syntax in param ~name:"input_format" ~desc:"format of the input for conversion" @@ -154,6 +158,7 @@ let commands () = \"json\" or \"binary\".")) in let convert_output_format_param = + let open Lwt_result_syntax in param ~name:"output_format" ~desc:"format of the conversion output" @@ -176,33 +181,40 @@ let commands () = ~name:"source" ~desc:"literal or a path to a file" (parameter (fun cctxt s -> - cctxt#read_file s >>= function + let open Lwt_result_syntax in + let*! r = cctxt#read_file s in + match r with | Ok v -> return (Some s, v) | Error _ -> return (None, s))) in let handle_parsing_error label (cctxt : Protocol_client_context.full) (emacs_mode, no_print_source) program body = + let open Lwt_result_syntax in match program with | program, [] -> body program | res_with_errors when emacs_mode -> - cctxt#message - "(@[(%s . ())@ (errors . %a)@])" - label - Michelson_v1_emacs.report_errors - res_with_errors - >>= fun () -> return_unit + let*! () = + cctxt#message + "(@[(%s . ())@ (errors . %a)@])" + label + Michelson_v1_emacs.report_errors + res_with_errors + in + return_unit | parsed, errors -> - cctxt#message - "%a" - (fun ppf () -> - Michelson_v1_error_reporter.report_errors - ~details:(not no_print_source) - ~parsed - ~show_source:(not no_print_source) - ppf - errors) - () - >>= fun () -> cctxt#error "syntax error in program" + let*! () = + cctxt#message + "%a" + (fun ppf () -> + Michelson_v1_error_reporter.report_errors + ~details:(not no_print_source) + ~parsed + ~show_source:(not no_print_source) + ppf + errors) + () + in + cctxt#error "syntax error in program" in [ command @@ -211,8 +223,9 @@ let commands () = no_options (fixed ["list"; "known"; "scripts"]) (fun () (cctxt : Protocol_client_context.full) -> - Program.load cctxt >>=? fun list -> - List.iter_s (fun (n, _) -> cctxt#message "%s" n) list >>= fun () -> + let open Lwt_result_syntax in + let* list = Program.load cctxt in + let*! () = List.iter_s (fun (n, _) -> cctxt#message "%s" n) list in return_unit); command ~group @@ -221,7 +234,8 @@ let commands () = (prefixes ["remember"; "script"] @@ Program.fresh_alias_param @@ Program.source_param @@ stop) (fun force name hash cctxt -> - Program.of_fresh cctxt force name >>=? fun name -> + let open Lwt_result_syntax in + let* name = Program.of_fresh cctxt force name in Program.add ~force cctxt name hash); command ~group @@ -235,8 +249,10 @@ let commands () = no_options (prefixes ["show"; "known"; "script"] @@ Program.alias_param @@ stop) (fun () (_, program) (cctxt : Protocol_client_context.full) -> - Program.to_source program >>=? fun source -> - cctxt#message "%s\n" source >>= fun () -> return_unit); + let open Lwt_result_syntax in + let* source = Program.to_source program in + let*! () = cctxt#message "%s\n" source in + return_unit); command ~group ~desc:"Ask the node to run a script." @@ -276,42 +292,45 @@ let commands () = storage input cctxt -> - Lwt.return @@ Micheline_parser.no_parsing_error program - >>=? fun program -> + let open Lwt_result_syntax in + let*? program = Micheline_parser.no_parsing_error program in let show_source = not no_print_source in if trace_exec then - trace - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - { - amount = Some amount; - balance; - program; - storage; - shared_params = - {input; unparsing_mode; now; level; source; payer; gas}; - entrypoint; - self; - } - >>= fun res -> + let*! res = + trace + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + { + amount = Some amount; + balance; + program; + storage; + shared_params = + {input; unparsing_mode; now; level; source; payer; gas}; + entrypoint; + self; + } + in print_trace_result cctxt ~show_source ~parsed:program res else - run - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - { - amount = Some amount; - balance; - program; - storage; - shared_params = - {input; unparsing_mode; now; level; source; payer; gas}; - entrypoint; - self; - } - >>= fun res -> print_run_result cctxt ~show_source ~parsed:program res); + let*! res = + run + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + { + amount = Some amount; + balance; + program; + storage; + shared_params = + {input; unparsing_mode; now; level; source; payer; gas}; + entrypoint; + self; + } + in + print_run_result cctxt ~show_source ~parsed:program res); command ~group ~desc:"Ask the node to compute the size of a script." @@ -329,20 +348,23 @@ let commands () = program storage cctxt -> + let open Lwt_result_syntax in let setup = (emacs_mode, no_print_source) in - resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> + let* original_gas = resolve_max_gas cctxt cctxt#block original_gas in handle_parsing_error "size" cctxt setup program @@ fun program -> - script_size - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~gas:original_gas - ~legacy - ~program - ~storage - () - >>=? fun code_size -> - cctxt#message "%d" code_size >>= fun _ -> return ()); + let* code_size = + script_size + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~gas:original_gas + ~legacy + ~program + ~storage + () + in + let*! _ = cctxt#message "%d" code_size in + return_unit); command ~group ~desc:"Ask the node to typecheck a script." @@ -356,18 +378,20 @@ let commands () = (fun (show_types, emacs_mode, no_print_source, original_gas, legacy) program cctxt -> + let open Lwt_result_syntax in let setup = (emacs_mode, no_print_source) in handle_parsing_error "types" cctxt setup program @@ fun program -> - resolve_max_gas cctxt cctxt#block original_gas >>=? fun original_gas -> - typecheck_program - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~gas:original_gas - ~legacy - ~show_types - program - >>= fun res -> + let* original_gas = resolve_max_gas cctxt cctxt#block original_gas in + let*! res = + typecheck_program + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~gas:original_gas + ~legacy + ~show_types + program + in print_typecheck_result ~emacs:emacs_mode ~show_types @@ -385,32 +409,39 @@ let commands () = @@ param ~name:"type" ~desc:"the expected type" data_parameter @@ stop) (fun (no_print_source, custom_gas, legacy) data ty cctxt -> - resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas -> - Client_proto_programs.typecheck_data - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~gas:original_gas - ~legacy - ~data - ~ty - () - >>= function + let open Lwt_result_syntax in + let* original_gas = resolve_max_gas cctxt cctxt#block custom_gas in + let*! r = + Client_proto_programs.typecheck_data + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~gas:original_gas + ~legacy + ~data + ~ty + () + in + match r with | Ok gas -> - cctxt#message - "@[Well typed@,Gas remaining: %a@]" - Alpha_context.Gas.pp - gas - >>= fun () -> return_unit + let*! () = + cctxt#message + "@[Well typed@,Gas remaining: %a@]" + Alpha_context.Gas.pp + gas + in + return_unit | Error errs -> - cctxt#warning - "%a" - (Michelson_v1_error_reporter.report_errors - ~details:false - ~show_source:(not no_print_source) - ?parsed:None) - errs - >>= fun () -> cctxt#error "ill-typed data"); + let*! () = + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:(not no_print_source) + ?parsed:None) + errs + in + cctxt#error "ill-typed data"); command ~group ~desc: @@ -426,14 +457,17 @@ let commands () = @@ param ~name:"type" ~desc:"type of the data" data_parameter @@ stop) (fun (custom_gas, scriptable) data typ cctxt -> - resolve_max_gas cctxt cctxt#block custom_gas >>=? fun original_gas -> - Plugin.RPC.Scripts.pack_data - cctxt - (cctxt#chain, cctxt#block) - ~gas:original_gas - ~data:data.expanded - ~ty:typ.expanded - >>= function + let open Lwt_result_syntax in + let* original_gas = resolve_max_gas cctxt cctxt#block custom_gas in + let*! r = + Plugin.RPC.Scripts.pack_data + cctxt + (cctxt#chain, cctxt#block) + ~gas:original_gas + ~data:data.expanded + ~ty:typ.expanded + in + match r with | Ok (bytes, remaining_gas) -> let hash = Script_expr_hash.hash_bytes [bytes] in let name_value_rows = @@ -468,21 +502,25 @@ let commands () = Tezos_clic_unix.Scriptable.output scriptable ~for_human:(fun () -> - List.iter_s - (fun (name, value) -> cctxt#message "%s: %s" name value) - name_value_rows - >|= ok) + let*! () = + List.iter_s + (fun (name, value) -> cctxt#message "%s: %s" name value) + name_value_rows + in + return_unit) ~for_script:(fun () -> name_value_rows |> List.map (fun (name, value) -> [name; value])) | Error errs -> - cctxt#warning - "%a" - (Michelson_v1_error_reporter.report_errors - ~details:false - ~show_source:false - ?parsed:None) - errs - >>= fun () -> cctxt#error "ill-formed data"); + let*! () = + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:false + ?parsed:None) + errs + in + cctxt#error "ill-formed data"); command ~group ~desc:"Ask the node to hash a Michelson script with `BLAKE2B`." @@ -494,44 +532,51 @@ let commands () = (fun (check, display_names, scriptable) expr_strings (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in if List.compare_length_with expr_strings 0 = 0 then - cctxt#warning "No scripts were specified on the command line" >|= ok + let*! () = + cctxt#warning "No scripts were specified on the command line" + in + return_unit else - List.mapi_ep - (fun i (src, expr_string) -> - let program = - Michelson_v1_parser.parse_toplevel ~check expr_string - in - Micheline_parser.no_parsing_error program >>?= fun program -> - let code = program.expanded in - let bytes = - Data_encoding.Binary.to_bytes_exn - Alpha_context.Script.expr_encoding - code - in - let hash = - Format.asprintf - "%a" - Script_expr_hash.pp - (Script_expr_hash.hash_bytes [bytes]) - in - let name = - Option.value - src - ~default:("Literal script " ^ string_of_int (i + 1)) - in - return (hash, name)) - expr_strings - >>=? fun hash_name_rows -> + let* hash_name_rows = + List.mapi_ep + (fun i (src, expr_string) -> + let program = + Michelson_v1_parser.parse_toplevel ~check expr_string + in + let*? program = Micheline_parser.no_parsing_error program in + let code = program.expanded in + let bytes = + Data_encoding.Binary.to_bytes_exn + Alpha_context.Script.expr_encoding + code + in + let hash = + Format.asprintf + "%a" + Script_expr_hash.pp + (Script_expr_hash.hash_bytes [bytes]) + in + let name = + Option.value + src + ~default:("Literal script " ^ string_of_int (i + 1)) + in + return (hash, name)) + expr_strings + in Tezos_clic_unix.Scriptable.output scriptable ~for_human:(fun () -> - List.iter_s - (fun (hash, name) -> - if display_names then cctxt#answer "%s\t%s" hash name - else cctxt#answer "%s" hash) - hash_name_rows - >|= ok) + let*! () = + List.iter_s + (fun (hash, name) -> + if display_names then cctxt#answer "%s\t%s" hash name + else cctxt#answer "%s" hash) + hash_name_rows + in + return_unit) ~for_script:(fun () -> List.map (fun (hash, name) -> @@ -547,11 +592,13 @@ let commands () = @@ bytes_parameter ~name:"bytes" ~desc:"the packed data to parse" @@ stop) (fun () bytes cctxt -> - (if Bytes.get bytes 0 != '\005' then - failwith - "Not a piece of packed Michelson data (must start with `0x05`)" - else return_unit) - >>=? fun () -> + let open Lwt_result_syntax in + let* () = + if Bytes.get bytes 0 != '\005' then + failwith + "Not a piece of packed Michelson data (must start with `0x05`)" + else return_unit + in (* Remove first byte *) let bytes = Bytes.sub bytes 1 (Bytes.length bytes - 1) in match @@ -561,38 +608,46 @@ let commands () = with | None -> failwith "Could not decode bytes" | Some expr -> - cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr - >>= fun () -> return_unit); + let*! () = + cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr + in + return_unit); command ~group ~desc:"Ask the node to normalize a script." (args1 (unparsing_mode_arg ~default:"Readable")) (prefixes ["normalize"; "script"] @@ Program.source_param @@ stop) (fun unparsing_mode program cctxt -> - Lwt.return @@ Micheline_parser.no_parsing_error program - >>=? fun program -> - Plugin.RPC.Scripts.normalize_script - cctxt - (cctxt#chain, cctxt#block) - ~script:program.expanded - ~unparsing_mode - >>= function + let open Lwt_result_syntax in + let*? program = Micheline_parser.no_parsing_error program in + let*! r = + Plugin.RPC.Scripts.normalize_script + cctxt + (cctxt#chain, cctxt#block) + ~script:program.expanded + ~unparsing_mode + in + match r with | Ok program -> - cctxt#message - "%a" - (fun ppf () : unit -> - Michelson_v1_printer.print_expr_unwrapped ppf program) - () - >>= fun () -> return_unit + let*! () = + cctxt#message + "%a" + (fun ppf () : unit -> + Michelson_v1_printer.print_expr_unwrapped ppf program) + () + in + return_unit | Error errs -> - cctxt#warning - "%a" - (Michelson_v1_error_reporter.report_errors - ~details:false - ~show_source:false - ?parsed:None) - errs - >>= fun () -> cctxt#error "ill-typed script"); + let*! () = + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:false + ?parsed:None) + errs + in + cctxt#error "ill-typed script"); command ~group ~desc:"Ask the node to normalize a data expression." @@ -606,26 +661,33 @@ let commands () = @@ param ~name:"type" ~desc:"type of the data expression" data_parameter @@ stop) (fun (unparsing_mode, legacy) data typ cctxt -> - Plugin.RPC.Scripts.normalize_data - cctxt - (cctxt#chain, cctxt#block) - ~legacy - ~data:data.expanded - ~ty:typ.expanded - ~unparsing_mode - >>= function + let open Lwt_result_syntax in + let*! r = + Plugin.RPC.Scripts.normalize_data + cctxt + (cctxt#chain, cctxt#block) + ~legacy + ~data:data.expanded + ~ty:typ.expanded + ~unparsing_mode + in + match r with | Ok expr -> - cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr - >>= fun () -> return_unit + let*! () = + cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr + in + return_unit | Error errs -> - cctxt#warning - "%a" - (Michelson_v1_error_reporter.report_errors - ~details:false - ~show_source:false - ?parsed:None) - errs - >>= fun () -> cctxt#error "ill-typed data expression"); + let*! () = + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:false + ?parsed:None) + errs + in + cctxt#error "ill-typed data expression"); command ~group ~desc:"Ask the node to normalize a type." @@ -637,23 +699,30 @@ let commands () = data_parameter @@ stop) (fun () typ cctxt -> - Plugin.RPC.Scripts.normalize_type - cctxt - (cctxt#chain, cctxt#block) - ~ty:typ.expanded - >>= function + let open Lwt_result_syntax in + let*! r = + Plugin.RPC.Scripts.normalize_type + cctxt + (cctxt#chain, cctxt#block) + ~ty:typ.expanded + in + match r with | Ok expr -> - cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr - >>= fun () -> return_unit + let*! () = + cctxt#message "%a" Michelson_v1_printer.print_expr_unwrapped expr + in + return_unit | Error errs -> - cctxt#warning - "%a" - (Michelson_v1_error_reporter.report_errors - ~details:false - ~show_source:false - ?parsed:None) - errs - >>= fun () -> cctxt#error "ill-formed type"); + let*! () = + cctxt#warning + "%a" + (Michelson_v1_error_reporter.report_errors + ~details:false + ~show_source:false + ?parsed:None) + errs + in + cctxt#error "ill-formed type"); command ~group ~desc: @@ -664,8 +733,9 @@ let commands () = @@ bytes_parameter ~name:"data" ~desc:"the raw data to sign" @@ prefixes ["for"] @@ Client_keys.Secret_key.source_param @@ stop) (fun () bytes sk cctxt -> - Client_keys.sign cctxt sk bytes >>=? fun signature -> - cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> + let open Lwt_result_syntax in + let* signature = Client_keys.sign cctxt sk bytes in + let*! () = cctxt#message "Signature: %a" Signature.pp signature in return_unit); command ~group @@ -688,13 +758,14 @@ let commands () = (_, (key_locator, _)) signature (cctxt : #Protocol_client_context.full) -> - Client_keys.check key_locator signature bytes >>=? function - | false -> cctxt#error "invalid signature" - | true -> - if quiet then return_unit - else - cctxt#message "Signature check successful." >>= fun () -> - return_unit); + let open Lwt_result_syntax in + let* check = Client_keys.check key_locator signature bytes in + if check then + if quiet then return_unit + else + let*! () = cctxt#message "Signature check successful." in + return_unit + else cctxt#error "invalid signature"); command ~group ~desc:"Ask the type of an entrypoint of a script." @@ -706,14 +777,16 @@ let commands () = entrypoint_parameter @@ prefixes ["for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) entrypoint program cctxt -> + let open Lwt_syntax in handle_parsing_error "entrypoint" cctxt setup program @@ fun program -> - entrypoint_type - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - program - ~entrypoint - >>= fun entrypoint_type -> + let* entrypoint_type = + entrypoint_type + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + program + ~entrypoint + in print_entrypoint_type ~emacs:emacs_mode ~show_source:(not no_print_source) @@ -728,9 +801,11 @@ let commands () = (prefixes ["get"; "script"; "entrypoints"; "for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) program cctxt -> + let open Lwt_syntax in handle_parsing_error "entrypoints" cctxt setup program @@ fun program -> - list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program - >>= fun entrypoints -> + let* entrypoints = + list_entrypoints cctxt ~chain:cctxt#chain ~block:cctxt#block program + in print_entrypoints_list ~emacs:emacs_mode ~show_source:(not no_print_source) @@ -746,9 +821,11 @@ let commands () = (prefixes ["get"; "script"; "unreachable"; "paths"; "for"] @@ Program.source_param @@ stop) (fun ((emacs_mode, no_print_source) as setup) program cctxt -> + let open Lwt_syntax in handle_parsing_error "entrypoints" cctxt setup program @@ fun program -> - list_unreachables cctxt ~chain:cctxt#chain ~block:cctxt#block program - >>= fun entrypoints -> + let* entrypoints = + list_unreachables cctxt ~chain:cctxt#chain ~block:cctxt#block program + in print_unreachables ~emacs:emacs_mode ~show_source:(not no_print_source) @@ -761,14 +838,16 @@ let commands () = no_options (prefixes ["expand"; "macros"; "in"] @@ Program.source_param @@ stop) (fun () program (cctxt : Protocol_client_context.full) -> - Lwt.return @@ Micheline_parser.no_parsing_error program - >>=? fun program -> - cctxt#message - "%a" - (fun ppf () : unit -> - Michelson_v1_printer.print_expr_unwrapped ppf program.expanded) - () - >>= fun () -> return_unit); + let open Lwt_result_syntax in + let*? program = Micheline_parser.no_parsing_error program in + let*! () = + cctxt#message + "%a" + (fun ppf () : unit -> + Michelson_v1_printer.print_expr_unwrapped ppf program.expanded) + () + in + return_unit); command ~desc: "Conversion of Michelson script from Micheline, JSON or binary to \ @@ -782,46 +861,52 @@ let commands () = from_format to_format (cctxt : Protocol_client_context.full) -> - (match from_format with - | `Michelson -> - let program = - Michelson_v1_parser.parse_toplevel ~check expr_string - in - Lwt.return @@ Micheline_parser.no_parsing_error program - >>=? fun program -> - (typecheck_program - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~legacy - ~show_types:true - program - >>= function - | Error _ as res -> - print_typecheck_result - ~emacs:false - ~show_types:true - ~print_source_on_error:true - program - res - cctxt - | Ok _ -> return_unit) - >>=? fun () -> return program.expanded - | `JSON -> ( - match Data_encoding.Json.from_string expr_string with - | Error err -> cctxt#error "%s" err - | Ok json -> - safe_decode_json cctxt Alpha_context.Script.expr_encoding json) - | `Binary -> ( - bytes_of_prefixed_string expr_string >>=? fun bytes -> - match - Data_encoding.Binary.of_bytes_opt - Alpha_context.Script.expr_encoding - bytes - with - | None -> failwith "Could not decode bytes" - | Some expr -> return expr)) - >>=? fun (expression : Alpha_context.Script.expr) -> + let open Lwt_result_syntax in + let* (expression : Alpha_context.Script.expr) = + match from_format with + | `Michelson -> + let program = + Michelson_v1_parser.parse_toplevel ~check expr_string + in + let*? program = Micheline_parser.no_parsing_error program in + let* () = + let*! r = + typecheck_program + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~legacy + ~show_types:true + program + in + match r with + | Error _ as res -> + print_typecheck_result + ~emacs:false + ~show_types:true + ~print_source_on_error:true + program + res + cctxt + | Ok _ -> return_unit + in + return program.expanded + | `JSON -> ( + match Data_encoding.Json.from_string expr_string with + | Error err -> cctxt#error "%s" err + | Ok json -> + safe_decode_json cctxt Alpha_context.Script.expr_encoding json + ) + | `Binary -> ( + let* bytes = bytes_of_prefixed_string expr_string in + match + Data_encoding.Binary.of_bytes_opt + Alpha_context.Script.expr_encoding + bytes + with + | None -> failwith "Could not decode bytes" + | Some expr -> return expr) + in let output = match to_format with | `Michelson -> @@ -844,7 +929,8 @@ let commands () = ~zero_loc expression in - cctxt#message "%s" output >>= fun () -> return_unit); + let*! () = cctxt#message "%s" output in + return_unit); command ~desc: "Conversion of Micheline expression from Micheline, JSON or binary to \ @@ -858,6 +944,7 @@ let commands () = from_format to_format (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in let micheline_of_expr expr = Micheline_printer.printable Michelson_v1_primitives.string_of_prim @@ -865,14 +952,16 @@ let commands () = |> Format.asprintf "%a" Micheline_printer.print_expr in let typecheck_parsed ~data ~ty = - Client_proto_programs.typecheck_data - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~data - ~ty - () - >>= function + let*! r = + Client_proto_programs.typecheck_data + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~data + ~ty + () + in + match r with | Error errs -> failwith "%a" @@ -885,36 +974,42 @@ let commands () = in let typecheck_expr ~expr ~ty = let data_string = micheline_of_expr expr in - parse_expr data_string >>=? fun data -> typecheck_parsed ~data ~ty + let* data = parse_expr data_string in + typecheck_parsed ~data ~ty + in + let* (expression : Alpha_context.Script.expr) = + match from_format with + | `Michelson -> ( + let* data = parse_expr data_string in + match data_ty with + | Some ty -> typecheck_parsed ~data ~ty + | None -> return data.expanded) + | `JSON -> ( + match Data_encoding.Json.from_string data_string with + | Error err -> cctxt#error "%s" err + | Ok json -> ( + let* expr = + safe_decode_json + cctxt + Alpha_context.Script.expr_encoding + json + in + match data_ty with + | None -> return expr + | Some ty -> typecheck_expr ~expr ~ty)) + | `Binary -> ( + let* bytes = bytes_of_prefixed_string data_string in + match + Data_encoding.Binary.of_bytes_opt + Alpha_context.Script.expr_encoding + bytes + with + | None -> failwith "Could not decode bytes" + | Some expr -> ( + match data_ty with + | None -> return expr + | Some ty -> typecheck_expr ~expr ~ty)) in - (match from_format with - | `Michelson -> ( - parse_expr data_string >>=? fun data -> - match data_ty with - | Some ty -> typecheck_parsed ~data ~ty - | None -> return data.expanded) - | `JSON -> ( - match Data_encoding.Json.from_string data_string with - | Error err -> cctxt#error "%s" err - | Ok json -> ( - safe_decode_json cctxt Alpha_context.Script.expr_encoding json - >>=? fun expr -> - match data_ty with - | None -> return expr - | Some ty -> typecheck_expr ~expr ~ty)) - | `Binary -> ( - bytes_of_prefixed_string data_string >>=? fun bytes -> - match - Data_encoding.Binary.of_bytes_opt - Alpha_context.Script.expr_encoding - bytes - with - | None -> failwith "Could not decode bytes" - | Some expr -> ( - match data_ty with - | None -> return expr - | Some ty -> typecheck_expr ~expr ~ty))) - >>=? fun (expression : Alpha_context.Script.expr) -> let output = match to_format with | `Michelson -> micheline_of_expr expression @@ -933,7 +1028,8 @@ let commands () = ~zero_loc expression in - cctxt#message "%s" output >>= fun () -> return_unit); + let*! () = cctxt#message "%s" output in + return_unit); command ~group ~desc:"Ask the node to run a TZIP-4 view." @@ -961,17 +1057,20 @@ let commands () = contract input cctxt -> - Client_proto_programs.run_view - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - { - shared_params = - {input; unparsing_mode; now; level; source; payer; gas}; - contract; - entrypoint; - } - >>= fun res -> print_view_result cctxt res); + let open Lwt_syntax in + let* res = + Client_proto_programs.run_view + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + { + shared_params = + {input; unparsing_mode; now; level; source; payer; gas}; + contract; + entrypoint; + } + in + print_view_result cctxt res); command ~group ~desc:"Ask the node to run a Michelson view with Unit as input." @@ -994,21 +1093,25 @@ let commands () = view contract cctxt -> - Micheline_parser.no_parsing_error - @@ Michelson_v1_parser.parse_expression "Unit" - >>?= fun input -> - Client_proto_programs.run_script_view - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - { - shared_params = - {input; unparsing_mode; now; level; source; payer; gas}; - contract; - view; - unlimited_gas; - } - >>= fun res -> print_view_result cctxt res); + let open Lwt_result_syntax in + let*? input = + Micheline_parser.no_parsing_error + @@ Michelson_v1_parser.parse_expression "Unit" + in + let*! res = + Client_proto_programs.run_script_view + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + { + shared_params = + {input; unparsing_mode; now; level; source; payer; gas}; + contract; + view; + unlimited_gas; + } + in + print_view_result cctxt res); command ~group ~desc:"Ask the node to run a Michelson view." @@ -1037,16 +1140,19 @@ let commands () = contract input cctxt -> - Client_proto_programs.run_script_view - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - { - shared_params = - {input; unparsing_mode; now; level; source; payer; gas}; - contract; - view; - unlimited_gas; - } - >>= fun res -> print_view_result cctxt res); + let open Lwt_syntax in + let* res = + Client_proto_programs.run_script_view + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + { + shared_params = + {input; unparsing_mode; now; level; source; payer; gas}; + contract; + view; + unlimited_gas; + } + in + print_view_result cctxt res); ] diff --git a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml index 53d69d2af230..170ff3931f76 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_stresstest_commands.ml @@ -237,62 +237,74 @@ let parse_strategy s = Only unencrypted and encrypted sources from the wallet of [cctxt] are supported. *) let normalize_source cctxt = + let open Lwt_syntax in let sk_of_sk_uri sk_uri = match Signature.Secret_key.of_b58check (Uri.path (sk_uri : Client_keys.sk_uri :> Uri.t)) with | Ok sk -> Lwt.return_some sk - | Error _ -> ( - Tezos_signer_backends.Encrypted.decrypt cctxt sk_uri >>= function - | Error _ -> Lwt.return_none - | Ok sk -> Lwt.return_some sk) + | Error _ -> + let+ r = Tezos_signer_backends.Encrypted.decrypt cctxt sk_uri in + Option.of_result r in let key_from_alias alias = let warning msg alias = - cctxt#warning msg alias >>= fun () -> Lwt.return_none + let* () = cctxt#warning msg alias in + return_none in - (Client_keys.alias_keys cctxt alias >>= function - | Error _ | Ok None -> warning "Alias \"%s\" not found in the wallet" alias - | Ok (Some (_, None, _)) | Ok (Some (_, _, None)) -> - warning - "Alias \"%s\" does not contain public or secret key and could not \ - be used for stresstest" - alias - | Ok (Some (pkh, Some pk, Some sk_uri)) -> ( - sk_of_sk_uri sk_uri >>= function - | None -> - warning - "Cannot extract the secret key form the alias \"%s\" of the \ - wallet" - alias - | Some sk -> - Lwt.return_some - {source = {pkh; pk; sk}; origin = Wallet_alias alias})) - >>= function + let* key = + let* r = Client_keys.alias_keys cctxt alias in + match r with + | Error _ | Ok None -> + warning "Alias \"%s\" not found in the wallet" alias + | Ok (Some (_, None, _)) | Ok (Some (_, _, None)) -> + warning + "Alias \"%s\" does not contain public or secret key and could not \ + be used for stresstest" + alias + | Ok (Some (pkh, Some pk, Some sk_uri)) -> ( + let* o = sk_of_sk_uri sk_uri in + match o with + | None -> + warning + "Cannot extract the secret key form the alias \"%s\" of the \ + wallet" + alias + | Some sk -> + Lwt.return_some + {source = {pkh; pk; sk}; origin = Wallet_alias alias}) + in + match key with | None -> warning "Source given as alias \"%s\" ignored" alias | key -> Lwt.return key in let key_from_wallet pkh = let warning msg pkh = - cctxt#warning msg Signature.Public_key_hash.pp pkh >>= fun () -> - Lwt.return_none + let* () = cctxt#warning msg Signature.Public_key_hash.pp pkh in + return_none + in + let* key = + let* r = Client_keys.get_key cctxt pkh in + match r with + | Error _ -> warning "Pkh \"%a\" not found in the wallet" pkh + | Ok (alias, pk, sk_uri) -> ( + let* o = sk_of_sk_uri sk_uri in + match o with + | None -> + let* () = + cctxt#warning + "Cannot extract the secret key form the pkh \"%a\" (alias: \ + \"%s\") of the wallet" + Signature.Public_key_hash.pp + pkh + alias + in + Lwt.return_none + | Some sk -> + Lwt.return_some {source = {pkh; pk; sk}; origin = Wallet_pkh}) in - (Client_keys.get_key cctxt pkh >>= function - | Error _ -> warning "Pkh \"%a\" not found in the wallet" pkh - | Ok (alias, pk, sk_uri) -> ( - sk_of_sk_uri sk_uri >>= function - | None -> - cctxt#warning - "Cannot extract the secret key form the pkh \"%a\" (alias: \ - \"%s\") of the wallet" - Signature.Public_key_hash.pp - pkh - alias - >>= fun () -> Lwt.return_none - | Some sk -> - Lwt.return_some {source = {pkh; pk; sk}; origin = Wallet_pkh})) - >>= function + match key with | None -> warning "Source given as pkh \"%a\" ignored" pkh | key -> Lwt.return key in @@ -322,24 +334,28 @@ let sample_any_source_from_pool state = value (meaning that [--single-op-per-pkh-per-block] is active) then it is sampled from there, otherwise from [state.pool]. *) let rec sample_source_from_pool state (cctxt : Protocol_client_context.full) = + let open Lwt_syntax in match state.shuffled_pool with | None -> sample_any_source_from_pool state | Some (source :: l) -> state.shuffled_pool <- Some l ; - log Debug (fun () -> - cctxt#message - "sample_transfer: %d unused sources for the block next to %a" - (List.length l) - Block_hash.pp - state.last_block) - >>= fun () -> Lwt.return source + let* () = + log Debug (fun () -> + cctxt#message + "sample_transfer: %d unused sources for the block next to %a" + (List.length l) + Block_hash.pp + state.last_block) + in + Lwt.return source | Some [] -> - cctxt#message - "all available sources have been used for block next to %a" - Block_hash.pp - state.last_block - >>= fun () -> - Lwt_condition.wait state.new_block_condition >>= fun () -> + let* () = + cctxt#message + "all available sources have been used for block next to %a" + Block_hash.pp + state.last_block + in + let* () = Lwt_condition.wait state.new_block_condition in sample_source_from_pool state cctxt let random_seed rng = @@ -425,19 +441,22 @@ let sample_smart_contracts smart_contracts rng_state = We could maintain a local cache of existing contracts with sufficient balance. *) let rec sample_transfer (cctxt : Protocol_client_context.full) chain block (parameters : parameters) (state : state) = - sample_source_from_pool state cctxt >>= fun src -> - Alpha_services.Contract.balance - cctxt - (chain, block) - (Contract.Implicit src.pkh) - >>=? fun tez -> + let open Lwt_result_syntax in + let*! src = sample_source_from_pool state cctxt in + let* tez = + Alpha_services.Contract.balance + cctxt + (chain, block) + (Contract.Implicit src.pkh) + in if Tez.(tez = zero) then - log Debug (fun () -> - cctxt#message - "sample_transfer: invalid balance %a" - Signature.Public_key_hash.pp - src.pkh) - >>= fun () -> + let*! () = + log Debug (fun () -> + cctxt#message + "sample_transfer: invalid balance %a" + Signature.Public_key_hash.pp + src.pkh) + in (* Sampled source has zero balance: the transfer that created that address was not included yet. Retry *) sample_transfer cctxt chain block parameters state @@ -445,19 +464,21 @@ let rec sample_transfer (cctxt : Protocol_client_context.full) chain block let fresh = Random.State.float state.rng_state 1.0 < parameters.fresh_probability in - (match - sample_smart_contracts parameters.smart_contracts state.rng_state - with - | None -> - (if fresh then Lwt.return (generate_fresh_source state) - else sample_any_source_from_pool state) - >|= fun dest -> - Ok - ( Implicit dest.pkh, - parameters.regular_transfer_fee, - parameters.regular_transfer_gas_limit ) - | Some v -> return v) - >>=? fun (dst, fee, gas_limit) -> + let* dst, fee, gas_limit = + match + sample_smart_contracts parameters.smart_contracts state.rng_state + with + | None -> + let*! dest = + if fresh then Lwt.return (generate_fresh_source state) + else sample_any_source_from_pool state + in + return + ( Implicit dest.pkh, + parameters.regular_transfer_fee, + parameters.regular_transfer_gas_limit ) + | Some v -> return v + in let amount = match parameters.strategy with | Fixed_amount {mutez} -> mutez @@ -526,9 +547,11 @@ let cost_of_manager_operation = Gas.Arith.integral_of_int_exn 1_000 let inject_transfer (cctxt : Protocol_client_context.full) parameters state transfer = - Shell_services.Blocks.hash cctxt () >>=? fun branch -> - Alpha_services.Contract.counter cctxt (`Main, `Head 0) transfer.src.pkh - >>=? fun pcounter -> + let open Lwt_result_syntax in + let* branch = Shell_services.Blocks.hash cctxt () in + let* pcounter = + Alpha_services.Contract.counter cctxt (`Main, `Head 0) transfer.src.pkh + in let freshest_counter = match Signature.Public_key_hash.Table.find state.counters transfer.src.pkh @@ -548,92 +571,103 @@ let inject_transfer (cctxt : Protocol_client_context.full) parameters state given by the RPC. *) pcounter in - (if Signature.Public_key_hash.Set.mem transfer.src.pkh state.revealed then - return true - else ( - (* Either the [manager_key] RPC tells us the key is already - revealed, or we immediately inject a reveal operation: in any - case the key is revealed in the end. *) - state.revealed <- - Signature.Public_key_hash.Set.add transfer.src.pkh state.revealed ; - Alpha_services.Contract.manager_key cctxt (`Main, `Head 0) transfer.src.pkh - >>=? fun pk_opt -> return (Option.is_some pk_opt))) - >>=? fun already_revealed -> - (if not already_revealed then ( - let reveal_counter = Z.succ freshest_counter in - let transf_counter = Z.succ reveal_counter in - let reveal = - Manager_operation - { - source = transfer.src.pkh; - fee = Tez.zero; - counter = reveal_counter; - gas_limit = cost_of_manager_operation; - storage_limit = Z.zero; - operation = Reveal transfer.src.pk; - } - in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Cons (reveal, Single manager_op) in - Signature.Public_key_hash.Table.remove state.counters transfer.src.pkh ; - Signature.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - log Info (fun () -> - cctxt#message - "injecting reveal+transfer from %a (counters=%a,%a) to %a" - Signature.Public_key_hash.pp - transfer.src.pkh - Z.pp_print - reveal_counter - Z.pp_print - transf_counter - Contract.pp - (destination_to_contract transfer.dst)) - >>= fun () -> - (* NB: regardless of our best efforts to keep track of counters, injection can fail with - "counter in the future" if a block switch happens in between the moment we - get the branch and the moment we inject, and the new block does not include - all the operations we injected. *) - inject_contents cctxt state.target_block transfer.src.sk list) - else - let transf_counter = Z.succ freshest_counter in - let manager_op = - manager_op_of_transfer - parameters - {transfer with counter = Some transf_counter} - in - let list = Single manager_op in - Signature.Public_key_hash.Table.remove state.counters transfer.src.pkh ; - Signature.Public_key_hash.Table.add - state.counters - transfer.src.pkh - (branch, transf_counter) ; - log Info (fun () -> - cctxt#message - "injecting transfer from %a (counter=%a) to %a" - Signature.Public_key_hash.pp + let* already_revealed = + if Signature.Public_key_hash.Set.mem transfer.src.pkh state.revealed then + return true + else ( + (* Either the [manager_key] RPC tells us the key is already + revealed, or we immediately inject a reveal operation: in any + case the key is revealed in the end. *) + state.revealed <- + Signature.Public_key_hash.Set.add transfer.src.pkh state.revealed ; + let* pk_opt = + Alpha_services.Contract.manager_key + cctxt + (`Main, `Head 0) transfer.src.pkh - Z.pp_print - transf_counter - Contract.pp - (destination_to_contract transfer.dst)) - >>= fun () -> - (* See comment above. *) - inject_contents cctxt state.target_block transfer.src.sk list) - >>= function + in + return (Option.is_some pk_opt)) + in + let*! r = + if not already_revealed then ( + let reveal_counter = Z.succ freshest_counter in + let transf_counter = Z.succ reveal_counter in + let reveal = + Manager_operation + { + source = transfer.src.pkh; + fee = Tez.zero; + counter = reveal_counter; + gas_limit = cost_of_manager_operation; + storage_limit = Z.zero; + operation = Reveal transfer.src.pk; + } + in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Cons (reveal, Single manager_op) in + Signature.Public_key_hash.Table.remove state.counters transfer.src.pkh ; + Signature.Public_key_hash.Table.add + state.counters + transfer.src.pkh + (branch, transf_counter) ; + let*! () = + log Info (fun () -> + cctxt#message + "injecting reveal+transfer from %a (counters=%a,%a) to %a" + Signature.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + reveal_counter + Z.pp_print + transf_counter + Contract.pp + (destination_to_contract transfer.dst)) + in + (* NB: regardless of our best efforts to keep track of counters, injection can fail with + "counter in the future" if a block switch happens in between the moment we + get the branch and the moment we inject, and the new block does not include + all the operations we injected. *) + inject_contents cctxt state.target_block transfer.src.sk list) + else + let transf_counter = Z.succ freshest_counter in + let manager_op = + manager_op_of_transfer + parameters + {transfer with counter = Some transf_counter} + in + let list = Single manager_op in + Signature.Public_key_hash.Table.remove state.counters transfer.src.pkh ; + Signature.Public_key_hash.Table.add + state.counters + transfer.src.pkh + (branch, transf_counter) ; + let*! () = + log Info (fun () -> + cctxt#message + "injecting transfer from %a (counter=%a) to %a" + Signature.Public_key_hash.pp + transfer.src.pkh + Z.pp_print + transf_counter + Contract.pp + (destination_to_contract transfer.dst)) + in + (* See comment above. *) + inject_contents cctxt state.target_block transfer.src.sk list + in + match r with | Ok op_hash -> - log Debug (fun () -> - cctxt#message - "inject_transfer: op injected %a" - Operation_hash.pp - op_hash) - >>= fun () -> + let*! () = + log Debug (fun () -> + cctxt#message + "inject_transfer: op injected %a" + Operation_hash.pp + op_hash) + in let ops = Option.value ~default:[] @@ -642,14 +676,17 @@ let inject_transfer (cctxt : Protocol_client_context.full) parameters state Block_hash.Table.replace state.injected_operations branch (op_hash :: ops) ; return_unit | Error e -> - log Debug (fun () -> - cctxt#message - "inject_transfer: error, op not injected: %a" - Error_monad.pp_print_trace - e) - >>= fun () -> return_unit + let*! () = + log Debug (fun () -> + cctxt#message + "inject_transfer: error, op not injected: %a" + Error_monad.pp_print_trace + e) + in + return_unit let save_injected_operations (cctxt : Protocol_client_context.full) state = + let open Lwt_syntax in let json = Data_encoding.Json.construct injected_operations_encoding @@ -661,8 +698,9 @@ let save_injected_operations (cctxt : Protocol_client_context.full) state = let path = Filename.temp_file "client-stresstest-injected_operations-" ".json" in - cctxt#message "writing injected operations in file %s" path >>= fun () -> - Lwt_utils_unix.Json.write_file path json >>= function + let* () = cctxt#message "writing injected operations in file %s" path in + let* r = Lwt_utils_unix.Json.write_file path json in + match r with | Error e -> cctxt#message "could not write injected operations json file: %a" @@ -671,8 +709,9 @@ let save_injected_operations (cctxt : Protocol_client_context.full) state = | Ok _ -> Lwt.return_unit let stat_on_exit (cctxt : Protocol_client_context.full) state = + let open Lwt_result_syntax in let ratio_injected_included_op () = - Shell_services.Blocks.hash cctxt () >>=? fun current_head_on_exit -> + let* current_head_on_exit = Shell_services.Blocks.hash cctxt () in let inter_cardinal s1 s2 = Operation_hash.Set.cardinal (Operation_hash.Set.inter @@ -683,19 +722,23 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = let rec get_included_ops block acc_included_ops = if block = older_block then return acc_included_ops else - Shell_services.Chain.Blocks.Operation_hashes.operation_hashes_in_pass - cctxt - ~chain:`Main - ~block:(`Hash (block, 0)) - 3 - >>=? fun included_ops -> - Shell_services.Blocks.list - cctxt - ~chain:`Main - ~heads:[block] - ~length:2 - () - >>=? function + let* included_ops = + Shell_services.Chain.Blocks.Operation_hashes + .operation_hashes_in_pass + cctxt + ~chain:`Main + ~block:(`Hash (block, 0)) + 3 + in + let* bs = + Shell_services.Blocks.list + cctxt + ~chain:`Main + ~heads:[block] + ~length:2 + () + in + match bs with | [[current; predecessor]] when current = block -> get_included_ops predecessor @@ -713,26 +756,30 @@ let stat_on_exit (cctxt : Protocol_client_context.full) state = state.injected_operations [] in - get_included_ops state.current_head_on_start >>=? fun included_ops -> + let* included_ops = get_included_ops state.current_head_on_start in let included_ops_count = inter_cardinal injected_ops included_ops in - log Debug (fun () -> - cctxt#message - "injected : [%a]@.included: [%a]" - (Format.pp_print_list ~pp_sep Operation_hash.pp) - injected_ops - (Format.pp_print_list ~pp_sep Operation_hash.pp) - included_ops) - >>= fun () -> + let*! () = + log Debug (fun () -> + cctxt#message + "injected : [%a]@.included: [%a]" + (Format.pp_print_list ~pp_sep Operation_hash.pp) + injected_ops + (Format.pp_print_list ~pp_sep Operation_hash.pp) + included_ops) + in let injected_ops_count = List.length injected_ops in - cctxt#message - "%s of the injected operations have been included (%d injected, %d \ - included). Note that the operations injected during the last block are \ - ignored because they should not be currently included." - (if Int.equal injected_ops_count 0 then "N/A" - else Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) - injected_ops_count - included_ops_count - >>= fun () -> return_unit + let*! () = + cctxt#message + "%s of the injected operations have been included (%d injected, %d \ + included). Note that the operations injected during the last block \ + are ignored because they should not be currently included." + (if Int.equal injected_ops_count 0 then "N/A" + else + Format.sprintf "%d%%" (included_ops_count * 100 / injected_ops_count)) + injected_ops_count + included_ops_count + in + return_unit in ratio_injected_included_op () @@ -747,64 +794,79 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) in let dt = 1. /. parameters.tps in let terminated () = + let open Lwt_syntax in if match parameters.total_transfers with | None -> false | Some bound -> bound <= !injected then - cctxt#message - "Stopping after %d injections (target %a)." - !injected - Format.(pp_print_option pp_print_int) - parameters.total_transfers - >>= fun () -> Lwt.return_true + let* () = + cctxt#message + "Stopping after %d injections (target %a)." + !injected + Format.(pp_print_option pp_print_int) + parameters.total_transfers + in + Lwt.return_true else match target_level with | None -> Lwt.return_false | Some target -> if target <= state.last_level then - cctxt#message - "Stopping at level %d (target level: %d)." - state.last_level - target - >>= fun () -> Lwt.return_true + let* () = + cctxt#message + "Stopping at level %d (target level: %d)." + state.last_level + target + in + Lwt.return_true else Lwt.return_false in let rec loop () = - terminated () >>= fun terminated -> + let open Lwt_result_syntax in + let*! terminated = terminated () in if terminated then - save_pool_callback () >>= fun () -> - save_injected_operations cctxt state >>= fun () -> + let*! () = save_pool_callback () in + let*! () = save_injected_operations cctxt state in stat_on_exit cctxt state else let start = Mtime_clock.elapsed () in - log Debug (fun () -> cctxt#message "launch.loop: invoke sample_transfer") - >>= fun () -> - sample_transfer cctxt cctxt#chain cctxt#block parameters state - >>=? fun transfer -> - log Debug (fun () -> cctxt#message "launch.loop: invoke inject_transfer") - >>= fun () -> - inject_transfer cctxt parameters state transfer >>=? fun () -> + let*! () = + log Debug (fun () -> + cctxt#message "launch.loop: invoke sample_transfer") + in + let* transfer = + sample_transfer cctxt cctxt#chain cctxt#block parameters state + in + let*! () = + log Debug (fun () -> + cctxt#message "launch.loop: invoke inject_transfer") + in + let* () = inject_transfer cctxt parameters state transfer in incr injected ; let stop = Mtime_clock.elapsed () in let elapsed = Mtime.Span.(to_s stop -. to_s start) in let remaining = dt -. elapsed in - (if remaining <= 0.0 then - cctxt#warning - "warning: tps target could not be reached, consider using a lower \ - value for --tps" - else Lwt_unix.sleep remaining) - >>= loop + let*! () = + if remaining <= 0.0 then + cctxt#warning + "warning: tps target could not be reached, consider using a lower \ + value for --tps" + else Lwt_unix.sleep remaining + in + loop () in let on_new_head : Block_hash.t * Tezos_base.Block_header.t -> unit tzresult Lwt.t = (* Because of how Tenderbake works the target block should stay 2 blocks in the past because this guarantees that we are targeting a block that is decided. *) + let open Lwt_result_syntax in let update_target_block () = - Shell_services.Blocks.hash cctxt ~block:(`Head 2) () - >>=? fun target_block -> + let* target_block = + Shell_services.Blocks.hash cctxt ~block:(`Head 2) () + in state.target_block <- target_block ; return_unit in @@ -812,7 +874,7 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) (* Some _ if and only if [single_op_per_pkh_per_block] is true. *) | Some _ -> fun (new_block_hash, new_block_header) -> - update_target_block () >>=? fun () -> + let* () = update_target_block () in if not (Block_hash.equal new_block_hash state.last_block) then ( state.last_block <- new_block_hash ; state.last_level <- Int32.to_int new_block_header.shell.level ; @@ -827,9 +889,10 @@ let launch (cctxt : Protocol_client_context.full) (parameters : parameters) (* only wait for the end of the head stream; don't act on heads *) fun _ -> update_target_block () in - heads_iter cctxt on_new_head >>=? fun (heads_iteration, stopper) -> + let open Lwt_result_syntax in + let* heads_iteration, stopper = heads_iter cctxt on_new_head in (* The head iteration stops at protocol change. *) - Lwt.pick [loop (); heads_iteration] >>=? fun () -> + let* () = Lwt.pick [loop (); heads_iteration] in (match Lwt.state heads_iteration with Lwt.Return _ -> () | _ -> stopper ()) ; return_unit @@ -845,14 +908,15 @@ let json_of_pool_source = function let json_file_or_text_parameter = Clic.parameter (fun _ p -> + let open Lwt_result_syntax in match String.split ~limit:1 ':' p with | ["text"; text] -> return (From_string {json = Ezjsonm.from_string text}) | ["file"; path] -> - Lwt_utils_unix.Json.read_file path >|=? fun json -> + let+ json = Lwt_utils_unix.Json.read_file path in From_file {path; json} | _ -> ( if Sys.file_exists p then - Lwt_utils_unix.Json.read_file p >|=? fun json -> + let+ json = Lwt_utils_unix.Json.read_file p in From_file {path = p; json} else try return (From_string {json = Ezjsonm.from_string p}) @@ -870,7 +934,7 @@ let seed_arg = | exception _ -> cctxt#error "While parsing --seed: could not convert argument to int" - | i -> return i)) + | i -> Lwt_result_syntax.return i)) let tps_arg = let open Clic in @@ -885,7 +949,7 @@ let tps_arg = "While parsing --tps: could not convert argument to float" | f when f < 0.0 -> cctxt#error "While parsing --tps: negative argument" - | f -> return f)) + | f -> Lwt_result_syntax.return f)) let fresh_probability_arg = let open Clic in @@ -909,7 +973,7 @@ let fresh_probability_arg = to float" | f when f < 0.0 || f > 1.0 -> cctxt#error "While parsing --fresh-probability: invalid argument" - | f -> return f)) + | f -> Lwt_result_syntax.return f)) let smart_contract_parameters_arg = let open Clic in @@ -924,7 +988,7 @@ let smart_contract_parameters_arg = (parameter (fun (cctxt : Protocol_client_context.full) s -> match Data_encoding.Json.from_string s with | Ok json -> - return + Lwt_result_syntax.return (Data_encoding.Json.destruct Smart_contracts.contract_parameters_collection_encoding json) @@ -942,7 +1006,7 @@ let strategy_arg = (parameter (fun (cctxt : Protocol_client_context.full) s -> match parse_strategy s with | Error msg -> cctxt#error "While parsing --strategy: %s" msg - | Ok strategy -> return strategy)) + | Ok strategy -> Lwt_result_syntax.return strategy)) let gas_limit_arg = let open Clic in @@ -950,7 +1014,7 @@ let gas_limit_arg = parameter (fun _ s -> try let v = Z.of_string s in - return (Gas.Arith.integral_exn v) + Lwt_result_syntax.return (Gas.Arith.integral_exn v) with _ -> failwith "invalid gas limit (must be a positive number)") in arg @@ -972,7 +1036,7 @@ let storage_limit_arg = try let v = Z.of_string s in assert (Compare.Z.(v >= Z.zero)) ; - return v + Lwt_result_syntax.return v with _ -> failwith "invalid storage limit (must be a positive number of bytes)") in @@ -1000,7 +1064,7 @@ let transfers_arg = cctxt#error "While parsing --transfers: invalid integer literal" | i when i <= 0 -> cctxt#error "While parsing --transfers: negative integer" - | i -> return i)) + | i -> Lwt_result_syntax.return i)) let single_op_per_pkh_per_block_arg = Clic.switch @@ -1019,6 +1083,7 @@ let level_limit_arg = "Level at which the stresstest will stop (if prefixed by '+', the level \ is relative to the current head)" (parameter (fun (cctxt : Protocol_client_context.full) s -> + let open Lwt_result_syntax in match int_of_string s with | exception _ -> cctxt#error "While parsing --levels: invalid integer literal" @@ -1053,18 +1118,21 @@ let save_pool_callback (cctxt : Protocol_client_context.full) pool_source state e | Ok () -> Lwt.return_unit in + let open Lwt_syntax in match pool_source with | From_string _ -> (* If the initial pool was given directly as json, save pool to a temp file. *) let path = Filename.temp_file "client-stresstest-pool-" ".json" in - cctxt#message "writing back address pool in file %s" path >>= fun () -> - Lwt_utils_unix.Json.write_file path json >>= catch_write_error + let* () = cctxt#message "writing back address pool in file %s" path in + let* r = Lwt_utils_unix.Json.write_file path json in + catch_write_error r | From_file {path; _} -> (* If the pool specification was a json file, save pool to the same file. *) - cctxt#message "writing back address pool in file %s" path >>= fun () -> - Lwt_utils_unix.Json.write_file path json >>= catch_write_error + let* () = cctxt#message "writing back address pool in file %s" path in + let* r = Lwt_utils_unix.Json.write_file path json in + catch_write_error r let generate_random_transactions = let open Clic in @@ -1107,15 +1175,17 @@ let generate_random_transactions = debug_flag ) sources_json (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in (verbosity := match (debug_flag, verbose_flag) with | true, _ -> Debug | false, true -> Info | false, false -> Notice) ; - Smart_contracts.init - cctxt - (Option.value ~default:[] smart_contract_parameters) - >>=? fun smart_contracts -> + let* smart_contracts = + Smart_contracts.init + cctxt + (Option.value ~default:[] smart_contract_parameters) + in let parameters = {default_parameters with smart_contracts} |> set_option seed (fun parameter seed -> {parameter with seed}) @@ -1145,11 +1215,14 @@ let generate_random_transactions = | exception _ -> cctxt#error "Could not decode list of sources" | [] -> cctxt#error "It is required to provide sources" | sources -> - log Info (fun () -> cctxt#message "starting to normalize sources") - >>= fun () -> - List.filter_map_s (normalize_source cctxt) sources >>= fun sources -> - log Info (fun () -> cctxt#message "all sources have been normalized") - >>= fun () -> + let*! () = + log Info (fun () -> cctxt#message "starting to normalize sources") + in + let*! sources = List.filter_map_s (normalize_source cctxt) sources in + let*! () = + log Info (fun () -> + cctxt#message "all sources have been normalized") + in let sources = List.sort_uniq (fun src1 src2 -> @@ -1158,20 +1231,23 @@ let generate_random_transactions = in let counters = Signature.Public_key_hash.Table.create 1023 in let rng_state = Random.State.make [|parameters.seed|] in - Shell_services.Blocks.hash cctxt () >>=? fun current_head_on_start -> - Shell_services.Blocks.Header.shell_header cctxt () - >>=? fun header_on_start -> - (if header_on_start.level <= 2l then - cctxt#error - "The level of the head (%a) needs to be greater than 2 and is \ - actually %ld." - Block_hash.pp - current_head_on_start - header_on_start.level - else return_unit) - >>=? fun () -> - Shell_services.Blocks.hash cctxt ~block:(`Head 2) () - >>=? fun current_target_block -> + let* current_head_on_start = Shell_services.Blocks.hash cctxt () in + let* header_on_start = + Shell_services.Blocks.Header.shell_header cctxt () + in + let* () = + if header_on_start.level <= 2l then + cctxt#error + "The level of the head (%a) needs to be greater than 2 and is \ + actually %ld." + Block_hash.pp + current_head_on_start + header_on_start.level + else return_unit + in + let* current_target_block = + Shell_services.Blocks.hash cctxt ~block:(`Head 2) () + in let state = { rng_state; @@ -1196,7 +1272,8 @@ let generate_random_transactions = in let exit_callback_id = Lwt_exit.register_clean_up_callback ~loc:__LOC__ (fun _retcode -> - stat_on_exit cctxt state >>= function + let*! r = stat_on_exit cctxt state in + match r with | Ok () -> Lwt.return_unit | Error e -> cctxt#message "Error: %a" Error_monad.pp_print_trace e) @@ -1222,14 +1299,17 @@ let generate_random_transactions = let estimate_transaction_cost ?smart_contracts (cctxt : Protocol_client_context.full) : Gas.Arith.integral tzresult Lwt.t = - normalize_source cctxt (Wallet_alias "bootstrap1") >>= fun src -> - normalize_source cctxt (Wallet_alias "bootstrap2") >>= fun dst -> + let open Lwt_result_syntax in + let*! src = normalize_source cctxt (Wallet_alias "bootstrap1") in + let*! dst = normalize_source cctxt (Wallet_alias "bootstrap2") in let rng_state = Random.State.make [|default_parameters.seed|] in - (match (src, dst) with - | Some src, Some dst -> return (src, dst) - | _ -> - cctxt#error "Cannot find bootstrap1 or bootstrap2 accounts in the wallet.") - >>=? fun (src, dst) -> + let* src, dst = + match (src, dst) with + | Some src, Some dst -> return (src, dst) + | _ -> + cctxt#error + "Cannot find bootstrap1 or bootstrap2 accounts in the wallet." + in let chain = cctxt#chain in let block = cctxt#block in let selected_smart_contract = @@ -1244,8 +1324,9 @@ let estimate_transaction_cost ?smart_contracts default_parameters.regular_transfer_fee, default_parameters.regular_transfer_gas_limit ) in - Alpha_services.Contract.counter cctxt (chain, block) src.source.pkh - >>=? fun current_counter -> + let* current_counter = + Alpha_services.Contract.counter cctxt (chain, block) src.source.pkh + in let transf_counter = Z.succ current_counter in let transfer = { @@ -1267,8 +1348,9 @@ let estimate_transaction_cost ?smart_contracts } transfer in - Injection.simulate cctxt ~chain ~block (Single manager_op) - >>=? fun (_oph, op, result) -> + let* _oph, op, result = + Injection.simulate cctxt ~chain ~block (Single manager_op) + in match result.contents with | Single_result (Manager_operation_result {operation_result; _}) -> ( match operation_result with @@ -1296,12 +1378,14 @@ let estimate_transaction_costs : Protocol_client_context.full Clic.command = no_options (prefixes ["stresstest"; "estimate"; "gas"] @@ stop) (fun () cctxt -> - estimate_transaction_cost cctxt >>=? fun regular -> - Smart_contracts.with_every_known_smart_contract - cctxt - (fun smart_contracts -> - estimate_transaction_cost ~smart_contracts cctxt) - >>=? fun smart_contracts -> + let open Lwt_result_syntax in + let* regular = estimate_transaction_cost cctxt in + let* smart_contracts = + Smart_contracts.with_every_known_smart_contract + cctxt + (fun smart_contracts -> + estimate_transaction_cost ~smart_contracts cctxt) + in let transaction_costs : transaction_costs = {regular; smart_contracts} in let json = Data_encoding.Json.construct diff --git a/src/proto_alpha/lib_client_commands/client_proto_stresstest_contracts.ml b/src/proto_alpha/lib_client_commands/client_proto_stresstest_contracts.ml index c70186d221d4..565da64f25a4 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_stresstest_contracts.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_stresstest_contracts.ml @@ -114,23 +114,28 @@ let all_contracts = [hic_et_nunc] let init (cctxt : Protocol_client_context.full) (contract_parameters : (string * contract_parameters) list) : t tzresult Lwt.t = + let open Lwt_result_syntax in let sum_of_probabilities = List.fold_left (fun acc (_, {probability; _}) -> acc +. probability) 0.0 contract_parameters in - (if sum_of_probabilities > 1.0 then - failwith "sum of smart contract call probabilities is greater than 1.0!" - else return_unit) - >>=? fun () -> + let* () = + if sum_of_probabilities > 1.0 then + failwith "sum of smart contract call probabilities is greater than 1.0!" + else return_unit + in let init_one (alias, params) = - Client_proto_contracts.ContractAlias.get_contract cctxt alias - >>=? fun contract -> - (match List.find (fun x -> String.equal alias x.alias) all_contracts with - | None -> failwith "unknown smart contract alias: %s" alias - | Some x -> return x) - >>=? fun smart_contract -> return (params, contract, smart_contract) + let* contract = + Client_proto_contracts.ContractAlias.get_contract cctxt alias + in + let* smart_contract = + match List.find (fun x -> String.equal alias x.alias) all_contracts with + | None -> failwith "unknown smart contract alias: %s" alias + | Some x -> return x + in + return (params, contract, smart_contract) in List.map_es init_one contract_parameters @@ -175,11 +180,12 @@ let originate_command = ~desc:"name of the source contract" @@ stop) (fun () source (cctxt : Protocol_client_context.full) -> + let open Lwt_result_syntax in match source with | Originated _ -> failwith "only implicit accounts can be the source of an origination" | Implicit source -> - Client_keys.get_key cctxt source >>=? fun (_, src_pk, src_sk) -> + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in let originate_one (scontract : smart_contract) = let fee_parameter = { @@ -191,26 +197,29 @@ let originate_command = burn_cap = scontract.origination_burn_cap; } in - originate_contract - cctxt - ~chain:cctxt#chain - ~block:cctxt#block - ~delegate:None - ~initial_storage:scontract.initial_storage - ~balance:Tez.zero (* initial balance *) - ~source - ~src_pk - ~src_sk - ~code:scontract.code - ~fee_parameter - () - >>= fun errors -> - report_michelson_errors - ~no_print_source:true - ~msg:"origination simulation failed" - cctxt - errors - >>= function + let*! errors = + originate_contract + cctxt + ~chain:cctxt#chain + ~block:cctxt#block + ~delegate:None + ~initial_storage:scontract.initial_storage + ~balance:Tez.zero (* initial balance *) + ~source + ~src_pk + ~src_sk + ~code:scontract.code + ~fee_parameter + () + in + let*! r = + report_michelson_errors + ~no_print_source:true + ~msg:"origination simulation failed" + cctxt + errors + in + match r with | None -> return_unit | Some (_res, contract) -> save_contract ~force:false cctxt scontract.alias contract @@ -218,6 +227,7 @@ let originate_command = List.iter_es originate_one all_contracts) let with_every_known_smart_contract cctxt callback = + let open Lwt_result_syntax in let items = List.map (fun x -> @@ -230,19 +240,21 @@ let with_every_known_smart_contract cctxt callback = } )) all_contracts in - init cctxt items >>=? fun smart_contracts -> + let* smart_contracts = init cctxt items in let rec go xs0 = match xs0 with | [] -> return [] | (contract_parameters, contract, smart_contract) :: xs1 -> - callback - [ - ( {contract_parameters with probability = 1.0}, - contract, - smart_contract ); - ] - >>=? fun r -> - go xs1 >>=? fun rs -> return ((smart_contract.alias, r) :: rs) + let* r = + callback + [ + ( {contract_parameters with probability = 1.0}, + contract, + smart_contract ); + ] + in + let* rs = go xs1 in + return ((smart_contract.alias, r) :: rs) in go smart_contracts diff --git a/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml index c661dbd2eb6b..a76bf9689544 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_utils_commands.ml @@ -33,6 +33,7 @@ let unsigned_block_header_param = ~name:"unsigned block header" ~desc:"A hex or JSON encoded unsigned block header" @@ parameter (fun _ s -> + let open Lwt_result_syntax in let bytes_opt = `Hex s |> Hex.to_bytes in let enc = Protocol.Alpha_context.Block_header.unsigned_encoding in Option.bind bytes_opt (Data_encoding.Binary.of_bytes_opt enc) @@ -47,9 +48,9 @@ let unsigned_block_header_param = in let open Data_encoding.Json in from_string s |> function - | Error _ -> fail error + | Error _ -> tzfail error | Ok json -> ( - try destruct enc json |> return with _ -> fail error))) + try destruct enc json |> return with _ -> tzfail error))) let commands () = let open Clic in @@ -85,10 +86,16 @@ let commands () = ~desc:"name of the signer contract" @@ stop) (fun block_head message src_sk cctxt -> - Shell_services.Blocks.hash cctxt ~chain:cctxt#chain ~block:block_head () - >>=? fun block -> - sign_message cctxt ~src_sk ~block ~message >>=? fun signature -> - cctxt#message "Signature: %a" Signature.pp signature >>= fun () -> + let open Lwt_result_syntax in + let* block = + Shell_services.Blocks.hash + cctxt + ~chain:cctxt#chain + ~block:block_head + () + in + let* signature = sign_message cctxt ~src_sk ~block ~message in + let*! () = cctxt#message "Signature: %a" Signature.pp signature in return_unit); command ~group @@ -116,16 +123,23 @@ let commands () = (_, (key_locator, _)) signature (cctxt : #Protocol_client_context.full) -> - Shell_services.Blocks.hash cctxt ~chain:cctxt#chain ~block:block_head () - >>=? fun block -> - check_message cctxt ~key_locator ~block ~quiet ~message ~signature - >>=? function - | false -> cctxt#error "invalid signature" - | true -> - if quiet then return_unit - else - cctxt#message "Signature check successful" >>= fun () -> - return_unit); + let open Lwt_result_syntax in + let* block = + Shell_services.Blocks.hash + cctxt + ~chain:cctxt#chain + ~block:block_head + () + in + let* check = + check_message cctxt ~key_locator ~block ~quiet ~message ~signature + in + if check then + if quiet then return_unit + else + let*! () = cctxt#message "Signature check successful" in + return_unit + else cctxt#error "invalid signature"); command ~group ~desc: @@ -142,20 +156,25 @@ let commands () = unsigned_block_header delegate (cctxt : #Protocol_client_context.full) -> + let open Lwt_result_syntax in let unsigned_header = Data_encoding.Binary.to_bytes_exn Protocol.Alpha_context.Block_header.unsigned_encoding unsigned_block_header in - Shell_services.Chain.chain_id cctxt ~chain:cctxt#chain () - >>=? fun chain_id -> - Client_keys.get_key cctxt delegate >>=? fun (_, _, sk) -> - Client_keys.sign - cctxt - ~watermark: - (Protocol.Alpha_context.Block_header.to_watermark - (Block_header chain_id)) - sk - unsigned_header - >>=? fun s -> cctxt#message "%a" Hex.pp (Signature.to_hex s) >>= return); + let* chain_id = + Shell_services.Chain.chain_id cctxt ~chain:cctxt#chain () + in + let* _, _, sk = Client_keys.get_key cctxt delegate in + let* s = + Client_keys.sign + cctxt + ~watermark: + (Protocol.Alpha_context.Block_header.to_watermark + (Block_header chain_id)) + sk + unsigned_header + in + let*! () = cctxt#message "%a" Hex.pp (Signature.to_hex s) in + return_unit); ] diff --git a/src/proto_alpha/lib_client_commands/dune b/src/proto_alpha/lib_client_commands/dune index db6a3c31c7d3..5282bfdb1dfa 100644 --- a/src/proto_alpha/lib_client_commands/dune +++ b/src/proto_alpha/lib_client_commands/dune @@ -26,7 +26,6 @@ (flags (:standard) -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals -open Tezos_protocol_alpha -open Tezos_protocol_alpha_parameters -open Tezos_stdlib_unix @@ -60,7 +59,6 @@ (flags (:standard) -open Tezos_base.TzPervasives - -open Tezos_base.TzPervasives.Error_monad.Legacy_monad_globals -open Tezos_protocol_alpha -open Tezos_protocol_alpha_parameters -open Tezos_shell_services -- GitLab From de3b6e860e647028e2b47aed176262d4688b7101 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Rapha=C3=ABl=20Proust?= Date: Thu, 11 Aug 2022 15:31:50 +0200 Subject: [PATCH 2/2] Alpha/Client-commands: factor out common patterns and clean-up a bit --- .../client_proto_context_commands.ml | 61 ++++++++----------- 1 file changed, 25 insertions(+), 36 deletions(-) diff --git a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml index ee20652e495e..ad9140441a47 100644 --- a/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml +++ b/src/proto_alpha/lib_client_commands/client_proto_context_commands.ml @@ -348,8 +348,8 @@ let commands_ro () = let {Michelson_v1_parser.source; _} = Michelson_v1_printer.unparse_toplevel code in - let*! a = cctxt#answer "%s" source in - return a)); + let*! () = cctxt#answer "%s" source in + return_unit)); command ~group ~desc:"Get the `BLAKE2B` script hash of a contract." @@ -368,8 +368,8 @@ let commands_ro () = | Error errs -> cctxt#error "%a" pp_print_trace errs | Ok None -> cctxt#error "This is not a smart contract." | Ok (Some hash) -> - let* a = cctxt#answer "%a" Script_expr_hash.pp hash in - return_ok a); + let* () = cctxt#answer "%a" Script_expr_hash.pp hash in + return_ok_unit); command ~group ~desc:"Get the type of an entrypoint of a contract." @@ -500,15 +500,11 @@ let commands_ro () = | Some hash -> Lwt_result_syntax.return hash)) @@ stop) (fun predecessors operation_hash (ctxt : Protocol_client_context.full) -> - let open Lwt_result_syntax in - let* _ = - display_receipt_for_operation - ctxt - ~chain:ctxt#chain - ~predecessors - operation_hash - in - return_unit); + display_receipt_for_operation + ctxt + ~chain:ctxt#chain + ~predecessors + operation_hash); command ~group ~desc:"Summarize the current voting period" @@ -833,14 +829,14 @@ let transfer_command amount (source : Contract.t) destination ~successor_level () in - let*! o = + let*! _ = report_michelson_errors ~no_print_source ~msg:"transfer simulation failed" cctxt r in - match o with None -> return_unit | Some (_res, _contracts) -> return_unit + return_unit let prepare_batch_operation cctxt ?arg ?fee ?gas_limit ?storage_limit ?entrypoint (source : Contract.t) index batch = @@ -1276,18 +1272,13 @@ let commands_rw () = with | [] -> failwith "Empty operation list" | operations -> - let* source, src_pk, src_sk = + let* source = match source with | Originated contract -> - let* source = - Managed_contract.get_contract_manager cctxt contract - in - let* _, src_pk, src_sk = Client_keys.get_key cctxt source in - return (source, src_pk, src_sk) - | Implicit source -> - let* _, src_pk, src_sk = Client_keys.get_key cctxt source in - return (source, src_pk, src_sk) + Managed_contract.get_contract_manager cctxt contract + | Implicit source -> return source in + let* _, src_pk, src_sk = Client_keys.get_key cctxt source in let* contents = List.mapi_ep prepare operations in let (Manager_list contents) = Annotated_manager_operation.manager_of_list contents @@ -2106,7 +2097,7 @@ let commands_rw () = cctxt -> let open Lwt_result_syntax in let* _, src_pk, src_sk = Client_keys.get_key cctxt source in - let* res = + let* _, _, res = originate_tx_rollup cctxt ~chain:cctxt#chain @@ -2124,22 +2115,20 @@ let commands_rw () = ~fee_parameter () in - let* alias_name = TxRollupAlias.of_fresh cctxt force alias in let*? res = match res with - | ( _, - _, - Apply_results.Manager_operation_result - { - operation_result = - Apply_operation_result.Applied - (Apply_results.Tx_rollup_origination_result - {originated_tx_rollup; _}); - _; - } ) -> + | Apply_results.Manager_operation_result + { + operation_result = + Apply_operation_result.Applied + (Apply_results.Tx_rollup_origination_result + {originated_tx_rollup; _}); + _; + } -> Ok originated_tx_rollup | _ -> error_with "transaction rollup was not correctly originated" in + let* alias_name = TxRollupAlias.of_fresh cctxt force alias in save_tx_rollup ~force cctxt alias_name res); command ~group -- GitLab