Source file injection.ml

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

let get_branch (rpc_config : #Protocol_client_context.full) ~chain
    ~(block : Block_services.block) branch =
  let branch = Option.value ~default:0 branch in
  (* TODO export parameter *)
  (match block with
  | `Head n -> return (`Head (n + branch))
  | `Hash (h, n) -> return (`Hash (h, n + branch))
  | `Alias (a, n) -> return (`Alias (a, n))
  | `Genesis -> return `Genesis
  | `Level i -> return (`Level i))
  >>=? fun block ->
  Shell_services.Blocks.hash rpc_config ~chain ~block () >>=? fun hash ->
  Shell_services.Chain.chain_id rpc_config ~chain () >>=? fun chain_id ->
  return (chain_id, hash)

type 'kind preapply_result =
  Operation_hash.t * 'kind operation * 'kind operation_metadata

type 'kind result_list =
  Operation_hash.t * 'kind contents_list * 'kind contents_result_list

type 'kind result = Operation_hash.t * 'kind contents * 'kind contents_result

let get_manager_operation_gas_and_fee contents =
  let open Operation in
  let l = to_list (Contents_list contents) in
  List.fold_left
    (fun acc -> function
      | Contents (Manager_operation {fee; gas_limit; _}) -> (
          match acc with
          | Error _ as e -> e
          | Ok (total_fee, total_gas) -> (
              match Tez.(total_fee +? fee) with
              | Ok total_fee -> Ok (total_fee, Gas.Arith.add total_gas gas_limit)
              | Error _ as e -> e))
      | _ -> acc)
    (Ok (Tez.zero, Gas.Arith.zero))
    l

type fee_parameter = {
  minimal_fees : Tez.t;
  minimal_nanotez_per_byte : Q.t;
  minimal_nanotez_per_gas_unit : Q.t;
  force_low_fee : bool;
  fee_cap : Tez.t;
  burn_cap : Tez.t;
}

let dummy_fee_parameter =
  {
    minimal_fees = Tez.zero;
    minimal_nanotez_per_byte = Q.zero;
    minimal_nanotez_per_gas_unit = Q.zero;
    force_low_fee = false;
    fee_cap = Tez.one;
    burn_cap = Tez.zero;
  }

(* Rounding up (see Z.cdiv) *)
let z_mutez_of_q_nanotez (ntz : Q.t) =
  let q_mutez = Q.div ntz (Q.of_int 1000) in
  Z.cdiv q_mutez.Q.num q_mutez.Q.den

let check_fees :
    type t.
    #Protocol_client_context.full ->
    fee_parameter ->
    t contents_list ->
    int ->
    unit Lwt.t =
 fun cctxt config op size ->
  match get_manager_operation_gas_and_fee op with
  | Error _ -> assert false (* FIXME *)
  | Ok (fee, gas) ->
      if Tez.compare fee config.fee_cap > 0 then
        cctxt#error
          "The proposed fee (%s%a) are higher than the configured fee cap \
           (%s%a).@\n\
          \ Use `--fee-cap %a` to emit this operation anyway."
          Client_proto_args.tez_sym
          Tez.pp
          fee
          Client_proto_args.tez_sym
          Tez.pp
          config.fee_cap
          Tez.pp
          fee
        >>= fun () -> exit 1
      else
        let fees_in_nanotez =
          Q.mul (Q.of_int64 (Tez.to_mutez fee)) (Q.of_int 1000)
        in
        let minimal_fees_in_nanotez =
          Q.mul (Q.of_int64 (Tez.to_mutez config.minimal_fees)) (Q.of_int 1000)
        in
        let minimal_fees_for_gas_in_nanotez =
          Q.mul
            config.minimal_nanotez_per_gas_unit
            (Q.of_bigint (Gas.Arith.integral_to_z gas))
        in
        let minimal_fees_for_size_in_nanotez =
          Q.mul config.minimal_nanotez_per_byte (Q.of_int size)
        in
        let estimated_fees_in_nanotez =
          Q.add
            minimal_fees_in_nanotez
            (Q.add
               minimal_fees_for_gas_in_nanotez
               minimal_fees_for_size_in_nanotez)
        in
        let estimated_fees_in_mutez =
          z_mutez_of_q_nanotez estimated_fees_in_nanotez
        in
        let estimated_fees =
          match Tez.of_mutez (Z.to_int64 estimated_fees_in_mutez) with
          | None -> assert false
          | Some fee -> fee
        in
        if
          (not config.force_low_fee)
          && Q.compare fees_in_nanotez estimated_fees_in_nanotez < 0
        then
          cctxt#error
            "The proposed fee (%s%a) are lower than the fee that baker expect \
             by default (%s%a).@\n\
            \ Use `--force-low-fee` to emit this operation anyway."
            Client_proto_args.tez_sym
            Tez.pp
            fee
            Client_proto_args.tez_sym
            Tez.pp
            estimated_fees
          >>= fun () -> exit 1
        else Lwt.return_unit

