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

RPC: add HTTP methods and Content-Type headers.

Browse Source
This commit is contained in:
Guillem Rieu 2016-12-11 16:34:58 +01:00 committed by Benjamin Canou
parent a2758253ea
commit cc44053229
14 changed files with 390 additions and 64 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
src/.merlin
View File

@ -37,6 +37,7 @@ PKG git
PKG ipv6-multicast
PKG irmin
PKG lwt
PKG magic-mime
PKG mtime.os
PKG nocrypto
PKG ocplib-endian

3
src/Makefile
View File

@ -522,7 +522,8 @@ WEBCLIENT_IMPLS := \
webclient_main.ml
CLIENT_PACKAGES := \
${NODE_PACKAGES}
${NODE_PACKAGES} \
magic-mime \
EMBEDDED_CLIENT_PROTOCOLS := \
$(patsubst client/embedded/%/, \

4
src/client/client_generic_rpcs.ml
View File

@ -308,7 +308,7 @@ let call url cctxt =
| Error msg ->
cctxt.error "%s" msg
| Ok json ->
Client_node_rpcs.get_json cctxt args json >>= fun json ->
Client_node_rpcs.get_json cctxt `POST args json >>= fun json ->
cctxt.message
"Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)
end
@ -325,7 +325,7 @@ let call_with_json url json (cctxt: Client_commands.context) =
err
| Ok json ->
let open RPC.Description in
Client_node_rpcs.get_json cctxt args json >>= fun json ->
Client_node_rpcs.get_json cctxt `POST args json >>= fun json ->
cctxt.message
"Output:\n%s\n%!" (Data_encoding_ezjsonm.to_string json)

32
src/client/client_node_rpcs.ml
View File

@ -21,7 +21,7 @@ let log_response { log } cpt code ans =
log "requests" "<<<<%d: %s\n%s\n" cpt (Cohttp.Code.string_of_status code) ans
let cpt = ref 0
let make_request cctxt service json =
let make_request cctxt meth service json =
incr cpt ;
let cpt = !cpt in
let scheme = if Client_config.tls#get then "https" else "http" in
@ -35,7 +35,7 @@ let make_request cctxt service json =
catch
(fun () ->
let body = Cohttp_lwt_body.of_string reqbody in
Cohttp_lwt_unix.Client.post ~body uri >>= fun (code, ansbody) ->
Cohttp_lwt_unix.Client.call meth ~body uri >>= fun (code, ansbody) ->
log_request cctxt cpt string_uri reqbody >>= fun () ->
return (cpt, Unix.gettimeofday () -. tzero,
code.Cohttp.Response.status, ansbody))
@ -45,8 +45,8 @@ let make_request cctxt service json =
| e -> Printexc.to_string e in
cctxt.error "cannot connect to the RPC server (%s)" msg)
let get_streamed_json cctxt service json =
make_request cctxt service json >>= fun (_cpt, time, code, ansbody) ->
let get_streamed_json cctxt meth service json =
make_request cctxt meth service json >>= fun (_cpt, time, code, ansbody) ->
let ansbody = Cohttp_lwt_body.to_stream ansbody in
match code, ansbody with
| #Cohttp.Code.success_status, ansbody ->
@ -73,8 +73,8 @@ let get_streamed_json cctxt service json =
cctxt.error "the RPC server returned a non-success status (%s)"
(Cohttp.Code.string_of_status err)
let get_json cctxt service json =
make_request cctxt service json >>= fun (cpt, time, code, ansbody) ->
let get_json cctxt meth service json =
make_request cctxt meth service json >>= fun (cpt, time, code, ansbody) ->
Cohttp_lwt_body.to_string ansbody >>= fun ansbody ->
match code, ansbody with
| #Cohttp.Code.success_status, ansbody -> begin
@ -108,23 +108,23 @@ let parse_answer cctxt service path json =
| Ok v -> return v
let call_service0 cctxt service arg =
let path, arg = RPC.forge_request service () arg in
get_json cctxt path arg >>= fun json ->
let meth, path, arg = RPC.forge_request service () arg in
get_json cctxt meth path arg >>= fun json ->
parse_answer cctxt service path json
let call_service1 cctxt service a1 arg =
let path, arg = RPC.forge_request service ((), a1) arg in
get_json cctxt path arg >>= fun json ->
let meth, path, arg = RPC.forge_request service ((), a1) arg in
get_json cctxt meth path arg >>= fun json ->
parse_answer cctxt service path json
let call_service2 cctxt service a1 a2 arg =
let path, arg = RPC.forge_request service (((), a1), a2) arg in
get_json cctxt path arg >>= fun json ->
let meth, path, arg = RPC.forge_request service (((), a1), a2) arg in
get_json cctxt meth path arg >>= fun json ->
parse_answer cctxt service path json
let call_streamed_service0 cctxt service arg =
let path, arg = RPC.forge_request service () arg in
get_streamed_json cctxt path arg >|= fun st ->
let meth, path, arg = RPC.forge_request service () arg in
get_streamed_json cctxt meth path arg >|= fun st ->
Lwt_stream.map_s (parse_answer cctxt service path) st
module Services = Node_rpc_services
@ -150,8 +150,8 @@ let complete cctxt ?block prefix =
| Some block ->
call_service2 cctxt Services.Blocks.complete block prefix ()
let describe cctxt ?recurse path =
let prefix, arg = RPC.forge_request Services.describe () recurse in
get_json cctxt (prefix @ path) arg >>=
let meth, prefix, arg = RPC.forge_request Services.describe () recurse in
get_json cctxt meth (prefix @ path) arg >>=
parse_answer cctxt Services.describe prefix
module Blocks = struct

