Resto: lift the lwt monad into Resto.

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 :

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

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

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 :

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

src/lib_shell/block_directory.ml

@@ -316,8 +316,8 @@ let build_raw_rpc_directory
     !dir
     (RPC_directory.map
        (fun block ->
-          State.Block.context block >>= fun context ->
+          State.Block.context block >|= fun context ->
-          Lwt.return Tezos_protocol_environment_shell.{
+          { Tezos_protocol_environment_shell.
             block_hash = State.Block.hash block ;
             block_header = State.Block.shell_header block ;
             context })
@@ -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)
 

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

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

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) =
+let rpc_init ({ block_hash ; block_header ; context } : Updater.rpc_context) =
-  rpc_context >>= fun { block_hash ; block_header ; 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 :=

src/proto_alpha/lib_protocol/test/helpers/block.ml

@@ -20,12 +20,11 @@ type t = {
 }
 type block = t
 
-let rpc_context block =
+let rpc_context block = {
-  Lwt.return {
   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

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 ;

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

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

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)

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
-              (MethMap.find service.meth services).builder params in
+              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 ->

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