diff --git a/src/proto_alpha/lib_client/client_baking_blocks.ml b/src/proto_alpha/lib_client/client_baking_blocks.ml index 319d0b5cf..8496eabbd 100644 --- a/src/proto_alpha/lib_client/client_baking_blocks.ml +++ b/src/proto_alpha/lib_client/client_baking_blocks.ml @@ -23,7 +23,7 @@ type block_info = { let convert_block_info cctxt ( { hash ; net_id ; predecessor ; fitness ; timestamp ; protocol } : Block_services.block_info ) = - Client_proto_rpcs.Context.level cctxt (`Hash hash) >>= function + Alpha_services.Context.level cctxt (`Hash hash) >>= function | Ok level -> Lwt.return (Some { hash ; net_id ; predecessor ; @@ -35,7 +35,7 @@ let convert_block_info cctxt let convert_block_info_err cctxt ( { hash ; net_id ; predecessor ; fitness ; timestamp ; protocol } : Block_services.block_info ) = - Client_proto_rpcs.Context.level cctxt (`Hash hash) >>=? fun level -> + Alpha_services.Context.level cctxt (`Hash hash) >>=? fun level -> return { hash ; net_id ; predecessor ; fitness ; timestamp ; protocol ; level } let info cctxt ?include_ops block = @@ -71,8 +71,8 @@ let monitor cctxt let blocks_from_cycle cctxt block cycle = let block = Block_services.last_baked_block block in - Client_proto_rpcs.Context.level cctxt block >>=? fun level -> - Client_proto_rpcs.Helpers.levels cctxt block cycle >>=? fun (first, last) -> + Alpha_services.Context.level cctxt block >>=? fun level -> + Alpha_services.Helpers.levels cctxt block cycle >>=? fun (first, last) -> let length = Int32.to_int (Raw_level.diff level.level first) in Block_services.predecessors cctxt block length >>=? fun blocks -> let blocks = diff --git a/src/proto_alpha/lib_client/client_baking_endorsement.ml b/src/proto_alpha/lib_client/client_baking_endorsement.ml index 9e444394f..616dbb3f1 100644 --- a/src/proto_alpha/lib_client/client_baking_endorsement.ml +++ b/src/proto_alpha/lib_client/client_baking_endorsement.ml @@ -83,9 +83,9 @@ end = struct end let get_signing_slots cctxt ?max_priority block delegate level = - Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate cctxt + Alpha_services.Delegate.Endorser.rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level - block delegate () >>=? fun possibilities -> + block delegate >>=? fun possibilities -> let slots = List.map (fun (_,slot) -> slot) @@ List.filter (fun (l, _) -> l = level) possibilities in @@ -96,7 +96,7 @@ let inject_endorsement (cctxt : #Proto_alpha.full_context) src_sk source slot = let block = Block_services.last_baked_block block in Block_services.info cctxt block >>=? fun bi -> - Client_proto_rpcs.Helpers.Forge.Delegate.endorsement cctxt + Alpha_services.Forge.Delegate.endorsement cctxt block ~branch:bi.hash ~source @@ -128,7 +128,7 @@ let forge_endorsement (cctxt : #Proto_alpha.full_context) ~src_sk ?slot ?max_priority src_pk = let block = Block_services.last_baked_block block in let src_pkh = Ed25519.Public_key.hash src_pk in - Client_proto_rpcs.Context.next_level cctxt block >>=? fun { level } -> + Alpha_services.Context.next_level cctxt block >>=? fun { level } -> begin match slot with | Some slot -> return slot diff --git a/src/proto_alpha/lib_client/client_baking_forge.ml b/src/proto_alpha/lib_client/client_baking_forge.ml index f9f227d95..a5bfba343 100644 --- a/src/proto_alpha/lib_client/client_baking_forge.ml +++ b/src/proto_alpha/lib_client/client_baking_forge.ml @@ -23,7 +23,7 @@ let generate_seed_nonce () = let forge_block_header cctxt block delegate_sk shell priority seed_nonce_hash = - Client_proto_rpcs.Constants.stamp_threshold + Alpha_services.Constants.proof_of_work_threshold cctxt block >>=? fun stamp_threshold -> let rec loop () = let proof_of_work_nonce = generate_proof_of_work_nonce () in @@ -133,22 +133,22 @@ let forge_block cctxt block end >>=? fun operations -> begin match priority with - | `Set prio -> begin - Client_proto_rpcs.Helpers.minimal_time - cctxt block ~prio () >>=? fun time -> - return (prio, time) + | `Set priority -> begin + Alpha_services.Helpers.minimal_time + cctxt block ~priority >>=? fun time -> + return (priority, time) end | `Auto (src_pkh, max_priority, free_baking) -> - Client_proto_rpcs.Context.next_level cctxt block >>=? fun { level } -> - Client_proto_rpcs.Helpers.Rights.baking_rights_for_delegate cctxt + Alpha_services.Context.next_level cctxt block >>=? fun { level } -> + Alpha_services.Delegate.Baker.rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level - block src_pkh () >>=? fun possibilities -> + block src_pkh >>=? fun possibilities -> try begin if free_baking then - Client_proto_rpcs.Constants.first_free_baking_slot cctxt block + Alpha_services.Constants.first_free_baking_slot cctxt block else return 0 end >>=? fun min_prio -> @@ -304,11 +304,11 @@ let get_baking_slot cctxt let level = Raw_level.succ bi.level.level in Lwt_list.filter_map_p (fun delegate -> - Client_proto_rpcs.Helpers.Rights.baking_rights_for_delegate cctxt + Alpha_services.Delegate.Baker.rights_for_delegate cctxt ?max_priority ~first_level:level ~last_level:level - block delegate () >>= function + block delegate >>= function | Error errs -> log_error "Error while fetching baking possibilities:\n%a" pp_print_error errs ; @@ -369,7 +369,7 @@ let compute_timeout { future_slots } = Lwt_unix.sleep (Int64.to_float delay) let get_unrevealed_nonces (cctxt : #Proto_alpha.full_context) ?(force = false) block = - Client_proto_rpcs.Context.next_level cctxt block >>=? fun level -> + Alpha_services.Context.next_level cctxt block >>=? fun level -> let cur_cycle = level.cycle in match Cycle.pred cur_cycle with | None -> return [] @@ -380,12 +380,12 @@ let get_unrevealed_nonces (cctxt : #Proto_alpha.full_context) ?(force = false) b Client_proto_nonces.find cctxt hash >>=? function | None -> return None | Some nonce -> - Client_proto_rpcs.Context.level + Alpha_services.Context.level cctxt (`Hash hash) >>=? fun level -> if force then return (Some (hash, (level.level, nonce))) else - Client_proto_rpcs.Context.Nonce.get + Alpha_services.Nonce.get cctxt block level.level >>=? function | Missing nonce_hash when Nonce.check_hash nonce nonce_hash -> diff --git a/src/proto_alpha/lib_client/client_baking_lib.ml b/src/proto_alpha/lib_client/client_baking_lib.ml index 16f3941a8..797e41e62 100644 --- a/src/proto_alpha/lib_client/client_baking_lib.ml +++ b/src/proto_alpha/lib_client/client_baking_lib.ml @@ -19,7 +19,7 @@ let bake_block (cctxt : #Proto_alpha.full_context) block return src_sk | Some sk -> return sk end >>=? fun src_sk -> - Client_proto_rpcs.Context.level cctxt block >>=? fun level -> + Alpha_services.Context.level cctxt block >>=? fun level -> let level = Raw_level.succ level.level in let seed_nonce = Client_baking_forge.generate_seed_nonce () in let seed_nonce_hash = Nonce.hash seed_nonce in diff --git a/src/proto_alpha/lib_client/client_baking_operations.ml b/src/proto_alpha/lib_client/client_baking_operations.ml index b3f049507..0b6bd8a1e 100644 --- a/src/proto_alpha/lib_client/client_baking_operations.ml +++ b/src/proto_alpha/lib_client/client_baking_operations.ml @@ -24,7 +24,7 @@ let monitor cctxt ?contents ?check () = match op with | None -> return { hash; content = None } | Some (op : Operation.raw) -> - Client_proto_rpcs.Helpers.Parse.operations cctxt + Alpha_services.Parse.operations cctxt `Prevalidation ?check [op] >>=? function | [proto] -> return { hash ; content = Some proto } diff --git a/src/proto_alpha/lib_client/client_baking_revelation.ml b/src/proto_alpha/lib_client/client_baking_revelation.ml index 72c3effcd..e4372f924 100644 --- a/src/proto_alpha/lib_client/client_baking_revelation.ml +++ b/src/proto_alpha/lib_client/client_baking_revelation.ml @@ -17,7 +17,7 @@ let inject_seed_nonce_revelation rpc_config block ?async nonces = Seed_nonce_revelation { level ; nonce }) nonces in let block = Block_services.last_baked_block block in Block_services.info rpc_config block >>=? fun bi -> - Client_proto_rpcs.Helpers.Forge.Anonymous.operations rpc_config + Alpha_services.Forge.Anonymous.operations rpc_config block ~branch:bi.hash operations >>=? fun bytes -> Shell_services.inject_operation rpc_config ?async ~net_id:bi.net_id diff --git a/src/proto_alpha/lib_client/client_proto_context.ml b/src/proto_alpha/lib_client/client_proto_context.ml index a0198762a..603d33955 100644 --- a/src/proto_alpha/lib_client/client_proto_context.ml +++ b/src/proto_alpha/lib_client/client_proto_context.ml @@ -14,10 +14,10 @@ open Client_proto_contracts open Client_keys let get_balance (rpc : #Proto_alpha.rpc_context) block contract = - Client_proto_rpcs.Context.Contract.balance rpc block contract + Alpha_services.Contract.balance rpc block contract let get_storage (rpc : #Proto_alpha.rpc_context) block contract = - Client_proto_rpcs.Context.Contract.storage rpc block contract + Alpha_services.Contract.storage_opt rpc block contract let rec find_predecessor rpc_config h n = if n <= 0 then @@ -54,10 +54,10 @@ let transfer rpc_config return (Some arg) | None -> return None end >>=? fun parameters -> - Client_proto_rpcs.Context.Contract.counter + Alpha_services.Contract.counter rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in - Client_proto_rpcs.Helpers.Forge.Manager.transaction + Alpha_services.Forge.Manager.transaction rpc_config block ~branch ~source ~sourcePubKey:src_pk ~counter ~amount ~destination ?parameters ~fee () >>=? fun bytes -> @@ -66,7 +66,7 @@ let transfer rpc_config let signed_bytes = MBytes.concat bytes (Ed25519.Signature.to_bytes signature) in let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_proto_rpcs.Helpers.apply_operation rpc_config block + Alpha_services.Helpers.apply_operation rpc_config block predecessor oph bytes (Some signature) >>=? fun contracts -> Shell_services.inject_operation rpc_config ~net_id signed_bytes >>=? fun injected_oph -> @@ -80,7 +80,7 @@ let originate rpc_config ?net_id ~block ?signature bytes = | Some signature -> Ed25519.Signature.concat bytes signature in Block_services.predecessor rpc_config block >>=? fun predecessor -> let oph = Operation_hash.hash_bytes [ signed_bytes ] in - Client_proto_rpcs.Helpers.apply_operation rpc_config block + Alpha_services.Helpers.apply_operation rpc_config block predecessor oph bytes signature >>=? function | [ contract ] -> Shell_services.inject_operation @@ -106,10 +106,10 @@ let originate_account ?branch ~source ~src_pk ~src_sk ~manager_pkh ?delegatable ?delegate ~balance ~fee block rpc_config () = get_branch rpc_config block branch >>=? fun (net_id, branch) -> - Client_proto_rpcs.Context.Contract.counter + Alpha_services.Contract.counter rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in - Client_proto_rpcs.Helpers.Forge.Manager.origination rpc_config block + Alpha_services.Forge.Manager.origination rpc_config block ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager_pkh ~counter ~balance ~spendable:true ?delegatable ?delegatePubKey:delegate ~fee () >>=? fun bytes -> @@ -118,8 +118,9 @@ let originate_account ?branch let faucet ?branch ~manager_pkh block rpc_config () = get_branch rpc_config block branch >>=? fun (net_id, branch) -> - Client_proto_rpcs.Helpers.Forge.Anonymous.faucet - rpc_config block ~branch ~id:manager_pkh () >>=? fun bytes -> + let nonce = Rand.generate Constants_repr.nonce_length in + Alpha_services.Forge.Anonymous.faucet + rpc_config block ~branch ~id:manager_pkh ~nonce () >>=? fun bytes -> originate rpc_config ~net_id ~block bytes let delegate_contract rpc_config @@ -127,10 +128,10 @@ let delegate_contract rpc_config ~source ?src_pk ~manager_sk ~fee delegate_opt = get_branch rpc_config block branch >>=? fun (net_id, branch) -> - Client_proto_rpcs.Context.Contract.counter + Alpha_services.Contract.counter rpc_config block source >>=? fun pcounter -> let counter = Int32.succ pcounter in - Client_proto_rpcs.Helpers.Forge.Manager.delegation rpc_config block + Alpha_services.Forge.Manager.delegation rpc_config block ~branch ~source ?sourcePubKey:src_pk ~counter ~fee delegate_opt >>=? fun bytes -> Client_keys.sign manager_sk bytes >>=? fun signature -> @@ -141,8 +142,8 @@ let delegate_contract rpc_config assert (Operation_hash.equal oph injected_oph) ; return oph -let list_contract_labels (cctxt : #Client_commands.full_context) block = - Client_proto_rpcs.Context.Contract.list +let list_contract_labels (cctxt : #Proto_alpha.full_context) block = + Alpha_services.Contract.list cctxt block >>=? fun contracts -> map_s (fun h -> begin match Contract.is_default h with @@ -167,10 +168,10 @@ let list_contract_labels (cctxt : #Client_commands.full_context) block = return (nm, h_b58, kind)) contracts -let message_added_contract (cctxt : #Client_commands.full_context) name = +let message_added_contract (cctxt : #Proto_alpha.full_context) name = cctxt#message "Contract memorized as %s." name -let get_manager (cctxt : #Client_commands.full_context) block source = +let get_manager (cctxt : #Proto_alpha.full_context) block source = Client_proto_contracts.get_manager cctxt block source >>=? fun src_pkh -> Client_keys.get_key cctxt src_pkh >>=? fun (src_name, src_pk, src_sk) -> @@ -180,7 +181,7 @@ let dictate rpc_config block command seckey = let block = Block_services.last_baked_block block in Block_services.info rpc_config block >>=? fun { net_id ; hash = branch } -> - Client_proto_rpcs.Helpers.Forge.Dictator.operation + Alpha_services.Forge.Dictator.operation rpc_config block ~branch command >>=? fun bytes -> let signature = Ed25519.sign seckey bytes in let signed_bytes = Ed25519.Signature.concat bytes signature in @@ -221,11 +222,11 @@ let originate_contract Lwt.return (Micheline_parser.no_parsing_error result) >>=? fun { Michelson_v1_parser.expanded = storage } -> let block = cctxt#block in - Client_proto_rpcs.Context.Contract.counter + Alpha_services.Contract.counter cctxt block source >>=? fun pcounter -> let counter = Int32.succ pcounter in get_branch cctxt block None >>=? fun (_net_id, branch) -> - Client_proto_rpcs.Helpers.Forge.Manager.origination cctxt block + Alpha_services.Forge.Manager.origination cctxt block ~branch ~source ~sourcePubKey:src_pk ~managerPubKey:manager ~counter ~balance ~spendable:spendable ~delegatable ?delegatePubKey:delegate diff --git a/src/proto_alpha/lib_client/client_proto_contracts.ml b/src/proto_alpha/lib_client/client_proto_contracts.ml index f94ea4a5f..2bf2021c8 100644 --- a/src/proto_alpha/lib_client/client_proto_contracts.ml +++ b/src/proto_alpha/lib_client/client_proto_contracts.ml @@ -132,18 +132,18 @@ let list_contracts cctxt = let get_manager cctxt block source = match Contract.is_default source with | Some hash -> return hash - | None -> Client_proto_rpcs.Context.Contract.manager cctxt block source + | None -> Alpha_services.Contract.manager cctxt block source let get_delegate cctxt block source = match Contract.is_default source with | Some hash -> return hash | None -> - Client_proto_rpcs.Context.Contract.delegate cctxt + Alpha_services.Contract.delegate_opt cctxt block source >>=? function | Some delegate -> return delegate | None -> - Client_proto_rpcs.Context.Contract.manager cctxt block source + Alpha_services.Contract.manager cctxt block source let may_check_key sourcePubKey sourcePubKeyHash = match sourcePubKey with @@ -156,7 +156,7 @@ let may_check_key sourcePubKey sourcePubKeyHash = return () let check_public_key cctxt block ?src_pk src_pk_hash = - Client_proto_rpcs.Context.Key.get cctxt block src_pk_hash >>= function + Alpha_services.Delegate.Key.get cctxt block src_pk_hash >>= function | Error errors -> begin match src_pk with diff --git a/src/proto_alpha/lib_client/client_proto_programs.ml b/src/proto_alpha/lib_client/client_proto_programs.ml index e98303857..83d556f34 100644 --- a/src/proto_alpha/lib_client/client_proto_programs.ml +++ b/src/proto_alpha/lib_client/client_proto_programs.ml @@ -93,7 +93,7 @@ let run ~(input : Michelson_v1_parser.parsed) block (cctxt : #RPC_context.simple) = - Client_proto_rpcs.Helpers.run_code cctxt + Alpha_services.Helpers.run_code cctxt block program.expanded (storage.expanded, input.expanded, amount) let trace @@ -103,11 +103,11 @@ let trace ~(input : Michelson_v1_parser.parsed) block (cctxt : #RPC_context.simple) = - Client_proto_rpcs.Helpers.trace_code cctxt + Alpha_services.Helpers.trace_code cctxt block program.expanded (storage.expanded, input.expanded, amount) let hash_and_sign (data : Michelson_v1_parser.parsed) (typ : Michelson_v1_parser.parsed) sk block cctxt = - Client_proto_rpcs.Helpers.hash_data cctxt block (data.expanded, typ.expanded) >>=? fun hash -> + Alpha_services.Helpers.hash_data cctxt block (data.expanded, typ.expanded) >>=? fun hash -> Client_keys.sign sk (MBytes.of_string hash) >>=? fun signature -> return (hash, signature |> @@ -119,10 +119,10 @@ let typecheck_data ~(data : Michelson_v1_parser.parsed) ~(ty : Michelson_v1_parser.parsed) block cctxt = - Client_proto_rpcs.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded) + Alpha_services.Helpers.typecheck_data cctxt block (data.expanded, ty.expanded) let typecheck_program (program : Michelson_v1_parser.parsed) block cctxt = - Client_proto_rpcs.Helpers.typecheck_code cctxt block program.expanded + Alpha_services.Helpers.typecheck_code cctxt block program.expanded let print_typecheck_result ~emacs ~show_types ~print_source_on_error diff --git a/src/proto_alpha/lib_client/client_proto_programs_commands.ml b/src/proto_alpha/lib_client/client_proto_programs_commands.ml index 6d02980f5..99c6c585e 100644 --- a/src/proto_alpha/lib_client/client_proto_programs_commands.ml +++ b/src/proto_alpha/lib_client/client_proto_programs_commands.ml @@ -7,6 +7,8 @@ (* *) (**************************************************************************) +open Proto_alpha + let group = { Cli_entries.name = "programs" ; title = "Commands for managing the library of known programs" } @@ -153,7 +155,7 @@ let commands () = data_parameter @@ stop) (fun () data typ cctxt -> - Client_proto_rpcs.Helpers.hash_data cctxt + Alpha_services.Helpers.hash_data cctxt cctxt#block (data.expanded, typ.expanded) >>= function | Ok hash -> cctxt#message "%S" hash >>= fun () -> diff --git a/src/proto_alpha/lib_client/client_proto_rpcs.ml b/src/proto_alpha/lib_client/client_proto_rpcs.ml deleted file mode 100644 index 34feeee68..000000000 --- a/src/proto_alpha/lib_client/client_proto_rpcs.ml +++ /dev/null @@ -1,283 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Proto_alpha -open Alpha_context - -let make_call1 cctxt s= - RPC_context.make_call1 (s (Block_services.S.proto_path ())) cctxt -let make_call2 cctxt s = - RPC_context.make_call2 (s (Block_services.S.proto_path ())) cctxt -let make_call3 cctxt s = - RPC_context.make_call3 (s (Block_services.S.proto_path ())) cctxt - -let make_opt_call2 cctxt s block a1 q i = - make_call2 cctxt s block a1 q i >>= function - | Ok v -> return (Some v) - | Error [RPC_context.Not_found _] -> return None - | Error _ as err -> Lwt.return err - -type block = Block_services.block - -let header cctxt block = - make_call1 cctxt Services.header block () () - -module Header = struct - let priority cctxt block = - make_call1 cctxt Services.Header.priority block () () - let seed_nonce_hash cctxt block = - make_call1 cctxt Services.Header.seed_nonce_hash block () () -end - -module Constants = struct - let errors cctxt block = - make_call1 cctxt Services.Constants.errors block () () - let cycle_length cctxt block = - make_call1 cctxt Services.Constants.cycle_length block () () - let voting_period_length cctxt block = - make_call1 cctxt Services.Constants.voting_period_length block () () - let time_before_reward cctxt block = - make_call1 cctxt Services.Constants.time_before_reward block () () - let slot_durations cctxt block = - make_call1 cctxt Services.Constants.slot_durations block () () - let first_free_baking_slot cctxt block = - make_call1 cctxt Services.Constants.first_free_baking_slot block () () - let max_signing_slot cctxt block = - make_call1 cctxt Services.Constants.max_signing_slot block () () - let instructions_per_transaction cctxt block = - make_call1 cctxt Services.Constants.max_gas block () () - let stamp_threshold cctxt block = - make_call1 cctxt Services.Constants.proof_of_work_threshold block () () -end - -module Context = struct - - let level cctxt block = - make_call1 cctxt Services.Context.level block () () - - let next_level cctxt block = - make_call1 cctxt Services.Context.next_level block () () - - let voting_period_kind cctxt block = - make_call1 cctxt Services.Context.voting_period_kind block () () - - module Nonce = struct - - type nonce_info = Services.Context.Nonce.nonce_info = - | Revealed of Nonce.t - | Missing of Nonce_hash.t - | Forgotten - - let get cctxt block level = - make_call2 cctxt Services.Context.Nonce.get block level () () - - let hash cctxt block = - make_call1 cctxt Services.Context.Nonce.hash block () () - - end - - module Key = struct - - let get cctxt block pk_h = - make_call2 cctxt Services.Context.Key.get block pk_h () () - - let list cctxt block = - make_call1 cctxt Services.Context.Key.list block () () - - end - - module Contract = struct - let list cctxt b = - make_call1 cctxt Services.Context.Contract.list b () () - type info = Services.Context.Contract.info = { - manager: public_key_hash ; - balance: Tez.t ; - spendable: bool ; - delegate: bool * public_key_hash option ; - script: Script.t option ; - counter: int32 ; - } - let get cctxt b c = - make_call2 cctxt Services.Context.Contract.get b c () () - let balance cctxt b c = - make_call2 cctxt Services.Context.Contract.balance b c () () - let manager cctxt b c = - make_call2 cctxt Services.Context.Contract.manager b c () () - let delegate cctxt b c = - make_opt_call2 cctxt Services.Context.Contract.delegate b c () () - let counter cctxt b c = - make_call2 cctxt Services.Context.Contract.counter b c () () - let spendable cctxt b c = - make_call2 cctxt Services.Context.Contract.spendable b c () () - let delegatable cctxt b c = - make_call2 cctxt Services.Context.Contract.delegatable b c () () - let script cctxt b c = - make_opt_call2 cctxt Services.Context.Contract.script b c () () - let storage cctxt b c = - make_opt_call2 cctxt Services.Context.Contract.storage b c () () - end - -end - -module Helpers = struct - - let minimal_time cctxt block ?prio () = - make_call1 cctxt Services.Helpers.minimal_timestamp block () prio - - let typecheck_code cctxt block = - make_call1 cctxt Services.Helpers.typecheck_code block () - - let apply_operation cctxt block pred_block hash forged_operation signature = - make_call1 cctxt Services.Helpers.apply_operation - block () (pred_block, hash, forged_operation, signature) - - let run_code cctxt block code (storage, input, amount) = - make_call1 cctxt Services.Helpers.run_code - block () (code, storage, input, amount, None, None) - - let trace_code cctxt block code (storage, input, amount) = - make_call1 cctxt Services.Helpers.trace_code - block () (code, storage, input, amount, None, None) - - let typecheck_data cctxt block = - make_call1 cctxt Services.Helpers.typecheck_data block () - - let hash_data cctxt block = - make_call1 cctxt Services.Helpers.hash_data block () - - let level cctxt block ?offset lvl = - make_call2 cctxt Services.Helpers.level block lvl () offset - - let levels cctxt block cycle = - make_call2 cctxt Services.Helpers.levels block cycle () () - - module Rights = struct - type baking_slot = Raw_level.t * int * Time.t - type endorsement_slot = Raw_level.t * int - let baking_rights_for_delegate cctxt - b c ?max_priority ?first_level ?last_level () = - make_call2 cctxt Services.Helpers.Rights.baking_rights_for_delegate - b c () (max_priority, first_level, last_level) - let endorsement_rights_for_delegate cctxt - b c ?max_priority ?first_level ?last_level () = - make_call2 cctxt Services.Helpers.Rights.endorsement_rights_for_delegate - b c () (max_priority, first_level, last_level) - end - - module Forge = struct - - module Manager = struct - let operations cctxt - block ~branch ~source ?sourcePubKey ~counter ~fee operations = - let ops = - Manager_operations { source ; public_key = sourcePubKey ; - counter ; operations ; fee } in - (make_call1 cctxt Services.Helpers.Forge.operations block - () ({ branch }, Sourced_operations ops)) - let transaction cctxt - block ~branch ~source ?sourcePubKey ~counter - ~amount ~destination ?parameters ~fee ()= - operations cctxt block ~branch ~source ?sourcePubKey ~counter ~fee - Alpha_context.[Transaction { amount ; parameters ; destination }] - let origination cctxt - block ~branch - ~source ?sourcePubKey ~counter - ~managerPubKey ~balance - ?(spendable = true) - ?(delegatable = true) - ?delegatePubKey ?script ~fee () = - operations cctxt block ~branch ~source ?sourcePubKey ~counter ~fee - Alpha_context.[ - Origination { manager = managerPubKey ; - delegate = delegatePubKey ; - script ; - spendable ; - delegatable ; - credit = balance } - ] - let delegation cctxt - block ~branch ~source ?sourcePubKey ~counter ~fee delegate = - operations cctxt block ~branch ~source ?sourcePubKey ~counter ~fee - Alpha_context.[Delegation delegate] - end - module Delegate = struct - let operations cctxt - block ~branch ~source operations = - let ops = Delegate_operations { source ; operations } in - (make_call1 cctxt Services.Helpers.Forge.operations block - () ({ branch }, Sourced_operations ops)) - let endorsement cctxt - b ~branch ~source ~block ~slot () = - operations cctxt b ~branch ~source - Alpha_context.[Endorsement { block ; slot }] - let proposals cctxt - b ~branch ~source ~period ~proposals () = - operations cctxt b ~branch ~source - Alpha_context.[Proposals { period ; proposals }] - let ballot cctxt - b ~branch ~source ~period ~proposal ~ballot () = - operations cctxt b ~branch ~source - Alpha_context.[Ballot { period ; proposal ; ballot }] - end - module Dictator = struct - let operation cctxt - block ~branch operation = - let op = Dictator_operation operation in - (make_call1 cctxt Services.Helpers.Forge.operations block - () ({ branch }, Sourced_operations op)) - let activate cctxt - b ~branch hash = - operation cctxt b ~branch (Activate hash) - let activate_testnet cctxt - b ~branch hash = - operation cctxt b ~branch (Activate_testnet hash) - end - module Anonymous = struct - let operations cctxt block ~branch operations = - (make_call1 cctxt Services.Helpers.Forge.operations block - () ({ branch }, Anonymous_operations operations)) - let seed_nonce_revelation cctxt - block ~branch ~level ~nonce () = - operations cctxt block ~branch [Seed_nonce_revelation { level ; nonce }] - let faucet cctxt - block ~branch ~id () = - let nonce = Rand.generate 16 in - operations cctxt block ~branch [Faucet { id ; nonce }] - end - let empty_proof_of_work_nonce = - MBytes.of_string - (String.make Constants_repr.proof_of_work_nonce_size '\000') - let block_proto_header cctxt - block - ~priority ~seed_nonce_hash - ?(proof_of_work_nonce = empty_proof_of_work_nonce) () = - make_call1 cctxt Services.Helpers.Forge.block_proto_header - block () (priority, seed_nonce_hash, proof_of_work_nonce) - end - - module Parse = struct - let operations cctxt block ?check operations = - make_call1 cctxt - Services.Helpers.Parse.operations block () (operations, check) - let block cctxt block shell proto = - make_call1 cctxt - Services.Helpers.Parse.block block - () ({ shell ; proto } : Block_header.raw) - end - -end -(* type slot = *) -(* raw_level * int * timestamp option *) -(* let baking_possibilities *) -(* b c ?max_priority ?first_level ?last_level () = *) -(* make_call2 Services.Helpers.Context.Contract.baking_possibilities *) -(* b c (max_priority, first_level, last_level) *) -(* (\* let endorsement_possibilities b c ?max_priority ?first_level ?last_level () = *\) *) -(* make_call2 Services.Helpers.Context.Contract.endorsement_possibilities *) -(* b c (max_priority, first_level, last_level) *) diff --git a/src/proto_alpha/lib_client/client_proto_rpcs.mli b/src/proto_alpha/lib_client/client_proto_rpcs.mli deleted file mode 100644 index ef26c1e0a..000000000 --- a/src/proto_alpha/lib_client/client_proto_rpcs.mli +++ /dev/null @@ -1,346 +0,0 @@ -(**************************************************************************) -(* *) -(* Copyright (c) 2014 - 2018. *) -(* Dynamic Ledger Solutions, Inc. *) -(* *) -(* All rights reserved. No warranty, explicit or implicit, provided. *) -(* *) -(**************************************************************************) - -open Proto_alpha -open Alpha_context - -type block = Block_services.block - -val header: - #RPC_context.simple -> block -> Block_header.t tzresult Lwt.t - -module Header : sig - val priority: - #RPC_context.simple -> block -> int tzresult Lwt.t - val seed_nonce_hash: - #RPC_context.simple -> block -> Nonce_hash.t tzresult Lwt.t -end - -module Constants : sig - val errors: - #RPC_context.simple -> - block -> Json_schema.schema tzresult Lwt.t - val cycle_length: - #RPC_context.simple -> - block -> int32 tzresult Lwt.t - val voting_period_length: - #RPC_context.simple -> - block -> int32 tzresult Lwt.t - val time_before_reward: - #RPC_context.simple -> - block -> Period.t tzresult Lwt.t - val slot_durations: - #RPC_context.simple -> - block -> (Period.t list) tzresult Lwt.t - val first_free_baking_slot: - #RPC_context.simple -> - block -> int tzresult Lwt.t - val max_signing_slot: - #RPC_context.simple -> - block -> int tzresult Lwt.t - val instructions_per_transaction: - #RPC_context.simple -> - block -> int tzresult Lwt.t - val stamp_threshold: - #RPC_context.simple -> - block -> int64 tzresult Lwt.t -end - -module Context : sig - val level: - #RPC_context.simple -> - block -> Level.t tzresult Lwt.t - (** [level cctxt blk] returns the (protocol view of the) level of - [blk]. *) - - val next_level: - #RPC_context.simple -> - block -> Level.t tzresult Lwt.t - (** [next_level cctxt blk] returns the (protocol view of the) level - of the successor of [blk]. *) - - val voting_period_kind: - #RPC_context.simple -> - block -> Voting_period.kind tzresult Lwt.t - (** [voting_period_kind cctxt blk] returns the voting period kind - of [blk]. *) - - module Nonce : sig - val hash: - #RPC_context.simple -> - block -> Nonce_hash.t tzresult Lwt.t - type nonce_info = - | Revealed of Nonce.t - | Missing of Nonce_hash.t - | Forgotten - val get: - #RPC_context.simple -> - block -> Raw_level.t -> nonce_info tzresult Lwt.t - end - module Key : sig - val get : - #RPC_context.simple -> - block -> - public_key_hash -> (public_key_hash * public_key) tzresult Lwt.t - val list : - #RPC_context.simple -> - block -> - ((public_key_hash * public_key) list) tzresult Lwt.t - end - module Contract : sig - val list: - #RPC_context.simple -> - block -> Contract.t list tzresult Lwt.t - type info = { - manager: public_key_hash ; - balance: Tez.t ; - spendable: bool ; - delegate: bool * public_key_hash option ; - script: Script.t option ; - counter: int32 ; - } - val get: - #RPC_context.simple -> - block -> Contract.t -> info tzresult Lwt.t - val balance: - #RPC_context.simple -> - block -> Contract.t -> - Tez.t tzresult Lwt.t - val manager: - #RPC_context.simple -> - block -> Contract.t -> - public_key_hash tzresult Lwt.t - val delegate: - #RPC_context.simple -> - block -> Contract.t -> - public_key_hash option tzresult Lwt.t - val counter: - #RPC_context.simple -> - block -> Contract.t -> - int32 tzresult Lwt.t - val spendable: - #RPC_context.simple -> - block -> Contract.t -> - bool tzresult Lwt.t - val delegatable: - #RPC_context.simple -> - block -> Contract.t -> - bool tzresult Lwt.t - val script: - #RPC_context.simple -> - block -> Contract.t -> Script.t option tzresult Lwt.t - val storage: - #RPC_context.simple -> - block -> Contract.t -> Script.expr option tzresult Lwt.t - end -end - -module Helpers : sig - val minimal_time: - #RPC_context.simple -> - block -> ?prio:int -> unit -> Time.t tzresult Lwt.t - (** [minimal_time cctxt blk ?prio ()] is the minimal acceptable - timestamp for the successor of [blk]. [?prio] defaults to - [0]. *) - - val apply_operation: - #RPC_context.simple -> - block -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Ed25519.Signature.t option -> - (Contract.t list) tzresult Lwt.t - val run_code: - #RPC_context.simple -> - block -> Script.expr -> - (Script.expr * Script.expr * Tez.t) -> - (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) tzresult Lwt.t - val trace_code: - #RPC_context.simple -> - block -> Script.expr -> - (Script.expr * Script.expr * Tez.t) -> - (Script.expr * Script.expr * - (Script.location * Gas.t * Script.expr list) list * - (Script.expr * Script.expr option) list option) tzresult Lwt.t - val typecheck_code: - #RPC_context.simple -> - block -> Script.expr -> Script_tc_errors.type_map tzresult Lwt.t - val typecheck_data: - #RPC_context.simple -> - block -> Script.expr * Script.expr -> unit tzresult Lwt.t - val hash_data: - #RPC_context.simple -> - block -> Script.expr * Script.expr -> string tzresult Lwt.t - val level: - #RPC_context.simple -> - block -> ?offset:int32 -> Raw_level.t -> Level.t tzresult Lwt.t - val levels: - #RPC_context.simple -> - block -> Cycle.t -> (Raw_level.t * Raw_level.t) tzresult Lwt.t - - module Rights : sig - type baking_slot = Raw_level.t * int * Time.t - type endorsement_slot = Raw_level.t * int - val baking_rights_for_delegate: - #RPC_context.simple -> - block -> public_key_hash -> - ?max_priority:int -> ?first_level:Raw_level.t -> - ?last_level:Raw_level.t -> unit -> - (baking_slot list) tzresult Lwt.t - val endorsement_rights_for_delegate: - #RPC_context.simple -> - block -> public_key_hash -> - ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> unit -> - (endorsement_slot list) tzresult Lwt.t - end - - module Forge : sig - module Manager : sig - val operations: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:Contract.t -> - ?sourcePubKey:public_key -> - counter:int32 -> - fee:Tez.t -> - manager_operation list -> - MBytes.t tzresult Lwt.t - val transaction: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:Contract.t -> - ?sourcePubKey:public_key -> - counter:int32 -> - amount:Tez.t -> - destination:Contract.t -> - ?parameters:Script.expr -> - fee:Tez.t -> - unit -> MBytes.t tzresult Lwt.t - val origination: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:Contract.t -> - ?sourcePubKey:public_key -> - counter:int32 -> - managerPubKey:public_key_hash -> - balance:Tez.t -> - ?spendable:bool -> - ?delegatable:bool -> - ?delegatePubKey: public_key_hash -> - ?script:Script.t -> - fee:Tez.t-> - unit -> - MBytes.t tzresult Lwt.t - val delegation: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:Contract.t -> - ?sourcePubKey:public_key -> - counter:int32 -> - fee:Tez.t -> - public_key_hash option -> - MBytes.t tzresult Lwt.t - end - module Dictator : sig - val operation: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - dictator_operation -> - MBytes.t tzresult Lwt.t - val activate: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - Protocol_hash.t -> - MBytes.t tzresult Lwt.t - val activate_testnet: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - Protocol_hash.t -> - MBytes.t tzresult Lwt.t - end - module Delegate : sig - val operations: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:public_key -> - delegate_operation list -> - MBytes.t tzresult Lwt.t - val endorsement: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:public_key -> - block:Block_hash.t -> - slot:int -> - unit -> MBytes.t tzresult Lwt.t - val proposals: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:public_key -> - period:Voting_period.t -> - proposals:Protocol_hash.t list -> - unit -> MBytes.t tzresult Lwt.t - val ballot: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - source:public_key -> - period:Voting_period.t -> - proposal:Protocol_hash.t -> - ballot:Vote.ballot -> - unit -> MBytes.t tzresult Lwt.t - end - module Anonymous : sig - val operations: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - anonymous_operation list -> - MBytes.t tzresult Lwt.t - val seed_nonce_revelation: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - level:Raw_level.t -> - nonce:Nonce.t -> - unit -> MBytes.t tzresult Lwt.t - val faucet: - #RPC_context.simple -> - block -> - branch:Block_hash.t -> - id:public_key_hash -> - unit -> MBytes.t tzresult Lwt.t - end - val block_proto_header: - #RPC_context.simple -> - block -> - priority: int -> - seed_nonce_hash: Nonce_hash.t -> - ?proof_of_work_nonce: MBytes.t -> - unit -> MBytes.t tzresult Lwt.t - end - - module Parse : sig - val operations: - #RPC_context.simple -> - block -> ?check:bool -> Operation.raw list -> - Operation.t list tzresult Lwt.t - val block: - #RPC_context.simple -> - block -> Block_header.shell_header -> MBytes.t -> - Block_header.proto_header tzresult Lwt.t - end - -end diff --git a/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml b/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml index 89f6abc37..bc8e64057 100644 --- a/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml +++ b/src/proto_alpha/lib_client/test/proto_alpha_helpers.ml @@ -28,7 +28,7 @@ let build_rpc_context config = let rpc_ctxt = ref (build_rpc_context !rpc_config) (* Context that does not write to alias files *) -let no_write_context config block : Client_commands.full_context = object +let no_write_context config block : #Client_commands.full_context = object inherit RPC_client.http_ctxt config Media_type.all_media_types inherit Client_commands.logger (fun _ _ -> Lwt.return_unit) method load : type a. string -> default:a -> a Data_encoding.encoding -> a Error_monad.tzresult Lwt.t = @@ -69,7 +69,7 @@ let init ?exe ?(sandbox = "sandbox.json") ?rpc_port () = return (pid, hash) let level block = - Client_proto_rpcs.Context.level !rpc_ctxt block + Alpha_services.Context.level !rpc_ctxt block module Account = struct @@ -225,13 +225,12 @@ module Account = struct delegate_opt let balance ?(block = `Prevalidation) (account : t) = - Client_proto_rpcs.Context.Contract.balance !rpc_ctxt + Alpha_services.Contract.balance !rpc_ctxt block account.contract (* TODO: gather contract related functions in a Contract module? *) let delegate ?(block = `Prevalidation) (contract : Contract.t) = - Client_proto_rpcs.Context.Contract.delegate !rpc_ctxt - block contract + Alpha_services.Contract.delegate_opt !rpc_ctxt block contract end @@ -240,12 +239,12 @@ module Protocol = struct open Account let voting_period_kind ?(block = `Prevalidation) () = - Client_proto_rpcs.Context.voting_period_kind !rpc_ctxt block + Alpha_services.Context.voting_period_kind !rpc_ctxt block let proposals ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) proposals = Block_services.info !rpc_ctxt block >>=? fun block_info -> - Client_proto_rpcs.Context.next_level !rpc_ctxt block >>=? fun next_level -> - Client_proto_rpcs.Helpers.Forge.Delegate.proposals !rpc_ctxt block + Alpha_services.Context.next_level !rpc_ctxt block >>=? fun next_level -> + Alpha_services.Forge.Delegate.proposals !rpc_ctxt block ~branch:block_info.hash ~source:pk ~period:next_level.voting_period @@ -256,8 +255,8 @@ module Protocol = struct let ballot ?(block = `Prevalidation) ~src:({ pk; sk } : Account.t) ~proposal ballot = Block_services.info !rpc_ctxt block >>=? fun block_info -> - Client_proto_rpcs.Context.next_level !rpc_ctxt block >>=? fun next_level -> - Client_proto_rpcs.Helpers.Forge.Delegate.ballot !rpc_ctxt block + Alpha_services.Context.next_level !rpc_ctxt block >>=? fun next_level -> + Alpha_services.Forge.Delegate.ballot !rpc_ctxt block ~branch:block_info.hash ~source:pk ~period:next_level.voting_period @@ -412,7 +411,7 @@ module Assert = struct block_proto h let check_voting_period_kind ?msg ~block kind = - Client_proto_rpcs.Context.voting_period_kind !rpc_ctxt block + Alpha_services.Context.voting_period_kind !rpc_ctxt block >>=? fun current_kind -> return @@ equal ?msg @@ -450,7 +449,7 @@ module Baking = struct () let endorsement_reward block = - Client_proto_rpcs.Header.priority !rpc_ctxt block >>=? fun prio -> + Alpha_services.priority !rpc_ctxt block >>=? fun prio -> Baking.endorsement_reward ~block_priority:prio >|= Alpha_environment.wrap_error >>|? Tez.to_mutez @@ -466,7 +465,7 @@ module Endorse = struct slot = let block = Block_services.last_baked_block block in Block_services.info !rpc_ctxt block >>=? fun { hash ; _ } -> - Client_proto_rpcs.Helpers.Forge.Delegate.endorsement !rpc_ctxt + Alpha_services.Forge.Delegate.endorsement !rpc_ctxt block ~branch:hash ~source @@ -481,9 +480,9 @@ module Endorse = struct block delegate level = - Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate + Alpha_services.Delegate.Endorser.rights_for_delegate !rpc_ctxt ~max_priority ~first_level:level ~last_level:level - block delegate () >>=? fun possibilities -> + block delegate >>=? fun possibilities -> let slots = List.map (fun (_,slot) -> slot) @@ List.filter (fun (l, _) -> l = level) possibilities in @@ -493,7 +492,7 @@ module Endorse = struct ?slot (contract : Account.t) block = - Client_proto_rpcs.Context.next_level !rpc_ctxt block >>=? fun { level } -> + Alpha_services.Context.next_level !rpc_ctxt block >>=? fun { level } -> begin match slot with | Some slot -> return slot @@ -511,16 +510,16 @@ module Endorse = struct (* FIXME @vb: I don't understand this function, copied from @cago. *) let endorsers_list block = let get_endorser_list result (account : Account.t) level block = - Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate + Alpha_services.Delegate.Endorser.rights_for_delegate !rpc_ctxt block account.pkh ~max_priority:16 ~first_level:level - ~last_level:level () >>|? fun slots -> + ~last_level:level >>|? fun slots -> List.iter (fun (_,slot) -> result.(slot) <- account) slots in let { Account.b1 ; b2 ; b3 ; b4 ; b5 } = Account.bootstrap_accounts in let result = Array.make 16 b1 in - Client_proto_rpcs.Context.level !rpc_ctxt block >>=? fun level -> + Alpha_services.Context.level !rpc_ctxt block >>=? fun level -> let level = Raw_level.succ @@ level.level in get_endorser_list result b1 level block >>=? fun () -> get_endorser_list result b2 level block >>=? fun () -> @@ -532,19 +531,19 @@ module Endorse = struct let endorsement_rights ?(max_priority = 1024) (contract : Account.t) block = - Client_proto_rpcs.Context.level !rpc_ctxt block >>=? fun level -> + Alpha_services.Context.level !rpc_ctxt block >>=? fun level -> let delegate = contract.pkh in let level = level.level in - Client_proto_rpcs.Helpers.Rights.endorsement_rights_for_delegate + Alpha_services.Delegate.Endorser.rights_for_delegate !rpc_ctxt ~max_priority ~first_level:level ~last_level:level - block delegate () + block delegate end let display_level block = - Client_proto_rpcs.Context.level !rpc_ctxt block >>=? fun lvl -> + Alpha_services.Context.level !rpc_ctxt block >>=? fun lvl -> Format.eprintf "Level: %a@." Level.pp_full lvl ; return () diff --git a/src/proto_alpha/lib_client/test/proto_alpha_helpers.mli b/src/proto_alpha/lib_client/test/proto_alpha_helpers.mli index 574060910..47d265c88 100644 --- a/src/proto_alpha/lib_client/test/proto_alpha_helpers.mli +++ b/src/proto_alpha/lib_client/test/proto_alpha_helpers.mli @@ -123,7 +123,7 @@ module Endorse : sig ?max_priority:int -> Account.t -> Block_services.block -> - Client_proto_rpcs.Helpers.Rights.endorsement_slot list tzresult Lwt.t + (Raw_level.t * int) list tzresult Lwt.t end diff --git a/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL b/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL index 32e82d17b..551593e00 100644 --- a/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL +++ b/src/proto_alpha/lib_protocol/src/TEZOS_PROTOCOL @@ -59,8 +59,12 @@ "Amendment", "Apply", - "Services", "Services_registration", + "Constants_services", + "Contract_services", + "Delegate_services", + "Helpers_services", + "Alpha_services", "Main" ] diff --git a/src/proto_alpha/lib_protocol/src/alpha_services.ml b/src/proto_alpha/lib_protocol/src/alpha_services.ml new file mode 100644 index 000000000..0d4962df0 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/alpha_services.ml @@ -0,0 +1,249 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +let custom_root = RPC_path.open_root + +module S = struct + + open Data_encoding + + let operations = + RPC_service.post_service + ~description: "All the operations of the block (fully decoded)." + ~query: RPC_query.empty + ~input: empty + ~output: (list (list (dynamic_size Operation.encoding))) + RPC_path.(custom_root / "operations") + + let header = + RPC_service.post_service + ~description: "The header of the block (fully decoded)." + ~query: RPC_query.empty + ~input: empty + ~output: Block_header.encoding + RPC_path.(custom_root / "header") + + let priority = + RPC_service.post_service + ~description: "Baking priority of the block." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "priority" uint16)) + RPC_path.(custom_root / "header" / "priority") + + let seed_nonce_hash = + RPC_service.post_service + ~description: "Hash of the seed nonce of the block." + ~query: RPC_query.empty + ~input: empty + ~output: Nonce_hash.encoding + RPC_path.(custom_root / "header" / "seed_nonce_hash") + +end + +let () = + let open Services_registration in + register0_fullctxt S.operations begin fun ctxt () () -> + ctxt.operation_hashes () >>= fun operation_hashes -> + ctxt.operations () >>= fun operations -> + map2_s + (map2_s (fun x y -> Lwt.return (Operation.parse x y))) + operation_hashes operations + end ; + register0_fullctxt S.header begin fun { block_header ; _ } () () -> + Lwt.return (Block_header.parse block_header) >>=? fun block_header -> + return block_header + end ; + register0_fullctxt S.priority begin fun { block_header ; _ } () () -> + Lwt.return (Block_header.parse block_header) >>=? fun block_header -> + return block_header.proto.priority + end ; + register0_fullctxt S.seed_nonce_hash begin fun { block_header ; _ } () ( )-> + Lwt.return (Block_header.parse block_header) >>=? fun block_header -> + return block_header.proto.seed_nonce_hash + end + +let operations ctxt block = + RPC_context.make_call0 S.operations ctxt block () () +let header ctxt block = + RPC_context.make_call0 S.header ctxt block () () +let priority ctxt block = + RPC_context.make_call0 S.priority ctxt block () () +let seed_nonce_hash ctxt block = + RPC_context.make_call0 S.seed_nonce_hash ctxt block () () + +module Context = struct + + module S = struct + + open Data_encoding + + let level = + RPC_service.post_service + ~description: "Detailled level information for the current block" + ~query: RPC_query.empty + ~input: empty + ~output: Level.encoding + RPC_path.(custom_root / "context" / "level") + + let next_level = + RPC_service.post_service + ~description: "Detailled level information for the next block" + ~query: RPC_query.empty + ~input: empty + ~output: Level.encoding + RPC_path.(custom_root / "context" / "next_level") + + let roll_value = + RPC_service.post_service + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "roll_value" Tez.encoding)) + RPC_path.(custom_root / "context" / "roll_value") + + let next_roll = + RPC_service.post_service + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "next_roll" int32)) + RPC_path.(custom_root / "context" / "next_roll") + + let voting_period_kind = + RPC_service.post_service + ~description: "Voting period kind for the current block" + ~query: RPC_query.empty + ~input: empty + ~output: + (obj1 (req "voting_period_kind" Voting_period.kind_encoding)) + RPC_path.(custom_root / "context" / "voting_period_kind") + + end + + type error += Unexpected_level_in_context + + let () = + let open Services_registration in + register0 S.level begin fun ctxt () () -> + let level = Level.current ctxt in + match Level.pred ctxt level with + | None -> fail Unexpected_level_in_context + | Some level -> return level + end ; + register0 S.next_level begin fun ctxt () () -> + return (Level.current ctxt) + end ; + register0 S.roll_value begin fun ctxt () () -> + return (Roll.value ctxt) + end; + register0 S.next_roll begin fun ctxt () () -> + Roll.next ctxt + end ; + register0 S.voting_period_kind begin fun ctxt () () -> + Vote.get_current_period_kind ctxt + end + + let level ctxt block = + RPC_context.make_call0 S.level ctxt block () () + + let next_level ctxt block = + RPC_context.make_call0 S.next_level ctxt block () () + + let roll_value ctxt block = + RPC_context.make_call0 S.roll_value ctxt block () () + + let next_roll ctxt block = + RPC_context.make_call0 S.next_roll ctxt block () () + + let voting_period_kind ctxt block = + RPC_context.make_call0 S.voting_period_kind ctxt block () () + +end + +module Nonce = struct + + type info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + + let info_encoding = + let open Data_encoding in + union [ + case (Tag 0) + (obj1 (req "nonce" Nonce.encoding)) + (function Revealed nonce -> Some nonce | _ -> None) + (fun nonce -> Revealed nonce) ; + case (Tag 1) + (obj1 (req "hash" Nonce_hash.encoding)) + (function Missing nonce -> Some nonce | _ -> None) + (fun nonce -> Missing nonce) ; + case (Tag 2) + empty + (function Forgotten -> Some () | _ -> None) + (fun () -> Forgotten) ; + ] + + module S = struct + + open Data_encoding + + let get = + RPC_service.post_service + ~description: "Info about the nonce of a previous block." + ~query: RPC_query.empty + ~input: empty + ~output: info_encoding + RPC_path.(custom_root / "context" / "nonce" /: Raw_level.arg) + + let hash = + RPC_service.post_service + ~description: "Hash of the current block's nonce." + ~query: RPC_query.empty + ~input: empty + ~output: Nonce_hash.encoding + RPC_path.(custom_root / "context" / "nonce") + + end + + let () = + let open Services_registration in + register1 S.get begin fun ctxt raw_level () () -> + let level = Level.from_raw ctxt raw_level in + Nonce.get ctxt level >>= function + | Ok (Revealed nonce) -> return (Revealed nonce) + | Ok (Unrevealed { nonce_hash ; _ }) -> + return (Missing nonce_hash) + | Error _ -> return Forgotten + end ; + register0 S.hash begin fun ctxt () () -> + let level = Level.current ctxt in + match Level.pred ctxt level with + | None -> fail Context.Unexpected_level_in_context + | Some level -> + Nonce.get ctxt level >>=? function + | Unrevealed { nonce_hash ; _ } -> return nonce_hash + | _ -> assert false + end + + let get ctxt block level = + RPC_context.make_call1 S.get ctxt block level () () + + let hash ctxt block = + RPC_context.make_call0 S.hash ctxt block () () + +end + +module Contract = Contract_services +module Constants = Constants_services +module Delegate = Delegate_services +module Helpers = Helpers_services +module Forge = Helpers_services.Forge +module Parse = Helpers_services.Parse diff --git a/src/proto_alpha/lib_protocol/src/alpha_services.mli b/src/proto_alpha/lib_protocol/src/alpha_services.mli new file mode 100644 index 000000000..6ebd619c0 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/alpha_services.mli @@ -0,0 +1,68 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +val operations: + 'a #RPC_context.simple -> 'a -> Operation.t list list shell_tzresult Lwt.t +val header: + 'a #RPC_context.simple -> 'a -> Block_header.t shell_tzresult Lwt.t +val priority: + 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t +val seed_nonce_hash: + 'a #RPC_context.simple -> 'a -> Nonce_hash.t shell_tzresult Lwt.t + +module Context : sig + + val level: + 'a #RPC_context.simple -> 'a -> Level.t shell_tzresult Lwt.t + (** [level cctxt blk] returns the (protocol view of the) level of + [blk]. *) + + val next_level: + 'a #RPC_context.simple -> 'a -> Level.t shell_tzresult Lwt.t + (** [next_level cctxt blk] returns the (protocol view of the) level + of the successor of [blk]. *) + + val next_roll: + 'a #RPC_context.simple -> 'a -> int32 shell_tzresult Lwt.t + + val roll_value: + 'a #RPC_context.simple -> 'a -> Tez.t shell_tzresult Lwt.t + + val voting_period_kind: + 'a #RPC_context.simple -> 'a -> Voting_period.kind shell_tzresult Lwt.t + (** [voting_period_kind cctxt blk] returns the voting period kind + of [blk]. *) + +end + +module Nonce : sig + + val hash: + 'a #RPC_context.simple -> + 'a -> Nonce_hash.t shell_tzresult Lwt.t + + type info = + | Revealed of Nonce.t + | Missing of Nonce_hash.t + | Forgotten + + val get: + 'a #RPC_context.simple -> + 'a -> Raw_level.t -> info shell_tzresult Lwt.t + +end + +module Contract = Contract_services +module Constants = Constants_services +module Delegate = Delegate_services +module Helpers = Helpers_services +module Forge = Helpers_services.Forge +module Parse = Helpers_services.Parse diff --git a/src/proto_alpha/lib_protocol/src/constants_services.ml b/src/proto_alpha/lib_protocol/src/constants_services.ml new file mode 100644 index 000000000..0c0a2f463 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/constants_services.ml @@ -0,0 +1,141 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +let custom_root = + (RPC_path.(open_root / "constants") : RPC_context.t RPC_path.context) + +module S = struct + + open Data_encoding + + let cycle_length = + RPC_service.post_service + ~description: "Cycle length" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "cycle_length" int32)) + RPC_path.(custom_root / "cycle_length") + + let voting_period_length = + RPC_service.post_service + ~description: "Length of the voting period" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "voting_period_length" int32)) + RPC_path.(custom_root / "voting_period_length") + + let time_before_reward = + RPC_service.post_service + ~description: "Time before reward" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "time_before_reward" Period.encoding)) + RPC_path.(custom_root / "time_before_reward") + + let slot_durations = + RPC_service.post_service + ~description: "Slot durations" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "time_between_slots" (list Period.encoding))) + RPC_path.(custom_root / "time_between_slots") + + let first_free_baking_slot = + RPC_service.post_service + ~description: "First free baking slot" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "first_free_baking_slot" uint16)) + RPC_path.(custom_root / "first_free_baking_slot") + + let max_signing_slot = + RPC_service.post_service + ~description: "Max signing slot" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "max_signing_slot" uint16)) + RPC_path.(custom_root / "max_signing_slot") + + let max_gas = + RPC_service.post_service + ~description: "Instructions per transaction" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "instructions_per_transaction" int31)) + RPC_path.(custom_root / "max_gas") + + let proof_of_work_threshold = + RPC_service.post_service + ~description: "Stamp threshold" + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "proof_of_work_threshold" int64)) + RPC_path.(custom_root / "proof_of_work_threshold") + + let errors = + RPC_service.post_service + ~description: "Schema for all the RPC errors from this protocol version" + ~query: RPC_query.empty + ~input: empty + ~output: json_schema + RPC_path.(custom_root / "errors") + +end + + +let () = + let open Services_registration in + register0 S.cycle_length begin fun ctxt () () -> + return (Constants.cycle_length ctxt) + end ; + register0 S.voting_period_length begin fun ctxt () () -> + return (Constants.voting_period_length ctxt) + end ; + register0 S.time_before_reward begin fun ctxt () () -> + return (Constants.time_before_reward ctxt) + end ; + register0 S.slot_durations begin fun ctxt () () -> + return (Constants.slot_durations ctxt) + end ; + register0 S.first_free_baking_slot begin fun ctxt () () -> + return (Constants.first_free_baking_slot ctxt) + end ; + register0 S.max_signing_slot begin fun ctxt () () -> + return (Constants.max_signing_slot ctxt) + end ; + register0 S.max_gas begin fun ctxt () () -> + return (Constants.max_gas ctxt) + end ; + register0 S.proof_of_work_threshold begin fun ctxt () () -> + return (Constants.proof_of_work_threshold ctxt) + end ; + register0_noctxt S.errors begin fun () () -> + return (Data_encoding.Json.(schema error_encoding)) + end + +let cycle_length ctxt block = + RPC_context.make_call0 S.cycle_length ctxt block () () +let voting_period_length ctxt block = + RPC_context.make_call0 S.voting_period_length ctxt block () () +let time_before_reward ctxt block = + RPC_context.make_call0 S.time_before_reward ctxt block () () +let slot_durations ctxt block = + RPC_context.make_call0 S.slot_durations ctxt block () () +let first_free_baking_slot ctxt block = + RPC_context.make_call0 S.first_free_baking_slot ctxt block () () +let max_signing_slot ctxt block = + RPC_context.make_call0 S.max_signing_slot ctxt block () () +let max_gas ctxt block = + RPC_context.make_call0 S.max_gas ctxt block () () +let proof_of_work_threshold ctxt block = + RPC_context.make_call0 S.proof_of_work_threshold ctxt block () () +let errors ctxt block = + RPC_context.make_call0 S.errors ctxt block () () diff --git a/src/proto_alpha/lib_protocol/src/constants_services.mli b/src/proto_alpha/lib_protocol/src/constants_services.mli new file mode 100644 index 000000000..1e19d8754 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/constants_services.mli @@ -0,0 +1,37 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +val cycle_length: + 'a #RPC_context.simple -> 'a -> int32 shell_tzresult Lwt.t + +val voting_period_length: + 'a #RPC_context.simple -> 'a -> int32 shell_tzresult Lwt.t + +val time_before_reward: + 'a #RPC_context.simple -> 'a -> Period.t shell_tzresult Lwt.t + +val slot_durations: + 'a #RPC_context.simple -> 'a -> Period.t list shell_tzresult Lwt.t + +val first_free_baking_slot: + 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t + +val max_signing_slot: + 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t + +val max_gas: + 'a #RPC_context.simple -> 'a -> int shell_tzresult Lwt.t + +val proof_of_work_threshold: + 'a #RPC_context.simple -> 'a -> Int64.t shell_tzresult Lwt.t + +val errors: + 'a #RPC_context.simple -> 'a -> Data_encoding.json_schema shell_tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/contract_services.ml b/src/proto_alpha/lib_protocol/src/contract_services.ml new file mode 100644 index 000000000..0b18d88fa --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/contract_services.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +let custom_root = + (RPC_path.(open_root / "context" / "contracts") : RPC_context.t RPC_path.context) + +type info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + counter: int32 ; + script: Script.t option ; + storage: Script.expr option ; +} + +let info_encoding = + let open Data_encoding in + conv + (fun {manager ; balance ; spendable ; delegate ; script ; counter ; storage } -> + (manager, balance, spendable, delegate, script, storage, counter)) + (fun (manager, balance, spendable, delegate, script, storage, counter) -> + {manager ; balance ; spendable ; delegate ; script ; storage ; counter}) @@ + obj7 + (req "manager" Ed25519.Public_key_hash.encoding) + (req "balance" Tez.encoding) + (req "spendable" bool) + (req "delegate" @@ obj2 + (req "setable" bool) + (opt "value" Ed25519.Public_key_hash.encoding)) + (opt "script" Script.encoding) + (opt "storage" Script.expr_encoding) + (req "counter" int32) + +module S = struct + + open Data_encoding + + let balance = + RPC_service.post_service + ~description: "Access the balance of a contract." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "balance" Tez.encoding)) + RPC_path.(custom_root /: Contract.arg / "balance") + + let manager = + RPC_service.post_service + ~description: "Access the manager of a contract." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "manager" Ed25519.Public_key_hash.encoding)) + RPC_path.(custom_root /: Contract.arg / "manager") + + let delegate = + RPC_service.post_service + ~description: "Access the delegate of a contract, if any." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "delegate" Ed25519.Public_key_hash.encoding)) + RPC_path.(custom_root /: Contract.arg / "delegate") + + let counter = + RPC_service.post_service + ~description: "Access the counter of a contract, if any." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "counter" int32)) + RPC_path.(custom_root /: Contract.arg / "counter") + + let spendable = + RPC_service.post_service + ~description: "Tells if the contract tokens can be spent by the manager." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "spendable" bool)) + RPC_path.(custom_root /: Contract.arg / "spendable") + + let delegatable = + RPC_service.post_service + ~description: "Tells if the contract delegate can be changed." + ~query: RPC_query.empty + ~input: empty + ~output: (obj1 (req "delegatable" bool)) + RPC_path.(custom_root /: Contract.arg / "delegatable") + + let script = + RPC_service.post_service + ~description: "Access the code and data of the contract." + ~query: RPC_query.empty + ~input: empty + ~output: Script.encoding + RPC_path.(custom_root /: Contract.arg / "script") + + let storage = + RPC_service.post_service + ~description: "Access the data of the contract." + ~query: RPC_query.empty + ~input: empty + ~output: Script.expr_encoding + RPC_path.(custom_root /: Contract.arg / "storage") + + let info = + RPC_service.post_service + ~description: "Access the complete status of a contract." + ~query: RPC_query.empty + ~input: empty + ~output: info_encoding + RPC_path.(custom_root /: Contract.arg) + + let list = + RPC_service.post_service + ~description: + "All existing contracts (including non-empty default contracts)." + ~query: RPC_query.empty + ~input: empty + ~output: (list Contract.encoding) + custom_root + +end + +let () = + let open Services_registration in + register0 S.list begin fun ctxt () () -> + Contract.list ctxt >>= return + end + +let () = + let open Services_registration in + let register_field s f = + register1 s (fun ctxt contract () () -> + Contract.exists ctxt contract >>=? function + | true -> f ctxt contract + | false -> raise Not_found) in + let register_opt_field s f = + register_field s + (fun ctxt a1 -> + f ctxt a1 >>=? function + | None -> raise Not_found + | Some v -> return v) in + register_field S.balance Contract.get_balance ; + register_field S.manager Contract.get_manager ; + register_opt_field S.delegate Contract.get_delegate_opt ; + register_field S.counter Contract.get_counter ; + register_field S.spendable Contract.is_spendable ; + register_field S.delegatable Contract.is_delegatable ; + register_opt_field S.script Contract.get_script ; + register_opt_field S.storage Contract.get_storage ; + register_field S.info (fun ctxt contract -> + Contract.get_balance ctxt contract >>=? fun balance -> + Contract.get_manager ctxt contract >>=? fun manager -> + Contract.get_delegate_opt ctxt contract >>=? fun delegate -> + Contract.get_counter ctxt contract >>=? fun counter -> + Contract.is_delegatable ctxt contract >>=? fun delegatable -> + Contract.is_spendable ctxt contract >>=? fun spendable -> + Contract.get_script ctxt contract >>=? fun script -> + Contract.get_storage ctxt contract >>=? fun storage -> + return { manager ; balance ; + spendable ; delegate = (delegatable, delegate) ; + script ; counter ; storage}) + +let list ctxt block = + RPC_context.make_call0 S.list ctxt block () () + +let info ctxt block contract = + RPC_context.make_call1 S.info ctxt block contract () () + +let balance ctxt block contract = + RPC_context.make_call1 S.balance ctxt block contract () () + +let manager ctxt block contract = + RPC_context.make_call1 S.manager ctxt block contract () () + +let delegate ctxt block contract = + RPC_context.make_call1 S.delegate ctxt block contract () () + +let delegate_opt ctxt block contract = + RPC_context.make_opt_call1 S.delegate ctxt block contract () () + +let counter ctxt block contract = + RPC_context.make_call1 S.counter ctxt block contract () () + +let is_delegatable ctxt block contract = + RPC_context.make_call1 S.delegatable ctxt block contract () () + +let is_spendable ctxt block contract = + RPC_context.make_call1 S.spendable ctxt block contract () () + +let script ctxt block contract = + RPC_context.make_call1 S.script ctxt block contract () () + +let script_opt ctxt block contract = + RPC_context.make_opt_call1 S.script ctxt block contract () () + +let storage ctxt block contract = + RPC_context.make_call1 S.storage ctxt block contract () () + +let storage_opt ctxt block contract = + RPC_context.make_opt_call1 S.storage ctxt block contract () () + diff --git a/src/proto_alpha/lib_protocol/src/contract_services.mli b/src/proto_alpha/lib_protocol/src/contract_services.mli new file mode 100644 index 000000000..a5c2f8174 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/contract_services.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +val list: + 'a #RPC_context.simple -> 'a -> Contract.t list shell_tzresult Lwt.t + +type info = { + manager: public_key_hash ; + balance: Tez.t ; + spendable: bool ; + delegate: bool * public_key_hash option ; + counter: int32 ; + script: Script.t option ; + storage: Script.expr option ; +} + +val info_encoding: info Data_encoding.t + +val info: + 'a #RPC_context.simple -> 'a -> Contract.t -> info shell_tzresult Lwt.t + +val balance: + 'a #RPC_context.simple -> 'a -> Contract.t -> Tez.t shell_tzresult Lwt.t + +val manager: + 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t + +val delegate: + 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash shell_tzresult Lwt.t + +val delegate_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> public_key_hash option shell_tzresult Lwt.t + +val is_delegatable: + 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t + +val is_spendable: + 'a #RPC_context.simple -> 'a -> Contract.t -> bool shell_tzresult Lwt.t + +val counter: + 'a #RPC_context.simple -> 'a -> Contract.t -> int32 shell_tzresult Lwt.t + +val script: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t shell_tzresult Lwt.t + +val script_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.t option shell_tzresult Lwt.t + +val storage: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr shell_tzresult Lwt.t + +val storage_opt: + 'a #RPC_context.simple -> 'a -> Contract.t -> Script.expr option shell_tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/delegate_services.ml b/src/proto_alpha/lib_protocol/src/delegate_services.ml new file mode 100644 index 000000000..3533c8e3d --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/delegate_services.ml @@ -0,0 +1,375 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +let slots_range_encoding = + let open Data_encoding in + (obj3 + (opt "max_priority" int31) + (opt "first_level" Raw_level.encoding) + (opt "last_level" Raw_level.encoding)) + +module Baker = struct + + module S = struct + + open Data_encoding + + let custom_root = + RPC_path.(open_root / "helpers" / "rights" / "baking") + + let slot_encoding = + (obj3 + (req "level" Raw_level.encoding) + (req "priority" int31) + (req "timestamp" Timestamp.encoding)) + + let rights = + RPC_service.post_service + ~description: + "List delegates allowed to bake for the next level, \ + ordered by priority." + ~query: RPC_query.empty + ~input: (obj1 (opt "max_priority" int31)) + ~output: (obj2 + (req "level" Raw_level.encoding) + (req "baking_rights" + (list + (obj2 + (req "delegate" Ed25519.Public_key_hash.encoding) + (req "timestamp" Timestamp.encoding))))) + custom_root + + let rights_for_level = + RPC_service.post_service + ~description: + "List delegate allowed to bake for a given level, \ + ordered by priority." + ~query: RPC_query.empty + ~input: (obj1 (opt "max_priority" int31)) + ~output: (obj2 + (req "level" Raw_level.encoding) + (req "delegates" + (list Ed25519.Public_key_hash.encoding))) + RPC_path.(custom_root / "level" /: Raw_level.arg) + + (* let levels = *) + (* RPC_service.post_service *) + (* ~description: *) + (* "List level for which we might computed baking rights." *) + (* ~query: RPC_query.empty *) + (* ~input: empty *) + (* ~output: (obj1 (req "levels" (list Raw_level.encoding))) *) + (* RPC_path.(custom_root / "level") *) + + let rights_for_delegate = + RPC_service.post_service + ~description: "Future baking rights for a given delegate." + ~query: RPC_query.empty + ~input: slots_range_encoding + ~output: (Data_encoding.list slot_encoding) + RPC_path.(custom_root / "delegate" /: Ed25519.Public_key_hash.rpc_arg) + + (* let delegates = *) + (* RPC_service.post_service *) + (* ~description: *) + (* "List delegates with baking rights." *) + (* ~query: RPC_query.empty *) + (* ~input: empty *) + (* ~output: (obj1 (req "delegates" *) + (* (list Ed25519.Public_key_hash.encoding))) *) + (* RPC_path.(custom_root / "delegate") *) + + end + + module I = struct + + let default_max_baking_priority ctxt arg = + let default = Constants.first_free_baking_slot ctxt in + match arg with + | None -> 2 * default + | Some m -> m + + let baking_rights_for_level ctxt level max = + let max = default_max_baking_priority ctxt max in + Baking.baking_priorities ctxt level >>=? fun contract_list -> + let rec loop l n = + match n with + | 0 -> return [] + | n -> + let Misc.LCons (h, t) = l in + t () >>=? fun t -> + loop t (pred n) >>=? fun t -> + return (h :: t) + in + loop contract_list max >>=? fun prio -> + return (level.level, prio) + + let baking_rights ctxt () max = + let level = Level.current ctxt in + baking_rights_for_level ctxt level max >>=? fun (raw_level, slots) -> + begin + Lwt_list.filter_map_p (fun x -> x) @@ + List.mapi + (fun prio c -> + let timestamp = Timestamp.current ctxt in + Baking.minimal_time ctxt prio timestamp >>= function + | Error _ -> Lwt.return None + | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp))) + slots + end >>= fun timed_slots -> + return (raw_level, timed_slots) + + let baking_rights_for_delegate + ctxt contract () (max_priority, min_level, max_level) = + let max_priority = default_max_baking_priority ctxt max_priority in + let current_level = Level.current ctxt in + let min_level = match min_level with + | None -> current_level + | Some l -> Level.from_raw ctxt l in + let max_level = + match max_level with + | Some max_level -> Level.from_raw ctxt max_level + | None -> + Level.last_level_in_cycle ctxt @@ + current_level.cycle in + let rec loop level = + if Level.(>) level max_level + then return [] + else + loop (Level.succ ctxt level) >>=? fun t -> + Baking.first_baking_priorities + ctxt ~max_priority contract level >>=? fun priorities -> + let raw_level = level.level in + Error_monad.map_s + (fun priority -> + let timestamp = Timestamp.current ctxt in + Baking.minimal_time ctxt priority timestamp >>=? fun time -> + return (raw_level, priority, time)) + priorities >>=? fun priorities -> + return (priorities @ t) + in + loop min_level + + end + + let () = + let open Services_registration in + register0 S.rights I.baking_rights ; + register1 S.rights_for_level begin fun ctxt raw_level () max -> + let level = Level.from_raw ctxt raw_level in + I.baking_rights_for_level ctxt level max + end; + register1 S.rights_for_delegate I.baking_rights_for_delegate + + let rights ctxt ?max_priority block = + RPC_context.make_call0 S.rights ctxt block () max_priority + + let rights_for_level ctxt ?max_priority block level = + RPC_context.make_call1 S.rights_for_level ctxt block level () max_priority + + let rights_for_delegate ctxt ?max_priority ?first_level ?last_level block delegate = + RPC_context.make_call1 S.rights_for_delegate ctxt block delegate () + (max_priority, first_level, last_level) + +end + +module Endorser = struct + + module S = struct + + open Data_encoding + + let custom_root = + RPC_path.(open_root / "helpers" / "rights" / "endorsement") + + let slot_encoding = + (obj2 + (req "level" Raw_level.encoding) + (req "priority" int31)) + + let rights = + RPC_service.post_service + ~description: + "List delegates allowed to endorse for the current block." + ~query: RPC_query.empty + ~input: (obj1 (opt "max_priority" int31)) + ~output: (obj2 + (req "level" Raw_level.encoding) + (req "delegates" + (list Ed25519.Public_key_hash.encoding))) + custom_root + + let rights_for_level = + RPC_service.post_service + ~description: + "List delegates allowed to endorse blocks for a given level." + ~query: RPC_query.empty + ~input: (obj1 (opt "max_priority" int31)) + ~output: (obj2 + (req "level" Raw_level.encoding) + (req "delegates" + (list Ed25519.Public_key_hash.encoding))) + RPC_path.(custom_root / "level" /: Raw_level.arg) + + (* let levels = *) + (* RPC_service.post_service *) + (* ~description: *) + (* "List level for which we might computed endorsement rights." *) + (* ~query: RPC_query.empty *) + (* ~input: empty *) + (* ~output: (obj1 (req "levels" (list Raw_level.encoding))) *) + (* RPC_path.(custom_root / "level") *) + + let rights_for_delegate = + RPC_service.post_service + ~description: "Compute endorsement rights for a given delegate." + ~query: RPC_query.empty + ~input: slots_range_encoding + ~output: (Data_encoding.list slot_encoding) + RPC_path.(custom_root / "delegate" /: Ed25519.Public_key_hash.rpc_arg) + + (* let delegates = *) + (* RPC_service.post_service *) + (* ~description: *) + (* "List delegates with endorsement rights." *) + (* ~query: RPC_query.empty *) + (* ~input: empty *) + (* ~output: (obj1 (req "delegates" *) + (* (list Ed25519.Public_key_hash.encoding))) *) + (* RPC_path.(custom_root / "delegate") *) + + end + + module I = struct + + let default_max_endorsement_priority ctxt arg = + let default = Constants.max_signing_slot ctxt in + match arg with + | None -> default + | Some m -> m + + let endorsement_rights ctxt level max = + let max = default_max_endorsement_priority ctxt max in + Baking.endorsement_priorities ctxt level >>=? fun contract_list -> + let rec loop l n = + match n with + | 0 -> return [] + | n -> + let Misc.LCons (h, t) = l in + t () >>=? fun t -> + loop t (pred n) >>=? fun t -> + return (h :: t) + in + loop contract_list max >>=? fun prio -> + return (level.level, prio) + + let endorsement_rights_for_delegate + ctxt contract () (max_priority, min_level, max_level) = + let current_level = Level.current ctxt in + let max_priority = default_max_endorsement_priority ctxt max_priority in + let min_level = match min_level with + | None -> Level.succ ctxt current_level + | Some l -> Level.from_raw ctxt l in + let max_level = + match max_level with + | None -> min_level + | Some l -> Level.from_raw ctxt l in + let rec loop level = + if Level.(>) level max_level + then return [] + else + loop (Level.succ ctxt level) >>=? fun t -> + Baking.first_endorsement_slots + ctxt ~max_priority contract level >>=? fun slots -> + let raw_level = level.level in + let slots = List.rev_map (fun slot -> (raw_level, slot)) slots in + return (List.rev_append slots t) + in + loop min_level + + end + + let () = + let open Services_registration in + register0 S.rights begin fun ctxt () max -> + let level = Level.current ctxt in + I.endorsement_rights ctxt level max + end ; + register1 S.rights_for_level begin fun ctxt raw_level () max -> + let level = Level.from_raw ctxt raw_level in + I.endorsement_rights ctxt level max + end ; + register1 S.rights_for_delegate I.endorsement_rights_for_delegate + + let rights ctxt ?max_priority block = + RPC_context.make_call0 S.rights ctxt block () max_priority + + let rights_for_level ctxt ?max_priority block level = + RPC_context.make_call1 S.rights_for_level ctxt block level () max_priority + + let rights_for_delegate ctxt ?max_priority ?first_level ?last_level block delegate = + RPC_context.make_call1 S.rights_for_delegate ctxt block delegate () + (max_priority, first_level, last_level) + +end + +module Key = struct + + module S = struct + + open Data_encoding + + let custom_root = + RPC_path.(open_root / "context" / "key") + + let pk_encoding = + (obj2 + (req "hash" Ed25519.Public_key_hash.encoding) + (req "public_key" Ed25519.Public_key.encoding)) + + let list = + RPC_service.post_service + ~description: "List the known public keys" + ~query: RPC_query.empty + ~input: empty + ~output: (list pk_encoding) + custom_root + + let get = + RPC_service.post_service + ~description: "Fetch the stored public key" + ~query: RPC_query.empty + ~input: empty + ~output: pk_encoding + RPC_path.(custom_root /: Ed25519.Public_key_hash.rpc_arg ) + + end + + let () = + let open Services_registration in + register1 S.get begin fun ctxt hash () () -> + Delegates_pubkey.get ctxt hash >>=? fun pk -> + return (hash, pk) + end ; + register0 S.list begin fun ctxt () () -> + Delegates_pubkey.list ctxt >>= return + end + + let list ctxt block = + RPC_context.make_call0 S.list ctxt block () () + + let get ctxt block pkh = + RPC_context.make_call1 S.get ctxt block pkh () () + +end + +let baking_rights = Baker.I.baking_rights +let endorsement_rights = Endorser.I.endorsement_rights diff --git a/src/proto_alpha/lib_protocol/src/delegate_services.mli b/src/proto_alpha/lib_protocol/src/delegate_services.mli new file mode 100644 index 000000000..ce0a631e5 --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/delegate_services.mli @@ -0,0 +1,71 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +module Baker : sig + + val rights: + 'a #RPC_context.simple -> ?max_priority:int -> 'a -> + (Raw_level.t * (Ed25519.Public_key_hash.t * Time.t) list) shell_tzresult Lwt.t + + val rights_for_level: + 'a #RPC_context.simple -> ?max_priority:int -> 'a -> Raw_level.t -> + (Raw_level.t * Ed25519.Public_key_hash.t list) shell_tzresult Lwt.t + + val rights_for_delegate: + 'a #RPC_context.simple -> + ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> + 'a -> Ed25519.Public_key_hash.t -> + (Raw_level.t * int * Time.t) list shell_tzresult Lwt.t + +end + +module Endorser : sig + + val rights: + 'a #RPC_context.simple -> ?max_priority:int -> 'a -> + (Raw_level.t * Ed25519.Public_key_hash.t list) shell_tzresult Lwt.t + + val rights_for_level: + 'a #RPC_context.simple -> ?max_priority:int -> 'a -> Raw_level.t -> + (Raw_level.t * Ed25519.Public_key_hash.t list) shell_tzresult Lwt.t + + val rights_for_delegate: + 'a #RPC_context.simple -> + ?max_priority:int -> ?first_level:Raw_level.t -> ?last_level:Raw_level.t -> + 'a -> Ed25519.Public_key_hash.t -> + (Raw_level.t * int) list shell_tzresult Lwt.t + +end + +module Key : sig + + val list: + 'a #RPC_context.simple -> 'a -> + (Ed25519.Public_key_hash.t * Ed25519.Public_key.t) list shell_tzresult Lwt.t + + val get: + 'a #RPC_context.simple -> 'a -> + Ed25519.Public_key_hash.t -> + (Ed25519.Public_key_hash.t * Ed25519.Public_key.t) shell_tzresult Lwt.t + +end + +(* temporary export *) +val endorsement_rights: + Alpha_context.t -> + Level.t -> + int option -> (Raw_level.t * public_key_hash list) tzresult Lwt.t + +val baking_rights: + Alpha_context.t -> + unit -> + int option -> + (Raw_level.t * (public_key_hash * Time.t) list) tzresult Lwt.t diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.ml b/src/proto_alpha/lib_protocol/src/helpers_services.ml new file mode 100644 index 000000000..486dc948c --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/helpers_services.ml @@ -0,0 +1,493 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +module S = struct + + open Data_encoding + + let custom_root = RPC_path.(open_root / "helpers") + + let minimal_timestamp = + RPC_service.post_service + ~description: "Minimal timestamp for the next block." + ~query: RPC_query.empty + ~input: (obj1 (opt "priority" int31)) + ~output: (obj1 (req "timestamp" Timestamp.encoding)) + RPC_path.(custom_root / "minimal_timestamp") + + let run_code_input_encoding = + (obj6 + (req "script" Script.expr_encoding) + (req "storage" Script.expr_encoding) + (req "input" Script.expr_encoding) + (req "amount" Tez.encoding) + (opt "contract" Contract.encoding) + (opt "origination_nonce" Contract.origination_nonce_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: (obj3 + (req "storage" Script.expr_encoding) + (req "output" Script.expr_encoding) + (opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding))))) + RPC_path.(custom_root / "run_code") + + let apply_operation = + RPC_service.post_service + ~description: "Applies an operation in the current context" + ~query: RPC_query.empty + ~input: (obj4 + (req "pred_block" Block_hash.encoding) + (req "operation_hash" Operation_hash.encoding) + (req "forged_operation" bytes) + (opt "signature" Ed25519.Signature.encoding)) + ~output: (obj1 (req "contracts" (list Contract.encoding))) + RPC_path.(custom_root / "apply_operation") + + + 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 "output" Script.expr_encoding) + (req "trace" + (list @@ obj3 + (req "location" Script.location_encoding) + (req "gas" Gas.encoding) + (req "stack" (list (Script.expr_encoding))))) + (opt "big_map_diff" (list (tup2 Script.expr_encoding (option Script.expr_encoding))))) + RPC_path.(custom_root / "trace_code") + + let typecheck_code = + RPC_service.post_service + ~description: "Typecheck a piece of code in the current context" + ~query: RPC_query.empty + ~input: Script.expr_encoding + ~output: Script_tc_errors_registration.type_map_enc + RPC_path.(custom_root / "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: (obj2 + (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output: empty + RPC_path.(custom_root / "typecheck_data") + + let hash_data = + RPC_service.post_service + ~description: "Computes the hash of some data expression \ + using the same algorithm as script instruction H" + ~input: (obj2 (req "data" Script.expr_encoding) + (req "type" Script.expr_encoding)) + ~output: (obj1 (req "hash" string)) + ~query: RPC_query.empty + RPC_path.(custom_root / "hash_data") + + let level = + RPC_service.post_service + ~description: "..." + ~query: RPC_query.empty + ~input: (obj1 (opt "offset" int32)) + ~output: Level.encoding + RPC_path.(custom_root / "level" /: Raw_level.arg) + + let levels = + RPC_service.post_service + ~description: "Levels of a cycle" + ~query: RPC_query.empty + ~input: empty + ~output: (describe ~title: "levels of a cycle" + (obj2 + (req "first" Raw_level.encoding) + (req "last" Raw_level.encoding))) + RPC_path.(custom_root / "levels" /: Cycle.arg) + +end + +module I = struct + + let apply_operation ctxt () (pred_block, hash, forged_operation, signature) = + (* ctxt accept_failing_script baker_contract pred_block block_prio operation *) + match Data_encoding.Binary.of_bytes + Operation.unsigned_operation_encoding + forged_operation with + | None -> Error_monad.fail Operation.Cannot_parse_operation + | Some (shell, contents) -> + let operation = { hash ; shell ; contents ; signature } in + let level = Alpha_context.Level.current ctxt in + Baking.baking_priorities ctxt level >>=? fun (Misc.LCons (baker_pkh, _)) -> + let baker_contract = Contract.default_contract baker_pkh in + let block_prio = 0 in + Apply.apply_operation + ctxt (Some baker_contract) pred_block block_prio operation + >>=? function + | (_ctxt, _, Some script_err) -> Lwt.return (Error script_err) + | (_ctxt, contracts, None) -> Lwt.return (Ok contracts) + + + let run_parameters ctxt (script, storage, input, amount, contract, origination_nonce) = + let contract = + match contract with + | Some contract -> contract + | None -> + Contract.default_contract + (List.hd (Bootstrap.accounts ctxt)).Bootstrap.public_key_hash in + let max_gas = + Constants.max_gas ctxt in + let origination_nonce = + match origination_nonce with + | Some origination_nonce -> origination_nonce + | None -> + Contract.initial_origination_nonce + (Operation_hash.hash_string [ "FAKE " ; "FAKE" ; "FAKE" ]) in + (script, storage, input, amount, contract, max_gas, origination_nonce) + +end + +let () = + let open Services_registration in + register0 S.minimal_timestamp begin fun ctxt () slot -> + let timestamp = Alpha_context.Timestamp.current ctxt in + let slot = match slot with None -> 0 | Some p -> p in + Baking.minimal_time ctxt slot timestamp + end ; + register0 S.apply_operation I.apply_operation ; + register0 S.run_code begin fun ctxt () parameters -> + let (code, storage, input, amount, contract, gas, origination_nonce) = + I.run_parameters ctxt parameters in + Script_interpreter.execute + origination_nonce + contract (* transaction initiator *) + contract (* script owner *) + ctxt { storage ; code } amount input + (Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _, maybe_big_map_diff) -> + return (sto, ret, + Option.map maybe_big_map_diff + ~f:Script_ir_translator.to_printable_big_map) + end ; + register0 S.trace_code begin fun ctxt () parameters -> + let (code, storage, input, amount, contract, gas, origination_nonce) = + I.run_parameters ctxt parameters in + Script_interpreter.trace + origination_nonce + contract (* transaction initiator *) + contract (* script owner *) + ctxt { storage ; code } amount input + (Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _, maybe_big_map_diff), trace) -> + return (sto, ret, trace, + Option.map maybe_big_map_diff + ~f:Script_ir_translator.to_printable_big_map) + end ; + register0 S.typecheck_code begin fun ctxt () -> + Script_ir_translator.typecheck_code ctxt + end ; + register0 S.typecheck_data begin fun ctxt () -> + Script_ir_translator.typecheck_data ctxt + end ; + register0 S.hash_data begin fun ctxt () (expr, typ) -> + let open Script_ir_translator in + Lwt.return @@ parse_ty false (Micheline.root typ) >>=? fun (Ex_ty typ, _) -> + parse_data ctxt typ (Micheline.root expr) >>=? fun data -> + return (Script_ir_translator.hash_data typ data) + end ; + register1 S.level begin fun ctxt raw () offset -> + return (Level.from_raw ctxt ?offset raw) + end ; + register1 S.levels begin fun ctxt cycle () () -> + let levels = Level.levels_in_cycle ctxt cycle in + let first = List.hd (List.rev levels) in + let last = List.hd levels in + return (first.level, last.level) + end + +let minimal_time ctxt ?priority block = + RPC_context.make_call0 S.minimal_timestamp ctxt block () priority + +let run_code ctxt block code (storage, input, amount) = + RPC_context.make_call0 S.run_code ctxt + block () (code, storage, input, amount, None, None) + +let apply_operation ctxt block pred_block hash forged_operation signature = + RPC_context.make_call0 S.apply_operation ctxt + block () (pred_block, hash, forged_operation, signature) + +let trace_code ctxt block code (storage, input, amount) = + RPC_context.make_call0 S.trace_code ctxt + block () (code, storage, input, amount, None, None) + +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 hash_data ctxt block = + RPC_context.make_call0 S.hash_data ctxt block () + +let level ctxt block ?offset lvl = + RPC_context.make_call1 S.level ctxt block lvl () offset + +let levels ctxt block cycle = + RPC_context.make_call1 S.levels ctxt block cycle () () + +module Forge = struct + + module S = struct + + open Data_encoding + + let custom_root = RPC_path.(open_root / "helpers" / "forge") + + let operations = + RPC_service.post_service + ~description:"Forge an operation" + ~query: RPC_query.empty + ~input: Operation.unsigned_operation_encoding + ~output: + (obj1 + (req "operation" @@ + describe ~title: "hex encoded operation" bytes)) + RPC_path.(custom_root / "forge" / "operations" ) + + let empty_proof_of_work_nonce = + MBytes.of_string + (String.make Constants_repr.proof_of_work_nonce_size '\000') + + let block_proto_header = + RPC_service.post_service + ~description: "Forge the protocol-specific part of a block header" + ~query: RPC_query.empty + ~input: + (obj3 + (req "priority" uint16) + (req "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 "proto_header" bytes)) + RPC_path.(custom_root / "forge" / "block_proto_header") + + end + + let () = + let open Services_registration in + register0_noctxt S.operations begin fun () (shell, proto) -> + return (Operation.forge shell proto) + end ; + register0_noctxt S.block_proto_header begin fun () + (priority, seed_nonce_hash, proof_of_work_nonce) -> + return (Block_header.forge_unsigned_proto_header + { priority ; seed_nonce_hash ; proof_of_work_nonce }) + end + + module Manager = struct + + let operations ctxt + block ~branch ~source ?sourcePubKey ~counter ~fee operations = + let ops = + Manager_operations { source ; public_key = sourcePubKey ; + counter ; operations ; fee } in + (RPC_context.make_call0 S.operations ctxt block + () ({ branch }, Sourced_operations ops)) + + let transaction ctxt + block ~branch ~source ?sourcePubKey ~counter + ~amount ~destination ?parameters ~fee ()= + operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + Alpha_context.[Transaction { amount ; parameters ; destination }] + + let origination ctxt + block ~branch + ~source ?sourcePubKey ~counter + ~managerPubKey ~balance + ?(spendable = true) + ?(delegatable = true) + ?delegatePubKey ?script ~fee () = + operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + Alpha_context.[ + Origination { manager = managerPubKey ; + delegate = delegatePubKey ; + script ; + spendable ; + delegatable ; + credit = balance } + ] + + let delegation ctxt + block ~branch ~source ?sourcePubKey ~counter ~fee delegate = + operations ctxt block ~branch ~source ?sourcePubKey ~counter ~fee + Alpha_context.[Delegation delegate] + + end + + module Delegate = struct + + let operations ctxt + block ~branch ~source operations = + let ops = Delegate_operations { source ; operations } in + (RPC_context.make_call0 S.operations ctxt block + () ({ branch }, Sourced_operations ops)) + + let endorsement ctxt + b ~branch ~source ~block ~slot () = + operations ctxt b ~branch ~source + Alpha_context.[Endorsement { block ; slot }] + + let proposals ctxt + b ~branch ~source ~period ~proposals () = + operations ctxt b ~branch ~source + Alpha_context.[Proposals { period ; proposals }] + + let ballot ctxt + b ~branch ~source ~period ~proposal ~ballot () = + operations ctxt b ~branch ~source + Alpha_context.[Ballot { period ; proposal ; ballot }] + + end + + module Dictator = struct + + let operation ctxt + block ~branch operation = + let op = Dictator_operation operation in + (RPC_context.make_call0 S.operations ctxt block + () ({ branch }, Sourced_operations op)) + + let activate ctxt + b ~branch hash = + operation ctxt b ~branch (Activate hash) + + let activate_testnet ctxt + b ~branch hash = + operation ctxt b ~branch (Activate_testnet hash) + + end + + module Anonymous = struct + + let operations ctxt block ~branch operations = + (RPC_context.make_call0 S.operations ctxt block + () ({ branch }, Anonymous_operations operations)) + + let seed_nonce_revelation ctxt + block ~branch ~level ~nonce () = + operations ctxt block ~branch [Seed_nonce_revelation { level ; nonce }] + + let faucet ctxt + block ~branch ~id ~nonce () = + operations ctxt block ~branch [Faucet { id ; nonce }] + + end + + let empty_proof_of_work_nonce = + MBytes.of_string + (String.make Constants_repr.proof_of_work_nonce_size '\000') + + let block_proto_header ctxt + block + ~priority ~seed_nonce_hash + ?(proof_of_work_nonce = empty_proof_of_work_nonce) () = + RPC_context.make_call0 S.block_proto_header + ctxt block () (priority, seed_nonce_hash, proof_of_work_nonce) + +end + +module Parse = struct + + module S = struct + + open Data_encoding + + let custom_root = RPC_path.(open_root / "helpers" / "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.(custom_root / "parse" / "operations" ) + + let block = + RPC_service.post_service + ~description:"Parse a block" + ~query: RPC_query.empty + ~input: Block_header.raw_encoding + ~output: Block_header.proto_header_encoding + RPC_path.(custom_root / "parse" / "block" ) + + end + + module I = struct + + let check_signature ctxt signature shell contents = + match contents with + | Anonymous_operations _ -> return () + | Sourced_operations (Manager_operations op) -> + begin + match op.public_key with + | Some key -> return key + | None -> + Contract.get_manager ctxt op.source >>=? fun manager -> + Delegates_pubkey.get ctxt manager + end >>=? fun public_key -> + Operation.check_signature public_key + { signature ; shell ; contents ; hash = Operation_hash.zero } + | Sourced_operations (Delegate_operations { source ; _ }) -> + Operation.check_signature source + { signature ; shell ; contents ; hash = Operation_hash.zero } + | Sourced_operations (Dictator_operation _) -> + let key = Constants.dictator_pubkey ctxt in + Operation.check_signature key + { signature ; shell ; contents ; hash = Operation_hash.zero } + + end + + let () = + let open Services_registration in + register0 S.operations begin fun ctxt () (operations, check) -> + map_s begin fun raw -> + Lwt.return (Operation.parse (Operation.hash_raw raw) raw) >>=? fun op -> + begin match check with + | Some true -> I.check_signature ctxt op.signature op.shell op.contents + | Some false | None -> return () + end >>|? fun () -> op + end operations + end ; + register0_noctxt S.block begin fun () raw_block -> + Lwt.return (Block_header.parse raw_block) >>=? fun { proto ; _ } -> + return proto + end + + let operations ctxt block ?check operations = + RPC_context.make_call0 + S.operations ctxt block () (operations, check) + let block ctxt block shell proto = + RPC_context.make_call0 + S.block ctxt block () ({ shell ; proto } : Block_header.raw) + +end + diff --git a/src/proto_alpha/lib_protocol/src/helpers_services.mli b/src/proto_alpha/lib_protocol/src/helpers_services.mli new file mode 100644 index 000000000..db66a32fe --- /dev/null +++ b/src/proto_alpha/lib_protocol/src/helpers_services.mli @@ -0,0 +1,209 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2018. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* All rights reserved. No warranty, explicit or implicit, provided. *) +(* *) +(**************************************************************************) + +open Alpha_context + +val minimal_time: + 'a #RPC_context.simple -> + ?priority:int -> 'a -> Time.t shell_tzresult Lwt.t +(** [minimal_time cctxt ?prio blk] is the minimal acceptable + timestamp for the successor of [blk]. [?priority] defaults to + [0]. *) + +val apply_operation: + 'a #RPC_context.simple -> + 'a -> Block_hash.t -> Operation_hash.t -> MBytes.t -> Ed25519.Signature.t option -> + (Contract.t list) shell_tzresult Lwt.t + +val run_code: + 'a #RPC_context.simple -> + 'a -> Script.expr -> + (Script.expr * Script.expr * Tez.t) -> + (Script.expr * Script.expr * (Script.expr * Script.expr option) list option) shell_tzresult Lwt.t + +val trace_code: + 'a #RPC_context.simple -> + 'a -> Script.expr -> + (Script.expr * Script.expr * Tez.t) -> + (Script.expr * Script.expr * + (Script.location * Gas.t * Script.expr list) list * + (Script.expr * Script.expr option) list option) shell_tzresult Lwt.t + +val typecheck_code: + 'a #RPC_context.simple -> + 'a -> Script.expr -> Script_tc_errors.type_map shell_tzresult Lwt.t + +val typecheck_data: + 'a #RPC_context.simple -> + 'a -> Script.expr * Script.expr -> unit shell_tzresult Lwt.t + +val hash_data: + 'a #RPC_context.simple -> + 'a -> Script.expr * Script.expr -> string shell_tzresult Lwt.t + +val level: + 'a #RPC_context.simple -> + 'a -> ?offset:int32 -> Raw_level.t -> Level.t shell_tzresult Lwt.t + +val levels: + 'a #RPC_context.simple -> + 'a -> Cycle.t -> (Raw_level.t * Raw_level.t) shell_tzresult Lwt.t + + +module Forge : sig + + module Manager : sig + + val operations: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + fee:Tez.t -> + manager_operation list -> MBytes.t shell_tzresult Lwt.t + + val transaction: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + amount:Tez.t -> + destination:Contract.t -> + ?parameters:Script.expr -> + fee:Tez.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val origination: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + managerPubKey:public_key_hash -> + balance:Tez.t -> + ?spendable:bool -> + ?delegatable:bool -> + ?delegatePubKey: public_key_hash -> + ?script:Script.t -> + fee:Tez.t-> + unit -> MBytes.t shell_tzresult Lwt.t + + val delegation: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:Contract.t -> + ?sourcePubKey:public_key -> + counter:int32 -> + fee:Tez.t -> + public_key_hash option -> + MBytes.t shell_tzresult Lwt.t + + end + + module Dictator : sig + + val operation: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + dictator_operation -> MBytes.t shell_tzresult Lwt.t + + val activate: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + Protocol_hash.t -> MBytes.t shell_tzresult Lwt.t + + val activate_testnet: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + Protocol_hash.t -> MBytes.t shell_tzresult Lwt.t + + end + + module Delegate : sig + + val operations: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:public_key -> + delegate_operation list -> MBytes.t shell_tzresult Lwt.t + + val endorsement: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:public_key -> + block:Block_hash.t -> + slot:int -> + unit -> MBytes.t shell_tzresult Lwt.t + + val proposals: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:public_key -> + period:Voting_period.t -> + proposals:Protocol_hash.t list -> + unit -> MBytes.t shell_tzresult Lwt.t + + val ballot: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + source:public_key -> + period:Voting_period.t -> + proposal:Protocol_hash.t -> + ballot:Vote.ballot -> + unit -> MBytes.t shell_tzresult Lwt.t + + end + + module Anonymous : sig + + val operations: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + anonymous_operation list -> MBytes.t shell_tzresult Lwt.t + + val seed_nonce_revelation: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + level:Raw_level.t -> + nonce:Nonce.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + val faucet: + 'a #RPC_context.simple -> 'a -> + branch:Block_hash.t -> + id:public_key_hash -> + nonce:MBytes.t -> + unit -> MBytes.t shell_tzresult Lwt.t + + end + + val block_proto_header: + 'a #RPC_context.simple -> 'a -> + priority: int -> + seed_nonce_hash: Nonce_hash.t -> + ?proof_of_work_nonce: MBytes.t -> + unit -> MBytes.t shell_tzresult Lwt.t + +end + +module Parse : sig + + val operations: + 'a #RPC_context.simple -> 'a -> + ?check:bool -> Operation.raw list -> + Operation.t list shell_tzresult Lwt.t + + val block: + 'a #RPC_context.simple -> 'a -> + Block_header.shell_header -> MBytes.t -> + Block_header.proto_header shell_tzresult Lwt.t + +end diff --git a/src/proto_alpha/lib_protocol/src/main.ml b/src/proto_alpha/lib_protocol/src/main.ml index e8d1dc5b2..e22390b91 100644 --- a/src/proto_alpha/lib_protocol/src/main.ml +++ b/src/proto_alpha/lib_protocol/src/main.ml @@ -21,7 +21,7 @@ let validation_passes = Updater.[ { max_size = 32 * 1024 ; max_op = None } ; (* 32kB FIXME *) { max_size = 1024 * 1024 ; max_op = None } ] (* 1MB *) -let rpc_services = Services_registration.rpc_services +let rpc_services = Services_registration.get_rpc_services () type validation_mode = | Application of { diff --git a/src/proto_alpha/lib_protocol/src/services_registration.ml b/src/proto_alpha/lib_protocol/src/services_registration.ml index 0b901be06..243ae404e 100644 --- a/src/proto_alpha/lib_protocol/src/services_registration.ml +++ b/src/proto_alpha/lib_protocol/src/services_registration.ml @@ -30,531 +30,36 @@ let rpc_services = ref (RPC_directory.empty : Updater.rpc_context Lwt.t RPC_dire let register0_fullctxt s f = rpc_services := - RPC_directory.register !rpc_services (s RPC_path.open_root) - (fun ctxt q () -> + RPC_directory.register !rpc_services s + (fun ctxt q i -> rpc_init ctxt >>=? fun ctxt -> - f ctxt q) -let register0 s f = register0_fullctxt s (fun { context ; _ } -> f context) + f ctxt q i) +let register0 s f = + register0_fullctxt s (fun { context ; _ } -> f context) +let register0_noctxt s f = + rpc_services := + RPC_directory.register !rpc_services s + (fun _ q i -> f q i) let register1_fullctxt s f = rpc_services := - RPC_directory.register !rpc_services (s RPC_path.open_root) - (fun ctxt q arg -> + RPC_directory.register !rpc_services s + (fun (ctxt, arg) q i -> rpc_init ctxt >>=? fun ctxt -> - f ctxt q arg ) + f ctxt arg q i) let register1 s f = register1_fullctxt s (fun { context ; _ } x -> f context x) let register1_noctxt s f = rpc_services := - RPC_directory.register !rpc_services (s RPC_path.open_root) - (fun _ q arg -> f q arg) + RPC_directory.register !rpc_services s + (fun (_, arg) q i -> f arg q i) let register2_fullctxt s f = rpc_services := - RPC_directory.register !rpc_services (s RPC_path.open_root) - (fun (ctxt, arg1) q arg2 -> + RPC_directory.register !rpc_services s + (fun ((ctxt, arg1), arg2) q i -> rpc_init ctxt >>=? fun ctxt -> - f ctxt q arg1 arg2) + f ctxt arg1 arg2 q i) let register2 s f = - register2_fullctxt s (fun { context ; _ } q x y -> f context q x y) + register2_fullctxt s (fun { context ; _ } a1 a2 q i -> f context a1 a2 q i) - -(*-- Operations --------------------------------------------------------------*) - -let () = - register0_fullctxt - Services.operations - (fun { operation_hashes ; operations ; _ } () -> - operation_hashes () >>= fun operation_hashes -> - operations () >>= fun operations -> - map2_s - (map2_s (fun x y -> Lwt.return (Operation.parse x y))) - operation_hashes operations) - -let () = - register0_fullctxt - Services.header - (fun { block_header ; _ } () -> - Lwt.return (Block_header.parse block_header) >>=? fun block_header -> - return block_header) ; - register0_fullctxt - Services.Header.priority - (fun { block_header ; _ } () -> - Lwt.return (Block_header.parse block_header) >>=? fun block_header -> - return block_header.proto.priority) ; - register0_fullctxt - Services.Header.seed_nonce_hash - (fun { block_header ; _ } () -> - Lwt.return (Block_header.parse block_header) >>=? fun block_header -> - return block_header.proto.seed_nonce_hash) - - -(*-- Constants ---------------------------------------------------------------*) - -let cycle_length ctxt () = - return @@ Constants.cycle_length ctxt - -let () = register0 Services.Constants.cycle_length cycle_length - -let voting_period_length ctxt () = - return @@ Constants.voting_period_length ctxt - -let () = - register0 - Services.Constants.voting_period_length - voting_period_length - -let time_before_reward ctxt () = - return @@ Constants.time_before_reward ctxt - -let () = register0 Services.Constants.time_before_reward time_before_reward - -let slot_durations ctxt () = - return @@ Constants.slot_durations ctxt - -let () = register0 Services.Constants.slot_durations slot_durations - -let first_free_baking_slot ctxt () = - return @@ Constants.first_free_baking_slot ctxt - -let () = - register0 Services.Constants.first_free_baking_slot first_free_baking_slot - -let max_signing_slot ctxt () = - return @@ Constants.max_signing_slot ctxt - -let () = register0 Services.Constants.max_signing_slot max_signing_slot - -let max_gas ctxt () = - return @@ Constants.max_gas ctxt - -let () = - register0 - Services.Constants.max_gas max_gas - -let proof_of_work_threshold ctxt () = - return @@ Constants.proof_of_work_threshold ctxt - -let () = - register0 Services.Constants.proof_of_work_threshold - proof_of_work_threshold - -let () = - register1_noctxt Services.Constants.errors - (fun () () -> - return (Data_encoding.Json.(schema error_encoding))) - -(*-- Context -----------------------------------------------------------------*) - -type error += Unexpected_level_in_context - -let level ctxt () = - let level = Level.current ctxt in - match Level.pred ctxt level with - | None -> fail Unexpected_level_in_context - | Some level -> return level - -let () = register0 Services.Context.level level - -let next_level ctxt () = - return (Level.current ctxt) - -let () = - register0 Services.Context.next_level next_level - -let () = - register0 Services.Context.roll_value - (fun ctxt () -> return (Roll.value ctxt)) - -let () = - register0 Services.Context.next_roll - (fun ctxt () -> Roll.next ctxt) - -let () = - register0 Services.Context.voting_period_kind - (fun ctxt () -> Vote.get_current_period_kind ctxt) - - -(*-- Context.Nonce -----------------------------------------------------------*) - -let nonce ctxt () raw_level () = - let level = Level.from_raw ctxt raw_level in - Nonce.get ctxt level >>= function - | Ok (Revealed nonce) -> return (Services.Context.Nonce.Revealed nonce) - | Ok (Unrevealed { nonce_hash ; _ }) -> - return (Services.Context.Nonce.Missing nonce_hash) - | Error _ -> return Services.Context.Nonce.Forgotten - -let () = register2 Services.Context.Nonce.get nonce - -let nonce_hash ctxt () = - level ctxt () >>=? fun level -> - Nonce.get ctxt level >>=? function - | Unrevealed { nonce_hash ; _ } -> return nonce_hash - | _ -> assert false - -let () = register0 Services.Context.Nonce.hash nonce_hash - -(*-- Context.Key -------------------------------------------------------------*) - -let get_key ctxt () hash () = - Delegates_pubkey.get ctxt hash >>=? fun pk -> - return (hash, pk) - -let () = register2 Services.Context.Key.get get_key -let () = - register0 Services.Context.Key.list - (fun t () -> Delegates_pubkey.list t >>= return) - -(*-- Context.Contract --------------------------------------------------------*) - -let () = - register0 Services.Context.Contract.list - (fun ctxt () -> Contract.list ctxt >>= return) - -let () = - let register2 s f = - rpc_services := - RPC_directory.register !rpc_services (s RPC_path.open_root) - (fun (ctxt, contract) () arg -> - rpc_init ctxt >>=? fun { context = ctxt ; _ } -> - Contract.exists ctxt contract >>=? function - | true -> f ctxt contract arg - | false -> raise Not_found) in - let register2' s f = register2 s (fun ctxt a1 () -> f ctxt a1) in - let register2'' s f = - register2 s (fun ctxt a1 () -> f ctxt a1 >>=? function - | None -> raise Not_found - | Some v -> return v) in - register2' Services.Context.Contract.balance Contract.get_balance ; - register2' Services.Context.Contract.manager Contract.get_manager ; - register2'' Services.Context.Contract.delegate Contract.get_delegate_opt ; - register2' Services.Context.Contract.counter Contract.get_counter ; - register2' Services.Context.Contract.spendable Contract.is_spendable ; - register2' Services.Context.Contract.delegatable Contract.is_delegatable ; - register2'' Services.Context.Contract.script Contract.get_script ; - register2'' Services.Context.Contract.storage Contract.get_storage ; - register2' Services.Context.Contract.get (fun ctxt contract -> - Contract.get_balance ctxt contract >>=? fun balance -> - Contract.get_manager ctxt contract >>=? fun manager -> - Contract.get_delegate_opt ctxt contract >>=? fun delegate -> - Contract.get_counter ctxt contract >>=? fun counter -> - Contract.is_delegatable ctxt contract >>=? fun delegatable -> - Contract.is_spendable ctxt contract >>=? fun spendable -> - Contract.get_script ctxt contract >>=? fun script -> - return { Services.Context.Contract.manager ; balance ; - spendable ; delegate = (delegatable, delegate) ; - script ; counter }) ; - () - -(*-- Helpers -----------------------------------------------------------------*) - -let minimal_timestamp ctxt prio = - let prio = match prio with None -> 0 | Some p -> p in - Baking.minimal_time ctxt prio - -let () = register1 - Services.Helpers.minimal_timestamp - (fun ctxt () slot -> - let timestamp = Alpha_context.Timestamp.current ctxt in - minimal_timestamp ctxt slot timestamp) - -let () = - (* ctxt accept_failing_script baker_contract pred_block block_prio operation *) - register1 Services.Helpers.apply_operation - (fun ctxt () (pred_block, hash, forged_operation, signature) -> - match Data_encoding.Binary.of_bytes - Operation.unsigned_operation_encoding - forged_operation with - | None -> Error_monad.fail Operation.Cannot_parse_operation - | Some (shell, contents) -> - let operation = { hash ; shell ; contents ; signature } in - let level = Alpha_context.Level.current ctxt in - Baking.baking_priorities ctxt level >>=? fun (Misc.LCons (baker_pkh, _)) -> - let baker_contract = Contract.default_contract baker_pkh in - let block_prio = 0 in - Apply.apply_operation - ctxt (Some baker_contract) pred_block block_prio operation - >>=? function - | (_ctxt, _, Some script_err) -> Lwt.return (Error script_err) - | (_ctxt, contracts, None) -> Lwt.return (Ok contracts)) ; - let run_parameters ctxt (script, storage, input, amount, contract, origination_nonce) = - let contract = - match contract with - | Some contract -> contract - | None -> - Contract.default_contract - (List.hd (Bootstrap.accounts ctxt)).Bootstrap.public_key_hash in - let max_gas = - Constants.max_gas ctxt in - let origination_nonce = - match origination_nonce with - | Some origination_nonce -> origination_nonce - | None -> - Contract.initial_origination_nonce - (Operation_hash.hash_string [ "FAKE " ; "FAKE" ; "FAKE" ]) in - (script, storage, input, amount, contract, max_gas, origination_nonce) in - register1 Services.Helpers.run_code - (fun ctxt () parameters -> - let (code, storage, input, amount, contract, gas, origination_nonce) = - run_parameters ctxt parameters in - Script_interpreter.execute - origination_nonce - contract (* transaction initiator *) - contract (* script owner *) - ctxt { storage ; code } amount input - (Gas.of_int gas) >>=? fun (sto, ret, _gas, _ctxt, _, maybe_big_map_diff) -> - Error_monad.return (sto, ret, Option.map ~f:Script_ir_translator.to_printable_big_map maybe_big_map_diff)) ; - register1 Services.Helpers.trace_code - (fun ctxt () parameters -> - let (code, storage, input, amount, contract, gas, origination_nonce) = - run_parameters ctxt parameters in - Script_interpreter.trace - origination_nonce - contract (* transaction initiator *) - contract (* script owner *) - ctxt { storage ; code } amount input - (Gas.of_int gas) >>=? fun ((sto, ret, _gas, _ctxt, _, maybe_big_map_diff), trace) -> - Error_monad.return (sto, ret, trace, Option.map ~f:Script_ir_translator.to_printable_big_map maybe_big_map_diff)) - -let () = - register1 Services.Helpers.typecheck_code - (fun ctxt () -> Script_ir_translator.typecheck_code ctxt) - -let () = - register1 Services.Helpers.typecheck_data - (fun ctxt () -> Script_ir_translator.typecheck_data ctxt) - -let () = - register1 Services.Helpers.hash_data - (fun ctxt () (expr, typ) -> - let open Script_ir_translator in - Lwt.return @@ parse_ty false (Micheline.root typ) >>=? fun (Ex_ty typ, _) -> - parse_data ctxt typ (Micheline.root expr) >>=? fun data -> - return (Script_ir_translator.hash_data typ data)) - -let () = - register2 Services.Helpers.level - (fun ctxt () raw offset -> return (Level.from_raw ctxt ?offset raw)) - -let () = - register2 Services.Helpers.levels - (fun ctxt () cycle () -> - let levels = Level.levels_in_cycle ctxt cycle in - let first = List.hd (List.rev levels) in - let last = List.hd levels in - return (first.level, last.level)) - - -(*-- Helpers.Rights ----------------------------------------------------------*) - -let default_max_baking_priority ctxt arg = - let default = Constants.first_free_baking_slot ctxt in - match arg with - | None -> 2 * default - | Some m -> m - -let baking_rights ctxt level max = - let max = default_max_baking_priority ctxt max in - Baking.baking_priorities ctxt level >>=? fun contract_list -> - let rec loop l n = - match n with - | 0 -> return [] - | n -> - let Misc.LCons (h, t) = l in - t () >>=? fun t -> - loop t (pred n) >>=? fun t -> - return (h :: t) - in - loop contract_list max >>=? fun prio -> - return (level.level, prio) - -let () = - register1 Services.Helpers.Rights.baking_rights - (fun ctxt () max -> - let level = Level.current ctxt in - baking_rights ctxt level max >>=? fun (raw_level, slots) -> - begin - Lwt_list.filter_map_p (fun x -> x) @@ - List.mapi - (fun prio c -> - let timestamp = Timestamp.current ctxt in - Baking.minimal_time ctxt prio timestamp >>= function - | Error _ -> Lwt.return None - | Ok minimal_timestamp -> Lwt.return (Some (c, minimal_timestamp))) - slots - end >>= fun timed_slots -> - return (raw_level, timed_slots)) - -let () = - register2 Services.Helpers.Rights.baking_rights_for_level - (fun ctxt () raw_level max -> - let level = Level.from_raw ctxt raw_level in - baking_rights ctxt level max) - -let baking_rights_for_delegate - ctxt () contract (max_priority, min_level, max_level) = - let max_priority = default_max_baking_priority ctxt max_priority in - let current_level = Level.current ctxt in - let min_level = match min_level with - | None -> current_level - | Some l -> Level.from_raw ctxt l in - let max_level = - match max_level with - | Some max_level -> Level.from_raw ctxt max_level - | None -> - Level.last_level_in_cycle ctxt @@ - current_level.cycle in - let rec loop level = - if Level.(>) level max_level - then return [] - else - loop (Level.succ ctxt level) >>=? fun t -> - Baking.first_baking_priorities - ctxt ~max_priority contract level >>=? fun priorities -> - let raw_level = level.level in - Error_monad.map_s - (fun priority -> - let timestamp = Timestamp.current ctxt in - Baking.minimal_time ctxt priority timestamp >>=? fun time -> - return (raw_level, priority, time)) - priorities >>=? fun priorities -> - return (priorities @ t) - in - loop min_level - -let () = - register2 Services.Helpers.Rights.baking_rights_for_delegate - baking_rights_for_delegate - -let default_max_endorsement_priority ctxt arg = - let default = Constants.max_signing_slot ctxt in - match arg with - | None -> default - | Some m -> m - -let endorsement_rights ctxt level max = - let max = default_max_endorsement_priority ctxt max in - Baking.endorsement_priorities ctxt level >>=? fun contract_list -> - let rec loop l n = - match n with - | 0 -> return [] - | n -> - let Misc.LCons (h, t) = l in - t () >>=? fun t -> - loop t (pred n) >>=? fun t -> - return (h :: t) - in - loop contract_list max >>=? fun prio -> - return (level.level, prio) - -let () = - register1 Services.Helpers.Rights.endorsement_rights - (fun ctxt () max -> - let level = Level.current ctxt in - endorsement_rights ctxt (Level.succ ctxt level) max) ; - register2 Services.Helpers.Rights.endorsement_rights_for_level - (fun ctxt () raw_level max -> - let level = Level.from_raw ctxt raw_level in - endorsement_rights ctxt level max) - -let endorsement_rights_for_delegate - ctxt () contract (max_priority, min_level, max_level) = - let current_level = Level.current ctxt in - let max_priority = default_max_endorsement_priority ctxt max_priority in - let min_level = match min_level with - | None -> Level.succ ctxt current_level - | Some l -> Level.from_raw ctxt l in - let max_level = - match max_level with - | None -> min_level - | Some l -> Level.from_raw ctxt l in - let rec loop level = - if Level.(>) level max_level - then return [] - else - loop (Level.succ ctxt level) >>=? fun t -> - Baking.first_endorsement_slots - ctxt ~max_priority contract level >>=? fun slots -> - let raw_level = level.level in - let slots = List.rev_map (fun slot -> (raw_level, slot)) slots in - return (List.rev_append slots t) - in - loop min_level - -let () = - register2 Services.Helpers.Rights.endorsement_rights_for_delegate - endorsement_rights_for_delegate - -(*-- Helpers.Forge -----------------------------------------------------------*) - -let operation_public_key ctxt = function - | None -> return None - | Some public_key -> - let hash = Ed25519.Public_key.hash public_key in - Delegates_pubkey.get_option ctxt hash >>=? function - | None -> return (Some public_key) - | Some _ -> return None - -let forge_operations _ctxt () (shell, proto) = - return (Operation.forge shell proto) - -let () = register1 Services.Helpers.Forge.operations forge_operations - -let forge_block_proto_header _ctxt - (priority, seed_nonce_hash, proof_of_work_nonce) : MBytes.t tzresult Lwt.t = - return (Block_header.forge_unsigned_proto_header - { priority ; seed_nonce_hash ; proof_of_work_nonce }) - -let () = - register1 Services.Helpers.Forge.block_proto_header - (fun ctxt () -> forge_block_proto_header ctxt) - -(*-- Helpers.Parse -----------------------------------------------------------*) - -let dummy_hash = Operation_hash.hash_bytes [] - -let check_signature ctxt signature shell contents = - match contents with - | Anonymous_operations _ -> return () - | Sourced_operations (Manager_operations op) -> - begin - match op.public_key with - | Some key -> return key - | None -> - Contract.get_manager ctxt op.source >>=? fun manager -> - Delegates_pubkey.get ctxt manager - end >>=? fun public_key -> - Operation.check_signature public_key - { signature ; shell ; contents ; hash = dummy_hash } - | Sourced_operations (Delegate_operations { source ; _ }) -> - Operation.check_signature source - { signature ; shell ; contents ; hash = dummy_hash } - | Sourced_operations (Dictator_operation _) -> - let key = Constants.dictator_pubkey ctxt in - Operation.check_signature key - { signature ; shell ; contents ; hash = dummy_hash } - -let parse_operations ctxt () (operations, check) = - map_s begin fun raw -> - begin - Lwt.return - (Operation.parse (Operation.hash_raw raw) raw) >>=? fun op -> - begin match check with - | Some true -> check_signature ctxt op.signature op.shell op.contents - | Some false | None -> return () - end >>|? fun () -> op - end - end operations - -let () = - register1 Services.Helpers.Parse.operations parse_operations - -let () = - register1 Services.Helpers.Parse.block - (fun _ctxt () raw_block -> - Lwt.return (Block_header.parse raw_block) >>=? fun { proto ; _ } -> - return proto) - -(*****) - -let rpc_services = !rpc_services +let get_rpc_services () = !rpc_services diff --git a/src/proto_alpha/lib_protocol/test/helpers/helpers_services.ml b/src/proto_alpha/lib_protocol/test/helpers/helpers_services.ml index 36b1a8226..9602568ad 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/helpers_services.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/helpers_services.ml @@ -7,17 +7,17 @@ (* *) (**************************************************************************) -open Proto_alpha.Alpha_context +open Proto_alpha +open Alpha_context open Helpers_assert let endorsement_rights ~tc () = let level = Level.current tc in - Proto_alpha.Services_registration.endorsement_rights tc level None >>=?? fun (_, endorsers) -> + Alpha_services.Delegate.endorsement_rights tc level None >>=?? fun (_, endorsers) -> return @@ List.mapi (fun x i -> x, i) endorsers let baking_rights ~tc () = - let level = Level.succ tc @@ Level.current tc in - Proto_alpha.Services_registration.baking_rights tc level None >>=?? fun (_, bakers) -> - return @@ List.mapi (fun x i -> x, i) bakers + Alpha_services.Delegate.baking_rights tc () None >>=?? fun (_, bakers) -> + return @@ List.mapi (fun x (i,_) -> x, i) bakers diff --git a/src/proto_alpha/lib_protocol/test/test_endorsement.ml b/src/proto_alpha/lib_protocol/test/test_endorsement.ml index 8c1a9c994..adf35b310 100644 --- a/src/proto_alpha/lib_protocol/test/test_endorsement.ml +++ b/src/proto_alpha/lib_protocol/test/test_endorsement.ml @@ -49,7 +49,7 @@ let test_endorsement_payment () = let open Proto_alpha.Alpha_context in get_tc_full root >>=? fun tc -> let level = Level.succ tc @@ Level.current tc in - Proto_alpha.Services_registration.endorsement_rights tc level None >>=? fun (_, endorsers) -> + Alpha_services.Delegate.endorsement_rights tc level None >>=? fun (_, endorsers) -> let aux (endorser_slot, block_priority) = let contract_p = @@ -98,7 +98,7 @@ let test_multiple_endorsement () = Init.main () >>=? fun pred -> let tc = pred.tezos_context in let level = Level.current tc in - Proto_alpha.Services_registration.endorsement_rights tc level None >>=? fun (_, endorsers) -> + Alpha_services.Delegate.endorsement_rights tc level None >>=? fun (_, endorsers) -> let endorser = Misc.find_account Account.bootstrap_accounts @@ List.nth endorsers 0 in