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

Resto: lift the lwt monad into Resto.

Browse Source
This commit is contained in:
Grégoire Henry 2018-04-23 01:21:33 +02:00 committed by Benjamin Canou
parent b6b30875e4
commit f5e3fb17c0
16 changed files with 45 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/lib_protocol_environment/sigs/v1/RPC_context.mli
View File

@ -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 :

2
src/lib_protocol_environment/sigs/v1/RPC_directory.mli
View File

@ -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

2
src/lib_protocol_environment/sigs/v1/updater.mli
View File

@ -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

4
src/lib_protocol_environment/tezos_protocol_environment.ml
View File

@ -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 :

2
src/lib_protocol_environment/tezos_protocol_environment.mli
View File

@ -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

12
src/lib_shell/block_directory.ml
View File

@ -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)

10
src/lib_shell/chain_directory.ml
View File

@ -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 ->

2
src/lib_shell/chain_directory.mli
View File

@ -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

5
src/proto_alpha/lib_protocol/src/services_registration.ml
View File

@ -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 :=

11
src/proto_alpha/lib_protocol/test/helpers/block.ml
View File

@ -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

2
src/proto_alpha/lib_protocol/test/helpers/incremental.ml
View File

@ -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 ;

2
src/proto_demo/lib_protocol/src/services.ml
View File

@ -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

2
src/proto_genesis/lib_protocol/src/services.ml
View File

@ -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

4
vendors/ocplib-resto/lib_ezresto-directory/ezResto_directory.ml vendored
View File

@ -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)

28
vendors/ocplib-resto/lib_resto-directory/resto_directory.ml vendored
View File

@ -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 ->

2
vendors/ocplib-resto/lib_resto-directory/resto_directory.mli vendored
View File

@ -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