let print_for_verbose_signing ppf ~watermark ~bytes ~branch ~contents =
  let open Format in
  pp_open_vbox ppf 0 ;
  let item f =
    pp_open_hovbox ppf 4 ;
    pp_print_string ppf "  * " ;
    f ppf () ;
    pp_close_box ppf () ;
    pp_print_cut ppf ()
  in
  let hash_pp l =
    fprintf
      ppf
      "%s"
      (Tezos_crypto.Base58.raw_encode
         Tezos_crypto.Blake2B.(hash_bytes l |> to_string))
  in
  item (fun ppf () ->
      pp_print_text ppf "Branch: " ;
      Block_hash.pp ppf branch) ;
  item (fun ppf () ->
      fprintf
        ppf
        "Watermark: `%a` (0x%s)"
        Tezos_crypto.Signature.V0.pp_watermark
        watermark
        (Hex.of_bytes (Tezos_crypto.Signature.V0.bytes_of_watermark watermark)
        |> Hex.show)) ;
  item (fun ppf () ->
      pp_print_text ppf "Operation bytes: " ;
      TzString.fold_left (* We split the bytes into lines for display: *)
        (fun n c ->
          pp_print_char ppf c ;
          if
            n < 72
            (* is the email-body standard width, ideal for copy-pasting. *)
          then n + 1
          else (
            pp_print_space ppf () ;
            0))
        0
        (Hex.of_bytes bytes |> Hex.show)
      |> ignore) ;
  item (fun ppf () ->
      pp_print_text ppf "Blake 2B Hash (raw): " ;
      hash_pp [bytes]) ;
  item (fun ppf () ->
      pp_print_text
        ppf
        "Blake 2B Hash (ledger-style, with operation watermark): " ;
      hash_pp [Tezos_crypto.Signature.V0.bytes_of_watermark watermark; bytes]) ;
  let json =
    Data_encoding.Json.construct
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  item (fun ppf () ->
      pp_print_text ppf "JSON encoding: " ;
      Data_encoding.Json.pp ppf json) ;
  pp_close_box ppf ()

