(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. *) (* *) (* 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 begin 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) end ; register0 S.trace_code begin 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) end ; register0 S.typecheck_code begin 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) end ; register0 S.typecheck_data begin 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) end ; register0 S.pack_data begin 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) end ; register0 S.run_operation begin 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 () -> begin 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 = 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 end >>=? 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 end; register0 S.entrypoint_type begin fun ctxt () (expr, entrypoint) -> let ctxt = Gas.set_unlimited ctxt in let legacy = false in let open Script_ir_translator in Lwt.return begin 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 end >>=? fun (_f , Ex_ty ty)-> unparse_ty ctxt ty >>=? fun (ty_node, _) -> return (Micheline.strip_locations ty_node) end ; register0 S.list_entrypoints begin fun ctxt () expr -> let ctxt = Gas.set_unlimited ctxt in let legacy = false in let open Script_ir_translator in Lwt.return begin 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 end >>=? fun (unreachable_entrypoint,map) -> return (unreachable_entrypoint, Entrypoints_map.fold begin fun entry (_,ty) acc -> (entry , Micheline.strip_locations ty) ::acc end map []) end 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 begin fun () (shell, proto) -> return (Data_encoding.Binary.to_bytes_exn Operation.unsigned_encoding (shell, proto)) end ; register0_noctxt S.protocol_data begin 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 }) end 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 begin fun _ctxt () (operations, check) -> map_s begin fun raw -> Lwt.return (parse_operation raw) >>=? fun op -> begin 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 end >>|? fun () -> op end operations end ; register0_noctxt S.block begin fun () raw_block -> parse_protocol_data raw_block.protocol_data end 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 begin fun ctxt q () -> let level = Level.current ctxt in return (Level.from_raw ctxt ~offset:q.offset level.level) end ; register0 S.levels_in_current_cycle begin 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) end 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 } ()