balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

RPC: remove deprecated function RPC.register*

Browse Source
This commit is contained in:
Grégoire Henry 2017-12-07 17:43:21 +01:00 committed by Benjamin Canou
parent f4c19694e0
commit e57a0734e5
6 changed files with 183 additions and 222 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

169
lib_embedded_protocol_alpha/src/services_registration.ml
View File

@ -30,31 +30,31 @@ let rpc_services = ref (RPC.Directory.empty : Updater.rpc_context RPC.Directory.
let register0_fullctxt s f = let register0_fullctxt s f =
rpc_services := rpc_services :=
RPC.register !rpc_services (s RPC.Path.open_root) RPC.Directory.register !rpc_services (s RPC.Path.open_root)
(fun ctxt () -> (fun ctxt q () ->
( rpc_init ctxt >>=? fun ctxt -> ( rpc_init ctxt >>=? fun ctxt ->
f ctxt ) >>= RPC.Answer.return) f ctxt q) >>= RPC.Answer.return)
let register0 s f = register0_fullctxt s (fun { context } -> f context) let register0 s f = register0_fullctxt s (fun { context ; _ } -> f context)
let register1_fullctxt s f = let register1_fullctxt s f =
rpc_services := rpc_services :=
RPC.register !rpc_services (s RPC.Path.open_root) RPC.Directory.register !rpc_services (s RPC.Path.open_root)
(fun ctxt arg -> (fun ctxt q arg ->
( rpc_init ctxt >>=? fun ctxt -> ( rpc_init ctxt >>=? fun ctxt ->
f ctxt arg ) >>= RPC.Answer.return) f ctxt q arg ) >>= RPC.Answer.return)
let register1 s f = register1_fullctxt s (fun { context } x -> f context x) let register1 s f = register1_fullctxt s (fun { context ; _ } x -> f context x)
let register1_noctxt s f = let register1_noctxt s f =
rpc_services := rpc_services :=
RPC.register !rpc_services (s RPC.Path.open_root) RPC.Directory.register !rpc_services (s RPC.Path.open_root)
(fun _ arg -> f arg >>= RPC.Answer.return) (fun _ q arg -> f q arg >>= RPC.Answer.return)
let register2_fullctxt s f = let register2_fullctxt s f =
rpc_services := rpc_services :=
RPC.register !rpc_services (s RPC.Path.open_root) RPC.Directory.register !rpc_services (s RPC.Path.open_root)
(fun (ctxt, arg1) arg2 -> (fun (ctxt, arg1) q arg2 ->
( rpc_init ctxt >>=? fun ctxt -> ( rpc_init ctxt >>=? fun ctxt ->
f ctxt arg1 arg2 ) >>= RPC.Answer.return) f ctxt q arg1 arg2 ) >>= RPC.Answer.return)
let register2 s f = register2_fullctxt s (fun { context } x y -> f context x y) let register2 s f = register2_fullctxt s (fun { context ; _ } q x y -> f context q x y)
(*-- Operations --------------------------------------------------------------*) (*-- Operations --------------------------------------------------------------*)
@ -62,7 +62,7 @@ let register2 s f = register2_fullctxt s (fun { context } x y -> f context x y)
let () = let () =
register0_fullctxt register0_fullctxt
Services.operations Services.operations
(fun { operation_hashes ; operations } -> (fun { operation_hashes ; operations ; _ } () ->
operation_hashes () >>= fun operation_hashes -> operation_hashes () >>= fun operation_hashes ->
operations () >>= fun operations -> operations () >>= fun operations ->
map2_s map2_s
@ -72,29 +72,29 @@ let () =
let () = let () =
register0_fullctxt register0_fullctxt
Services.header Services.header
(fun { block_header } -> (fun { block_header ; _ } () ->
Lwt.return (Block_header.parse block_header) >>=? fun block_header -> Lwt.return (Block_header.parse block_header) >>=? fun block_header ->
return block_header) ; return block_header) ;
register0_fullctxt register0_fullctxt
Services.Header.priority Services.Header.priority
(fun { block_header } -> (fun { block_header ; _ } () ->
Lwt.return (Block_header.parse block_header) >>=? fun block_header -> Lwt.return (Block_header.parse block_header) >>=? fun block_header ->
return block_header.proto.priority) ; return block_header.proto.priority) ;
register0_fullctxt register0_fullctxt
Services.Header.seed_nonce_hash Services.Header.seed_nonce_hash
(fun { block_header } -> (fun { block_header ; _ } () ->
Lwt.return (Block_header.parse block_header) >>=? fun block_header -> Lwt.return (Block_header.parse block_header) >>=? fun block_header ->
return block_header.proto.seed_nonce_hash) return block_header.proto.seed_nonce_hash)
(*-- Constants ---------------------------------------------------------------*) (*-- Constants ---------------------------------------------------------------*)
let cycle_length ctxt = let cycle_length ctxt () =
return @@ Constants.cycle_length ctxt return @@ Constants.cycle_length ctxt
let () = register0 Services.Constants.cycle_length cycle_length let () = register0 Services.Constants.cycle_length cycle_length
let voting_period_length ctxt = let voting_period_length ctxt () =
return @@ Constants.voting_period_length ctxt return @@ Constants.voting_period_length ctxt
let () = let () =
@ -102,50 +102,52 @@ let () =
Services.Constants.voting_period_length Services.Constants.voting_period_length
voting_period_length voting_period_length
let time_before_reward ctxt = let time_before_reward ctxt () =
return @@ Constants.time_before_reward ctxt return @@ Constants.time_before_reward ctxt
let () = register0 Services.Constants.time_before_reward time_before_reward let () = register0 Services.Constants.time_before_reward time_before_reward
let slot_durations ctxt = let slot_durations ctxt () =
return @@ Constants.slot_durations ctxt return @@ Constants.slot_durations ctxt
let () = register0 Services.Constants.slot_durations slot_durations let () = register0 Services.Constants.slot_durations slot_durations
let first_free_baking_slot ctxt = let first_free_baking_slot ctxt () =
return @@ Constants.first_free_baking_slot ctxt return @@ Constants.first_free_baking_slot ctxt
let () = let () =
register0 Services.Constants.first_free_baking_slot first_free_baking_slot register0 Services.Constants.first_free_baking_slot first_free_baking_slot
let max_signing_slot ctxt = let max_signing_slot ctxt () =
return @@ Constants.max_signing_slot ctxt return @@ Constants.max_signing_slot ctxt
let () = register0 Services.Constants.max_signing_slot max_signing_slot let () = register0 Services.Constants.max_signing_slot max_signing_slot
let instructions_per_transaction ctxt = let instructions_per_transaction ctxt () =
return @@ Constants.instructions_per_transaction ctxt return @@ Constants.instructions_per_transaction ctxt
let () = let () =
register0 register0
Services.Constants.instructions_per_transaction instructions_per_transaction Services.Constants.instructions_per_transaction
instructions_per_transaction
let proof_of_work_threshold ctxt = let proof_of_work_threshold ctxt () =
return @@ Constants.proof_of_work_threshold ctxt return @@ Constants.proof_of_work_threshold ctxt
let () = let () =
register0 Services.Constants.proof_of_work_threshold proof_of_work_threshold register0 Services.Constants.proof_of_work_threshold
proof_of_work_threshold
let () = let () =
register1_noctxt Services.Constants.errors register1_noctxt Services.Constants.errors
(fun () -> (fun () () ->
Lwt.return (Data_encoding.Json.(schema error_encoding))) Lwt.return (Data_encoding.Json.(schema error_encoding)))
(*-- Context -----------------------------------------------------------------*) (*-- Context -----------------------------------------------------------------*)
type error += Unexpected_level_in_context type error += Unexpected_level_in_context
let level ctxt = let level ctxt () =
let level = Level.current ctxt in let level = Level.current ctxt in
match Level.pred ctxt level with match Level.pred ctxt level with
| None -> fail Unexpected_level_in_context | None -> fail Unexpected_level_in_context
@ -153,64 +155,68 @@ let level ctxt =
let () = register0 Services.Context.level level let () = register0 Services.Context.level level
let next_level ctxt = let next_level ctxt () =
return (Level.current ctxt) return (Level.current ctxt)
let () = register0 Services.Context.next_level next_level let () =
register0 Services.Context.next_level next_level
let roll_value ctxt =
return (Roll.value ctxt)
let () = register0 Services.Context.roll_value roll_value
let () = register0 Services.Context.next_roll Roll.next
let () = let () =
register0 Services.Context.voting_period_kind Vote.get_current_period_kind 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 -----------------------------------------------------------*) (*-- Context.Nonce -----------------------------------------------------------*)
let nonce ctxt raw_level () = let nonce ctxt () raw_level () =
let level = Level.from_raw ctxt raw_level in let level = Level.from_raw ctxt raw_level in
Nonce.get ctxt level >>= function Nonce.get ctxt level >>= function
| Ok (Revealed nonce) -> return (Services.Context.Nonce.Revealed nonce) | Ok (Revealed nonce) -> return (Services.Context.Nonce.Revealed nonce)
| Ok (Unrevealed { nonce_hash }) -> | Ok (Unrevealed { nonce_hash ; _ }) ->
return (Services.Context.Nonce.Missing nonce_hash) return (Services.Context.Nonce.Missing nonce_hash)
| Error _ -> return Services.Context.Nonce.Forgotten | Error _ -> return Services.Context.Nonce.Forgotten
let () = register2 Services.Context.Nonce.get nonce let () = register2 Services.Context.Nonce.get nonce
let nonce_hash ctxt = let nonce_hash ctxt () =
level ctxt >>=? fun level -> level ctxt () >>=? fun level ->
Nonce.get ctxt level >>=? function Nonce.get ctxt level >>=? function
| Unrevealed { nonce_hash } -> return nonce_hash | Unrevealed { nonce_hash ; _ } -> return nonce_hash
| _ -> assert false | _ -> assert false
let () = register0 Services.Context.Nonce.hash nonce_hash let () = register0 Services.Context.Nonce.hash nonce_hash
(*-- Context.Key -------------------------------------------------------------*) (*-- Context.Key -------------------------------------------------------------*)
let get_key ctxt hash () = let get_key ctxt () hash () =
Delegates_pubkey.get ctxt hash >>=? fun pk -> Delegates_pubkey.get ctxt hash >>=? fun pk ->
return (hash, pk) return (hash, pk)
let () = register2 Services.Context.Key.get get_key let () = register2 Services.Context.Key.get get_key
let () = let () =
register0 Services.Context.Key.list register0 Services.Context.Key.list
(fun t -> Delegates_pubkey.list t >>= return) (fun t () -> Delegates_pubkey.list t >>= return)
(*-- Context.Contract --------------------------------------------------------*) (*-- Context.Contract --------------------------------------------------------*)
let () = let () =
register0 Services.Context.Contract.list register0 Services.Context.Contract.list
(fun ctxt -> Contract.list ctxt >>= return) (fun ctxt () -> Contract.list ctxt >>= return)
let () = let () =
let register2 s f = let register2 s f =
rpc_services := rpc_services :=
RPC.register !rpc_services (s RPC.Path.open_root) RPC.Directory.register !rpc_services (s RPC.Path.open_root)
(fun (ctxt, contract) arg -> (fun (ctxt, contract) () arg ->
( rpc_init ctxt >>=? fun { context = ctxt } -> ( rpc_init ctxt >>=? fun { context = ctxt ; _ } ->
Contract.exists ctxt contract >>=? function Contract.exists ctxt contract >>=? function
| true -> f ctxt contract arg | true -> f ctxt contract arg
| false -> raise Not_found ) >>= RPC.Answer.return) in | false -> raise Not_found ) >>= RPC.Answer.return) in
@ -244,14 +250,14 @@ let minimal_timestamp ctxt prio =
let () = register1 let () = register1
Services.Helpers.minimal_timestamp Services.Helpers.minimal_timestamp
(fun ctxt slot -> (fun ctxt () slot ->
let timestamp = Tezos_context.Timestamp.current ctxt in let timestamp = Tezos_context.Timestamp.current ctxt in
minimal_timestamp ctxt slot timestamp) minimal_timestamp ctxt slot timestamp)
let () = let () =
(* ctxt accept_failing_script baker_contract pred_block block_prio operation *) (* ctxt accept_failing_script baker_contract pred_block block_prio operation *)
register1 Services.Helpers.apply_operation register1 Services.Helpers.apply_operation
(fun ctxt (pred_block, hash, forged_operation, signature) -> (fun ctxt () (pred_block, hash, forged_operation, signature) ->
match Data_encoding.Binary.of_bytes match Data_encoding.Binary.of_bytes
Operation.unsigned_operation_encoding Operation.unsigned_operation_encoding
forged_operation with forged_operation with
@ -284,7 +290,7 @@ let () =
(Operation_hash.hash_string [ "FAKE " ; "FAKE" ; "FAKE" ]) in (Operation_hash.hash_string [ "FAKE " ; "FAKE" ; "FAKE" ]) in
(script, storage, input, amount, contract, qta, origination_nonce) in (script, storage, input, amount, contract, qta, origination_nonce) in
register1 Services.Helpers.run_code register1 Services.Helpers.run_code
(fun ctxt parameters -> (fun ctxt () parameters ->
let (code, storage, input, amount, contract, qta, origination_nonce) = let (code, storage, input, amount, contract, qta, origination_nonce) =
run_parameters ctxt parameters in run_parameters ctxt parameters in
Script_interpreter.execute Script_interpreter.execute
@ -295,7 +301,7 @@ let () =
qta >>=? fun (sto, ret, _qta, _ctxt, _) -> qta >>=? fun (sto, ret, _qta, _ctxt, _) ->
Error_monad.return (sto, ret)) ; Error_monad.return (sto, ret)) ;
register1 Services.Helpers.trace_code register1 Services.Helpers.trace_code
(fun ctxt parameters -> (fun ctxt () parameters ->
let (code, storage, input, amount, contract, qta, origination_nonce) = let (code, storage, input, amount, contract, qta, origination_nonce) =
run_parameters ctxt parameters in run_parameters ctxt parameters in
Script_interpreter.trace Script_interpreter.trace
@ -308,28 +314,27 @@ let () =
let () = let () =
register1 Services.Helpers.typecheck_code register1 Services.Helpers.typecheck_code
Script_ir_translator.typecheck_code (fun ctxt () -> Script_ir_translator.typecheck_code ctxt)
let () = let () =
register1 Services.Helpers.typecheck_data register1 Services.Helpers.typecheck_data
Script_ir_translator.typecheck_data (fun ctxt () -> Script_ir_translator.typecheck_data ctxt)
let () = let () =
register1 Services.Helpers.hash_data register1 Services.Helpers.hash_data
(fun _ctxt expr -> return (Script.hash_expr expr)) (fun _ctxt () expr -> return (Script.hash_expr expr))
let compute_level ctxt raw offset = let () =
return (Level.from_raw ctxt ?offset raw) register2 Services.Helpers.level
(fun ctxt () raw offset -> return (Level.from_raw ctxt ?offset raw))
let () = register2 Services.Helpers.level compute_level let () =
register2 Services.Helpers.levels
let levels ctxt cycle () = (fun ctxt () cycle () ->
let levels = Level.levels_in_cycle ctxt cycle in let levels = Level.levels_in_cycle ctxt cycle in
let first = List.hd (List.rev levels) in let first = List.hd (List.rev levels) in
let last = List.hd levels in let last = List.hd levels in
return (first.level, last.level) return (first.level, last.level))
let () = register2 Services.Helpers.levels levels
(*-- Helpers.Rights ----------------------------------------------------------*) (*-- Helpers.Rights ----------------------------------------------------------*)
@ -357,7 +362,7 @@ let baking_rights ctxt level max =
let () = let () =
register1 Services.Helpers.Rights.baking_rights register1 Services.Helpers.Rights.baking_rights
(fun ctxt max -> (fun ctxt () max ->
let level = Level.current ctxt in let level = Level.current ctxt in
baking_rights ctxt level max >>=? fun (raw_level, slots) -> baking_rights ctxt level max >>=? fun (raw_level, slots) ->
begin begin
@ -374,12 +379,12 @@ let () =
let () = let () =
register2 Services.Helpers.Rights.baking_rights_for_level register2 Services.Helpers.Rights.baking_rights_for_level
(fun ctxt raw_level max -> (fun ctxt () raw_level max ->
let level = Level.from_raw ctxt raw_level in let level = Level.from_raw ctxt raw_level in
baking_rights ctxt level max) baking_rights ctxt level max)
let baking_rights_for_delegate let baking_rights_for_delegate
ctxt contract (max_priority, min_level, max_level) = ctxt () contract (max_priority, min_level, max_level) =
let max_priority = default_max_baking_priority ctxt max_priority in let max_priority = default_max_baking_priority ctxt max_priority in
let current_level = Level.current ctxt in let current_level = Level.current ctxt in
let min_level = match min_level with let min_level = match min_level with
@ -436,16 +441,16 @@ let endorsement_rights ctxt level max =
let () = let () =
register1 Services.Helpers.Rights.endorsement_rights register1 Services.Helpers.Rights.endorsement_rights
(fun ctxt max -> (fun ctxt () max ->
let level = Level.current ctxt in let level = Level.current ctxt in
endorsement_rights ctxt (Level.succ ctxt level) max) ; endorsement_rights ctxt (Level.succ ctxt level) max) ;
register2 Services.Helpers.Rights.endorsement_rights_for_level register2 Services.Helpers.Rights.endorsement_rights_for_level
(fun ctxt raw_level max -> (fun ctxt () raw_level max ->
let level = Level.from_raw ctxt raw_level in let level = Level.from_raw ctxt raw_level in
endorsement_rights ctxt level max) endorsement_rights ctxt level max)
let endorsement_rights_for_delegate let endorsement_rights_for_delegate
ctxt contract (max_priority, min_level, max_level) = ctxt () contract (max_priority, min_level, max_level) =
let current_level = Level.current ctxt in let current_level = Level.current ctxt in
let max_priority = default_max_endorsement_priority ctxt max_priority in let max_priority = default_max_endorsement_priority ctxt max_priority in
let min_level = match min_level with let min_level = match min_level with
@ -482,7 +487,7 @@ let operation_public_key ctxt = function
| None -> return (Some public_key) | None -> return (Some public_key)
| Some _ -> return None | Some _ -> return None
let forge_operations _ctxt (shell, proto) = let forge_operations _ctxt () (shell, proto) =
return (Operation.forge shell proto) return (Operation.forge shell proto)
let () = register1 Services.Helpers.Forge.operations forge_operations let () = register1 Services.Helpers.Forge.operations forge_operations
@ -493,7 +498,8 @@ let forge_block_proto_header _ctxt
{ priority ; seed_nonce_hash ; proof_of_work_nonce }) { priority ; seed_nonce_hash ; proof_of_work_nonce })
let () = let () =
register1 Services.Helpers.Forge.block_proto_header forge_block_proto_header register1 Services.Helpers.Forge.block_proto_header
(fun ctxt () -> forge_block_proto_header ctxt)
(*-- Helpers.Parse -----------------------------------------------------------*) (*-- Helpers.Parse -----------------------------------------------------------*)
@ -512,7 +518,7 @@ let check_signature ctxt signature shell contents =
end >>=? fun public_key -> end >>=? fun public_key ->
Operation.check_signature public_key Operation.check_signature public_key
{ signature ; shell ; contents ; hash = dummy_hash } { signature ; shell ; contents ; hash = dummy_hash }
| Sourced_operations (Delegate_operations { source }) -> | Sourced_operations (Delegate_operations { source ; _ }) ->
Operation.check_signature source Operation.check_signature source
{ signature ; shell ; contents ; hash = dummy_hash } { signature ; shell ; contents ; hash = dummy_hash }
| Sourced_operations (Dictator_operation _) -> | Sourced_operations (Dictator_operation _) ->
@ -520,7 +526,7 @@ let check_signature ctxt signature shell contents =
Operation.check_signature key Operation.check_signature key
{ signature ; shell ; contents ; hash = dummy_hash } { signature ; shell ; contents ; hash = dummy_hash }
let parse_operations ctxt (operations, check) = let parse_operations ctxt () (operations, check) =
map_s begin fun raw -> map_s begin fun raw ->
begin begin
Lwt.return Lwt.return
@ -532,13 +538,14 @@ let parse_operations ctxt (operations, check) =
end end
end operations end operations
let () = register1 Services.Helpers.Parse.operations parse_operations let () =
register1 Services.Helpers.Parse.operations parse_operations
let parse_block _ctxt raw_block = let () =
Lwt.return (Block_header.parse raw_block) >>=? fun { proto } -> register1 Services.Helpers.Parse.block
return proto (fun _ctxt () raw_block ->
Lwt.return (Block_header.parse raw_block) >>=? fun { proto ; _ } ->
let () = register1 Services.Helpers.Parse.block parse_block return proto)
(*****) (*****)

11
lib_embedded_protocol_demo/src/services.ml
View File

@ -49,18 +49,17 @@ let failing_service custom_root =
~error: Data_encoding.empty ~error: Data_encoding.empty
RPC.Path.(custom_root / "failing") RPC.Path.(custom_root / "failing")
let rpc_services : Updater.rpc_context RPC.Directory.t = let rpc_services : Updater.rpc_context RPC.Directory.t = let dir = RPC.Directory.empty in
let dir = RPC.Directory.empty in
let dir = let dir =
RPC.register RPC.Directory.register
dir dir
(failing_service RPC.Path.open_root) (failing_service RPC.Path.open_root)
(fun _ctxt x -> Error.demo_error x >>= RPC.Answer.return) (fun _ctxt () x -> Error.demo_error x >>= RPC.Answer.return)
in in
let dir = let dir =
RPC.register RPC.Directory.register
dir dir
(echo_service RPC.Path.open_root) (echo_service RPC.Path.open_root)
(fun _ctxt x -> RPC.Answer.return x) (fun _ctxt () x -> RPC.Answer.return x)
in in
dir dir

4
lib_embedded_protocol_genesis/src/services.ml
View File

@ -63,10 +63,10 @@ let operations_hash =
let rpc_services : Updater.rpc_context RPC.Directory.t = let rpc_services : Updater.rpc_context RPC.Directory.t =
let dir = RPC.Directory.empty in let dir = RPC.Directory.empty in
let dir = let dir =
RPC.register RPC.Directory.register
dir dir
(Forge.block RPC.Path.open_root) (Forge.block RPC.Path.open_root)
(fun _ctxt ((_net_id, level, proto_level, predecessor, (fun _ctxt () ((_net_id, level, proto_level, predecessor,
timestamp, fitness), command) -> timestamp, fitness), command) ->
let shell = { Block_header.level ; proto_level ; predecessor ; let shell = { Block_header.level ; proto_level ; predecessor ;
timestamp ; fitness ; validation_passes = 0 ; operations_hash } in timestamp ; fitness ; validation_passes = 0 ; operations_hash } in

16
lib_node_http/RPC_server.ml
View File

@ -47,19 +47,3 @@ let octet_stream = {
| Some data -> Ok data | Some data -> Ok data
end ; end ;
} }
(* Compatibility layer, to be removed ASAP. *)
let empty = Directory.empty
let register d s f = Directory.register d s (fun p () i -> f p i)
open Directory.Curry
let register0 root s f = register root s (curry Z f)
let register1 root s f = register root s (curry (S Z) f)
let register2 root s f = register root s (curry (S (S Z)) f)
(* let register3 root s f = register root s (curry (S (S (S Z))) f) *)
(* let register4 root s f = register root s (curry (S (S (S (S Z)))) f) *)
(* let register5 root s f = register root s (curry (S (S (S (S (S Z))))) f) *)
let register_dynamic_directory1 =
Directory.register_dynamic_directory1

35
lib_node_http/RPC_server.mli
View File

@ -42,38 +42,3 @@ val launch :
(** Kill an RPC server. *) (** Kill an RPC server. *)
val shutdown : server -> unit Lwt.t val shutdown : server -> unit Lwt.t
(** Compatibility layer, to be removed ASAP. *)
val register:
'prefix Directory.t ->
([`POST], 'prefix, 'params, unit, 'input, 'output, unit) RPC.Service.t ->
('params -> 'input -> [< ('output, unit) RestoDirectory.Answer.t ] Lwt.t) ->
'prefix Directory.t
val register0:
unit Directory.t ->
([`POST], unit, unit, unit, 'i, 'o, unit) RPC.Service.t ->
('i -> [< ('o, unit) Answer.t ] Lwt.t) ->
unit Directory.t
val register1:
'prefix Directory.t ->
([`POST], 'prefix, unit * 'a, unit, 'i, 'o, unit) RPC.Service.t ->
('a -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
'prefix Directory.t
val register2:
'prefix Directory.t ->
([`POST], 'prefix, (unit * 'a) * 'b, unit, 'i, 'o, unit) RPC.Service.t ->
('a -> 'b -> 'i -> [< ('o, unit) Answer.t ] Lwt.t) ->
'prefix Directory.t
val register_dynamic_directory1:
?descr:string ->
'prefix Directory.t ->
('prefix, unit * 'a) RPC.Path.path ->
('a -> (unit * 'a) Directory.t Lwt.t) ->
'prefix Directory.t

160
lib_node_shell/node_rpc.ml
View File

@ -40,69 +40,69 @@ let monitor_operations node contents =
let register_bi_dir node dir = let register_bi_dir node dir =
let dir = let dir =
let implementation b include_ops = let implementation b () include_ops =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return (filter_bi include_ops bi) in RPC_server.Answer.return (filter_bi include_ops bi) in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.info implementation in Services.Blocks.info implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.hash in RPC_server.Answer.return bi.hash in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.hash Services.Blocks.hash
implementation in implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.net_id in RPC_server.Answer.return bi.net_id in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.net_id implementation in Services.Blocks.net_id implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.level in RPC_server.Answer.return bi.level in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.level implementation in Services.Blocks.level implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.predecessor in RPC_server.Answer.return bi.predecessor in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.predecessor implementation in Services.Blocks.predecessor implementation in
let dir = let dir =
let implementation b len = let implementation b () len =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
Node.RPC.predecessors node len bi.hash >>= fun hashes -> Node.RPC.predecessors node len bi.hash >>= fun hashes ->
RPC_server.Answer.return hashes in RPC_server.Answer.return hashes in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.predecessors implementation in Services.Blocks.predecessors implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.fitness in RPC_server.Answer.return bi.fitness in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.fitness implementation in Services.Blocks.fitness implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.timestamp in RPC_server.Answer.return bi.timestamp in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.timestamp implementation in Services.Blocks.timestamp implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.protocol in RPC_server.Answer.return bi.protocol in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.protocol implementation in Services.Blocks.protocol implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.block_info node b >>= fun bi -> Node.RPC.block_info node b >>= fun bi ->
RPC_server.Answer.return bi.test_network in RPC_server.Answer.return bi.test_network in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.test_network implementation in Services.Blocks.test_network implementation in
let dir = let dir =
let implementation b { Node_rpc_services.Blocks.contents ; monitor } = let implementation b () { Node_rpc_services.Blocks.contents ; monitor } =
match b with match b with
| `Prevalidation when monitor -> | `Prevalidation when monitor ->
monitor_operations node contents monitor_operations node contents
@ -116,18 +116,19 @@ let register_bi_dir node dir =
RPC_server.Answer.return @@ RPC_server.Answer.return @@
List.map (List.map (fun h -> h, None)) hashes List.map (List.map (fun h -> h, None)) hashes
in in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.operations implementation in Services.Blocks.operations implementation in
let dir = let dir =
let implementation b () = let implementation b () () =
Node.RPC.pending_operations node b >>= fun res -> Node.RPC.pending_operations node b >>= fun res ->
RPC_server.Answer.return res in RPC_server.Answer.return res in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.pending_operations Services.Blocks.pending_operations
implementation in implementation in
let dir = let dir =
let implementation let implementation
b { Services.Blocks.operations ; sort_operations ; b ()
{ Services.Blocks.operations ; sort_operations ;
timestamp ; proto_header} = timestamp ; proto_header} =
Node.RPC.preapply node b Node.RPC.preapply node b
~timestamp ~proto_header ~sort_operations operations >>= function ~timestamp ~proto_header ~sort_operations operations >>= function
@ -135,7 +136,7 @@ let register_bi_dir node dir =
RPC_server.Answer.return RPC_server.Answer.return
(Ok { Services.Blocks.shell_header ; operations }) (Ok { Services.Blocks.shell_header ; operations })
| Error _ as err -> RPC_server.Answer.return err in | Error _ as err -> RPC_server.Answer.return err in
RPC_server.register1 dir RPC_server.Directory.register1 dir
Services.Blocks.preapply implementation in Services.Blocks.preapply implementation in
dir dir
@ -240,7 +241,7 @@ let create_delayed_stream
stream stream
let list_blocks let list_blocks
node node ()
{ Services.Blocks.include_ops ; length ; heads ; monitor ; delay ; { Services.Blocks.include_ops ; length ; heads ; monitor ; delay ;
min_date; min_heads} = min_date; min_heads} =
let len = match length with None -> 1 | Some x -> x in let len = match length with None -> 1 | Some x -> x in
@ -328,11 +329,11 @@ let list_blocks
RPC_server.Answer.return_stream { next ; shutdown } RPC_server.Answer.return_stream { next ; shutdown }
end end
let list_invalid node () = let list_invalid node () () =
Node.RPC.list_invalid node >>= fun l -> Node.RPC.list_invalid node >>= fun l ->
RPC_server.Answer.return l RPC_server.Answer.return l
let list_protocols node {Services.Protocols.monitor; contents} = let list_protocols node () {Services.Protocols.monitor; contents} =
let monitor = match monitor with None -> false | Some x -> x in let monitor = match monitor with None -> false | Some x -> x in
let include_contents = match contents with None -> false | Some x -> x in let include_contents = match contents with None -> false | Some x -> x in
Node.RPC.protocols node >>= fun protocols -> Node.RPC.protocols node >>= fun protocols ->
@ -363,7 +364,7 @@ let list_protocols node {Services.Protocols.monitor; contents} =
end in end in
RPC_server.Answer.return_stream { next ; shutdown } RPC_server.Answer.return_stream { next ; shutdown }
let get_protocols node hash () = let get_protocols node hash () () =
Node.RPC.protocol_content node hash >>= function Node.RPC.protocol_content node hash >>= function
| Ok bytes -> RPC_server.Answer.return bytes | Ok bytes -> RPC_server.Answer.return bytes
| Error _ -> raise Not_found | Error _ -> raise Not_found
@ -371,9 +372,11 @@ let get_protocols node hash () =
let build_rpc_directory node = let build_rpc_directory node =
let dir = RPC_server.Directory.empty in let dir = RPC_server.Directory.empty in
let dir = let dir =
RPC_server.register0 dir Services.Blocks.list (list_blocks node) in RPC_server.Directory.register0 dir Services.Blocks.list
(list_blocks node) in
let dir = let dir =
RPC_server.register0 dir Services.Blocks.list_invalid (list_invalid node) in RPC_server.Directory.register0 dir Services.Blocks.list_invalid
(list_invalid node) in
let dir = register_bi_dir node dir in let dir = register_bi_dir node dir in
let dir = let dir =
let implementation block = let implementation block =
@ -382,22 +385,25 @@ let build_rpc_directory node =
| None -> Lwt.fail Not_found | None -> Lwt.fail Not_found
| Some context_dir -> Lwt.return context_dir) | Some context_dir -> Lwt.return context_dir)
(fun _ -> Lwt.return RPC_server.Directory.empty) in (fun _ -> Lwt.return RPC_server.Directory.empty) in
RPC_server.register_dynamic_directory1 RPC_server.Directory.register_dynamic_directory1
~descr: ~descr:
"All the RPCs which are specific to the protocol version." "All the RPCs which are specific to the protocol version."
dir Services.Blocks.proto_path implementation in dir Services.Blocks.proto_path implementation in
let dir = let dir =
RPC_server.register0 dir Services.Protocols.list (list_protocols node) in RPC_server.Directory.register0 dir Services.Protocols.list
(list_protocols node) in
let dir = let dir =
RPC_server.register1 dir Services.Protocols.contents (get_protocols node) in RPC_server.Directory.register1 dir Services.Protocols.contents
(get_protocols node) in
let dir = let dir =
let implementation header = let implementation () header =
let res = let res =
Data_encoding.Binary.to_bytes Block_header.encoding header in Data_encoding.Binary.to_bytes Block_header.encoding header in
RPC_server.Answer.return res in RPC_server.Answer.return res in
RPC_server.register0 dir Services.forge_block_header implementation in RPC_server.Directory.register0 dir Services.forge_block_header
implementation in
let dir = let dir =
let implementation let implementation ()
{ Node_rpc_services.raw ; blocking ; force ; operations } = { Node_rpc_services.raw ; blocking ; force ; operations } =
begin begin
Node.RPC.inject_block Node.RPC.inject_block
@ -405,89 +411,89 @@ let build_rpc_directory node =
raw operations >>=? fun (hash, wait) -> raw operations >>=? fun (hash, wait) ->
(if blocking then wait else return ()) >>=? fun () -> return hash (if blocking then wait else return ()) >>=? fun () -> return hash
end >>= RPC_server.Answer.return in end >>= RPC_server.Answer.return in
RPC_server.register0 dir Services.inject_block implementation in RPC_server.Directory.register0 dir Services.inject_block implementation in
let dir = let dir =
let implementation (contents, blocking, net_id, force) = let implementation () (contents, blocking, net_id, force) =
Node.RPC.inject_operation Node.RPC.inject_operation
node ?force ?net_id contents >>= fun (hash, wait) -> node ?force ?net_id contents >>= fun (hash, wait) ->
begin begin
(if blocking then wait else return ()) >>=? fun () -> return hash (if blocking then wait else return ()) >>=? fun () -> return hash
end >>= RPC_server.Answer.return in end >>= RPC_server.Answer.return in
RPC_server.register0 dir Services.inject_operation implementation in RPC_server.Directory.register0 dir Services.inject_operation implementation in
let dir = let dir =
let implementation (proto, blocking, force) = let implementation () (proto, blocking, force) =
Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) -> Node.RPC.inject_protocol ?force node proto >>= fun (hash, wait) ->
begin begin
(if blocking then wait else return ()) >>=? fun () -> return hash (if blocking then wait else return ()) >>=? fun () -> return hash
end >>= RPC_server.Answer.return in end >>= RPC_server.Answer.return in
RPC_server.register0 dir Services.inject_protocol implementation in RPC_server.Directory.register0 dir Services.inject_protocol implementation in
let dir = let dir =
let implementation () = let implementation () () =
RPC_server.Answer.return_stream (Node.RPC.bootstrapped node) in RPC_server.Answer.return_stream (Node.RPC.bootstrapped node) in
RPC_server.register0 dir Services.bootstrapped implementation in RPC_server.Directory.register0 dir Services.bootstrapped implementation in
let dir = let dir =
let implementation () = let implementation () () =
RPC_server.Answer.return RPC_server.Answer.return
Data_encoding.Json.(schema Error_monad.error_encoding) in Data_encoding.Json.(schema Error_monad.error_encoding) in
RPC_server.register0 dir Services.Error.service implementation in RPC_server.Directory.register0 dir Services.Error.service implementation in
let dir = let dir =
RPC_server.register1 dir Services.complete RPC_server.Directory.register1 dir Services.complete
(fun s () -> (fun s () () ->
Node.RPC.complete node s >>= RPC_server.Answer.return) in Node.RPC.complete node s >>= RPC_server.Answer.return) in
let dir = let dir =
RPC_server.register2 dir Services.Blocks.complete RPC_server.Directory.register2 dir Services.Blocks.complete
(fun block s () -> (fun block s () () ->
Node.RPC.complete node ~block s >>= RPC_server.Answer.return) in Node.RPC.complete node ~block s >>= RPC_server.Answer.return) in
(* Network : Global *) (* Network : Global *)
let dir = let dir =
let implementation () = let implementation () () =
Node.RPC.Network.stat node |> RPC_server.Answer.return in Node.RPC.Network.stat node |> RPC_server.Answer.return in
RPC_server.register0 dir Services.Network.stat implementation in RPC_server.Directory.register0 dir Services.Network.stat implementation in
let dir = let dir =
let implementation () = let implementation () () =
RPC_server.Answer.return Distributed_db.Raw.supported_versions in RPC_server.Answer.return Distributed_db.Raw.supported_versions in
RPC_server.register0 dir Services.Network.versions implementation in RPC_server.Directory.register0 dir Services.Network.versions implementation in
let dir = let dir =
let implementation () = let implementation () () =
let stream, stopper = Node.RPC.Network.watch node in let stream, stopper = Node.RPC.Network.watch node in
let shutdown () = Lwt_watcher.shutdown stopper in let shutdown () = Lwt_watcher.shutdown stopper in
let next () = Lwt_stream.get stream in let next () = Lwt_stream.get stream in
RPC_server.Answer.return_stream { next ; shutdown } in RPC_server.Answer.return_stream { next ; shutdown } in
RPC_server.register0 dir Services.Network.events implementation in RPC_server.Directory.register0 dir Services.Network.events implementation in
let dir = let dir =
let implementation point timeout = let implementation point () timeout =
Node.RPC.Network.connect node point timeout >>= RPC_server.Answer.return in Node.RPC.Network.connect node point timeout >>= RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.connect implementation in RPC_server.Directory.register1 dir Services.Network.connect implementation in
(* Network : Connection *) (* Network : Connection *)
let dir = let dir =
let implementation peer_id () = let implementation peer_id () () =
Node.RPC.Network.Connection.info node peer_id |> RPC_server.Answer.return in Node.RPC.Network.Connection.info node peer_id |> RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.Connection.info implementation in RPC_server.Directory.register1 dir Services.Network.Connection.info implementation in
let dir = let dir =
let implementation peer_id wait = let implementation peer_id () wait =
Node.RPC.Network.Connection.kick node peer_id wait >>= RPC_server.Answer.return in Node.RPC.Network.Connection.kick node peer_id wait >>= RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.Connection.kick implementation in RPC_server.Directory.register1 dir Services.Network.Connection.kick implementation in
let dir = let dir =
let implementation () = let implementation () () =
Node.RPC.Network.Connection.list node |> RPC_server.Answer.return in Node.RPC.Network.Connection.list node |> RPC_server.Answer.return in
RPC_server.register0 dir Services.Network.Connection.list implementation in RPC_server.Directory.register0 dir Services.Network.Connection.list implementation in
(* Network : Peer_id *) (* Network : Peer_id *)
let dir = let dir =
let implementation state = let implementation () state =
Node.RPC.Network.Peer_id.list node ~restrict:state |> RPC_server.Answer.return in Node.RPC.Network.Peer_id.list node ~restrict:state |> RPC_server.Answer.return in
RPC_server.register0 dir Services.Network.Peer_id.list implementation in RPC_server.Directory.register0 dir Services.Network.Peer_id.list implementation in
let dir = let dir =
let implementation peer_id () = let implementation peer_id () () =
Node.RPC.Network.Peer_id.info node peer_id |> RPC_server.Answer.return in Node.RPC.Network.Peer_id.info node peer_id |> RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.Peer_id.info implementation in RPC_server.Directory.register1 dir Services.Network.Peer_id.info implementation in
let dir = let dir =
let implementation peer_id monitor = let implementation peer_id () monitor =
if monitor then if monitor then
let stream, stopper = Node.RPC.Network.Peer_id.watch node peer_id in let stream, stopper = Node.RPC.Network.Peer_id.watch node peer_id in
let shutdown () = Lwt_watcher.shutdown stopper in let shutdown () = Lwt_watcher.shutdown stopper in
@ -502,20 +508,20 @@ let build_rpc_directory node =
RPC_server.Answer.return_stream { next ; shutdown } RPC_server.Answer.return_stream { next ; shutdown }
else else
Node.RPC.Network.Peer_id.events node peer_id |> RPC_server.Answer.return in Node.RPC.Network.Peer_id.events node peer_id |> RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.Peer_id.events implementation in RPC_server.Directory.register1 dir Services.Network.Peer_id.events implementation in
(* Network : Point *) (* Network : Point *)
let dir = let dir =
let implementation state = let implementation () state =
Node.RPC.Network.Point.list node ~restrict:state |> RPC_server.Answer.return in Node.RPC.Network.Point.list node ~restrict:state |> RPC_server.Answer.return in
RPC_server.register0 dir Services.Network.Point.list implementation in RPC_server.Directory.register0 dir Services.Network.Point.list implementation in
let dir = let dir =
let implementation point () = let implementation point () () =
Node.RPC.Network.Point.info node point |> RPC_server.Answer.return in Node.RPC.Network.Point.info node point |> RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.Point.info implementation in RPC_server.Directory.register1 dir Services.Network.Point.info implementation in
let dir = let dir =
let implementation point monitor = let implementation point () monitor =
if monitor then if monitor then
let stream, stopper = Node.RPC.Network.Point.watch node point in let stream, stopper = Node.RPC.Network.Point.watch node point in
let shutdown () = Lwt_watcher.shutdown stopper in let shutdown () = Lwt_watcher.shutdown stopper in
@ -530,7 +536,7 @@ let build_rpc_directory node =
RPC_server.Answer.return_stream { next ; shutdown } RPC_server.Answer.return_stream { next ; shutdown }
else else
Node.RPC.Network.Point.events node point |> RPC_server.Answer.return in Node.RPC.Network.Point.events node point |> RPC_server.Answer.return in
RPC_server.register1 dir Services.Network.Point.events implementation in RPC_server.Directory.register1 dir Services.Network.Point.events implementation in
let dir = let dir =
RPC_server.Directory.register_describe_directory_service dir Services.describe in RPC_server.Directory.register_describe_directory_service dir Services.describe in
dir dir