ligo/vendors/ligo-utils/tezos-protocol-alpha/helpers_services.ml

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

type error += Cannot_parse_operation (* `Branch *)

let () =
  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)

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 Scripts = struct
  module S = struct
    open Data_encoding

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

    let run_code_input_encoding =
      obj9
        (req "script" Script.expr_encoding)
        (req "storage" Script.expr_encoding)
        (req "input" Script.expr_encoding)
        (req "amount" Tez.encoding)
        (req "chain_id" Chain_id.encoding)
        (opt "source" Contract.encoding)
        (opt "payer" Contract.encoding)
        (opt "gas" z)
        (dft "entrypoint" string "default")

    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 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:
          (obj3
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "run_code")

    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:run_code_input_encoding
        ~output:
          (obj4
             (req "storage" Script.expr_encoding)
             (req "operations" (list Operation.internal_operation_encoding))
             (req "trace" trace_encoding)
             (opt "big_map_diff" Contract.big_map_diff_encoding))
        RPC_path.(path / "trace_code")

    let typecheck_code =
      RPC_service.post_service
        ~description:"Typecheck a piece of code in the current context"
        ~query:RPC_query.empty
        ~input:(obj2 (req "program" Script.expr_encoding) (opt "gas" z))
        ~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:
          (obj3
             (req "data" Script.expr_encoding)
             (req "type" Script.expr_encoding)
             (opt "gas" z))
        ~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" z))
        ~output:(obj2 (req "packed" bytes) (req "gas" Gas.encoding))
        ~query:RPC_query.empty
        RPC_path.(path / "pack_data")

    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

  let register () =
    let open Services_registration in
    let originate_dummy_contract ctxt script =
      let ctxt = Contract.init_origination_nonce ctxt Operation_hash.zero in
      Contract.fresh_contract_from_current_nonce ctxt
      >>=? fun (ctxt, dummy_contract) ->
      let balance =
        match Tez.of_mutez 4_000_000_000_000L with
        | Some balance ->
            balance
        | None ->
            assert false
      in
      Contract.originate
        ctxt
        dummy_contract
        ~balance
        ~delegate:None
        ~script:(script, None)
      >>=? fun ctxt -> return (ctxt, dummy_contract)
    in
    register0
      S.run_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? 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
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun {Script_interpreter.storage; operations; big_map_diff; _} ->
        return (storage, operations, big_map_diff)) ;
    register0
      S.trace_code
      (fun ctxt
           ()
           ( code,
             storage,
             parameter,
             amount,
             chain_id,
             source,
             payer,
             gas,
             entrypoint )
           ->
        let storage = Script.lazy_expr storage in
        let code = Script.lazy_expr code in
        originate_dummy_contract ctxt {storage; code}
        >>=? 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.trace
          ctxt
          Readable
          step_constants
          ~script:{storage; code}
          ~entrypoint
          ~parameter
        >>=? fun ( {Script_interpreter.storage; operations; big_map_diff; _},
                   trace ) ->
        return (storage, operations, trace, big_map_diff)) ;
    register0 S.typecheck_code (fun ctxt () (expr, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_code ctxt expr
        >>=? fun (res, ctxt) -> return (res, Gas.level ctxt)) ;
    register0 S.typecheck_data (fun ctxt () (data, ty, maybe_gas) ->
        let ctxt =
          match maybe_gas with
          | None ->
              Gas.set_unlimited ctxt
          | Some gas ->
              Gas.set_limit ctxt gas
        in
        Script_ir_translator.typecheck_data ctxt (data, ty)
        >>=? fun ctxt -> return (Gas.level ctxt)) ;
    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
        Lwt.return (parse_packable_ty ctxt ~legacy:true (Micheline.root typ))
        >>=? fun (Ex_ty typ, ctxt) ->
        parse_data ctxt ~legacy:true typ (Micheline.root expr)
        >>=? fun (data, ctxt) ->
        Script_ir_translator.pack_data ctxt typ data
        >>=? fun (bytes, ctxt) -> return (bytes, Gas.level ctxt)) ;
    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
          Lwt.return (Gas.check_limit ctxt gas_limit)
          >>=? fun () ->
          let ctxt = Gas.set_limit ctxt gas_limit in
          Lwt.return (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
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Gas.check_enough ctxt (Script.minimal_deserialize_cost arg)
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode 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
              (* Fail quickly if not enough gas for minimal deserialization cost *)
              Lwt.return
              @@ record_trace Apply.Gas_quota_exceeded_init_deserialize
              @@ ( Gas.consume
                     ctxt
                     (Script.minimal_deserialize_cost script.code)
                 >>? fun ctxt ->
                 Gas.check_enough
                   ctxt
                   (Script.minimal_deserialize_cost script.storage) )
              >>=? fun () ->
              (* Fail if not enough gas for complete deserialization cost *)
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode ctxt script.code
              >>=? fun (_code, ctxt) ->
              trace Apply.Gas_quota_exceeded_init_deserialize
              @@ Script.force_decode 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
          >>=? fun ctxt -> return ctxt
        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 return contents =
          return
            ( 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) -> return 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) -> return result
        | _ ->
            Apply.apply_contents_list
              ctxt
              chain_id
              Optimized
              shell.branch
              baker
              operation
              operation.protocol_data.contents
            >>=? fun (_ctxt, result) -> return result) ;
    register0 S.entrypoint_type (fun 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_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            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, _) -> return (Micheline.strip_locations ty_node)) ;
    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_ty
            ctxt
            ~legacy
            ~allow_big_map:true
            ~allow_operation:false
            ~allow_contract:true
            arg_type
          >>? fun (Ex_ty arg_type, _) ->
          Script_ir_translator.list_entrypoints ~root_name arg_type ctxt )
        >>=? fun (unreachable_entrypoint, map) ->
        return
          ( unreachable_entrypoint,
            Entrypoints_map.fold
              (fun entry (_, ty) acc ->
                (entry, Micheline.strip_locations ty) :: acc)
              map
              [] ))

  let run_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.run_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let trace_code ctxt block code
      (storage, input, amount, chain_id, source, payer, gas, entrypoint) =
    RPC_context.make_call0
      S.trace_code
      ctxt
      block
      ()
      (code, storage, input, amount, chain_id, source, payer, gas, entrypoint)

  let typecheck_code ctxt block =
    RPC_context.make_call0 S.typecheck_code ctxt block ()

  let typecheck_data ctxt block =
    RPC_context.make_call0 S.typecheck_data ctxt block ()

  let pack_data ctxt block = RPC_context.make_call0 S.pack_data ctxt block ()

  let run_operation ctxt block =
    RPC_context.make_call0 S.run_operation ctxt block ()

  let entrypoint_type ctxt block =
    RPC_context.make_call0 S.entrypoint_type ctxt block ()

  let list_entrypoints ctxt block =
    RPC_context.make_call0 S.list_entrypoints ctxt block ()
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 =
      MBytes.of_string
        (String.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:
          (obj3
             (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))
        ~output:(obj1 (req "protocol_data" bytes))
        RPC_path.(path / "protocol_data")
  end

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

  module Manager = struct
    let 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:Z.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.unopt_map
          ~f:Script.lazy_expr
          ~default: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:Z.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 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 () =
    operation ctxt block ~branch (Double_endorsement_evidence {op1; op2})

  let empty_proof_of_work_nonce =
    MBytes.of_string
      (String.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) () =
    RPC_context.make_call0
      S.protocol_data
      ctxt
      block
      ()
      (priority, seed_nonce_hash, proof_of_work_nonce)
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 ->
        failwith "Cant_parse_protocol_data"
    | Some protocol_data ->
        return protocol_data

  let register () =
    let open Services_registration in
    register0 S.operations (fun _ctxt () (operations, check) ->
        map_s
          (fun raw ->
            Lwt.return (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) ;
    register0_noctxt S.block (fun () raw_block ->
        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 () ;
  let open Services_registration in
  register0 S.current_level (fun ctxt q () ->
      let level = Level.current ctxt in
      return (Level.from_raw ctxt ~offset:q.offset level.level)) ;
  register0 S.levels_in_current_cycle (fun ctxt q () ->
      let levels = Level.levels_in_current_cycle ctxt ~offset:q.offset () in
      match levels with
      | [] ->
          raise Not_found
      | _ ->
          let first = List.hd (List.rev levels) in
          let last = List.hd levels in
          return (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} ()