Source file client_proto_programs.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* 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 Alpha_context
open Tezos_micheline
open Michelson_v1_printer

module Program = Client_aliases.Alias (struct
  type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result

  include Compare.Make (struct
    type nonrec t = t

    let compare = Micheline_parser.compare Michelson_v1_parser.compare_parsed
  end)

  let encoding =
    Data_encoding.conv
      (fun ({Michelson_v1_parser.source; _}, _) -> source)
      (fun source -> Michelson_v1_parser.parse_toplevel source)
      Data_encoding.string

  let of_source source =
    let open Lwt_result_syntax in
    return (Michelson_v1_parser.parse_toplevel source)

  let to_source ({Michelson_v1_parser.source; _}, _) =
    let open Lwt_result_syntax in
    return source

  let name = "script"
end)

let print_errors ?parsed (cctxt : #Protocol_client_context.full) errs
    ~show_source =
  let open Lwt_result_syntax in
  let parsed = Option.map Michelson_v1_parser.unrecognize_prims parsed in
  let*! errs =
    Michelson_v1_error_reporter.enrich_runtime_errors
      cctxt
      ~chain:cctxt#chain
      ~block:cctxt#block
      ~parsed
      errs
  in
  let*! () =
    cctxt#warning
      "%a"
      (Michelson_v1_error_reporter.report_errors
         ~details:false
         ?parsed
         ~show_source)
      errs
  in
  let*! () = cctxt#error "error running script" in
  return_unit

let print_view_result (cctxt : #Protocol_client_context.full) =
  let open Lwt_result_syntax in
  function
  | Ok expr ->
      let*! () = cctxt#message "%a" print_expr expr in
      return_unit
  | Error errs -> print_errors cctxt ~show_source:false errs

let print_run_result (cctxt : Protocol_client_context.full) ~show_source ~parsed
    =
  let open Lwt_result_syntax in
  function
  | Ok (storage, operations, maybe_lazy_storage_diff) ->
      let* operations =
        List.map_es
          (Operation_result.normalize_internal_operation cctxt Readable)
          operations
      in
      let*! () =
        cctxt#message
          "@[<v 0>@[<v 2>storage@,\
           %a@]@,\
           @[<v 2>emitted operations@,\
           %a@]@,\
           @[<v 2>big_map diff@,\
           %a@]@]@."
          print_expr
          storage
          (Format.pp_print_list Operation_result.pp_internal_operation)
          operations
          (fun ppf -> function
            | None -> ()
            | Some diff -> print_big_map_diff ppf diff)
          maybe_lazy_storage_diff
      in
      return_unit
  | Error errs -> print_errors cctxt errs ~show_source ~parsed

let print_trace_result (cctxt : #Client_context.printer) ~show_source ~parsed =
  let open Lwt_result_syntax in
  function
  | Ok (storage, operations, trace, maybe_lazy_storage_diff) ->
      let*! () =
        cctxt#message
          "@[<v 0>@[<v 2>storage@,\
           %a@]@,\
           @[<v 2>emitted operations@,\
           %a@]@,\
           @[<v 2>big_map diff@,\
           %a@]@,\
           @[<v 2>trace@,\
           %a@]@]@."
          print_expr
          storage
          (Format.pp_print_list Operation_result.pp_internal_operation)
          operations
          (fun ppf -> function
            | None -> ()
            | Some diff -> print_big_map_diff ppf diff)
          maybe_lazy_storage_diff
          print_execution_trace
          trace
      in
      return_unit
  | Error errs -> print_errors cctxt errs ~show_source ~parsed

let print_run_instr_result (cctxt : #Client_context.printer) ~show_source
    ~parsed =
  let open Lwt_result_syntax in
  function
  | Ok (stack, gas) ->
      let*! () =
        cctxt#message
          "@[<v 0>@[<v 2>Result@,%a@]@,@[<v 2>Gas remaining: %a@]@]@."
          Michelson_v1_printer.print_typed_stack
          stack
          Alpha_context.Gas.pp
          gas
      in
      return_unit
  | Error errs -> print_errors cctxt errs ~show_source ~parsed

type simulation_params = {
  input : Michelson_v1_parser.parsed;
  unparsing_mode : Script_ir_unparser.unparsing_mode;
  now : Script_timestamp.t option;
  level : Script_int.n Script_int.num option;
  sender : Contract.t option;
  payer : Signature.public_key_hash option;
  gas : Gas.Arith.integral option;
  other_contracts : RPC.Scripts.S.other_contract_description list option;
  extra_big_maps : RPC.Scripts.S.extra_big_map_description list option;
}

type run_view_params = {
  shared_params : simulation_params;
  contract : Contract_hash.t;
  entrypoint : Entrypoint.t;
}

type run_script_view_params = {
  shared_params : simulation_params;
  contract : Contract_hash.t;
  view : string;
  unlimited_gas : bool;
}

type run_params = {
  shared_params : simulation_params;
  amount : Tez.t option;
  balance : Tez.t option;
  program : Michelson_v1_parser.parsed;
  storage : Michelson_v1_parser.parsed;
  entrypoint : Entrypoint.t option;
  self : Contract_hash.t option;
}

type run_instr_params = {
  shared_params : simulation_params;
  amount : Tez.t;
  balance : Tez.t option;
  stack : (Script.expr * Script.expr) list;
  self : Contract_hash.t option;
  parameter : Script.expr option;
  legacy : bool;
}

let run_view (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block (params : run_view_params) =
  let open Lwt_result_syntax in
  let {
    shared_params =
      {
        input;
        unparsing_mode;
        now;
        level;
        sender;
        payer;
        gas;
        other_contracts;
        extra_big_maps;
      };
    contract;
    entrypoint;
  } =
    params
  in
  let* chain_id = Chain_services.chain_id cctxt ~chain () in
  Plugin.RPC.Scripts.run_tzip4_view
    cctxt
    (chain, block)
    ~gas
    ~contract
    ~entrypoint
    ~input:input.expanded
    ~chain_id
    ~sender
    ~payer
    ~unparsing_mode
    ~now
    ~level
    ~other_contracts
    ~extra_big_maps

let run_script_view (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block (params : run_script_view_params) =
  let open Lwt_result_syntax in
  let {
    shared_params =
      {
        input;
        unparsing_mode;
        now;
        level;
        sender;
        payer;
        gas;
        other_contracts;
        extra_big_maps;
      };
    contract;
    view;
    unlimited_gas;
  } =
    params
  in
  let* chain_id = Chain_services.chain_id cctxt ~chain () in
  Plugin.RPC.Scripts.run_script_view
    cctxt
    (chain, block)
    ~gas
    ~contract
    ~view
    ~input:input.expanded
    ~unlimited_gas
    ~chain_id
    ~sender
    ~payer
    ~unparsing_mode
    ~now
    ~level
    ~other_contracts
    ~extra_big_maps

let run (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block (params : run_params) =
  let open Lwt_result_syntax in
  let* chain_id = Chain_services.chain_id cctxt ~chain () in
  let {
    shared_params =
      {
        input;
        unparsing_mode;
        now;
        level;
        sender;
        payer;
        gas;
        other_contracts;
        extra_big_maps;
      };
    program;
    amount;
    balance;
    storage;
    entrypoint;
    self;
  } =
    params
  in
  let amount = Option.value ~default:Tez.fifty_cents amount in
  let entrypoint = Option.value ~default:Entrypoint.default entrypoint in
  Plugin.RPC.Scripts.run_code
    cctxt
    (chain, block)
    ~gas
    ~entrypoint
    ~unparsing_mode:(Some unparsing_mode)
    ~script:program.expanded
    ~storage:storage.expanded
    ~input:input.expanded
    ~amount
    ~balance
    ~chain_id
    ~sender
    ~payer
    ~self
    ~now
    ~level
    ~other_contracts
    ~extra_big_maps

let trace (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block (params : run_params) =
  let open Lwt_result_syntax in
  let* chain_id = Chain_services.chain_id cctxt ~chain () in
  let {
    shared_params =
      {
        input;
        unparsing_mode;
        now;
        level;
        sender;
        payer;
        gas;
        other_contracts;
        extra_big_maps;
      };
    program;
    amount;
    balance;
    storage;
    entrypoint;
    self;
  } =
    params
  in
  let amount = Option.value ~default:Tez.fifty_cents amount in
  let entrypoint = Option.value ~default:Entrypoint.default entrypoint in
  Plugin.RPC.Scripts.trace_code
    cctxt
    (chain, block)
    ~gas
    ~entrypoint
    ~unparsing_mode:(Some unparsing_mode)
    ~script:program.expanded
    ~storage:storage.expanded
    ~input:input.expanded
    ~amount
    ~balance
    ~chain_id
    ~sender
    ~payer
    ~self
    ~now
    ~level
    ~other_contracts
    ~extra_big_maps

let run_instr (cctxt : #Protocol_client_context.rpc_context)
    ~(chain : Chain_services.chain) ~block (params : run_instr_params) =
  let open Lwt_result_syntax in
  let* chain_id = Chain_services.chain_id cctxt ~chain () in
  let {shared_params; amount; balance; stack; self; parameter; legacy} =
    params
  in
  let {
    input;
    unparsing_mode;
    now;
    level;
    sender;
    payer;
    gas;
    other_contracts;
    extra_big_maps;
  } =
    shared_params
  in
  Plugin.RPC.Scripts.run_instr
    ~gas
    ~legacy
    ~input:stack
    ~code:input.expanded
    ~chain_id
    ~now
    ~level
    ~unparsing_mode:(Some unparsing_mode)
    ~source:payer
    ~sender
    ~self
    ~parameter
    ~amount
    ~balance
    ~other_contracts
    ~extra_big_maps
    cctxt
    (chain, block)

let typecheck_data cctxt ~(chain : Chain_services.chain) ~block ~gas ~legacy
    ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) () =
  Plugin.RPC.Scripts.typecheck_data
    cctxt
    (chain, block)
    ~gas
    ~legacy
    ~data:data.expanded
    ~ty:ty.expanded

let typecheck_program cctxt ~(chain : Chain_services.chain) ~block ~gas ~legacy
    ~show_types (program : Michelson_v1_parser.parsed) =
  Plugin.RPC.Scripts.typecheck_code
    cctxt
    (chain, block)
    ~gas
    ~legacy
    ~script:program.expanded
    ~show_types

let script_size cctxt ~(chain : Chain_services.chain) ~block ~gas ~legacy
    ~(program : Michelson_v1_parser.parsed)
    ~(storage : Michelson_v1_parser.parsed) () =
  Plugin.RPC.Scripts.script_size
    cctxt
    (chain, block)
    ~gas
    ~legacy
    ~script:program.expanded
    ~storage:storage.expanded

let print_typecheck_result ~emacs ~show_types ~print_source_on_error
    ~display_names ~name program res (cctxt : #Client_context.printer) =
  let open Lwt_result_syntax in
  if emacs then
    let type_map, errs, _gas =
      match res with
      | Ok (type_map, gas) -> (type_map, [], Some gas)
      | Error
          (Environment.Ecoproto_error
             (Script_tc_errors.Ill_typed_contract (_, type_map))
           :: _ as errs) ->
          (type_map, errs, None)
      | Error errs -> ([], errs, None)
    in
    let*! () =
      cctxt#message
        "(@[<v 0>(types . %a)@ (errors . %a)@])"
        Michelson_v1_emacs.print_type_map
        (program, type_map)
        Michelson_v1_emacs.report_errors
        (program, errs)
    in
    return_unit
  else
    match res with
    | Ok (type_map, gas) ->
        let program = Michelson_v1_printer.inject_types type_map program in
        let*! () =
          cctxt#message
            "@[Well typed (Gas remaining: %a)\t%t@]"
            Gas.pp
            gas
            (fun fmt -> if display_names then Format.pp_print_string fmt name)
        in
        if show_types then
          let*! () = cctxt#message "%a" Micheline_printer.print_expr program in
          return_unit
        else return_unit
    | Error errs ->
        let*! () =
          cctxt#warning
            "%a"
            (Michelson_v1_error_reporter.report_errors
               ~details:show_types
               ~show_source:print_source_on_error
               ~parsed:(Michelson_v1_parser.unrecognize_prims program))
            errs
        in
        cctxt#error "script %S is ill-typed" name

let entrypoint_type cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) ~entrypoint =
  Michelson_v1_entrypoints.script_entrypoint_type
    cctxt
    ~chain
    ~block
    program.expanded
    ~entrypoint

let print_entrypoint_type (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ~entrypoint ty =
  Michelson_v1_entrypoints.print_entrypoint_type
    cctxt
    ~entrypoint
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty

let list_entrypoints cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) =
  Michelson_v1_entrypoints.list_entrypoints cctxt ~chain ~block program.expanded

let print_entrypoints_list (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ty =
  Michelson_v1_entrypoints.print_entrypoints_list
    cctxt
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty

let list_unreachables cctxt ~(chain : Chain_services.chain) ~block
    (program : Michelson_v1_parser.parsed) =
  Michelson_v1_entrypoints.list_unreachables
    cctxt
    ~chain
    ~block
    program.expanded

let print_unreachables (cctxt : #Client_context.printer) ~emacs ?script_name
    ~show_source ~parsed ty =
  Michelson_v1_entrypoints.print_unreachables
    cctxt
    ~emacs
    ?script_name
    ~on_errors:(print_errors cctxt ~show_source ~parsed)
    ty