let preapply (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
    ?(verbose_signing = false) ?fee_parameter ?branch ?src_sk
    (contents : t contents_list) =
  get_branch cctxt ~chain ~block branch >>=? fun (chain_id, branch) ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn
      Operation.unsigned_encoding
      ({branch}, Contents_list contents)
  in
  (match src_sk with
  | None -> return_none
  | Some src_sk ->
      let watermark =
        match contents with
        | Single (Endorsement _) ->
            Tezos_crypto.Signature.V0.(Endorsement chain_id)
        | _ -> Tezos_crypto.Signature.V0.Generic_operation
      in
      (if verbose_signing then
       cctxt#message
         "Pre-signature information (verbose signing):@.%t%!"
         (print_for_verbose_signing ~watermark ~bytes ~branch ~contents)
      else Lwt.return_unit)
      >>= fun () ->
      Client_keys_v0.sign cctxt ~watermark src_sk bytes >>=? fun signature ->
      return_some signature)
  >>=? fun signature ->
  let op : _ Operation.t =
    {shell = {branch}; protocol_data = {contents; signature}}
  in
  let oph = Operation.hash op in
  let size = Bytes.length bytes + Tezos_crypto.Signature.V0.size in
  (match fee_parameter with
  | Some fee_parameter -> check_fees cctxt fee_parameter contents size
  | None -> Lwt.return_unit)
  >>= fun () ->
  Protocol_client_context.Alpha_block_services.Helpers.Preapply.operations
    cctxt
    ~chain
    ~block
    [Operation.pack op]
  >>=? function
  | [(Operation_data op', Operation_metadata result)] -> (
      match
        ( Operation.equal op {shell = {branch}; protocol_data = op'},
          Apply_results.kind_equal_list contents result.contents )
      with
      | Some Operation.Eq, Some Apply_results.Eq ->
          return ((oph, op, result) : t preapply_result)
      | _ -> failwith "Unexpected result")
  | _ -> failwith "Unexpected result"

let simulate (type t) (cctxt : #Protocol_client_context.full) ~chain ~block
    ?branch (contents : t contents_list) =
  get_branch cctxt ~chain ~block branch >>=? fun (_chain_id, branch) ->
  let op : _ Operation.t =
    {shell = {branch}; protocol_data = {contents; signature = None}}
  in
  let oph = Operation.hash op in
  Chain_services.chain_id cctxt ~chain () >>=? fun chain_id ->
  Alpha_services.Helpers.Scripts.run_operation
    cctxt
    (chain, block)
    ~op:(Operation.pack op)
    ~chain_id
  >>=? function
  | Operation_data op', Operation_metadata result -> (
      match
        ( Operation.equal op {shell = {branch}; protocol_data = op'},
          Apply_results.kind_equal_list contents result.contents )
      with
      | Some Operation.Eq, Some Apply_results.Eq ->
          return ((oph, op, result) : t preapply_result)
      | _ -> failwith "Unexpected result")
  | _ -> failwith "Unexpected result"

let estimated_gas_single (type kind)
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let consumed_gas (type kind) (result : kind manager_operation_result) =
    match result with
    | Applied (Transaction_result {consumed_gas; _}) -> Ok consumed_gas
    | Applied (Origination_result {consumed_gas; _}) -> Ok consumed_gas
    | Applied (Reveal_result {consumed_gas}) -> Ok consumed_gas
    | Applied (Delegation_result {consumed_gas}) -> Ok consumed_gas
    | Skipped _ -> assert false
    | Backtracked (_, None) ->
        Ok Gas.Arith.zero (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs)
    | Failed (_, errs) -> Error (Environment.wrap_tztrace errs)
  in
  consumed_gas operation_result >>? fun acc ->
  List.fold_left_e
    (fun acc (Internal_operation_result (_, r)) ->
      consumed_gas r >>? fun gas -> Ok (Gas.Arith.add acc gas))
    acc
    internal_operation_results

let estimated_storage_single (type kind) origination_size
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let storage_size_diff (type kind) (result : kind manager_operation_result) =
    match result with
    | Applied
        (Transaction_result
          {paid_storage_size_diff; allocated_destination_contract; _}) ->
        if allocated_destination_contract then
          Ok (Z.add paid_storage_size_diff origination_size)
        else Ok paid_storage_size_diff
    | Applied (Origination_result {paid_storage_size_diff; _}) ->
        Ok (Z.add paid_storage_size_diff origination_size)
    | Applied (Reveal_result _) -> Ok Z.zero
    | Applied (Delegation_result _) -> Ok Z.zero
    | Skipped _ -> assert false
    | Backtracked (_, None) ->
        Ok Z.zero (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs)
    | Failed (_, errs) -> Error (Environment.wrap_tztrace errs)
  in
  storage_size_diff operation_result >>? fun acc ->
  List.fold_left_e
    (fun acc (Internal_operation_result (_, r)) ->
      storage_size_diff r >>? fun storage -> Ok (Z.add acc storage))
    acc
    internal_operation_results

let estimated_storage origination_size res =
  let rec estimated_storage : type kind. kind contents_result_list -> _ =
    function
    | Single_result (Manager_operation_result _ as res) ->
        estimated_storage_single origination_size res
    | Single_result _ -> Ok Z.zero
    | Cons_result (res, rest) ->
        estimated_storage_single origination_size res >>? fun storage1 ->
        estimated_storage rest >>? fun storage2 -> Ok (Z.add storage1 storage2)
  in
  estimated_storage res >>? fun diff -> Ok (Z.max Z.zero diff)

let originated_contracts_single (type kind)
    (Manager_operation_result {operation_result; internal_operation_results; _} :
      kind Kind.manager contents_result) =
  let originated_contracts (type kind) (result : kind manager_operation_result)
      =
    match result with
    | Applied (Transaction_result {originated_contracts; _}) ->
        Ok originated_contracts
    | Applied (Origination_result {originated_contracts; _}) ->
        Ok originated_contracts
    | Applied (Reveal_result _) -> Ok []
    | Applied (Delegation_result _) -> Ok []
    | Skipped _ -> assert false
    | Backtracked (_, None) ->
        Ok [] (* there must be another error for this to happen *)
    | Backtracked (_, Some errs) -> Error (Environment.wrap_tztrace errs)
    | Failed (_, errs) -> Error (Environment.wrap_tztrace errs)
  in
  originated_contracts operation_result >>? fun acc ->
  let acc = List.rev acc in
  List.fold_left_e
    (fun acc (Internal_operation_result (_, r)) ->
      originated_contracts r >>? fun contracts ->
      Ok (List.rev_append contracts acc))
    acc
    internal_operation_results

let rec originated_contracts : type kind. kind contents_result_list -> _ =
  function
  | Single_result (Manager_operation_result _ as res) ->
      originated_contracts_single res >|? List.rev
  | Single_result _ -> Ok []
  | Cons_result (res, rest) ->
      originated_contracts_single res >>? fun contracts1 ->
      originated_contracts rest >>? fun contracts2 ->
      Ok (List.rev_append contracts1 contracts2)

let detect_script_failure : type kind. kind operation_metadata -> _ =
  let rec detect_script_failure : type kind. kind contents_result_list -> _ =
    let detect_script_failure_single (type kind)
        (Manager_operation_result
           {operation_result; internal_operation_results; _} :
          kind Kind.manager contents_result) =
      let detect_script_failure (type kind)
          (result : kind manager_operation_result) =
        match result with
        | Applied _ -> Ok ()
        | Skipped _ -> assert false
        | Backtracked (_, None) ->
            (* there must be another error for this to happen *)
            Ok ()
        | Backtracked (_, Some errs) ->
            record_trace
              (error_of_fmt "The transfer simulation failed.")
              (Error (Environment.wrap_tztrace errs))
        | Failed (_, errs) ->
            record_trace
              (error_of_fmt "The transfer simulation failed.")
              (Error (Environment.wrap_tztrace errs))
      in
      detect_script_failure operation_result >>? fun () ->
      List.iter_e
        (fun (Internal_operation_result (_, r)) -> detect_script_failure r)
        internal_operation_results
    in
    function
    | Single_result (Manager_operation_result _ as res) ->
        detect_script_failure_single res
    | Single_result _ -> Ok ()
    | Cons_result (res, rest) ->
        detect_script_failure_single res >>? fun () ->
        detect_script_failure rest
  in
  fun {contents} -> detect_script_failure contents

(* This value is used as a safety guard for gas limit. *)
let safety_guard = Gas.Arith.(integral_of_int_exn 100)

let may_patch_limits (type kind) (cctxt : #Protocol_client_context.full)
    ~fee_parameter ~chain ~block ?branch
    (annotated_contents : kind Annotated_manager_operation.annotated_list) :
    kind Kind.manager contents_list tzresult Lwt.t =
  Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt
  >>=? fun () ->
  Alpha_services.Constants.all cctxt (chain, block)
  >>=? fun {
             parametric =
               {
                 hard_gas_limit_per_operation;
                 hard_storage_limit_per_operation;
                 origination_size;
                 cost_per_byte;
                 _;
               };
             _;
           } ->
  let user_gas_limit_needs_patching user_gas_limit =
    Limit.fold user_gas_limit ~unknown:true ~known:(fun user_gas_limit ->
        Gas.Arith.(
          user_gas_limit < zero || hard_gas_limit_per_operation < user_gas_limit))
  in
  let user_storage_limit_needs_patching user_storage_limit =
    Limit.fold
      user_storage_limit
      ~unknown:true
      ~known:(fun user_storage_limit ->
        Z.Compare.(
          user_storage_limit < Z.zero
          || hard_storage_limit_per_operation < user_storage_limit))
  in
  let may_need_patching_single :
      type kind.
      kind Annotated_manager_operation.t ->
      kind Annotated_manager_operation.t option = function
    | Manager_info c ->
        let needs_patching =
          Limit.is_unknown c.fee
          || user_gas_limit_needs_patching c.gas_limit
          || user_storage_limit_needs_patching c.storage_limit
        in
        if not needs_patching then None
        else
          (* Set limits for simulation purposes *)
          let gas_limit =
            if user_gas_limit_needs_patching c.gas_limit then
              Limit.known hard_gas_limit_per_operation
            else c.gas_limit
          in
          let storage_limit =
            if user_storage_limit_needs_patching c.storage_limit then
              Limit.known hard_storage_limit_per_operation
            else c.storage_limit
          in
          let fee = Limit.value ~when_unknown:Tez.zero c.fee in
          Some
            (Manager_info
               {c with gas_limit; storage_limit; fee = Limit.known fee})
  in
  let rec may_need_patching :
      type kind.
      kind Annotated_manager_operation.annotated_list ->
      kind Annotated_manager_operation.annotated_list option = function
    | Single_manager annotated_op -> (
        match may_need_patching_single annotated_op with
        | None -> None
        | Some annotated_op -> Some (Single_manager annotated_op))
    | Cons_manager (annotated_op, rest) -> (
        let annotated_op_opt = may_need_patching_single annotated_op in
        let rest_opt = may_need_patching rest in
        match (annotated_op_opt, rest_opt) with
        | None, None -> None
        | _ ->
            let op = Option.value ~default:annotated_op annotated_op_opt in
            let rest = Option.value ~default:rest rest_opt in
            Some (Cons_manager (op, rest)))
  in
  let rec patch_fee : type kind. first:bool -> kind contents -> kind contents =
   fun ~first -> function
    | Manager_operation c as op -> (
        let size =
          if first then
            (WithExceptions.Option.get ~loc:__LOC__
            @@ Data_encoding.Binary.fixed_length
                 Tezos_base.Operation.shell_header_encoding)
            + Data_encoding.Binary.length
                Operation.contents_encoding
                (Contents op)
            + Tezos_crypto.Signature.V0.size
          else
            Data_encoding.Binary.length
              Operation.contents_encoding
              (Contents op)
        in
        let minimal_fees_in_nanotez =
          Q.mul
            (Q.of_int64 (Tez.to_mutez fee_parameter.minimal_fees))
            (Q.of_int 1000)
        in
        let minimal_fees_for_gas_in_nanotez =
          Q.mul
            fee_parameter.minimal_nanotez_per_gas_unit
            (Q.of_bigint @@ Gas.Arith.integral_to_z c.gas_limit)
        in
        let minimal_fees_for_size_in_nanotez =
          Q.mul fee_parameter.minimal_nanotez_per_byte (Q.of_int size)
        in
        let fees_in_nanotez =
          Q.add minimal_fees_in_nanotez
          @@ Q.add
               minimal_fees_for_gas_in_nanotez
               minimal_fees_for_size_in_nanotez
        in
        let fees_in_mutez = z_mutez_of_q_nanotez fees_in_nanotez in
        match Tez.of_mutez (Z.to_int64 fees_in_mutez) with
        | None -> assert false
        | Some fee ->
            if Tez.(fee <= c.fee) then op
            else patch_fee ~first (Manager_operation {c with fee}))
    | c -> c
  in
  let patch :
      type kind.
      first:bool ->
      kind Annotated_manager_operation.t * kind Kind.manager contents_result ->
      kind Kind.manager contents tzresult Lwt.t =
   fun ~first -> function
    | (Manager_info c as op), (Manager_operation_result _ as result) ->
        (if user_gas_limit_needs_patching c.gas_limit then
         Lwt.return (estimated_gas_single result) >>=? fun gas ->
         if Gas.Arith.(gas = zero) then
           cctxt#message "Estimated gas: none" >>= fun () ->
           return
             (Annotated_manager_operation.set_gas_limit
                (Limit.known Gas.Arith.zero)
                op)
         else
           cctxt#message
             "Estimated gas: %a units (will add 100 for safety)"
             Gas.Arith.pp
             gas
           >>= fun () ->
           let safe_gas = Gas.Arith.(add (ceil gas) safety_guard) in
           let patched_gas =
             Gas.Arith.min safe_gas hard_gas_limit_per_operation
           in
           return
             (Annotated_manager_operation.set_gas_limit
                (Limit.known patched_gas)
                op)
        else return op)
        >>=? fun op ->
        (if user_storage_limit_needs_patching c.storage_limit then
         Lwt.return
           (estimated_storage_single (Z.of_int origination_size) result)
         >>=? fun storage ->
         if Z.equal storage Z.zero then
           cctxt#message "Estimated storage: no bytes added" >>= fun () ->
           return
             (Annotated_manager_operation.set_storage_limit
                (Limit.known Z.zero)
                op)
         else
           cctxt#message
             "Estimated storage: %s bytes added (will add 20 for safety)"
             (Z.to_string storage)
           >>= fun () ->
           let storage_limit =
             Z.min
               (Z.add storage (Z.of_int 20))
               hard_storage_limit_per_operation
           in
           return
             (Annotated_manager_operation.set_storage_limit
                (Limit.known storage_limit)
                op)
        else return op)
        >>=? fun op ->
        if Limit.is_unknown c.fee then
          (* Setting a dummy fee is required for converting to manager op *)
          let op =
            Annotated_manager_operation.set_fee (Limit.known Tez.zero) op
          in
          Annotated_manager_operation.manager_from_annotated op >>?= fun cm ->
          return (patch_fee ~first cm)
        else Lwt.return (Annotated_manager_operation.manager_from_annotated op)
  in
  let rec patch_list :
      type kind.
      bool ->
      kind Annotated_manager_operation.annotated_list ->
      kind Kind.manager contents_result_list ->
      kind Kind.manager contents_list tzresult Lwt.t =
   fun first annotated_list result_list ->
    match (annotated_list, result_list) with
    | Single_manager annotated, Single_result res ->
        patch ~first (annotated, res) >>=? fun op -> return (Single op)
    | Cons_manager (annotated, annotated_rest), Cons_result (res, res_rest) ->
        patch ~first (annotated, res) >>=? fun op ->
        patch_list false annotated_rest res_rest >>=? fun rest ->
        return (Cons (op, rest))
    | _ -> assert false
  in
  match may_need_patching annotated_contents with
  | Some annotated_for_simulation ->
      Lwt.return
        (Annotated_manager_operation.manager_list_from_annotated
           annotated_for_simulation)
      >>=? fun contents_for_simulation ->
      simulate cctxt ~chain ~block ?branch contents_for_simulation
      >>=? fun (_, _, result) ->
      (match detect_script_failure result with
      | Ok () -> return_unit
      | Error _ ->
          cctxt#message
            "@[<v 2>This simulation failed:@,%a@]"
            Operation_result.pp_operation_result
            (contents_for_simulation, result.contents)
          >>= fun () -> return_unit)
      >>=? fun () ->
      ( Lwt.return
          (estimated_storage (Z.of_int origination_size) result.contents)
      >>=? fun storage ->
        Lwt.return
          (Environment.wrap_tzresult Tez.(cost_per_byte *? Z.to_int64 storage))
        >>=? fun burn ->
        if Tez.(burn > fee_parameter.burn_cap) then
          cctxt#error
            "The operation will burn %s%a which is higher than the configured \
             burn cap (%s%a).@\n\
            \ Use `--burn-cap %a` to emit this operation."
            Client_proto_args.tez_sym
            Tez.pp
            burn
            Client_proto_args.tez_sym
            Tez.pp
            fee_parameter.burn_cap
            Tez.pp
            burn
          >>= fun () -> exit 1
        else return_unit )
      >>=? fun () -> patch_list true annotated_contents result.contents
  | None ->
      Lwt.return
        (Annotated_manager_operation.manager_list_from_annotated
           annotated_contents)

let inject_operation_internal (type kind) cctxt ~chain ~block ?confirmations
    ?(dry_run = false) ?(simulation = false) ?branch ?src_sk ?verbose_signing
    ~fee_parameter (contents : kind contents_list) =
  (if simulation then simulate cctxt ~chain ~block ?branch contents
  else
    preapply
      cctxt
      ~chain
      ~block
      ~fee_parameter
      ?verbose_signing
      ?branch
      ?src_sk
      contents)
  >>=? fun (_oph, op, result) ->
  (match detect_script_failure result with
  | Ok () -> return_unit
  | Error _ as res ->
      cctxt#message
        "@[<v 2>This simulation failed:@,%a@]"
        Operation_result.pp_operation_result
        (op.protocol_data.contents, result.contents)
      >>= fun () -> Lwt.return res)
  >>=? fun () ->
  let bytes =
    Data_encoding.Binary.to_bytes_exn Operation.encoding (Operation.pack op)
  in
  if dry_run || simulation then
    let oph = Operation_hash.hash_bytes [bytes] in
    cctxt#message
      "@[<v 0>Operation: 0x%a@,Operation hash is '%a'@]"
      Hex.pp
      (Hex.of_bytes bytes)
      Operation_hash.pp
      oph
    >>= fun () ->
    cctxt#message
      "@[<v 2>Simulation result:@,%a@]"
      Operation_result.pp_operation_result
      (op.protocol_data.contents, result.contents)
    >>= fun () -> return (oph, op.protocol_data.contents, result.contents)
  else
    Shell_services.Injection.operation cctxt ~chain bytes >>=? fun oph ->
    cctxt#message "Operation successfully injected in the node." >>= fun () ->
    cctxt#message "Operation hash is '%a'" Operation_hash.pp oph >>= fun () ->
    (match confirmations with
    | None ->
        cctxt#message
          "@[<v 0>NOT waiting for the operation to be included.@,\
           Use command@,\
          \  octez-client wait for %a to be included --confirmations 30 \
           --branch %a@,\
           and/or an external block explorer to make sure that it has been \
           included.@]"
          Operation_hash.pp
          oph
          Block_hash.pp
          op.shell.branch
        >>= fun () -> return result
    | Some confirmations -> (
        cctxt#message "Waiting for the operation to be included..."
        >>= fun () ->
        Client_confirmations.wait_for_operation_inclusion
          ~branch:op.shell.branch
          ~confirmations
          cctxt
          ~chain
          oph
        >>=? fun (h, i, j) ->
        Alpha_block_services.Operations.operation
          cctxt
          ~chain
          ~block:(`Hash (h, 0))
          i
          j
        >>=? fun op' ->
        match op'.receipt with
        | Empty -> failwith "Internal error: pruned metadata."
        | Too_large -> failwith "Internal error: too large metadata."
        | Receipt No_operation_metadata ->
            failwith "Internal error: unexpected receipt."
        | Receipt (Operation_metadata receipt) -> (
            match Apply_results.kind_equal_list contents receipt.contents with
            | Some Apply_results.Eq ->
                return (receipt : kind operation_metadata)
            | None -> failwith "Internal error: unexpected receipt.")))
    >>=? fun result ->
    cctxt#message
      "@[<v 2>This sequence of operations was run:@,%a@]"
      Operation_result.pp_operation_result
      (op.protocol_data.contents, result.contents)
    >>= fun () ->
    Lwt.return (originated_contracts result.contents) >>=? fun contracts ->
    List.iter_s
      (fun c -> cctxt#message "New contract %a originated." Contract.pp c)
      contracts
    >>= fun () ->
    (match confirmations with
    | None -> Lwt.return_unit
    | Some number ->
        if number >= 30 then
          cctxt#message
            "The operation was included in a block %d blocks ago."
            number
        else
          cctxt#message
            "@[<v 0>The operation has only been included %d blocks ago.@,\
             We recommend to wait more.@,\
             Use command@,\
            \  octez-client wait for %a to be included --confirmations 30 \
             --branch %a@,\
             and/or an external block explorer.@]"
            number
            Operation_hash.pp
            oph
            Block_hash.pp
            op.shell.branch)
    >>= fun () -> return (oph, op.protocol_data.contents, result.contents)

let inject_operation (type kind) cctxt ~chain ~block ?confirmations
    ?(dry_run = false) ?(simulation = false) ?branch ?src_sk ?verbose_signing
    ~fee_parameter (contents : kind contents_list) =
  Tezos_client_base.Client_confirmations.wait_for_bootstrapped cctxt
  >>=? fun () ->
  inject_operation_internal
    cctxt
    ~chain
    ~block
    ?confirmations
    ~dry_run
    ~simulation
    ?branch
    ?src_sk
    ?verbose_signing
    ~fee_parameter
    (contents : kind contents_list)

let prepare_manager_operation ~fee ~gas_limit ~storage_limit operation =
  Annotated_manager_operation.Manager_info
    {source = None; fee; gas_limit; storage_limit; counter = None; operation}

(* [gas_limit] must correspond to
   [Michelson_v1_gas.Cost_of.manager_operation] *)
let cost_of_manager_operation = Gas.Arith.integral_of_int_exn 1_000

let reveal_error_message =
  "Requested operation requires to perform a public key revelation beforehand.\n\
   This cannot be done automatically when a custom fee or storage limit is \
   given.\n\
   If you wish to use a custom fee or storage limit, please first perform the \
   reveal operation separately using the dedicated command.\n\
   Otherwise, please do not specify custom fee or storage parameters."

let reveal_error (cctxt : #Protocol_client_context.full) =
  cctxt#error "%s" reveal_error_message

let inject_manager_operation cctxt ~chain ~block ?branch ?confirmations ?dry_run
    ?verbose_signing ?simulation ~source ~src_pk ~src_sk ~fee ~gas_limit
    ~storage_limit ?counter ~fee_parameter (type kind)
    (operations : kind Annotated_manager_operation.annotated_list) :
    (Operation_hash.t
    * kind Kind.manager contents_list
    * kind Kind.manager contents_result_list)
    tzresult
    Lwt.t =
  (match counter with
  | None ->
      Alpha_services.Contract.counter cctxt (chain, block) source
      >>=? fun pcounter ->
      let counter = Z.succ pcounter in
      return counter
  | Some counter -> return counter)
  >>=? fun counter ->
  Alpha_services.Contract.manager_key cctxt (chain, block) source
  >>=? fun key ->
  (* [has_reveal] assumes that a Reveal operation only appears as the first of a batch *)
  let has_reveal :
      type kind. kind Annotated_manager_operation.annotated_list -> bool =
    function
    | Single_manager (Manager_info {operation = Reveal _; _}) -> true
    | Cons_manager (Manager_info {operation = Reveal _; _}, _) -> true
    | _ -> false
  in
  let apply_specified_options counter op =
    Annotated_manager_operation.set_source source op >>? fun op ->
    Annotated_manager_operation.set_counter counter op >>? fun op ->
    Annotated_manager_operation.join_fee fee op >>? fun op ->
    Annotated_manager_operation.join_gas_limit gas_limit op >>? fun op ->
    Annotated_manager_operation.join_storage_limit storage_limit op
  in
  let rec build_contents :
      type kind.
      Z.t ->
      kind Annotated_manager_operation.annotated_list ->
      kind Annotated_manager_operation.annotated_list tzresult =
   fun counter -> function
    | Single_manager op ->
        apply_specified_options counter op >|? fun op ->
        Annotated_manager_operation.Single_manager op
    | Cons_manager (op, rest) ->
        apply_specified_options counter op >>? fun op ->
        build_contents (Z.succ counter) rest >|? fun rest ->
        Annotated_manager_operation.Cons_manager (op, rest)
  in
  match key with
  | None when not (has_reveal operations) -> (
      (if not (Limit.is_unknown fee && Limit.is_unknown storage_limit) then
       reveal_error cctxt
      else return_unit)
      >>=? fun () ->
      let reveal =
        prepare_manager_operation
          ~fee:Limit.unknown
          ~gas_limit:(Limit.known cost_of_manager_operation)
          ~storage_limit:Limit.unknown
          (Reveal src_pk)
      in
      Annotated_manager_operation.set_source source reveal >>?= fun reveal ->
      Annotated_manager_operation.set_counter counter reveal >>?= fun reveal ->
      build_contents (Z.succ counter) operations >>?= fun rest ->
      let contents = Annotated_manager_operation.Cons_manager (reveal, rest) in
      may_patch_limits cctxt ~fee_parameter ~chain ~block ?branch contents
      >>=? fun contents ->
      inject_operation_internal
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ~fee_parameter
        ?verbose_signing
        ?simulation
        ?branch
        ~src_sk
        contents
      >>=? fun (oph, op, result) ->
      match pack_contents_list op result with
      | Cons_and_result (_, _, rest) ->
          let op, result = unpack_contents_list rest in
          return (oph, op, result)
      | _ -> assert false)
  | Some _ when has_reveal operations ->
      failwith "The manager key was previously revealed."
  | _ ->
      build_contents counter operations >>?= fun contents ->
      may_patch_limits cctxt ~fee_parameter ~chain ~block ?branch contents
      >>=? fun contents ->
      inject_operation_internal
        cctxt
        ~chain
        ~block
        ?confirmations
        ?dry_run
        ?verbose_signing
        ?simulation
        ~fee_parameter
        ?branch
        ~src_sk
        contents