2
src/client/client_node_rpcs.mli
View File

@ -185,7 +185,7 @@ val describe:
val get_json:
Client_commands.context ->
string list -> Data_encoding.json -> Data_encoding.json Lwt.t
RPC.meth -> string list -> Data_encoding.json -> Data_encoding.json Lwt.t
val call_service0:
Client_commands.context ->

5
src/client/embedded/alpha/webclient/browser/webclient_main.ml
View File

@ -26,7 +26,8 @@ let call_service service params input =
(module Json_repr_browser.Repr)
(module Json_repr.Ezjsonm)
(Js._JSON##parse body) in
let path, json = RPC.forge_request service params input in
let meth, path, json = RPC.forge_request service params input in
let meth_str = RPC.string_of_method meth in
let url = String.concat "/" path in
let xhr = XmlHttpRequest.create () in
let t, u = Lwt.wait () in
@ -34,7 +35,7 @@ let call_service service params input =
if xhr##.readyState = XmlHttpRequest.DONE then
let response = read_json_body xhr##.responseText in
Lwt.wakeup u response) ;
xhr##_open (Js.string "POST") (Js.string url) Js._true ;
xhr##_open (Js.string meth_str) (Js.string url) Js._true ;
xhr##send (Js.Opt.return (write_json_body json)) ;
t >>= fun json ->
match RPC.read_answer service json with

245
src/minutils/RPC.ml
View File

