From f5e3fb17c04d71cc39a02771875a6002ecd3c99c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Mon, 23 Apr 2018 01:21:33 +0200 Subject: [PATCH] Resto: lift the lwt monad into Resto. --- .../sigs/v1/RPC_context.mli | 2 +- .../sigs/v1/RPC_directory.mli | 2 +- .../sigs/v1/updater.mli | 2 +- .../tezos_protocol_environment.ml | 4 +-- .../tezos_protocol_environment.mli | 2 +- src/lib_shell/block_directory.ml | 12 ++++---- src/lib_shell/chain_directory.ml | 10 +++---- src/lib_shell/chain_directory.mli | 2 +- .../lib_protocol/src/services_registration.ml | 5 ++-- .../lib_protocol/test/helpers/block.ml | 11 ++++---- .../lib_protocol/test/helpers/incremental.ml | 2 +- src/proto_demo/lib_protocol/src/services.ml | 2 +- .../lib_protocol/src/services.ml | 2 +- .../ezResto_directory.ml | 4 +-- .../lib_resto-directory/resto_directory.ml | 28 +++++++++---------- .../lib_resto-directory/resto_directory.mli | 2 +- 16 files changed, 45 insertions(+), 47 deletions(-) diff --git a/src/lib_protocol_environment/sigs/v1/RPC_context.mli b/src/lib_protocol_environment/sigs/v1/RPC_context.mli index 851fb2eff..138c68cf7 100644 --- a/src/lib_protocol_environment/sigs/v1/RPC_context.mli +++ b/src/lib_protocol_environment/sigs/v1/RPC_context.mli @@ -1,5 +1,5 @@ -type t = Updater.rpc_context Lwt.t +type t = Updater.rpc_context class type ['pr] simple = object method call_proto_service0 : diff --git a/src/lib_protocol_environment/sigs/v1/RPC_directory.mli b/src/lib_protocol_environment/sigs/v1/RPC_directory.mli index 3049220db..95b51251a 100644 --- a/src/lib_protocol_environment/sigs/v1/RPC_directory.mli +++ b/src/lib_protocol_environment/sigs/v1/RPC_directory.mli @@ -14,7 +14,7 @@ type 'prefix directory = 'prefix t (** Empty list of dispatch trees *) val empty: 'prefix directory -val map: ('a -> 'b) -> 'b directory -> 'a directory +val map: ('a -> 'b Lwt.t) -> 'b directory -> 'a directory val prefix: ('pr, 'p) RPC_path.path -> 'p directory -> 'pr directory val merge: 'a directory -> 'a directory -> 'a directory diff --git a/src/lib_protocol_environment/sigs/v1/updater.mli b/src/lib_protocol_environment/sigs/v1/updater.mli index df4f21f91..0765d28bb 100644 --- a/src/lib_protocol_environment/sigs/v1/updater.mli +++ b/src/lib_protocol_environment/sigs/v1/updater.mli @@ -188,7 +188,7 @@ module type PROTOCOL = sig (validation_result * block_header_metadata) tzresult Lwt.t (** The list of remote procedures exported by this implementation *) - val rpc_services: rpc_context Lwt.t RPC_directory.t + val rpc_services: rpc_context RPC_directory.t (** Initialize the context (or upgrade the context after a protocol amendment). This function receives the context resulting of the diff --git a/src/lib_protocol_environment/tezos_protocol_environment.ml b/src/lib_protocol_environment/tezos_protocol_environment.ml index 0839e4747..f824b6013 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.ml +++ b/src/lib_protocol_environment/tezos_protocol_environment.ml @@ -105,7 +105,7 @@ module Make (Context : CONTEXT) = struct val finalize_block: validation_state -> (validation_result * block_header_metadata) tzresult Lwt.t - val rpc_services: rpc_context Lwt.t RPC_directory.t + val rpc_services: rpc_context RPC_directory.t val init: context -> Block_header.shell_header -> validation_result tzresult Lwt.t end @@ -504,7 +504,7 @@ module Make (Context : CONTEXT) = struct end module RPC_context = struct - type t = rpc_context Lwt.t + type t = rpc_context class type ['pr] simple = object method call_proto_service0 : diff --git a/src/lib_protocol_environment/tezos_protocol_environment.mli b/src/lib_protocol_environment/tezos_protocol_environment.mli index af09e5dba..19d373b2b 100644 --- a/src/lib_protocol_environment/tezos_protocol_environment.mli +++ b/src/lib_protocol_environment/tezos_protocol_environment.mli @@ -98,7 +98,7 @@ module Make (Context : CONTEXT) : sig val finalize_block: validation_state -> (validation_result * block_header_metadata) tzresult Lwt.t - val rpc_services: rpc_context Lwt.t RPC_directory.t + val rpc_services: rpc_context RPC_directory.t val init: context -> Block_header.shell_header -> validation_result tzresult Lwt.t end diff --git a/src/lib_shell/block_directory.ml b/src/lib_shell/block_directory.ml index 9502985f3..0b7c206e5 100644 --- a/src/lib_shell/block_directory.ml +++ b/src/lib_shell/block_directory.ml @@ -316,11 +316,11 @@ let build_raw_rpc_directory !dir (RPC_directory.map (fun block -> - State.Block.context block >>= fun context -> - Lwt.return Tezos_protocol_environment_shell.{ - block_hash = State.Block.hash block ; - block_header = State.Block.shell_header block ; - context }) + State.Block.context block >|= fun context -> + { Tezos_protocol_environment_shell. + block_hash = State.Block.hash block ; + block_header = State.Block.shell_header block ; + context }) Next_proto.rpc_services) let get_protocol hash = @@ -364,5 +364,5 @@ let get_block chain_state = function let build_rpc_directory chain_state block = get_block chain_state block >>= fun block -> get_directory block >>= fun dir -> - Lwt.return (RPC_directory.map (fun _ -> block) dir) + Lwt.return (RPC_directory.map (fun _ -> Lwt.return block) dir) diff --git a/src/lib_shell/chain_directory.ml b/src/lib_shell/chain_directory.ml index dae314910..64a67145e 100644 --- a/src/lib_shell/chain_directory.ml +++ b/src/lib_shell/chain_directory.ml @@ -81,23 +81,23 @@ let list_blocks chain_state ?(length = 1) ?min_date heads = let rpc_directory = - let dir : State.Chain.t Lwt.t RPC_directory.t ref = + let dir : State.Chain.t RPC_directory.t ref = ref RPC_directory.empty in let register0 s f = dir := RPC_directory.register !dir (RPC_service.subst0 s) - (fun chain p q -> chain >>= fun chain -> f chain p q) in + (fun chain p q -> f chain p q) in let register1 s f = dir := RPC_directory.register !dir (RPC_service.subst1 s) - (fun (chain, a) p q -> chain >>= fun chain -> f chain a p q) in + (fun (chain, a) p q -> f chain a p q) in let register_dynamic_directory2 ?descr s f = dir := RPC_directory.register_dynamic_directory !dir ?descr (RPC_path.subst1 s) - (fun (chain, a) -> chain >>= fun chain -> f chain a) in + (fun (chain, a) -> f chain a) in register0 S.chain_id begin fun chain () () -> return (State.Chain.id chain) @@ -145,7 +145,7 @@ let build_rpc_directory validator = let register0 s f = dir := RPC_directory.register !dir (RPC_service.subst0 s) - (fun chain p q -> chain >>= fun chain -> f chain p q) in + (fun chain p q -> f chain p q) in register0 S.Mempool.pending_operations begin fun chain () () -> Validator.get_exn validator (State.Chain.id chain) >>= fun chain_validator -> diff --git a/src/lib_shell/chain_directory.mli b/src/lib_shell/chain_directory.mli index f231e5865..3de913f1f 100644 --- a/src/lib_shell/chain_directory.mli +++ b/src/lib_shell/chain_directory.mli @@ -10,6 +10,6 @@ val get_chain_id: State.t -> Chain_services.chain -> Chain_id.t Lwt.t val get_chain: State.t -> Chain_services.chain -> State.Chain.t Lwt.t -val rpc_directory: State.Chain.t Lwt.t RPC_directory.t +val rpc_directory: State.Chain.t RPC_directory.t val build_rpc_directory: Validator.t -> unit RPC_directory.t diff --git a/src/proto_alpha/lib_protocol/src/services_registration.ml b/src/proto_alpha/lib_protocol/src/services_registration.ml index c1b2f1002..a2222fd30 100644 --- a/src/proto_alpha/lib_protocol/src/services_registration.ml +++ b/src/proto_alpha/lib_protocol/src/services_registration.ml @@ -15,15 +15,14 @@ type rpc_context = { context: Alpha_context.t ; } -let rpc_init (rpc_context : Updater.rpc_context Lwt.t) = - rpc_context >>= fun { block_hash ; block_header ; context } -> +let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) = let level = block_header.level in let timestamp = block_header.timestamp in let fitness = block_header.fitness in Alpha_context.prepare ~level ~timestamp ~fitness context >>=? fun context -> return { block_hash ; block_header ; context } -let rpc_services = ref (RPC_directory.empty : Updater.rpc_context Lwt.t RPC_directory.t) +let rpc_services = ref (RPC_directory.empty : Updater.rpc_context RPC_directory.t) let register0_fullctxt s f = rpc_services := diff --git a/src/proto_alpha/lib_protocol/test/helpers/block.ml b/src/proto_alpha/lib_protocol/test/helpers/block.ml index 8941a68ac..7eb6ab367 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/block.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/block.ml @@ -20,12 +20,11 @@ type t = { } type block = t -let rpc_context block = - Lwt.return { - Alpha_environment.Updater.block_hash = block.hash ; - block_header = block.header.shell ; - context = block.context ; - } +let rpc_context block = { + Alpha_environment.Updater.block_hash = block.hash ; + block_header = block.header.shell ; + context = block.context ; +} let rpc_ctxt = new Alpha_environment.proto_rpc_context_of_directory diff --git a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml index 4b28a72ed..4cc352dbf 100644 --- a/src/proto_alpha/lib_protocol/test/helpers/incremental.ml +++ b/src/proto_alpha/lib_protocol/test/helpers/incremental.ml @@ -25,7 +25,7 @@ let level st = st.header.shell.level let rpc_context st = let result = Alpha_context.finalize st.state.ctxt in - Lwt.return { + { Alpha_environment.Updater.block_hash = Block_hash.zero ; block_header = { st.header.shell with fitness = result.fitness } ; context = result.context ; diff --git a/src/proto_demo/lib_protocol/src/services.ml b/src/proto_demo/lib_protocol/src/services.ml index 9b77a9086..bfa3700b5 100644 --- a/src/proto_demo/lib_protocol/src/services.ml +++ b/src/proto_demo/lib_protocol/src/services.ml @@ -23,7 +23,7 @@ let failing_service custom_root = ~output: Data_encoding.empty RPC_path.(custom_root / "failing") -let rpc_services : Updater.rpc_context Lwt.t RPC_directory.t = +let rpc_services : Updater.rpc_context RPC_directory.t = let dir = RPC_directory.empty in let dir = RPC_directory.register diff --git a/src/proto_genesis/lib_protocol/src/services.ml b/src/proto_genesis/lib_protocol/src/services.ml index af6bbc8e3..44b33995d 100644 --- a/src/proto_genesis/lib_protocol/src/services.ml +++ b/src/proto_genesis/lib_protocol/src/services.ml @@ -35,7 +35,7 @@ let int64_to_bytes i = let operations_hash = Operation_list_list_hash.compute [] -let rpc_services : Updater.rpc_context Lwt.t RPC_directory.t = +let rpc_services : Updater.rpc_context RPC_directory.t = let dir = RPC_directory.empty in let dir = RPC_directory.register diff --git a/vendors/ocplib-resto/lib_ezresto-directory/ezResto_directory.ml b/vendors/ocplib-resto/lib_ezresto-directory/ezResto_directory.ml index 92ac286ad..0b81247ca 100644 --- a/vendors/ocplib-resto/lib_ezresto-directory/ezResto_directory.ml +++ b/vendors/ocplib-resto/lib_ezresto-directory/ezResto_directory.ml @@ -31,7 +31,7 @@ exception Conflict = Directory.Conflict type directory = unit Directory.directory let empty = empty -let prefix path dir = (prefix path (map (fun _ -> ()) dir)) +let prefix path dir = (prefix path (map (fun _ -> Lwt.return_unit) dir)) let merge = merge let register d s h = register d s h @@ -44,7 +44,7 @@ let register5 d s h = register5 d s h let register_dynamic_directory ?descr dir path builder = register_dynamic_directory ?descr dir path - (fun p -> builder p >>= fun dir -> Lwt.return (map (fun _ -> ()) dir)) + (fun p -> builder p >>= fun dir -> Lwt.return (map (fun _ -> Lwt.return_unit) dir)) let register_dynamic_directory1 ?descr root s f = register_dynamic_directory ?descr root s Curry.(curry (S Z) f) diff --git a/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml b/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml index 26e0a6ee0..88cb4897b 100644 --- a/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml +++ b/vendors/ocplib-resto/lib_resto-directory/resto_directory.ml @@ -131,28 +131,28 @@ module Make (Encoding : ENCODING) = struct and 'key registered_service_builder = { meth : Resto.meth ; description : Encoding.schema Description.service ; - builder : 'key -> registered_service ; + builder : 'key -> registered_service Lwt.t ; } let empty = Empty let rec map_directory : type a b. - (a -> b) -> b directory -> a directory + (a -> b Lwt.t) -> b directory -> a directory = fun f t -> match t with | Empty -> Empty | Dynamic (descr, builder) -> - let builder a = builder (f a) >|= map_directory f in + let builder a = f a >>= builder >|= map_directory f in Dynamic (descr, builder) | DynamicTail (arg, dir) -> - DynamicTail (arg, map_directory (fun (x, l) -> (f x, l)) dir) + DynamicTail (arg, map_directory (fun (x, l) -> f x >|= fun x -> (x, l)) dir) | Static dir -> Static (map_static_directory f dir) and map_static_directory : type a b. - (a -> b) -> b static_directory -> a static_directory + (a -> b Lwt.t) -> b static_directory -> a static_directory = fun f t -> { services = MethMap.map (map_registered_service f) t.services ; subdirs = map_option (map_static_subdirectories f) t.subdirs ; @@ -160,20 +160,20 @@ module Make (Encoding : ENCODING) = struct and map_static_subdirectories : type a b. - (a -> b) -> b static_subdirectories -> a static_subdirectories + (a -> b Lwt.t) -> b static_subdirectories -> a static_subdirectories = fun f t -> match t with | Suffixes map -> Suffixes (StringMap.map (map_directory f) map) | Arg (arg, dir) -> - let dir = map_directory (fun (a, x) -> f a, x) dir in + let dir = map_directory (fun (a, x) -> f a >|= fun a -> (a, x)) dir in Arg (arg, dir) and map_registered_service : type a b. - (a -> b) -> b registered_service_builder -> a registered_service_builder + (a -> b Lwt.t) -> b registered_service_builder -> a registered_service_builder = fun f rs -> - { rs with builder = (fun p -> rs.builder (f p)) } + { rs with builder = (fun p -> f p >>= fun p -> rs.builder p) } let map = map_directory @@ -393,7 +393,7 @@ module Make (Encoding : ENCODING) = struct | [] -> Lwt.return_error `Not_found | l -> Lwt.return_error (`Method_not_allowed (List.map fst l)) end - | rs -> Lwt.return_ok (rs.builder args) + | rs -> rs.builder args >>= Lwt.return_ok end let lookup = @@ -490,8 +490,8 @@ module Make (Encoding : ENCODING) = struct | None -> Lwt.return (`Not_found None) | Some (Static { services ; _ }) -> begin try - let Service { handler ; types } = - (MethMap.find service.meth services).builder params in + (MethMap.find service.meth services).builder + params >>= fun (Service { handler ; types }) -> match Service.Internal.eq types service.types with | exception Service.Internal.Not_equal -> Lwt.return (`Not_found None) @@ -636,10 +636,10 @@ module Make (Encoding : ENCODING) = struct output = Encoding.schema s.types.output ; error = Encoding.schema s.types.error ; } in - let builder key = Service { + let builder key = Lwt.return (Service { types = s.types ; handler = handler key ; - } in + }) in { meth = s.meth ; description ; builder } in match dir with | Empty -> diff --git a/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli b/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli index 7badddb68..f41c46f33 100644 --- a/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli +++ b/vendors/ocplib-resto/lib_resto-directory/resto_directory.mli @@ -91,7 +91,7 @@ module Make (Encoding : ENCODING) : sig (** Empty tree *) val empty: 'prefix directory - val map: ('a -> 'b) -> 'b directory -> 'a directory + val map: ('a -> 'b Lwt.t) -> 'b directory -> 'a directory val prefix: ('pr, 'p) Path.path -> 'p directory -> 'pr directory val merge: 'a directory -> 'a directory -> 'a directory