michelson_v1_entrypoints.ml
(*****************************************************************************)
(* *)
(* Open Source License *)
(* Copyright (c) 2019 Nomadic Labs <contact@nomadic-labs.com> *)
(* *)
(* Permission is hereby granted, free of charge, to any person obtaining a *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense, *)
(* and/or sell copies of the Software, and to permit persons to whom the *)
(* Software is furnished to do so, subject to the following conditions: *)
(* *)
(* The above copyright notice and this permission notice shall be included *)
(* in all copies or substantial portions of the Software. *)
(* *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *)
(* DEALINGS IN THE SOFTWARE. *)
(* *)
(*****************************************************************************)
open Protocol
open Protocol_client_context
open Alpha_context
type error += Contract_without_code of Contract.t
let () =
register_error_kind
`Permanent
~id:"contractWithoutCode"
~title:"The given contract has no code"
~description:
"Attempt to get the code of a contract failed because it has nocode. No \
scriptless contract should remain."
~pp:(fun ppf contract ->
Format.fprintf ppf "Contract has no code %a." Contract.pp contract)
Data_encoding.(obj1 (req "contract" Contract.encoding))
(function Contract_without_code c -> Some c | _ -> None)
(fun c -> Contract_without_code c)
let print_errors (cctxt : #Client_context.printer) errs =
cctxt#error "%a" Error_monad.pp_print_trace errs >>= fun () -> return_unit
let script_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
(program : Script.expr) ~entrypoint =
Alpha_services.Helpers.Scripts.entrypoint_type
cctxt
(chain, block)
(program, entrypoint)
>>= function
| Ok ty -> return_some ty
| Error
(Environment.Ecoproto_error (Script_tc_errors.No_such_entrypoint _) :: _)
->
return None
| Error _ as err -> Lwt.return err
let contract_entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
~contract ~entrypoint =
Alpha_services.Contract.entrypoint_type
cctxt
(chain, block)
contract
entrypoint
>>= function
| Ok ty -> return_some ty
| Error (Tezos_rpc.Context.Not_found _ :: _) -> return None
| Error _ as err -> Lwt.return err
let print_entrypoint_type (cctxt : #Client_context.printer)
?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name ~entrypoint
= function
| Ok (Some ty) ->
(if emacs then
cctxt#message
"@[<v 2>((entrypoint . %s) (type . %a))@]@."
entrypoint
Michelson_v1_emacs.print_expr
ty
else
cctxt#message
"@[<v 2>Entrypoint %s: %a@]@."
entrypoint
Michelson_v1_printer.print_expr
ty)
>>= fun () -> return_unit
| Ok None ->
cctxt#message
"@[<v 2>No entrypoint named %s%a%a@]@."
entrypoint
(Format.pp_print_option (fun ppf ->
Format.fprintf ppf " for contract %a" Contract.pp))
contract
(Format.pp_print_option (fun ppf -> Format.fprintf ppf " for script %s"))
script_name
>>= fun () -> return_unit
| Error errs -> on_errors errs
let list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract =
Alpha_services.Contract.list_entrypoints cctxt (chain, block) contract
let list_contract_unreachables cctxt ~chain ~block ~contract =
list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
>>=? fun (unreachables, _) -> return unreachables
let list_contract_entrypoints cctxt ~chain ~block ~contract =
list_contract_unreachables_and_entrypoints cctxt ~chain ~block ~contract
>>=? fun (_, entrypoints) ->
if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then
contract_entrypoint_type cctxt ~chain ~block ~contract ~entrypoint:"default"
>>= function
| Ok (Some ty) -> return (("default", ty) :: entrypoints)
| Ok None -> return entrypoints
| Error _ as err -> Lwt.return err
else return entrypoints
let list_unreachables cctxt ~chain ~block (program : Script.expr) =
Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
>>=? fun (unreachables, _) -> return unreachables
let list_entrypoints cctxt ~chain ~block (program : Script.expr) =
Alpha_services.Helpers.Scripts.list_entrypoints cctxt (chain, block) program
>>=? fun (_, entrypoints) ->
if not @@ List.mem_assoc ~equal:String.equal "default" entrypoints then
script_entrypoint_type cctxt ~chain ~block program ~entrypoint:"default"
>>= function
| Ok (Some ty) -> return (("default", ty) :: entrypoints)
| Ok None -> return entrypoints
| Error _ as err -> Lwt.return err
else return entrypoints
let print_entrypoints_list (cctxt : #Client_context.printer)
?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
| Ok entrypoint_list ->
(if emacs then
cctxt#message
"@[<v 2>(@[%a@])@."
(Format.pp_print_list
~pp_sep:Format.pp_print_cut
(fun ppf (entrypoint, ty) ->
Format.fprintf
ppf
"@[<v 2>( ( entrypoint . %s ) ( type . @[%a@]))@]"
entrypoint
Michelson_v1_emacs.print_expr
ty))
entrypoint_list
else
cctxt#message
"@[<v 2>Entrypoints%a%a: @,%a@]@."
(Format.pp_print_option (fun ppf ->
Format.fprintf ppf " for contract %a" Contract.pp))
contract
(Format.pp_print_option (fun ppf ->
Format.fprintf ppf " for script %s"))
script_name
(Format.pp_print_list
~pp_sep:Format.pp_print_cut
(fun ppf (entrypoint, ty) ->
Format.fprintf
ppf
"@[<v 2>%s: @[%a@]@]"
entrypoint
Michelson_v1_printer.print_expr
ty))
entrypoint_list)
>>= fun () -> return_unit
| Error errs -> on_errors errs
let print_unreachables (cctxt : #Client_context.printer)
?(on_errors = print_errors cctxt) ~emacs ?contract ?script_name = function
| Ok unreachable ->
(if emacs then
cctxt#message
"@[<v 2>(@[%a@])@."
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf path ->
Format.fprintf
ppf
"@[<h>( unreachable-path . %a )@]"
(Format.pp_print_list
~pp_sep:Format.pp_print_space
(fun ppf prim ->
Format.pp_print_string ppf
@@ Michelson_v1_primitives.string_of_prim prim))
path))
unreachable
else
match unreachable with
| [] -> cctxt#message "@[<v 2>None.@]@."
| _ ->
cctxt#message
"@[<v 2>Unreachable paths in the argument%a%a: @[%a@]@."
(Format.pp_print_option (fun ppf ->
Format.fprintf ppf " of contract %a" Contract.pp))
contract
(Format.pp_print_option (fun ppf ->
Format.fprintf ppf " of script %s"))
script_name
(Format.pp_print_list ~pp_sep:Format.pp_print_cut (fun ppf ->
Format.fprintf
ppf
"@[<h> %a @]"
(Format.pp_print_list
~pp_sep:(fun ppf _ -> Format.pp_print_string ppf "/")
(fun ppf prim ->
Format.pp_print_string ppf
@@ Michelson_v1_primitives.string_of_prim prim))))
unreachable)
>>= fun () -> return_unit
| Error errs -> on_errors errs