(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Nomadic Development. <contact@tezcore.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

type Environment.Error_monad.error += Cannot_parse_operation (* `Branch *)

type Environment.Error_monad.error += Cannot_serialize_log

let () =
  Environment.Error_monad.register_error_kind
    `Branch
    ~id:"operation.cannot_parse"
    ~title:"Cannot parse operation"
    ~description:"The operation is ill-formed or for another protocol version"
    ~pp:(fun ppf () -> Format.fprintf ppf "The operation cannot be parsed")
    Data_encoding.unit
    (function Cannot_parse_operation -> Some () | _ -> None)
    (fun () -> Cannot_parse_operation) ;
  (* Cannot serialize log *)
  Environment.Error_monad.register_error_kind
    `Temporary
    ~id:"michelson_v1.cannot_serialize_log"
    ~title:"Not enough gas to serialize execution trace"
    ~description:
      "Execution trace with stacks was to big to be serialized with the \
       provided gas"
    Data_encoding.empty
    (function Cannot_serialize_log -> Some () | _ -> None)
    (fun () -> Cannot_serialize_log)

module Mempool = struct
  type nanotez = Q.t

  let nanotez_enc : nanotez Data_encoding.t =
    let open Data_encoding in
    def
      "nanotez"
      ~title:"A thousandth of a mutez"
      ~description:"One thousand nanotez make a mutez (1 tez = 1e9 nanotez)"
      (conv
         (fun q -> (q.Q.num, q.Q.den))
         (fun (num, den) -> {Q.num; den})
         (tup2 z z))

  type config = {
    minimal_fees : Tez.t;
    minimal_nanotez_per_gas_unit : nanotez;
    minimal_nanotez_per_byte : nanotez;
    allow_script_failure : bool;
        (** If [true], this makes [post_filter_manager] unconditionally return
            [`Passed_postfilter filter_state], no matter the operation's success. *)
  }

  type state = unit

  let init config ?(validation_state : validation_state option) ~predecessor ()
      =
    ignore config ;
    ignore validation_state ;
    ignore predecessor ;
    return ()

  let on_flush config filter_state ?(validation_state : validation_state option)
      ~predecessor () =
    ignore filter_state ;
    init config ?validation_state ~predecessor ()

  let remove ~filter_state _ = filter_state

  let default_minimal_fees =
    match Tez.of_mutez 100L with None -> assert false | Some t -> t

  let default_minimal_nanotez_per_gas_unit = Q.of_int 100

  let default_minimal_nanotez_per_byte = Q.of_int 1000

  let config_encoding : config Data_encoding.t =
    let open Data_encoding in
    conv
      (fun {
             minimal_fees;
             minimal_nanotez_per_gas_unit;
             minimal_nanotez_per_byte;
             allow_script_failure;
           } ->
        ( minimal_fees,
          minimal_nanotez_per_gas_unit,
          minimal_nanotez_per_byte,
          allow_script_failure ))
      (fun ( minimal_fees,
             minimal_nanotez_per_gas_unit,
             minimal_nanotez_per_byte,
             allow_script_failure ) ->
        {
          minimal_fees;
          minimal_nanotez_per_gas_unit;
          minimal_nanotez_per_byte;
          allow_script_failure;
        })
      (obj4
         (dft "minimal_fees" Tez.encoding default_minimal_fees)
         (dft
            "minimal_nanotez_per_gas_unit"
            nanotez_enc
            default_minimal_nanotez_per_gas_unit)
         (dft
            "minimal_nanotez_per_byte"
            nanotez_enc
            default_minimal_nanotez_per_byte)
         (dft "allow_script_failure" bool true))

  let default_config =
    {
      minimal_fees = default_minimal_fees;
      minimal_nanotez_per_gas_unit = default_minimal_nanotez_per_gas_unit;
      minimal_nanotez_per_byte = default_minimal_nanotez_per_byte;
      allow_script_failure = true;
    }

  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 Environment.Error_monad.error += Fees_too_low

  let () =
    Environment.Error_monad.register_error_kind
      `Permanent
      ~id:"prefilter.fees_too_low"
      ~title:"Operation fees are too low"
      ~description:"Operation fees are too low"
      ~pp:(fun ppf () -> Format.fprintf ppf "Operation fees are too low")
      Data_encoding.unit
      (function Fees_too_low -> Some () | _ -> None)
      (fun () -> Fees_too_low)

  let pre_filter_manager :
      type t.
      config ->
      t Kind.manager contents_list ->
      int ->
      [ `Passed_prefilter
      | `Branch_refused of tztrace
      | `Branch_delayed of tztrace
      | `Refused of tztrace
      | `Outdated of tztrace ] =
   fun config op size ->
    match get_manager_operation_gas_and_fee op with
    | Error err ->
        let err = Environment.wrap_tztrace err in
        `Refused err
    | Ok (fee, gas) ->
        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
        if
          Q.compare
            fees_in_nanotez
            (Q.add
               minimal_fees_in_nanotez
               (Q.add
                  minimal_fees_for_gas_in_nanotez
                  minimal_fees_for_size_in_nanotez))
          >= 0
        then `Passed_prefilter
        else `Refused [Environment.wrap_tzerror Fees_too_low]

  type Environment.Error_monad.error += Outdated_endorsement

  let () =
    Environment.Error_monad.register_error_kind
      `Temporary
      ~id:"prefilter.outdated_endorsement"
      ~title:"Endorsement is outdated"
      ~description:"Endorsement is outdated"
      ~pp:(fun ppf () -> Format.fprintf ppf "Endorsement is outdated")
      Data_encoding.unit
      (function Outdated_endorsement -> Some () | _ -> None)
      (fun () -> Outdated_endorsement)

  type Environment.Error_monad.error += Wrong_operation

  let () =
    Environment.Error_monad.register_error_kind
      `Temporary
      ~id:"prefilter.wrong_operation"
      ~title:"Wrong operation"
      ~description:"Failing_noop and old endorsement format are not accepted."
      ~pp:(fun ppf () ->
        Format.fprintf
          ppf
          "Failing_noop and old endorsement format are not accepted")
      Data_encoding.unit
      (function Wrong_operation -> Some () | _ -> None)
      (fun () -> Wrong_operation)

  let pre_filter config ~filter_state:_ ?validation_state_before
      ({shell = _; protocol_data = Operation_data {contents; _} as op} :
        Main.operation) =
    let bytes =
      (WithExceptions.Option.get ~loc:__LOC__
      @@ Data_encoding.Binary.fixed_length
           Tezos_base.Operation.shell_header_encoding)
      + Data_encoding.Binary.length Operation.protocol_data_encoding op
    in
    let prefilter_manager_op op =
      match pre_filter_manager config op bytes with
      | `Passed_prefilter -> `Passed_prefilter (`Low [])
      | (`Branch_refused _ | `Branch_delayed _ | `Refused _ | `Outdated _) as
        err ->
          err
    in
    (match contents with
    | Single (Endorsement _) | Single (Failing_noop _) ->
        `Refused [Environment.wrap_tzerror Wrong_operation]
    | Single
        (Endorsement_with_slot
          {
            endorsement =
              {
                protocol_data = {contents = Single (Endorsement {level}); _};
                shell = {branch};
              };
            _;
          }) -> (
        match validation_state_before with
        | None -> `Passed_prefilter `High
        | Some {ctxt; mode; _} -> (
            match mode with
            | Partial_construction {predecessor} ->
                if Block_hash.(predecessor = branch) then
                  (* conensus operation for the current head. *)
                  `Passed_prefilter `High
                else
                  let current_level = (Level.current ctxt).level in
                  let delta = Raw_level.diff current_level level in
                  if delta > 2l then
                    (* consensus operation too far in the past. *)
                    `Outdated [Environment.wrap_tzerror Outdated_endorsement]
                  else
                    (* consensus operation not too far in the past or in the
                       future. *)
                    `Branch_delayed
                      [Environment.wrap_tzerror Outdated_endorsement]
            | _ -> assert false))
    | Single (Seed_nonce_revelation _)
    | Single (Double_endorsement_evidence _)
    | Single (Double_baking_evidence _)
    | Single (Activate_account _)
    | Single (Proposals _)
    | Single (Ballot _) ->
        `Passed_prefilter (`Low [])
    | Single (Manager_operation _) as op -> prefilter_manager_op op
    | Cons (Manager_operation _, _) as op -> prefilter_manager_op op)
    |> fun res -> Lwt.return res

  let precheck _ ~filter_state:_ ~validation_state:_ _ _
      ~nb_successful_prechecks:_ =
    Lwt.return `Undecided

  open Apply_results

  type Environment.Error_monad.error += Skipped_operation

  let () =
    Environment.Error_monad.register_error_kind
      `Temporary
      ~id:"postfilter.skipped_operation"
      ~title:"The operation has been skipped by the protocol"
      ~description:"The operation has been skipped by the protocol"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "The operation has been skipped by the protocol")
      Data_encoding.unit
      (function Skipped_operation -> Some () | _ -> None)
      (fun () -> Skipped_operation)

  type Environment.Error_monad.error += Backtracked_operation

  let () =
    Environment.Error_monad.register_error_kind
      `Temporary
      ~id:"postfilter.backtracked_operation"
      ~title:"The operation has been backtracked by the protocol"
      ~description:"The operation has been backtracked by the protocol"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "The operation has been backtracked by the protocol")
      Data_encoding.unit
      (function Backtracked_operation -> Some () | _ -> None)
      (fun () -> Backtracked_operation)

  let rec post_filter_manager :
      type t.
      Alpha_context.t ->
      state ->
      t Kind.manager contents_result_list ->
      config ->
      [`Passed_postfilter of state | `Refused of tztrace] =
   fun ctxt filter_state op config ->
    match op with
    | Single_result (Manager_operation_result {operation_result; _}) -> (
        let check_allow_script_failure errs =
          if config.allow_script_failure then `Passed_postfilter filter_state
          else `Refused errs
        in
        match operation_result with
        | Applied _ -> `Passed_postfilter filter_state
        | Skipped _ ->
            check_allow_script_failure
              [Environment.wrap_tzerror Skipped_operation]
        | Failed (_, errors) ->
            check_allow_script_failure (Environment.wrap_tztrace errors)
        | Backtracked (_, errors) ->
            check_allow_script_failure
              (match errors with
              | Some e -> Environment.wrap_tztrace e
              | None -> [Environment.wrap_tzerror Backtracked_operation]))
    | Cons_result (Manager_operation_result res, rest) -> (
        post_filter_manager
          ctxt
          filter_state
          (Single_result (Manager_operation_result res))
          config
        |> function
        | `Passed_postfilter filter_state ->
            post_filter_manager ctxt filter_state rest config
        | res -> res)

  let post_filter config ~filter_state ~validation_state_before:_
      ~validation_state_after:({ctxt; _} : validation_state) (_op, receipt) =
    match receipt with
    | No_operation_metadata -> assert false (* only for multipass validator *)
    | Operation_metadata {contents} -> (
        match contents with
        | Single_result (Endorsement_result _) ->
            Lwt.return (`Refused []) (* legacy format *)
        | Single_result (Endorsement_with_slot_result _)
        | Single_result (Seed_nonce_revelation_result _)
        | Single_result (Double_endorsement_evidence_result _)
        | Single_result (Double_baking_evidence_result _)
        | Single_result (Activate_account_result _)
        | Single_result Proposals_result
        | Single_result Ballot_result ->
            Lwt.return (`Passed_postfilter filter_state)
        | Single_result (Manager_operation_result _) as result ->
            Lwt.return (post_filter_manager ctxt filter_state result config)
        | Cons_result (Manager_operation_result _, _) as result ->
            Lwt.return (post_filter_manager ctxt filter_state result config))
end

module View_helpers = struct
  open Tezos_micheline

  type Environment.Error_monad.error += Viewed_contract_has_no_script

  type Environment.Error_monad.error += View_callback_origination_failed

  type Environment.Error_monad.error +=
    | Illformed_view_type of string * Script.expr

  type Environment.Error_monad.error +=
    | View_never_returns of string * Contract.t

  type Environment.Error_monad.error +=
    | View_unexpected_return of string * Contract.t

  let () =
    Environment.Error_monad.register_error_kind
      `Permanent
      ~id:"viewedContractHasNoScript"
      ~title:"Viewed contract has no script"
      ~description:"A view was called on a contract with no script."
      ~pp:(fun ppf () ->
        Format.fprintf ppf "A view was called on a contract with no script.")
      Data_encoding.(unit)
      (function Viewed_contract_has_no_script -> Some () | _ -> None)
      (fun () -> Viewed_contract_has_no_script) ;
    Environment.Error_monad.register_error_kind
      `Permanent
      ~id:"viewCallbackOriginationFailed"
      ~title:"View callback origination failed"
      ~description:"View callback origination failed"
      ~pp:(fun ppf () ->
        Format.fprintf ppf "Error during origination of view callback contract.")
      Data_encoding.(unit)
      (function View_callback_origination_failed -> Some () | _ -> None)
      (fun () -> View_callback_origination_failed) ;
    Environment.Error_monad.register_error_kind
      `Permanent
      ~id:"illformedViewType"
      ~title:"An entrypoint type is incompatible with TZIP-4 view type."
      ~description:"An entrypoint type is incompatible with TZIP-4 view type."
      ~pp:(fun ppf (entrypoint, typ) ->
        Format.fprintf
          ppf
          "The view %s has type %a, it is not compatible with a TZIP-4 view \
           type."
          entrypoint
          Micheline_printer.print_expr
          (Micheline_printer.printable
             (fun x -> x)
             (Michelson_v1_primitives.strings_of_prims typ)))
      Data_encoding.(
        obj2 (req "entrypoint" string) (req "type" Script.expr_encoding))
      (function Illformed_view_type (etp, exp) -> Some (etp, exp) | _ -> None)
      (fun (etp, exp) -> Illformed_view_type (etp, exp)) ;
    Environment.Error_monad.register_error_kind
      `Permanent
      ~id:"viewNeverReturns"
      ~title:
        "A view never returned a transaction to the given callback contract"
      ~description:
        "A view never initiated a transaction to the given callback contract."
      ~pp:(fun ppf (entrypoint, callback) ->
        Format.fprintf
          ppf
          "The view %s never initiated a transaction to the given callback \
           contract %a."
          entrypoint
          Contract.pp
          callback)
      Data_encoding.(
        obj2 (req "entrypoint" string) (req "callback" Contract.encoding))
      (function View_never_returns (e, c) -> Some (e, c) | _ -> None)
      (fun (e, c) -> View_never_returns (e, c)) ;
    Environment.Error_monad.register_error_kind
      `Permanent
      ~id:"viewUnexpectedReturn"
      ~title:"A view returned an unexpected list of operations"
      ~description:
        "A view initiated a list of operations while the TZIP-4 standard \
         expects only a transaction to the given callback contract."
      ~pp:(fun ppf (entrypoint, callback) ->
        Format.fprintf
          ppf
          "The view %s initiated a list of operations while the TZIP-4 \
           standard expects only a transaction to the given callback contract \
           %a."
          entrypoint
          Contract.pp
          callback)
      Data_encoding.(
        obj2 (req "entrypoint" string) (req "callback" Contract.encoding))
      (function View_never_returns (e, c) -> Some (e, c) | _ -> None)
      (fun (e, c) -> View_never_returns (e, c))

  (* This script is actually never run, its usage is to ensure a
     contract that has the type `contract <ty>` is originated, which
     will be required as callback of the view. *)
  let make_viewer_script ty : Script.t =
    let loc = 0 in
    let ty = Micheline.root ty in
    let code =
      Micheline.strip_locations
      @@ Micheline.Seq
           ( loc,
             [
               Micheline.Prim (loc, Script.K_parameter, [ty], []);
               Micheline.Prim
                 ( loc,
                   Script.K_storage,
                   [Micheline.Prim (loc, Script.T_unit, [], [])],
                   [] );
               Micheline.Prim
                 ( loc,
                   Script.K_code,
                   [Micheline.Prim (loc, Script.I_FAILWITH, [], [])],
                   [] );
             ] )
    in
    let storage =
      Micheline.strip_locations (Micheline.Prim (loc, Script.D_Unit, [], []))
    in
    {code = Script.lazy_expr code; storage = Script.lazy_expr storage}

  let make_view_parameter input callback =
    let loc = 0 in
    Micheline.strip_locations
      (Micheline.Prim
         ( loc,
           Script.D_Pair,
           [
             input;
             Micheline.Bytes
               ( loc,
                 Data_encoding.Binary.to_bytes_exn Contract.encoding callback );
           ],
           [] ))

  let extract_view_output_type entrypoint ty =
    match Micheline.root ty with
    | Micheline.Prim
        ( _,
          Script.T_pair,
          [_; Micheline.Prim (_, Script.T_contract, [ty], _)],
          _ ) ->
        ok (Micheline.strip_locations ty)
    | _ -> Environment.Error_monad.error (Illformed_view_type (entrypoint, ty))

  (* 'view' entrypoints returns their value by calling a callback contract, thus
     the expected result is a unique internal transaction to this callback. *)
  let extract_parameter_from_operations entrypoint operations callback =
    let unexpected_return =
      Environment.Error_monad.error
      @@ View_unexpected_return (entrypoint, callback)
    in
    match operations with
    | [
     Internal_operation
       {operation = Transaction {destination; parameters; _}; _};
    ]
      when Contract.equal destination callback ->
        ok parameters
    | [] ->
        Environment.Error_monad.error
          (View_never_returns (entrypoint, callback))
    | _ -> unexpected_return
end

module RPC = struct
  open Environment
  open Alpha_context
  open Environment.Error_monad

  let parse_operation (op : Operation.raw) =
    match
      Data_encoding.Binary.of_bytes Operation.protocol_data_encoding op.proto
    with
    | Some protocol_data -> ok {shell = op.shell; protocol_data}
    | None -> error Cannot_parse_operation

  let path = RPC_path.(open_root / "helpers")

  module Registration = struct
    let patched_services =
      ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t)

    let register0_fullctxt s f =
      patched_services :=
        RPC_directory.register !patched_services s (fun ctxt q i ->
            Services_registration.rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

    let register0 s f = register0_fullctxt s (fun {context; _} -> f context)

    let register0_noctxt s f =
      patched_services :=
        RPC_directory.register !patched_services s (fun _ q i -> f q i)

    let opt_register0_fullctxt s f =
      patched_services :=
        RPC_directory.opt_register !patched_services s (fun ctxt q i ->
            Services_registration.rpc_init ctxt >>=? fun ctxt -> f ctxt q i)

    let opt_register0 s f =
      opt_register0_fullctxt s (fun {context; _} -> f context)

    let register1_fullctxt s f =
      patched_services :=
        RPC_directory.register !patched_services s (fun (ctxt, arg) q i ->
            Services_registration.rpc_init ctxt >>=? fun ctxt -> f ctxt arg q i)

    let register1 s f = register1_fullctxt s (fun {context; _} x -> f context x)

    let register2_fullctxt s f =
      patched_services :=
        RPC_directory.register
          !patched_services
          s
          (fun ((ctxt, arg1), arg2) q i ->
            Services_registration.rpc_init ctxt >>=? fun ctxt ->
            f ctxt arg1 arg2 q i)

    let register2 s f =
      register2_fullctxt s (fun {context; _} a1 a2 q i -> f context a1 a2 q i)
  end

  let unparsing_mode_encoding =
    let open Script_ir_translator in
    let open Data_encoding in
    union
      ~tag_size:`Uint8
      [
        case
          (Tag 0)
          ~title:"Readable"
          (constant "Readable")
          (function
            | Readable -> Some () | Optimized | Optimized_legacy -> None)
          (fun () -> Readable);
        case
          (Tag 1)
          ~title:"Optimized"
          (constant "Optimized")
          (function
            | Optimized -> Some () | Readable | Optimized_legacy -> None)
          (fun () -> Optimized);
        case
          (Tag 2)
          ~title:"Optimized_legacy"
          (constant "Optimized_legacy")
          (function
            | Optimized_legacy -> Some () | Readable | Optimized -> None)
          (fun () -> Optimized_legacy);
      ]

  module Scripts = struct
    module S = struct
      open Data_encoding

      let path = RPC_path.(path / "scripts")

      let run_code_input_encoding =
        merge_objs
          (obj10
             (req "script" Script.expr_encoding)
             (req "storage" Script.expr_encoding)
             (req "input" Script.expr_encoding)
             (req "amount" Tez.encoding)
             (req "balance" Tez.encoding)
             (req "chain_id" Chain_id.encoding)
             (opt "source" Contract.encoding)
             (opt "payer" Contract.encoding)
             (opt "gas" Gas.Arith.z_integral_encoding)
             (dft "entrypoint" string "default"))
          (obj1 (opt "unparsing_mode" unparsing_mode_encoding))

      let run_code_output_encoding =
        conv
          (fun (storage, operations, lazy_storage_diff) ->
            (storage, operations, lazy_storage_diff, lazy_storage_diff))
          (fun (storage, operations, legacy_lazy_storage_diff, lazy_storage_diff)
               ->
            let lazy_storage_diff =
              Option.either lazy_storage_diff legacy_lazy_storage_diff
            in
            (storage, operations, lazy_storage_diff))
          (obj4
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (opt "big_map_diff" Lazy_storage.legacy_big_map_diff_encoding)
             (opt "lazy_storage_diff" Lazy_storage.encoding))

      let trace_code_input_encoding = run_code_input_encoding

      let trace_encoding =
        def "scripted.trace" @@ list
        @@ obj3
             (req "location" Script.location_encoding)
             (req "gas" Gas.encoding)
             (req
                "stack"
                (list
                   (obj2 (req "item" Script.expr_encoding) (opt "annot" string))))

      let trace_code_output_encoding =
        conv
          (fun (storage, operations, trace, lazy_storage_diff) ->
            (storage, operations, trace, lazy_storage_diff, lazy_storage_diff))
          (fun ( storage,
                 operations,
                 trace,
                 legacy_lazy_storage_diff,
                 lazy_storage_diff ) ->
            let lazy_storage_diff =
              Option.either lazy_storage_diff legacy_lazy_storage_diff
            in
            (storage, operations, trace, lazy_storage_diff))
          (obj5
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (req "trace" trace_encoding)
             (opt "big_map_diff" Lazy_storage.legacy_big_map_diff_encoding)
             (opt "lazy_storage_diff" Lazy_storage.encoding))

      let run_view_encoding =
        let open Data_encoding in
        obj8
          (req "contract" Contract.encoding)
          (req "entrypoint" string)
          (req "input" Script.expr_encoding)
          (req "chain_id" Chain_id.encoding)
          (opt "source" Contract.encoding)
          (opt "payer" Contract.encoding)
          (opt "gas" Gas.Arith.z_integral_encoding)
          (req "unparsing_mode" unparsing_mode_encoding)

      let run_code =
        RPC_service.post_service
          ~description:"Run a piece of code in the current context"
          ~query:RPC_query.empty
          ~input:run_code_input_encoding
          ~output:run_code_output_encoding
          RPC_path.(path / "run_code")

      let run_code_normalized =
        RPC_service.post_service
          ~description:
            "Deprecated alias of the .../helpers/scripts/run_code RPC"
          ~query:RPC_query.empty
          ~input:run_code_input_encoding
          ~output:run_code_output_encoding
          RPC_path.(path / "run_code" / "normalized")

      let trace_code =
        RPC_service.post_service
          ~description:
            "Run a piece of code in the current context, keeping a trace"
          ~query:RPC_query.empty
          ~input:trace_code_input_encoding
          ~output:trace_code_output_encoding
          RPC_path.(path / "trace_code")

      let trace_code_normalized =
        RPC_service.post_service
          ~description:
            "Deprecated alias of the .../helpers/scripts/trace_code RPC"
          ~query:RPC_query.empty
          ~input:trace_code_input_encoding
          ~output:trace_code_output_encoding
          RPC_path.(path / "trace_code" / "normalized")

      let run_view =
        RPC_service.post_service
          ~description:
            "Simulate a call to a view following the TZIP-4 standard. See \
             https://gitlab.com/tzip/tzip/-/blob/master/proposals/tzip-4/tzip-4.md#view-entrypoints."
          ~input:run_view_encoding
          ~output:(obj1 (req "data" Script.expr_encoding))
          ~query:RPC_query.empty
          RPC_path.(path / "run_view")

      let typecheck_code =
        RPC_service.post_service
          ~description:"Typecheck a piece of code in the current context"
          ~query:RPC_query.empty
          ~input:
            (obj3
               (req "program" Script.expr_encoding)
               (opt "gas" Gas.Arith.z_integral_encoding)
               (opt "legacy" bool))
          ~output:
            (obj2
               (req "type_map" Script_tc_errors_registration.type_map_enc)
               (req "gas" Gas.encoding))
          RPC_path.(path / "typecheck_code")

      let typecheck_data =
        RPC_service.post_service
          ~description:
            "Check that some data expression is well formed and of a given \
             type in the current context"
          ~query:RPC_query.empty
          ~input:
            (obj4
               (req "data" Script.expr_encoding)
               (req "type" Script.expr_encoding)
               (opt "gas" Gas.Arith.z_integral_encoding)
               (opt "legacy" bool))
          ~output:(obj1 (req "gas" Gas.encoding))
          RPC_path.(path / "typecheck_data")

      let pack_data =
        RPC_service.post_service
          ~description:
            "Computes the serialized version of some data expression using the \
             same algorithm as script instruction PACK"
          ~input:
            (obj3
               (req "data" Script.expr_encoding)
               (req "type" Script.expr_encoding)
               (opt "gas" Gas.Arith.z_integral_encoding))
          ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding))
          ~query:RPC_query.empty
          RPC_path.(path / "pack_data")

      let normalize_data =
        RPC_service.post_service
          ~description:
            "Normalizes some data expression using the requested unparsing mode"
          ~input:
            (obj4
               (req "data" Script.expr_encoding)
               (req "type" Script.expr_encoding)
               (req "unparsing_mode" unparsing_mode_encoding)
               (opt "legacy" bool))
          ~output:(obj1 (req "normalized" Script.expr_encoding))
          ~query:RPC_query.empty
          RPC_path.(path / "normalize_data")

      let normalize_script =
        RPC_service.post_service
          ~description:
            "Normalizes a Michelson script using the requested unparsing mode"
          ~input:
            (obj2
               (req "script" Script.expr_encoding)
               (req "unparsing_mode" unparsing_mode_encoding))
          ~output:(obj1 (req "normalized" Script.expr_encoding))
          ~query:RPC_query.empty
          RPC_path.(path / "normalize_script")

      let normalize_type =
        RPC_service.post_service
          ~description:
            "Normalizes some Michelson type by expanding `pair a b c` as `pair \
             a (pair b c)"
          ~input:(obj1 (req "type" Script.expr_encoding))
          ~output:(obj1 (req "normalized" Script.expr_encoding))
          ~query:RPC_query.empty
          RPC_path.(path / "normalize_type")

      let run_operation =
        RPC_service.post_service
          ~description:"Run an operation without signature checks"
          ~query:RPC_query.empty
          ~input:
            (obj2
               (req "operation" Operation.encoding)
               (req "chain_id" Chain_id.encoding))
          ~output:Apply_results.operation_data_and_metadata_encoding
          RPC_path.(path / "run_operation")

      let entrypoint_type =
        RPC_service.post_service
          ~description:"Return the type of the given entrypoint"
          ~query:RPC_query.empty
          ~input:
            (obj2
               (req "script" Script.expr_encoding)
               (dft "entrypoint" string "default"))
          ~output:(obj1 (req "entrypoint_type" Script.expr_encoding))
          RPC_path.(path / "entrypoint")

      let list_entrypoints =
        RPC_service.post_service
          ~description:"Return the list of entrypoints of the given script"
          ~query:RPC_query.empty
          ~input:(obj1 (req "script" Script.expr_encoding))
          ~output:
            (obj2
               (dft
                  "unreachable"
                  (Data_encoding.list
                     (obj1
                        (req
                           "path"
                           (Data_encoding.list
                              Michelson_v1_primitives.prim_encoding))))
                  [])
               (req "entrypoints" (assoc Script.expr_encoding)))
          RPC_path.(path / "entrypoints")
    end

    module type UNPARSING_MODE = sig
      val unparsing_mode : Script_ir_translator.unparsing_mode
    end

    module Traced_interpreter (Unparsing_mode : UNPARSING_MODE) = struct
      type log_element =
        | Log :
            context
            * Script.location
            * ('a * 's)
            * ('a, 's) Script_typed_ir.stack_ty
            -> log_element

      let unparse_stack ctxt (stack, stack_ty) =
        (* We drop the gas limit as this function is only used for debugging/errors. *)
        let ctxt = Gas.set_unlimited ctxt in
        let rec unparse_stack :
            type a s.
            (a, s) Script_typed_ir.stack_ty * (a * s) ->
            (Script.expr * string option) list tzresult Lwt.t = function
          | (Bot_t, (EmptyCell, EmptyCell)) -> return_nil
          | (Item_t (ty, rest_ty, annot), (v, rest)) ->
              Script_ir_translator.unparse_data
                ctxt
                Unparsing_mode.unparsing_mode
                ty
                v
              >>=? fun (data, _ctxt) ->
              unparse_stack (rest_ty, rest) >|=? fun rest ->
              let annot =
                match Script_ir_annot.unparse_var_annot annot with
                | [] -> None
                | [a] -> Some a
                | _ -> assert false
              in
              let data = Micheline.strip_locations data in
              (data, annot) :: rest
        in
        unparse_stack (stack_ty, stack)

      let trace_logger () : Script_typed_ir.logger =
        let log : log_element list ref = ref [] in
        let log_interp _ ctxt loc sty stack =
          log := Log (ctxt, loc, stack, sty) :: !log
        in
        let log_entry _ _ctxt _loc _sty _stack = () in
        let log_exit _ ctxt loc sty stack =
          log := Log (ctxt, loc, stack, sty) :: !log
        in
        let log_control _ = () in
        let get_log () =
          map_s
            (fun (Log (ctxt, loc, stack, stack_ty)) ->
              trace Cannot_serialize_log (unparse_stack ctxt (stack, stack_ty))
              >>=? fun stack -> return (loc, Gas.level ctxt, stack))
            !log
          >>=? fun res -> return (Some (List.rev res))
        in
        {log_exit; log_entry; log_interp; get_log; log_control}

      let execute ctxt step_constants ~script ~entrypoint ~parameter =
        let open Script_interpreter in
        let logger = trace_logger () in
        execute
          ~logger
          ctxt
          Unparsing_mode.unparsing_mode
          step_constants
          ~script
          ~entrypoint
          ~parameter
          ~internal:true
        >>=? fun {ctxt; storage; lazy_storage_diff; operations} ->
        logger.get_log () >|=? fun trace ->
        let trace = Option.value ~default:[] trace in
        ({ctxt; storage; lazy_storage_diff; operations}, trace)
    end

    let typecheck_data :
        legacy:bool ->
        context ->
        Script.expr * Script.expr ->
        context tzresult Lwt.t =
     fun ~legacy ctxt (data, exp_ty) ->
      record_trace
        (Script_tc_errors.Ill_formed_type (None, exp_ty, 0))
        (Script_ir_translator.parse_parameter_ty
           ctxt
           ~legacy
           (Micheline.root exp_ty))
      >>?= fun (Ex_ty exp_ty, ctxt) ->
      trace_eval
        (fun () ->
          Lwt.return
            ( Script_ir_translator.serialize_ty_for_error ctxt exp_ty
            >|? fun (exp_ty, _ctxt) ->
              Script_tc_errors.Ill_typed_data (None, data, exp_ty) ))
        (let allow_forged =
           true
           (* Safe since we ignore the value afterwards. *)
         in
         Script_ir_translator.parse_data
           ctxt
           ~legacy
           ~allow_forged
           exp_ty
           (Micheline.root data))
      >|=? fun (_, ctxt) -> ctxt

    module Unparse_types = struct
      (* Same as the unparsing functions for types in Script_ir_translator but
         does not consume gas and never folds (pair a (pair b c)) *)

      open Script_ir_translator
      open Micheline
      open Michelson_v1_primitives
      open Script_ir_annot
      open Script_typed_ir

      let rec unparse_comparable_ty : type a. a comparable_ty -> Script.node =
        function
        | Unit_key tname -> Prim (-1, T_unit, [], unparse_type_annot tname)
        | Never_key tname -> Prim (-1, T_never, [], unparse_type_annot tname)
        | Int_key tname -> Prim (-1, T_int, [], unparse_type_annot tname)
        | Nat_key tname -> Prim (-1, T_nat, [], unparse_type_annot tname)
        | Signature_key tname ->
            Prim (-1, T_signature, [], unparse_type_annot tname)
        | String_key tname -> Prim (-1, T_string, [], unparse_type_annot tname)
        | Bytes_key tname -> Prim (-1, T_bytes, [], unparse_type_annot tname)
        | Mutez_key tname -> Prim (-1, T_mutez, [], unparse_type_annot tname)
        | Bool_key tname -> Prim (-1, T_bool, [], unparse_type_annot tname)
        | Key_hash_key tname ->
            Prim (-1, T_key_hash, [], unparse_type_annot tname)
        | Key_key tname -> Prim (-1, T_key, [], unparse_type_annot tname)
        | Timestamp_key tname ->
            Prim (-1, T_timestamp, [], unparse_type_annot tname)
        | Address_key tname -> Prim (-1, T_address, [], unparse_type_annot tname)
        | Chain_id_key tname ->
            Prim (-1, T_chain_id, [], unparse_type_annot tname)
        | Pair_key ((l, al), (r, ar), pname) ->
            let tl = add_field_annot al None (unparse_comparable_ty l) in
            let tr = add_field_annot ar None (unparse_comparable_ty r) in
            Prim (-1, T_pair, [tl; tr], unparse_type_annot pname)
        | Union_key ((l, al), (r, ar), tname) ->
            let tl = add_field_annot al None (unparse_comparable_ty l) in
            let tr = add_field_annot ar None (unparse_comparable_ty r) in
            Prim (-1, T_or, [tl; tr], unparse_type_annot tname)
        | Option_key (t, tname) ->
            Prim
              (-1, T_option, [unparse_comparable_ty t], unparse_type_annot tname)

      let unparse_memo_size memo_size =
        let z = Alpha_context.Sapling.Memo_size.unparse_to_z memo_size in
        Int (-1, z)

      let rec unparse_ty : type a. a ty -> Script.node =
       fun ty ->
        let return (name, args, annot) = Prim (-1, name, args, annot) in
        match ty with
        | Unit_t tname -> return (T_unit, [], unparse_type_annot tname)
        | Int_t tname -> return (T_int, [], unparse_type_annot tname)
        | Nat_t tname -> return (T_nat, [], unparse_type_annot tname)
        | Signature_t tname -> return (T_signature, [], unparse_type_annot tname)
        | String_t tname -> return (T_string, [], unparse_type_annot tname)
        | Bytes_t tname -> return (T_bytes, [], unparse_type_annot tname)
        | Mutez_t tname -> return (T_mutez, [], unparse_type_annot tname)
        | Bool_t tname -> return (T_bool, [], unparse_type_annot tname)
        | Key_hash_t tname -> return (T_key_hash, [], unparse_type_annot tname)
        | Key_t tname -> return (T_key, [], unparse_type_annot tname)
        | Timestamp_t tname -> return (T_timestamp, [], unparse_type_annot tname)
        | Address_t tname -> return (T_address, [], unparse_type_annot tname)
        | Operation_t tname -> return (T_operation, [], unparse_type_annot tname)
        | Chain_id_t tname -> return (T_chain_id, [], unparse_type_annot tname)
        | Never_t tname -> return (T_never, [], unparse_type_annot tname)
        | Bls12_381_g1_t tname ->
            return (T_bls12_381_g1, [], unparse_type_annot tname)
        | Bls12_381_g2_t tname ->
            return (T_bls12_381_g2, [], unparse_type_annot tname)
        | Bls12_381_fr_t tname ->
            return (T_bls12_381_fr, [], unparse_type_annot tname)
        | Contract_t (ut, tname) ->
            let t = unparse_ty ut in
            return (T_contract, [t], unparse_type_annot tname)
        | Pair_t ((utl, l_field, l_var), (utr, r_field, r_var), tname) ->
            let annot = unparse_type_annot tname in
            let utl = unparse_ty utl in
            let tl = add_field_annot l_field l_var utl in
            let utr = unparse_ty utr in
            let tr = add_field_annot r_field r_var utr in
            return (T_pair, [tl; tr], annot)
        | Union_t ((utl, l_field), (utr, r_field), tname) ->
            let annot = unparse_type_annot tname in
            let utl = unparse_ty utl in
            let tl = add_field_annot l_field None utl in
            let utr = unparse_ty utr in
            let tr = add_field_annot r_field None utr in
            return (T_or, [tl; tr], annot)
        | Lambda_t (uta, utr, tname) ->
            let ta = unparse_ty uta in
            let tr = unparse_ty utr in
            return (T_lambda, [ta; tr], unparse_type_annot tname)
        | Option_t (ut, tname) ->
            let annot = unparse_type_annot tname in
            let ut = unparse_ty ut in
            return (T_option, [ut], annot)
        | List_t (ut, tname) ->
            let t = unparse_ty ut in
            return (T_list, [t], unparse_type_annot tname)
        | Ticket_t (ut, tname) ->
            let t = unparse_comparable_ty ut in
            return (T_ticket, [t], unparse_type_annot tname)
        | Set_t (ut, tname) ->
            let t = unparse_comparable_ty ut in
            return (T_set, [t], unparse_type_annot tname)
        | Map_t (uta, utr, tname) ->
            let ta = unparse_comparable_ty uta in
            let tr = unparse_ty utr in
            return (T_map, [ta; tr], unparse_type_annot tname)
        | Big_map_t (uta, utr, tname) ->
            let ta = unparse_comparable_ty uta in
            let tr = unparse_ty utr in
            return (T_big_map, [ta; tr], unparse_type_annot tname)
        | Sapling_transaction_t (memo_size, tname) ->
            return
              ( T_sapling_transaction,
                [unparse_memo_size memo_size],
                unparse_type_annot tname )
        | Sapling_state_t (memo_size, tname) ->
            return
              ( T_sapling_state,
                [unparse_memo_size memo_size],
                unparse_type_annot tname )
    end

    let register () =
      let originate_dummy_contract ctxt script balance =
        let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
        Lwt.return (Contract.fresh_contract_from_current_nonce ctxt)
        >>=? fun (ctxt, dummy_contract) ->
        Contract.originate
          ctxt
          dummy_contract
          ~balance
          ~delegate:None
          ~script:(script, None)
        >>=? fun ctxt -> return (ctxt, dummy_contract)
      in
      let script_entrypoint_type ctxt expr entrypoint =
        let ctxt = Gas.set_unlimited ctxt in
        let legacy = false in
        let open Script_ir_translator in
        Lwt.return
          ( ( parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
              parse_parameter_ty ctxt ~legacy arg_type
              >>? fun (Ex_ty arg_type, _) ->
              Script_ir_translator.find_entrypoint
                ~root_name
                arg_type
                entrypoint )
          >>? fun (_f, Ex_ty ty) ->
            unparse_ty ctxt ty >|? fun (ty_node, _) ->
            Micheline.strip_locations ty_node )
      in
      let run_code_registration ctxt ()
          ( ( code,
              storage,
              parameter,
              amount,
              balance,
              chain_id,
              source,
              payer,
              gas,
              entrypoint ),
            unparsing_mode ) =
        let unparsing_mode =
          Option.value ~default:Script_ir_translator.Readable unparsing_mode
        in
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code} balance
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) -> (source, payer)
          | (Some source, None) -> (source, source)
          | (None, Some payer) -> (payer, payer)
          | (None, None) -> (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas -> gas
          | None -> Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        Script_interpreter.execute
          ctxt
          unparsing_mode
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
          ~internal:true
        >|=? fun {Script_interpreter.storage; operations; lazy_storage_diff; _}
          -> (storage, operations, lazy_storage_diff)
      in
      Registration.register0 S.run_code run_code_registration ;
      Registration.register0 S.run_code_normalized run_code_registration ;
      let trace_code_registration ctxt ()
          ( ( code,
              storage,
              parameter,
              amount,
              balance,
              chain_id,
              source,
              payer,
              gas,
              entrypoint ),
            unparsing_mode ) =
        let unparsing_mode =
          Option.value ~default:Script_ir_translator.Readable unparsing_mode
        in
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code} balance
        >>=? fun (ctxt, dummy_contract) ->
        let (source, payer) =
          match (source, payer) with
          | (Some source, Some payer) -> (source, payer)
          | (Some source, None) -> (source, source)
          | (None, Some payer) -> (payer, payer)
          | (None, None) -> (dummy_contract, dummy_contract)
        in
        let gas =
          match gas with
          | Some gas -> gas
          | None -> Constants.hard_gas_limit_per_operation ctxt
        in
        let ctxt = Gas.set_limit ctxt gas in
        let step_constants =
          let open Script_interpreter in
          {source; payer; self = dummy_contract; amount; chain_id}
        in
        let module Unparsing_mode = struct
          let unparsing_mode = unparsing_mode
        end in
        let module Interp = Traced_interpreter (Unparsing_mode) in
        Interp.execute
          ctxt
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >|=? fun ( {Script_interpreter.storage; operations; lazy_storage_diff; _},
                   trace ) -> (storage, operations, trace, lazy_storage_diff)
      in
      Registration.register0 S.trace_code trace_code_registration ;
      Registration.register0 S.trace_code_normalized trace_code_registration ;
      Registration.register0
        S.run_view
        (fun
          ctxt
          ()
          ( contract,
            entrypoint,
            input,
            chain_id,
            source,
            payer,
            gas,
            unparsing_mode )
        ->
          Contract.get_script ctxt contract >>=? fun (ctxt, script_opt) ->
          Option.fold
            ~some:ok
            ~none:(Error_monad.error View_helpers.Viewed_contract_has_no_script)
            script_opt
          >>?= fun script ->
          Script_repr.(force_decode script.code) >>?= fun decoded_script ->
          script_entrypoint_type ctxt decoded_script entrypoint
          >>=? fun view_ty ->
          View_helpers.extract_view_output_type entrypoint view_ty
          >>?= fun ty ->
          Error_monad.trace View_helpers.View_callback_origination_failed
          @@ originate_dummy_contract
               ctxt
               (View_helpers.make_viewer_script ty)
               Tez.zero
          >>=? fun (ctxt, viewer_contract) ->
          let (source, payer) =
            match (source, payer) with
            | (Some source, Some payer) -> (source, payer)
            | (Some source, None) -> (source, source)
            | (None, Some payer) -> (payer, payer)
            | (None, None) -> (contract, contract)
          in
          let gas =
            Option.value
              ~default:(Constants.hard_gas_limit_per_operation ctxt)
              gas
          in
          let ctxt = Gas.set_limit ctxt gas in
          let step_constants =
            let open Script_interpreter in
            {source; payer; self = contract; amount = Tez.zero; chain_id}
          in
          let parameter =
            View_helpers.make_view_parameter
              (Micheline.root input)
              viewer_contract
          in
          Script_interpreter.execute
            ctxt
            unparsing_mode
            step_constants
            ~script
            ~entrypoint
            ~parameter
            ~internal:true
          >>=? fun {Script_interpreter.operations; _} ->
          View_helpers.extract_parameter_from_operations
            entrypoint
            operations
            viewer_contract
          >>?= fun parameter -> Lwt.return (Script_repr.force_decode parameter)) ;
      Registration.register0
        S.typecheck_code
        (fun ctxt () (expr, maybe_gas, legacy) ->
          let legacy = Option.value ~default:false legacy in
          let ctxt =
            match maybe_gas with
            | None -> Gas.set_unlimited ctxt
            | Some gas -> Gas.set_limit ctxt gas
          in
          Script_ir_translator.typecheck_code ~legacy ctxt expr
          >|=? fun (res, ctxt) -> (res, Gas.level ctxt)) ;
      Registration.register0
        S.typecheck_data
        (fun ctxt () (data, ty, maybe_gas, legacy) ->
          let legacy = Option.value ~default:false legacy in
          let ctxt =
            match maybe_gas with
            | None -> Gas.set_unlimited ctxt
            | Some gas -> Gas.set_limit ctxt gas
          in
          typecheck_data ~legacy ctxt (data, ty) >|=? fun ctxt -> Gas.level ctxt) ;
      Registration.register0 S.pack_data (fun ctxt () (expr, typ, maybe_gas) ->
          let open Script_ir_translator in
          let ctxt =
            match maybe_gas with
            | None -> Gas.set_unlimited ctxt
            | Some gas -> Gas.set_limit ctxt gas
          in
          parse_packable_ty ctxt ~legacy:true (Micheline.root typ)
          >>?= fun (Ex_ty typ, ctxt) ->
          parse_data
            ctxt
            ~legacy:true
            ~allow_forged:true
            typ
            (Micheline.root expr)
          >>=? fun (data, ctxt) ->
          Script_ir_translator.pack_data ctxt typ data >|=? fun (bytes, ctxt) ->
          (bytes, Gas.level ctxt)) ;
      Registration.register0
        S.normalize_data
        (fun ctxt () (expr, typ, unparsing_mode, legacy) ->
          let open Script_ir_translator in
          let legacy = Option.value ~default:false legacy in
          let ctxt = Gas.set_unlimited ctxt in
          Script_ir_translator.parse_any_ty ctxt ~legacy (Micheline.root typ)
          >>?= fun (Ex_ty typ, ctxt) ->
          parse_data ctxt ~legacy ~allow_forged:true typ (Micheline.root expr)
          >>=? fun (data, ctxt) ->
          Script_ir_translator.unparse_data ctxt unparsing_mode typ data
          >|=? fun (normalized, _ctxt) -> Micheline.strip_locations normalized) ;
      Registration.register0
        S.normalize_script
        (fun ctxt () (script, unparsing_mode) ->
          let ctxt = Gas.set_unlimited ctxt in
          Script_ir_translator.unparse_code
            ctxt
            unparsing_mode
            (Micheline.root script)
          >|=? fun (normalized, _ctxt) -> Micheline.strip_locations normalized) ;
      Registration.register0 S.normalize_type (fun ctxt () typ ->
          let open Script_ir_translator in
          let ctxt = Gas.set_unlimited ctxt in
          (* Unfortunately, Script_ir_translator.parse_any_ty is not exported *)
          Script_ir_translator.parse_ty
            ctxt
            ~legacy:true
            ~allow_lazy_storage:true
            ~allow_operation:true
            ~allow_contract:true
            ~allow_ticket:true
            (Micheline.root typ)
          >>?= fun (Ex_ty typ, _ctxt) ->
          let normalized = Unparse_types.unparse_ty typ in
          return @@ Micheline.strip_locations normalized) ;
      Registration.register0
        S.run_operation
        (fun
          ctxt
          ()
          ({shell; protocol_data = Operation_data protocol_data}, chain_id)
        ->
          (* this code is a duplicate of Apply without signature check *)
          let partial_precheck_manager_contents (type kind) ctxt
              (op : kind Kind.manager contents) : context tzresult Lwt.t =
            let (Manager_operation
                  {source; fee; counter; operation; gas_limit; storage_limit}) =
              op
            in
            Gas.consume_limit_in_block ctxt gas_limit >>?= fun ctxt ->
            let ctxt = Gas.set_limit ctxt gas_limit in
            Fees.check_storage_limit ctxt ~storage_limit >>?= fun () ->
            Contract.must_be_allocated ctxt (Contract.implicit_contract source)
            >>=? fun () ->
            Contract.check_counter_increment ctxt source counter >>=? fun () ->
            (match operation with
            | Reveal pk -> Contract.reveal_manager_key ctxt source pk
            | Transaction {parameters; _} ->
                (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
                let arg_bytes =
                  Data_encoding.Binary.to_bytes_exn
                    Script.lazy_expr_encoding
                    parameters
                in
                let arg =
                  match
                    Data_encoding.Binary.of_bytes
                      Script.lazy_expr_encoding
                      arg_bytes
                  with
                  | Some arg -> arg
                  | None -> assert false
                in
                Lwt.return
                @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
                @@ (* Fail if not enough gas for complete deserialization cost *)
                ( Script.force_decode_in_context ctxt arg >|? fun (_arg, ctxt) ->
                  ctxt )
            | Origination {script; _} ->
                (* Here the data comes already deserialized, so we need to fake the deserialization to mimic apply *)
                let script_bytes =
                  Data_encoding.Binary.to_bytes_exn Script.encoding script
                in
                let script =
                  match
                    Data_encoding.Binary.of_bytes Script.encoding script_bytes
                  with
                  | Some script -> script
                  | None -> assert false
                in
                Lwt.return
                @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
                @@ (* Fail if not enough gas for complete deserialization cost *)
                ( Script.force_decode_in_context ctxt script.code
                >>? fun (_code, ctxt) ->
                  Script.force_decode_in_context ctxt script.storage
                  >|? fun (_storage, ctxt) -> ctxt )
            | _ -> return ctxt)
            >>=? fun ctxt ->
            Contract.get_manager_key ctxt source >>=? fun _public_key ->
            (* signature check unplugged from here *)
            Contract.increment_counter ctxt source >>=? fun ctxt ->
            Contract.spend ctxt (Contract.implicit_contract source) fee
          in
          let rec partial_precheck_manager_contents_list :
              type kind.
              Alpha_context.t ->
              kind Kind.manager contents_list ->
              context tzresult Lwt.t =
           fun ctxt contents_list ->
            match contents_list with
            | Single (Manager_operation _ as op) ->
                partial_precheck_manager_contents ctxt op
            | Cons ((Manager_operation _ as op), rest) ->
                partial_precheck_manager_contents ctxt op >>=? fun ctxt ->
                partial_precheck_manager_contents_list ctxt rest
          in
          let ret contents =
            ( Operation_data protocol_data,
              Apply_results.Operation_metadata {contents} )
          in
          let operation : _ operation = {shell; protocol_data} in
          let hash = Operation.hash {shell; protocol_data} in
          let ctxt = Contract.init_origination_nonce ctxt hash in
          let baker = Signature.Public_key_hash.zero in
          match protocol_data.contents with
          | Single (Manager_operation _) as op ->
              partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
              Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
              >|= fun (_ctxt, result) -> ok @@ ret result
          | Cons (Manager_operation _, _) as op ->
              partial_precheck_manager_contents_list ctxt op >>=? fun ctxt ->
              Apply.apply_manager_contents_list ctxt Optimized baker chain_id op
              >|= fun (_ctxt, result) -> ok @@ ret result
          | _ ->
              Apply.apply_contents_list
                ctxt
                chain_id
                Optimized
                shell.branch
                baker
                operation
                operation.protocol_data.contents
              >|=? fun (_ctxt, result) -> ret result) ;
      Registration.register0
        S.entrypoint_type
        (fun ctxt () (expr, entrypoint) ->
          script_entrypoint_type ctxt expr entrypoint) ;
      Registration.register0 S.list_entrypoints (fun ctxt () expr ->
          let ctxt = Gas.set_unlimited ctxt in
          let legacy = false in
          let open Script_ir_translator in
          Lwt.return
            ( parse_toplevel ~legacy expr >>? fun (arg_type, _, _, root_name) ->
              parse_parameter_ty ctxt ~legacy arg_type
              >>? fun (Ex_ty arg_type, _) ->
              Script_ir_translator.list_entrypoints ~root_name arg_type ctxt
              >|? fun (unreachable_entrypoint, map) ->
              ( unreachable_entrypoint,
                Entrypoints_map.fold
                  (fun entry (_, ty) acc ->
                    (entry, Micheline.strip_locations ty) :: acc)
                  map
                  [] ) ))

    let run_code ?unparsing_mode ?gas ?(entrypoint = "default") ~script ~storage
        ~input ~amount ~balance ~chain_id ~source ~payer ctxt block =
      RPC_context.make_call0
        S.run_code
        ctxt
        block
        ()
        ( ( script,
            storage,
            input,
            amount,
            balance,
            chain_id,
            source,
            payer,
            gas,
            entrypoint ),
          unparsing_mode )

    let trace_code ?unparsing_mode ?gas ?(entrypoint = "default") ~script
        ~storage ~input ~amount ~balance ~chain_id ~source ~payer ctxt block =
      RPC_context.make_call0
        S.trace_code
        ctxt
        block
        ()
        ( ( script,
            storage,
            input,
            amount,
            balance,
            chain_id,
            source,
            payer,
            gas,
            entrypoint ),
          unparsing_mode )

    let run_view ?gas ~contract ~entrypoint ~input ~chain_id ?source ?payer
        ~unparsing_mode ctxt block =
      RPC_context.make_call0
        S.run_view
        ctxt
        block
        ()
        ( contract,
          entrypoint,
          input,
          chain_id,
          source,
          payer,
          gas,
          unparsing_mode )

    let typecheck_code ?gas ?legacy ~script ctxt block =
      RPC_context.make_call0 S.typecheck_code ctxt block () (script, gas, legacy)

    let typecheck_data ?gas ?legacy ~data ~ty ctxt block =
      RPC_context.make_call0
        S.typecheck_data
        ctxt
        block
        ()
        (data, ty, gas, legacy)

    let pack_data ?gas ~data ~ty ctxt block =
      RPC_context.make_call0 S.pack_data ctxt block () (data, ty, gas)

    let normalize_data ?legacy ~data ~ty ~unparsing_mode ctxt block =
      RPC_context.make_call0
        S.normalize_data
        ctxt
        block
        ()
        (data, ty, unparsing_mode, legacy)

    let normalize_script ctxt block ~script ~unparsing_mode =
      RPC_context.make_call0
        S.normalize_script
        ctxt
        block
        ()
        (script, unparsing_mode)

    let normalize_type ctxt block ~ty =
      RPC_context.make_call0 S.normalize_type ctxt block () ty

    let run_operation ctxt block ~op ~chain_id =
      RPC_context.make_call0 S.run_operation ctxt block () (op, chain_id)

    let entrypoint_type ctxt block ~script ~entrypoint =
      RPC_context.make_call0 S.entrypoint_type ctxt block () (script, entrypoint)

    let list_entrypoints ctxt block ~script =
      RPC_context.make_call0 S.list_entrypoints ctxt block () script
  end

  module Contract = struct
    module S = struct
      let path =
        (RPC_path.(open_root / "context" / "contracts")
          : RPC_context.t RPC_path.context)

      let get_storage_normalized =
        let open Data_encoding in
        RPC_service.post_service
          ~description:
            "Access the data of the contract and normalize it using the \
             requested unparsing mode."
          ~input:(obj1 (req "unparsing_mode" unparsing_mode_encoding))
          ~query:RPC_query.empty
          ~output:(option Script.expr_encoding)
          RPC_path.(path /: Contract.rpc_arg / "storage" / "normalized")

      let get_script_normalized =
        let open Data_encoding in
        RPC_service.post_service
          ~description:
            "Access the script of the contract and normalize it using the \
             requested unparsing mode."
          ~input:(obj1 (req "unparsing_mode" unparsing_mode_encoding))
          ~query:RPC_query.empty
          ~output:(option Script.encoding)
          RPC_path.(path /: Contract.rpc_arg / "script" / "normalized")
    end

    let register () =
      (* Patched RPC: get_storage *)
      Registration.register1
        S.get_storage_normalized
        (fun ctxt contract () unparsing_mode ->
          Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
          match script with
          | None -> return_none
          | Some script ->
              let ctxt = Gas.set_unlimited ctxt in
              let open Script_ir_translator in
              parse_script
                ctxt
                ~legacy:true
                ~allow_forged_in_storage:true
                script
              >>=? fun (Ex_script script, ctxt) ->
              unparse_script ctxt unparsing_mode script
              >>=? fun (script, ctxt) ->
              Script.force_decode_in_context ctxt script.storage
              >>?= fun (storage, _ctxt) -> return_some storage) ;
      (* Patched RPC: get_script *)
      Registration.register1
        S.get_script_normalized
        (fun ctxt contract () unparsing_mode ->
          Contract.get_script ctxt contract >>=? fun (ctxt, script) ->
          match script with
          | None -> return_none
          | Some script ->
              let ctxt = Gas.set_unlimited ctxt in
              let open Script_ir_translator in
              parse_script
                ctxt
                ~legacy:true
                ~allow_forged_in_storage:true
                script
              >>=? fun (Ex_script script, ctxt) ->
              unparse_script ctxt unparsing_mode script
              >>=? fun (script, _ctxt) -> return_some script)

    let get_storage_normalized ctxt block ~contract ~unparsing_mode =
      RPC_context.make_call1
        S.get_storage_normalized
        ctxt
        block
        contract
        ()
        unparsing_mode

    let get_script_normalized ctxt block ~contract ~unparsing_mode =
      RPC_context.make_call1
        S.get_script_normalized
        ctxt
        block
        contract
        ()
        unparsing_mode
  end

  module Big_map = struct
    module S = struct
      let path =
        (RPC_path.(open_root / "context" / "big_maps")
          : RPC_context.t RPC_path.context)

      let big_map_get_normalized =
        let open Data_encoding in
        RPC_service.post_service
          ~description:
            "Access the value associated with a key in a big map, normalize \
             the output using the requested unparsing mode."
          ~query:RPC_query.empty
          ~input:(obj1 (req "unparsing_mode" unparsing_mode_encoding))
          ~output:Script.expr_encoding
          RPC_path.(
            path /: Big_map.Id.rpc_arg /: Script_expr_hash.rpc_arg
            / "normalized")
    end

    let register () =
      Registration.register2
        S.big_map_get_normalized
        (fun ctxt id key () unparsing_mode ->
          let open Script_ir_translator in
          let ctxt = Gas.set_unlimited ctxt in
          Big_map.exists ctxt id >>=? fun (ctxt, types) ->
          match types with
          | None -> raise Not_found
          | Some (_, value_type) -> (
              parse_big_map_value_ty
                ctxt
                ~legacy:true
                (Micheline.root value_type)
              >>?= fun (Ex_ty value_type, ctxt) ->
              Big_map.get_opt ctxt id key >>=? fun (_ctxt, value) ->
              match value with
              | None -> raise Not_found
              | Some value ->
                  parse_data
                    ctxt
                    ~legacy:true
                    ~allow_forged:true
                    value_type
                    (Micheline.root value)
                  >>=? fun (value, ctxt) ->
                  unparse_data ctxt unparsing_mode value_type value
                  >|=? fun (value, _ctxt) -> Micheline.strip_locations value))

    let big_map_get_normalized ctxt block id key ~unparsing_mode =
      RPC_context.make_call2
        S.big_map_get_normalized
        ctxt
        block
        id
        key
        ()
        unparsing_mode
  end

  module Forge = struct
    module S = struct
      open Data_encoding

      let path = RPC_path.(path / "forge")

      let operations =
        RPC_service.post_service
          ~description:"Forge an operation"
          ~query:RPC_query.empty
          ~input:Operation.unsigned_encoding
          ~output:bytes
          RPC_path.(path / "operations")

      let empty_proof_of_work_nonce =
        Bytes.make Constants_repr.proof_of_work_nonce_size '\000'

      let protocol_data =
        RPC_service.post_service
          ~description:"Forge the protocol-specific part of a block header"
          ~query:RPC_query.empty
          ~input:
            (obj4
               (req "priority" uint16)
               (opt "nonce_hash" Nonce_hash.encoding)
               (dft
                  "proof_of_work_nonce"
                  (Fixed.bytes Alpha_context.Constants.proof_of_work_nonce_size)
                  empty_proof_of_work_nonce)
               (dft "liquidity_baking_escape_vote" bool false))
          ~output:(obj1 (req "protocol_data" bytes))
          RPC_path.(path / "protocol_data")
    end

    let register () =
      Registration.register0_noctxt S.operations (fun () (shell, proto) ->
          return
            (Data_encoding.Binary.to_bytes_exn
               Operation.unsigned_encoding
               (shell, proto))) ;
      Registration.register0_noctxt
        S.protocol_data
        (fun
          ()
          ( priority,
            seed_nonce_hash,
            proof_of_work_nonce,
            liquidity_baking_escape_vote )
        ->
          return
            (Data_encoding.Binary.to_bytes_exn
               Block_header.contents_encoding
               {
                 priority;
                 seed_nonce_hash;
                 proof_of_work_nonce;
                 liquidity_baking_escape_vote;
               }))

    module Manager = struct
      let[@coq_axiom_with_reason "cast on e"] operations ctxt block ~branch
          ~source ?sourcePubKey ~counter ~fee ~gas_limit ~storage_limit
          operations =
        Contract_services.manager_key ctxt block source >>= function
        | Error _ as e -> Lwt.return e
        | Ok revealed ->
            let ops =
              List.map
                (fun (Manager operation) ->
                  Contents
                    (Manager_operation
                       {
                         source;
                         counter;
                         operation;
                         fee;
                         gas_limit;
                         storage_limit;
                       }))
                operations
            in
            let ops =
              match (sourcePubKey, revealed) with
              | (None, _) | (_, Some _) -> ops
              | (Some pk, None) ->
                  let operation = Reveal pk in
                  Contents
                    (Manager_operation
                       {
                         source;
                         counter;
                         operation;
                         fee;
                         gas_limit;
                         storage_limit;
                       })
                  :: ops
            in
            RPC_context.make_call0
              S.operations
              ctxt
              block
              ()
              ({branch}, Operation.of_list ops)

      let reveal ctxt block ~branch ~source ~sourcePubKey ~counter ~fee () =
        operations
          ctxt
          block
          ~branch
          ~source
          ~sourcePubKey
          ~counter
          ~fee
          ~gas_limit:Gas.Arith.zero
          ~storage_limit:Z.zero
          []

      let transaction ctxt block ~branch ~source ?sourcePubKey ~counter ~amount
          ~destination ?(entrypoint = "default") ?parameters ~gas_limit
          ~storage_limit ~fee () =
        let parameters =
          Option.fold
            ~some:Script.lazy_expr
            ~none:Script.unit_parameter
            parameters
        in
        operations
          ctxt
          block
          ~branch
          ~source
          ?sourcePubKey
          ~counter
          ~fee
          ~gas_limit
          ~storage_limit
          [Manager (Transaction {amount; parameters; destination; entrypoint})]

      let origination ctxt block ~branch ~source ?sourcePubKey ~counter ~balance
          ?delegatePubKey ~script ~gas_limit ~storage_limit ~fee () =
        operations
          ctxt
          block
          ~branch
          ~source
          ?sourcePubKey
          ~counter
          ~fee
          ~gas_limit
          ~storage_limit
          [
            Manager
              (Origination
                 {
                   delegate = delegatePubKey;
                   script;
                   credit = balance;
                   preorigination = None;
                 });
          ]

      let delegation ctxt block ~branch ~source ?sourcePubKey ~counter ~fee
          delegate =
        operations
          ctxt
          block
          ~branch
          ~source
          ?sourcePubKey
          ~counter
          ~fee
          ~gas_limit:Gas.Arith.zero
          ~storage_limit:Z.zero
          [Manager (Delegation delegate)]
    end

    let operation ctxt block ~branch operation =
      RPC_context.make_call0
        S.operations
        ctxt
        block
        ()
        ({branch}, Contents_list (Single operation))

    let endorsement ctxt b ~branch ~level () =
      operation ctxt b ~branch (Endorsement {level})

    let proposals ctxt b ~branch ~source ~period ~proposals () =
      operation ctxt b ~branch (Proposals {source; period; proposals})

    let ballot ctxt b ~branch ~source ~period ~proposal ~ballot () =
      operation ctxt b ~branch (Ballot {source; period; proposal; ballot})

    let failing_noop ctxt b ~branch ~message () =
      operation ctxt b ~branch (Failing_noop message)

    let seed_nonce_revelation ctxt block ~branch ~level ~nonce () =
      operation ctxt block ~branch (Seed_nonce_revelation {level; nonce})

    let double_baking_evidence ctxt block ~branch ~bh1 ~bh2 () =
      operation ctxt block ~branch (Double_baking_evidence {bh1; bh2})

    let double_endorsement_evidence ctxt block ~branch ~op1 ~op2 ~slot () =
      operation
        ctxt
        block
        ~branch
        (Double_endorsement_evidence {op1; op2; slot})

    let empty_proof_of_work_nonce =
      Bytes.make Constants_repr.proof_of_work_nonce_size '\000'

    let protocol_data ctxt block ~priority ?seed_nonce_hash
        ?(proof_of_work_nonce = empty_proof_of_work_nonce)
        ~liquidity_baking_escape_vote () =
      RPC_context.make_call0
        S.protocol_data
        ctxt
        block
        ()
        ( priority,
          seed_nonce_hash,
          proof_of_work_nonce,
          liquidity_baking_escape_vote )
  end

  module Parse = struct
    module S = struct
      open Data_encoding

      let path = RPC_path.(path / "parse")

      let operations =
        RPC_service.post_service
          ~description:"Parse operations"
          ~query:RPC_query.empty
          ~input:
            (obj2
               (req "operations" (list (dynamic_size Operation.raw_encoding)))
               (opt "check_signature" bool))
          ~output:(list (dynamic_size Operation.encoding))
          RPC_path.(path / "operations")

      let block =
        RPC_service.post_service
          ~description:"Parse a block"
          ~query:RPC_query.empty
          ~input:Block_header.raw_encoding
          ~output:Block_header.protocol_data_encoding
          RPC_path.(path / "block")
    end

    let parse_protocol_data protocol_data =
      match
        Data_encoding.Binary.of_bytes
          Block_header.protocol_data_encoding
          protocol_data
      with
      | None -> Stdlib.failwith "Cant_parse_protocol_data"
      | Some protocol_data -> protocol_data

    let register () =
      Registration.register0 S.operations (fun _ctxt () (operations, check) ->
          map_s
            (fun raw ->
              parse_operation raw >>?= fun op ->
              (match check with
              | Some true -> return_unit (* FIXME *)
              (* I.check_signature ctxt *)
              (* op.protocol_data.signature op.shell op.protocol_data.contents *)
              | Some false | None -> return_unit)
              >|=? fun () -> op)
            operations) ;
      Registration.register0_noctxt S.block (fun () raw_block ->
          return @@ parse_protocol_data raw_block.protocol_data)

    let operations ctxt block ?check operations =
      RPC_context.make_call0 S.operations ctxt block () (operations, check)

    let block ctxt block shell protocol_data =
      RPC_context.make_call0
        S.block
        ctxt
        block
        ()
        ({shell; protocol_data} : Block_header.raw)
  end

  module S = struct
    open Data_encoding

    type level_query = {offset : int32}

    let level_query : level_query RPC_query.t =
      let open RPC_query in
      query (fun offset -> {offset})
      |+ field "offset" RPC_arg.int32 0l (fun t -> t.offset)
      |> seal

    let current_level =
      RPC_service.get_service
        ~description:
          "Returns the level of the interrogated block, or the one of a block \
           located `offset` blocks after in the chain (or before when \
           negative). For instance, the next block if `offset` is 1."
        ~query:level_query
        ~output:Level.encoding
        RPC_path.(path / "current_level")

    let levels_in_current_cycle =
      RPC_service.get_service
        ~description:"Levels of a cycle"
        ~query:level_query
        ~output:
          (obj2
             (req "first" Raw_level.encoding)
             (req "last" Raw_level.encoding))
        RPC_path.(path / "levels_in_current_cycle")
  end

  let register () =
    Scripts.register () ;
    Forge.register () ;
    Parse.register () ;
    Contract.register () ;
    Big_map.register () ;
    Registration.register0 S.current_level (fun ctxt q () ->
        Level.from_raw ctxt ~offset:q.offset (Level.current ctxt).level
        |> return) ;
    Registration.opt_register0 S.levels_in_current_cycle (fun ctxt q () ->
        let rev_levels =
          Level.levels_in_current_cycle ctxt ~offset:q.offset ()
        in
        match rev_levels with
        | [] -> return_none
        | [level] -> return (Some (level.level, level.level))
        | last :: (_ :: _ as rest) ->
            (* The [rev_levels] list is reversed, the last level is the head *)
            let first = List.hd (List.rev rest) in
            return (Some (first.level, last.level)))

  let current_level ctxt ?(offset = 0l) block =
    RPC_context.make_call0 S.current_level ctxt block {offset} ()

  let levels_in_current_cycle ctxt ?(offset = 0l) block =
    RPC_context.make_call0 S.levels_in_current_cycle ctxt block {offset} ()

  let rpc_services =
    register () ;
    RPC_directory.merge rpc_services !Registration.patched_services
end