@ -7,18 +7,247 @@
(* *)
(**************************************************************************)
open Lwt.Infix
module Arg = Resto.Arg
module Path = Resto.Path
module Description = Resto.Description
let read_answer = Resto.read_answer
let forge_request = Resto.forge_request
let service ?description ~input ~output path =
(* Services *)
(* HTTP methods as defined in Cohttp.Code *)
type meth = [
| `GET
| `POST
| `HEAD
| `DELETE
| `PATCH
| `PUT
| `OPTIONS
| `TRACE
| `CONNECT
| `Other of string
]
type ('prefix, 'params, 'input, 'output) service =
meth * ('prefix, 'params, 'input, 'output) Resto.service
(* The default HTTP method for services *)
let default_meth = `POST
(* Commonly used REST HTTP methods *)
let rest_meths = [`GET; `POST; `HEAD; `DELETE; `PATCH; `PUT; `OPTIONS]
let string_of_method = function
| `GET -> "GET"
| `POST -> "POST"
| `HEAD -> "HEAD"
| `DELETE -> "DELETE"
| `PATCH -> "PATCH"
| `PUT -> "PUT"
| `OPTIONS -> "OPTIONS"
| `TRACE -> "TRACE"
| `CONNECT -> "CONNECT"
| `Other s -> s
let service ?(meth = default_meth) ?description ~input ~output path =
(meth,
Resto.service
?description
~input:(Data_encoding.Json.convert input)
~output:(Data_encoding.Json.convert output)
path
type ('prefix, 'params, 'input, 'output) service =
('prefix, 'params, 'input, 'output) Resto.service
path)
include RestoDirectory
(* REST services *)
(* GET service: no input body *)
let get_service ?description ~output path =
service ~meth:`GET ?description
~input:Data_encoding.empty ~output
path
(* HEAD service: same as GET, but without output body *)
let head_service ?description path =
service ~meth:`HEAD ?description
~input:Data_encoding.empty ~output:Data_encoding.empty
path
let post_service ?description ~input ~output path =
service ~meth:`POST ?description ~input ~output path
let put_service ?description ~input ~output path =
service ~meth:`PUT ?description ~input ~output path
let delete_service ?description ~input ~output path =
service ~meth:`DELETE ?description ~input ~output path
let prefix p (meth, s) = (meth, RestoDirectory.prefix p s)
let forge_request (meth, service) params input =
let path, arg = Resto.forge_request service params input in
meth, path, arg
let read_answer (_meth, service) json =
Resto.read_answer service json
module Description = struct
include Resto.Description
let service ?(meth = default_meth) ?description path =
(meth, Resto.Description.service ?description path)
end
module Answer = RestoDirectory.Answer
type step =
| Static of string
| Dynamic of Arg.descr
type conflict =
| CService
| CDir
| CBuilder
| CCustom
| CTypes of Arg.descr * Arg.descr
| CType of Arg.descr * string list
exception Conflict of step list * conflict
exception Cannot_parse of Arg.descr * string * string list
(* Dispatch *)
type 'prefix directory = (meth * 'prefix RestoDirectory.directory) list
let empty = []
let map_dirs f dirs =
List.map (fun (meth, dir) -> (meth, f ~meth dir)) dirs
let map f dirs =
map_dirs (fun ~meth:_ dir -> RestoDirectory.map f dir) dirs
let prefix path dirs =
map_dirs (fun ~meth:_ dir -> RestoDirectory.prefix path dir) dirs
let merge dirs1 dirs2 =
let compare (meth1, _dir1) (meth2, _dir2) = compare meth1 meth2 in
let f (meth1, dir1) (_, dir2) = (meth1, RestoDirectory.merge dir1 dir2) in
Utils.merge_list2 ~compare ~f dirs1 dirs2
(*****************************************************************************
* Registration
****************************************************************************)
(** [replace_assoc ~init ~f k l] searches for value corresponding to [k] in an
association list, and replaces it with [f value]. If not found, a new pair
[(k, f init)] is added to the list. *)
(* TODO: move to Utils? *)
let replace_assoc ?(finalize = List.rev) ~init ~f key l =
let rec aux acc = function
| [] -> finalize ((key, f init) :: acc)
| (k, v) :: tl when k = key -> finalize ((key, f v) :: acc) @ tl
| hd :: tl -> aux (hd :: acc) tl
in
aux [] l
(* Register [service] to the directory with corresponding [meth] using [reg] *)
let register dirs (meth, service) handler =
let init = RestoDirectory.empty in
let f dir = RestoDirectory.register dir service handler in
replace_assoc ~init ~f meth dirs
(* Register dynamic directory *)
(* By default, the [builder] function of dynamic directory is registered for
HTTP methods listed in [rest_meths] *)
let register_dynamic_directory
?(meths = rest_meths) ?descr init_dirs path builder =
let builder' ~meth prefix =
builder prefix >>= fun dirs ->
Lwt.return (List.assoc meth dirs)
in
let init = RestoDirectory.empty in
List.fold_left (fun dirs meth ->
let f dir =
RestoDirectory.register_dynamic_directory
?descr dir path (builder' ~meth)
in
replace_assoc ~init ~f meth dirs)
init_dirs meths
(* Register custom lookup *)
type custom_lookup = RestoDirectory.custom_lookup
let register_custom_lookup ?(meth = default_meth) ?descr dirs s f =
let init = RestoDirectory.empty in
let f dir = RestoDirectory.register_custom_lookup ?descr dir s f in
replace_assoc ~init ~f meth dirs
(* Register description service *)
let register_describe_directory_service dirs (meth, service) =
let init = RestoDirectory.empty in
let f dir = RestoDirectory.register_describe_directory_service dir service in
replace_assoc ~init ~f meth dirs
(*****************************************************************************
* Lookup
****************************************************************************)
let lookup dirs ?(meth = default_meth) args path =
let dir = List.assoc meth dirs in
RestoDirectory.lookup dir args path
(*****************************************************************************
* Currying
****************************************************************************)
(* Service registration *)
let register0 root s f =
register root s RestoDirectory.Internal.(curry Z f)
let register1 root s f =
register root s RestoDirectory.Internal.(curry (S Z) f)
let register2 root s f =
register root s RestoDirectory.Internal.(curry (S (S Z)) f)
let register3 root s f =
register root s RestoDirectory.Internal.(curry (S (S (S Z))) f)
let register4 root s f =
register root s RestoDirectory.Internal.(curry (S (S (S (S Z)))) f)
let register5 root s f =
register root s RestoDirectory.Internal.(curry (S (S (S (S (S Z))))) f)
(* Dynamic directory registration *)
let register_dynamic_directory1 ?descr root s f =
register_dynamic_directory
?descr root s RestoDirectory.Internal.(curry (S Z) f)
let register_dynamic_directory2 ?descr root s f =
register_dynamic_directory
?descr root s RestoDirectory.Internal.(curry (S (S Z)) f)
let register_dynamic_directory3 ?descr root s f =
register_dynamic_directory
?descr root s RestoDirectory.Internal.(curry (S (S (S Z))) f)
(* Custom lookup registration *)
let register_custom_lookup1 ?meth ?descr root s f =
register_custom_lookup ?meth ?descr root s
RestoDirectory.Internal.(curry (S Z) f)
let register_custom_lookup2 ?meth ?descr root s f =
register_custom_lookup ?meth ?descr root s
RestoDirectory.Internal.(curry (S (S Z)) f)
let register_custom_lookup3 ?meth ?descr root s f =
register_custom_lookup ?meth ?descr root s
RestoDirectory.Internal.(curry (S (S (S Z))) f)

75
src/minutils/RPC.mli
View File

@ -59,10 +59,60 @@ module Path : sig
end
(** HTTP methods as defined in Cohttp.Code *)
type meth = [
| `GET
| `POST
| `HEAD
| `DELETE
| `PATCH
| `PUT
| `OPTIONS
| `TRACE
| `CONNECT
| `Other of string
]
val string_of_method : meth -> string
(** Services. *)
type ('prefix, 'params, 'input, 'output) service
val service:
?meth: meth ->
?description: string ->
input: 'input Data_encoding.t ->
output: 'output Data_encoding.t ->
('prefix, 'params) Path.path ->
('prefix, 'params, 'input, 'output) service
val get_service:
?description: string ->
output: 'output Data_encoding.t ->
('prefix, 'params) Path.path ->
('prefix, 'params, unit, 'output) service
val head_service:
?description: string ->
('prefix, 'params) Path.path ->
('prefix, 'params, unit, unit) service
val post_service:
?description: string ->
input: 'input Data_encoding.t ->
output: 'output Data_encoding.t ->
('prefix, 'params) Path.path ->
('prefix, 'params, 'input, 'output) service
val put_service:
?description: string ->
input: 'input Data_encoding.t ->
output: 'output Data_encoding.t ->
('prefix, 'params) Path.path ->
('prefix, 'params, 'input, 'output) service
val delete_service:
?description: string ->
input: 'input Data_encoding.t ->
output: 'output Data_encoding.t ->
@ -76,7 +126,7 @@ val prefix:
val forge_request:
(unit, 'params, 'input, 'output) service ->
'params -> 'input -> string list * Data_encoding.json
'params -> 'input -> meth * string list * Data_encoding.json
val read_answer:
(unit, 'params, 'input, 'output) service ->
@ -105,6 +155,7 @@ module Description : sig
| Arg of Arg.descr * directory_descr
val service:
?meth: meth ->
?description:string ->
('prefix, 'params) Path.path ->
('prefix, 'params, bool option, directory_descr) service
@ -141,7 +192,7 @@ end
(** Dispatch tree *)
type 'prefix directory
(** Empty tree *)
(** Empty list of dispatch trees *)
val empty: 'prefix directory
val map: ('a -> 'b) -> 'b directory -> 'a directory
@ -206,9 +257,11 @@ val register5:
(** Registring dynamic subtree. *)
val register_dynamic_directory:
?meths:meth list ->
?descr:string ->
'prefix directory ->
('prefix, 'a) Path.path -> ('a -> 'a directory Lwt.t) ->
('prefix, 'a) Path.path ->
('a -> 'a directory Lwt.t) ->
'prefix directory
(** Registring dynamic subtree. (Curryfied variant) *)
@ -234,13 +287,14 @@ val register_dynamic_directory3:
'prefix directory
(** Registring custom directory lookup. *)
type custom_lookup =
| CustomService of Description.service_descr *
( Data_encoding.json option ->
Data_encoding.json Answer.answer Lwt.t )
| CustomDirectory of Description.directory_descr
type custom_lookup = RestoDirectory.custom_lookup
(* | CustomService of Description.service_descr * *)
(* ( Data_encoding.json option -> *)
(* Data_encoding.json Answer.answer Lwt.t ) *)
(* | CustomDirectory of Description.directory_descr *)
val register_custom_lookup:
?meth:meth ->
?descr:string ->
'prefix directory ->
('prefix, 'params) Path.path ->
@ -248,6 +302,7 @@ val register_custom_lookup:
'prefix directory
val register_custom_lookup1:
?meth:meth ->
?descr:string ->
'prefix directory ->
('prefix, unit * 'a) Path.path ->
@ -255,6 +310,7 @@ val register_custom_lookup1:
'prefix directory
val register_custom_lookup2:
?meth:meth ->
?descr:string ->
'prefix directory ->
('prefix, (unit * 'a) * 'b) Path.path ->
@ -262,6 +318,7 @@ val register_custom_lookup2:
'prefix directory
val register_custom_lookup3:
?meth:meth ->
?descr:string ->
'prefix directory ->
('prefix, ((unit * 'a) * 'b) * 'c) Path.path ->
@ -278,5 +335,5 @@ exception Cannot_parse of Arg.descr * string * string list
(** Resolve a service. *)
val lookup:
'prefix directory -> 'prefix -> string list ->
'prefix directory -> ?meth:meth -> 'prefix -> string list ->
(Data_encoding.json option -> Data_encoding.json Answer.answer Lwt.t) Lwt.t

26
src/node/net/RPC_server.ml
View File

@ -82,7 +82,12 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
Lwt.catch
(fun () ->
hook (Uri.path (Cohttp.Request.uri req))
>>= fun { Answer.code ; body } ->
>>= fun (content_type, { Answer.code ; body }) ->
let headers =
match content_type with
| None -> Cohttp.Header.init ()
| Some ct -> Cohttp.Header.init_with "Content-Type" ct
in
if code = 404 && not answer_404 then
Lwt.return None
else
@ -96,7 +101,7 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
create_stream io con (fun s -> s) s in
Cohttp_lwt_body.of_stream stream in
Lwt.return_some
(Response.make ~flush:true ~status:(`Code code) (),
(Response.make ~flush:true ~status:(`Code code) ~headers (),
body))
(function
| Not_found -> Lwt.return None
@ -114,16 +119,20 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
| Some res ->
Lwt.return res
| None ->
lookup root () path >>= fun handler ->
lookup root ~meth:req.meth () path >>= fun handler ->
begin
match req.meth with
| `POST -> begin
| `POST
| `PUT
| `PATCH
| `DELETE -> begin
Cohttp_lwt_body.to_string body >>= fun body ->
match Data_encoding_ezjsonm.from_string body with
| Error msg -> Lwt.fail (Cannot_parse_body msg)
| Ok body -> Lwt.return (Some body)
end
| `GET -> Lwt.return None
| `GET
| `HEAD -> Lwt.return None
| `OPTIONS -> Lwt.fail Options_preflight
| _ -> Lwt.fail Invalid_method
end >>= fun body ->
@ -142,7 +151,12 @@ let launch ?pre_hook ?post_hook ?(host="::") mode root cors_allowed_origins cors
(if Cohttp.Code.is_error code
then "failed"
else "success") >>= fun () ->
let headers = make_cors_headers cors_allowed_headers cors_allowed_origins origin_header in
let headers =
Cohttp.Header.init_with "Content-Type" "application/json" in
let headers =
make_cors_headers ~headers
cors_allowed_headers cors_allowed_origins origin_header
in
Lwt.return (Response.make
~flush:true ~status:(`Code code) ~headers (), body))
(function

8
src/node/net/RPC_server.mli
View File

@ -34,10 +34,12 @@ type server
before resolving each request, to delegate the answering to
another resolution mechanism. Its result is ignored if the return
code is [404]. The optional [post_hook] is called if both the
[pre_hook] and the serviced answered with a [404] code. *)
[pre_hook] and the serviced answered with a [404] code. [pre_hook] and
[post_hook] return a pair made of an optional Content-Type value and the
answer. *)
val launch :
?pre_hook: (string -> string RPC.Answer.answer Lwt.t) ->
?post_hook: (string -> string RPC.Answer.answer Lwt.t) ->
?pre_hook: (string -> (string option * string RPC.Answer.answer) Lwt.t) ->
?post_hook: (string -> (string option * string RPC.Answer.answer) Lwt.t) ->
?host:string ->
Conduit_lwt_unix.server ->
unit RPC.directory ->

5
src/node/shell/node_rpc_services.ml
View File

@ -19,12 +19,13 @@ module Error = struct
RPC.Path.(root / "errors")
let encoding =
let path, _ = RPC.forge_request service () () in
let meth, path, _ = RPC.forge_request service () () in
describe
~description:
(Printf.sprintf
"The full list of error is available with \
the global RPC `/%s`" (String.concat "/" path))
the global RPC `%s /%s`"
(RPC.string_of_method meth) (String.concat "/" path))
(conv
~schema:Json_schema.any
(fun exn -> `A (List.map json_of_error exn))

15
src/proto/environment/RPC.mli
View File

@ -57,7 +57,22 @@ end
(** Services. *)
type ('prefix, 'params, 'input, 'output) service
(** HTTP methods as defined in Cohttp.Code *)
type meth = [
| `GET
| `POST
| `HEAD
| `DELETE
| `PATCH
| `PUT
| `OPTIONS
| `TRACE
| `CONNECT
| `Other of string
]
val service:
?meth: meth ->
?description: string ->
input: 'input Data_encoding.t ->
output: 'output Data_encoding.t ->

1
src/tezos-deps.opam
View File

@ -37,6 +37,7 @@ depends: [
"tyxml"
"js_of_ocaml"
"sodium" {>= "0.3.0" }
"magic-mime"
"kaputt" # { test }
"bisect_ppx" # { test }
]

32
src/webclient_main.ml
View File

@ -125,14 +125,14 @@ let root =
Lwt.return directory) in
root
let find_static_file path =
let path = OCamlRes.Path.of_string path in
let find_static_file path_str =
let path = OCamlRes.Path.of_string path_str in
let index path = match path with
| ([], None) -> ([], Some ("index", Some "html"))
| oth -> oth in
| [], None -> "text/html", ([], Some ("index", Some "html"))
| oth -> Magic_mime.lookup path_str, oth in
match path with
| ("block" :: block :: path, file) ->
let path = index (path, file) in
let content_type, path = index (path, file) in
(match Node_rpc_services.Blocks.parse_block block with
| Ok block ->
block_protocol Client_commands.ignore_context block >>= fun version ->
@ -140,29 +140,33 @@ let find_static_file path =
(try
let root =
Webclient_version.find_contextual_static_files version in
Some (OCamlRes.Res.find path root)
Some (content_type, OCamlRes.Res.find path root)
with Not_found -> None)
| Error _ -> Lwt.return None)
| _ ->
Lwt.return
(try
Some (OCamlRes.Res.find (index path) Webclient_static.root)
let content_type, path = index path in
Some (content_type, OCamlRes.Res.find path Webclient_static.root)
with Not_found -> None)
let http_proxy mode =
let pre_hook path =
find_static_file path >>= function
| Some body ->
Lwt.return { RPC.Answer.code = 200 ; body = RPC.Answer.Single body }
| Some (content_type, body) ->
Lwt.return
(Some content_type,
{ RPC.Answer.code = 200 ; body = RPC.Answer.Single body })
| None ->
Lwt.return { RPC.Answer.code = 404 ; body = RPC.Answer.Empty } in
Lwt.return
(None, { RPC.Answer.code = 404 ; body = RPC.Answer.Empty }) in
let post_hook _ =
(find_static_file "not_found.html" >>= function
| Some body ->
Lwt.return (RPC.Answer.Single body)
| Some (content_type, body) ->
Lwt.return (Some content_type, RPC.Answer.Single body)
| None ->
Lwt.return (RPC.Answer.Empty)) >>= fun body ->
Lwt.return { RPC.Answer.code = 404 ; body } in
Lwt.return (None, RPC.Answer.Empty)) >>= fun (content_type, body) ->
Lwt.return (content_type, { RPC.Answer.code = 404 ; body }) in
RPC_server.launch ~pre_hook ~post_hook mode root [] []
let web_port = Client_config.in_both_groups @@