ligo/lib_embedded_client_alpha/client_proto_programs.ml

(**************************************************************************)
(*                                                                        *)
(*    Copyright (c) 2014 - 2017.                                          *)
(*    Dynamic Ledger Solutions, Inc. <contact@tezos.com>                  *)
(*                                                                        *)
(*    All rights reserved. No warranty, explicit or implicit, provided.   *)
(*                                                                        *)
(**************************************************************************)

open Tezos_micheline
open Client_proto_args

open Michelson_v1_printer

module Program = Client_aliases.Alias (struct
    type t = Michelson_v1_parser.parsed Micheline_parser.parsing_result
    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 _cctxt source =
      return (Michelson_v1_parser.parse_toplevel source)
    let to_source _ ({ Michelson_v1_parser.source }, _) = return source
    let name = "program"
  end)

let group =
  { Cli_entries.name = "programs" ;
    title = "Commands for managing the record of known programs" }

let data_parameter =
  Cli_entries.parameter (fun _ data -> return (Michelson_v1_parser.parse_expression data))

let commands () =
  let open Cli_entries in
  let show_types_switch =
    switch
      ~parameter:"-details"
      ~doc:"Show the types of each instruction" in
  let emacs_mode_switch =
    switch
      ~parameter:"-emacs"
      ~doc:"Output in michelson-mode.el compatible format" in
  let trace_stack_switch =
    switch
      ~parameter:"-trace-stack"
      ~doc:"Show the stack after each step" in
  let amount_arg =
    Client_proto_args.tez_arg
      ~parameter:"-amount"
      ~doc:"The amount of the transfer in \xEA\x9C\xA9."
      ~default:"0.05" in
  [

    command ~group ~desc: "lists all known programs"
      no_options
      (fixed [ "list" ; "known" ; "programs" ])
      (fun () cctxt ->
         Program.load cctxt >>=? fun list ->
         Lwt_list.iter_s (fun (n, _) -> cctxt.message "%s" n) list >>= fun () ->
         return ()) ;

    command ~group ~desc: "remember a program under some name"
      no_options
      (prefixes [ "remember" ; "program" ]
       @@ Program.fresh_alias_param
       @@ Program.source_param
       @@ stop)
      (fun () name program cctxt ->
         Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
         Program.add cctxt name (program, [])) ;

    command ~group ~desc: "forget a remembered program"
      no_options
      (prefixes [ "forget" ; "program" ]
       @@ Program.alias_param
       @@ stop)
      (fun () (name, _) cctxt -> Program.del cctxt name) ;

    command ~group ~desc: "display a program"
      no_options
      (prefixes [ "show" ; "known" ; "program" ]
       @@ Program.alias_param
       @@ stop)
      (fun () (_, program) cctxt ->
         Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
         cctxt.message "%s\n" program.source >>= fun () ->
         return ()) ;

    command ~group ~desc: "ask the node to run a program"
      (args3 trace_stack_switch amount_arg no_print_source_flag)
      (prefixes [ "run" ; "program" ]
       @@ Program.source_param
       @@ prefixes [ "on" ; "storage" ]
       @@ Cli_entries.param ~name:"storage" ~desc:"the storage data"
         data_parameter
       @@ prefixes [ "and" ; "input" ]
       @@ Cli_entries.param ~name:"storage" ~desc:"the input data"
         data_parameter
       @@ stop)
      (fun (trace_stack, amount, no_print_source) program storage input cctxt ->
         Lwt.return (Micheline_parser.no_parsing_error program) >>=? fun program ->
         Lwt.return (Micheline_parser.no_parsing_error storage) >>=? fun storage ->
         Lwt.return (Micheline_parser.no_parsing_error input) >>=? fun input ->
         let print_errors errs =
           cctxt.warning "%a"
             (Michelson_v1_error_reporter.report_errors
                ~details:false
                ~show_source: (not no_print_source)
                ~parsed: program) errs >>= fun () ->
           cctxt.error "error running program" >>= fun () ->
           return () in
         begin
           if trace_stack then
             Client_proto_rpcs.Helpers.trace_code cctxt.rpc_config
               cctxt.config.block program.expanded
               (storage.expanded, input.expanded, amount) >>=? fun (storage, output, trace) ->
             cctxt.message
               "@[<v 0>@[<v 2>storage@,%a@]@,\
                @[<v 2>output@,%a@]@,@[<v 2>trace@,%a@]@]@."
               print_expr storage
               print_expr output
               (Format.pp_print_list
                  (fun ppf (loc, gas, stack) ->
                     Format.fprintf ppf
                       "- @[<v 0>location: %d (remaining gas: %d)@,\
                        [ @[<v 0>%a ]@]@]"
                       loc gas
                       (Format.pp_print_list print_expr)
                       stack))
               trace >>= fun () ->
             return ()
           else
             Client_proto_rpcs.Helpers.run_code cctxt.rpc_config
               cctxt.config.block program.expanded
               (storage.expanded, input.expanded, amount) >>=? fun (storage, output) ->
             cctxt.message "@[<v 0>@[<v 2>storage@,%a@]@,@[<v 2>output@,%a@]@]@."
               print_expr storage
               print_expr output >>= fun () ->
             return ()
         end >>= function
         | Ok () -> return ()
         | Error errs ->
             print_errors errs);

    command ~group ~desc: "ask the node to typecheck a program"
      (args3 show_types_switch emacs_mode_switch no_print_source_flag)
      (prefixes [ "typecheck" ; "program" ]
       @@ Program.source_param
       @@ stop)
      (fun (show_types, emacs_mode, no_print_source) (program, errors) cctxt ->
         begin match errors with
           | [] ->
               Client_proto_rpcs.Helpers.typecheck_code
                 cctxt.rpc_config cctxt.config.block program.expanded
           | errors -> Lwt.return (Error errors)
         end >>= fun res ->
         if emacs_mode then
           let type_map, errs = match res with
             | Ok type_map -> type_map, []
             | Error (Environment.Ecoproto_error
                        (Script_ir_translator.Ill_typed_contract (_, type_map ) :: _)
                      :: _ as errs) ->
                 type_map, errs
             | Error errs ->
                 [], errs in
           cctxt.message
             "(@[<v 0>(types . %a)@ (errors . %a)@])"
             Michelson_v1_emacs.print_type_map (program, type_map)
             Michelson_v1_emacs.report_errors (program, errs) >>= fun () ->
           return ()
         else
           match res with
           | Ok type_map ->
               let program = inject_types type_map program in
               cctxt.message "Well typed" >>= fun () ->
               if show_types then
                 cctxt.message "%a" Micheline_printer.print_expr program >>= fun () ->
                 return ()
               else return ()
           | Error errs ->
               cctxt.warning "%a"
                 (Michelson_v1_error_reporter.report_errors
                    ~details: show_types
                    ~show_source: (not no_print_source)
                    ~parsed:program) errs >>= fun () ->
               cctxt.error "ill-typed program") ;

    command ~group ~desc: "ask the node to typecheck a data expression"
      (args1 no_print_source_flag)
      (prefixes [ "typecheck" ; "data" ]
       @@ Cli_entries.param ~name:"data" ~desc:"the data to typecheck"
         data_parameter
       @@ prefixes [ "against" ; "type" ]
       @@ Cli_entries.param ~name:"type" ~desc:"the expected type"
         data_parameter
       @@ stop)
      (fun no_print_source data exp_ty cctxt ->
         Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
         Lwt.return (Micheline_parser.no_parsing_error exp_ty) >>=? fun exp_ty ->
         Client_proto_rpcs.Helpers.typecheck_data cctxt.Client_commands.rpc_config
           cctxt.config.block (data.expanded, exp_ty.expanded) >>= function
         | Ok () ->
             cctxt.message "Well typed" >>= fun () ->
             return ()
         | 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") ;

    command ~group
      ~desc: "ask the node to compute the hash of a data expression \
              using the same algorithm as script instruction H"
      no_options
      (prefixes [ "hash" ; "data" ]
       @@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
         data_parameter
       @@ stop)
      (fun () data cctxt ->
         Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
         Client_proto_rpcs.Helpers.hash_data cctxt.Client_commands.rpc_config
           cctxt.config.block (data.expanded) >>= function
         | Ok hash ->
             cctxt.message "%S" hash >>= fun () ->
             return ()
         | Error errs ->
             cctxt.warning "%a" pp_print_error errs  >>= fun () ->
             cctxt.error "ill-formed data") ;

    command ~group
      ~desc: "ask the node to compute the hash of a data expression \
              using the same algorithm as script instruction H, sign it using \
              a given secret key, and display it using the format expected by \
              script instruction CHECK_SIGNATURE"
      no_options
      (prefixes [ "hash" ; "and" ; "sign" ; "data" ]
       @@ Cli_entries.param ~name:"data" ~desc:"the data to hash"
         data_parameter
       @@ prefixes [ "for" ]
       @@ Client_keys.Secret_key.alias_param
       @@ stop)
      (fun () data (_, key) cctxt ->
         Lwt.return (Micheline_parser.no_parsing_error data) >>=? fun data ->
         Client_proto_rpcs.Helpers.hash_data cctxt.rpc_config
           cctxt.config.block (data.expanded) >>= function
         | Ok hash ->
             let signature = Ed25519.sign key (MBytes.of_string hash) in
             cctxt.message "Hash: %S@.Signature: %S"
               hash
               (signature |>
                Data_encoding.Binary.to_bytes Ed25519.Signature.encoding |>
                Hex_encode.hex_of_bytes) >>= fun () ->
             return ()
         | Error errs ->
             cctxt.warning "%a" pp_print_error errs >>= fun () ->
             cctxt.error "ill-formed data") ;

  ]