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

RPC: introduce Resto_cohttp.Client and RPC_clients.

Browse Source
This commit is contained in:
Grégoire Henry 2017-12-07 17:43:21 +01:00 committed by Benjamin Canou
parent 02fd021aa9
commit 4aa1b14ba6
16 changed files with 943 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lib_base/data_encoding_ezjsonm.ml
View File

@ -15,7 +15,9 @@ let to_root = function
| `Null -> `O []
| oth -> `A [ oth ]
let to_string j = Ezjsonm.to_string ~minify:false (to_root j)
let to_string ?minify j = Ezjsonm.to_string ?minify (to_root j)
let pp = Json_repr.(pp (module Ezjsonm))
let from_string s =
try Ok (Ezjsonm.from_string s :> Data_encoding.json)

4
lib_base/data_encoding_ezjsonm.mli
View File

@ -19,7 +19,9 @@ val from_stream : string Lwt_stream.t -> (Data_encoding.json, string) result Lwt
(** Write a JSON document to a string. This goes via an intermediate
buffer and so may be slow on large documents. *)
val to_string : Data_encoding.json -> string
val to_string : ?minify:bool -> Data_encoding.json -> string
val pp : Format.formatter -> Data_encoding.json -> unit
(** Loads a JSON file in memory *)
val read_file : string -> Data_encoding.json tzresult Lwt.t

358
lib_node_http/RPC_client.ml Normal file
View File

@ -0,0 +1,358 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module Client = Resto_cohttp.Client.Make(RPC.Data)
module type LOGGER = Client.LOGGER
type logger = (module LOGGER)
let null_logger = Client.null_logger
let timings_logger = Client.timings_logger
let full_logger = Client.full_logger
type ('o, 'e) rest_result =
[ `Ok of 'o
| `Conflict of 'e
| `Error of 'e
| `Forbidden of 'e
| `Not_found of 'e
| `Unauthorized of 'e ] tzresult
type content_type = (string * string)
type raw_content = Cohttp_lwt.Body.t * content_type option
type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
type rest_error =
| Empty_answer
| Connection_failed of string
| Not_found
| Bad_request of string
| Method_not_allowed of RPC.meth list
| Unsupported_media_type of string option
| Not_acceptable of { proposed: string ; acceptable: string }
| Unexpected_status_code of { code: Cohttp.Code.status_code ;
content: string ;
media_type: string option }
| Unexpected_content_type of { received: string ;
acceptable: string list }
| Unexpected_content of { content: string ;
media_type: string ;
error: string }
| Generic_error (* temporary *)
let rest_error_encoding =
let open Data_encoding in
union
[ case ~tag: 0
(obj1
(req "kind" (constant "empty_answer")))
(function Empty_answer -> Some () | _ -> None)
(fun () -> Empty_answer) ;
case ~tag: 1
(obj2
(req "kind" (constant "connection_failed"))
(req "message" string))
(function Connection_failed msg -> Some ((), msg) | _ -> None)
(function (), msg -> Connection_failed msg) ;
case ~tag: 2
(obj2
(req "kind" (constant "bad_request"))
(req "message" string))
(function Bad_request msg -> Some ((), msg) | _ -> None)
(function (), msg -> Bad_request msg) ;
case ~tag: 3
(obj2
(req "kind" (constant "method_not_allowed"))
(req "allowed" (list RPC.meth_encoding)))
(function Method_not_allowed meths -> Some ((), meths) | _ -> None)
(function ((), meths) -> Method_not_allowed meths) ;
case ~tag: 4
(obj2
(req "kind" (constant "unsupported_media_type"))
(opt "content_type" string))
(function Unsupported_media_type m -> Some ((), m) | _ -> None)
(function ((), m) -> Unsupported_media_type m) ;
case ~tag: 5
(obj3
(req "kind" (constant "not_acceptable"))
(req "proposed" string)
(req "acceptable" string))
(function
| Not_acceptable { proposed ; acceptable } ->
Some ((), proposed, acceptable)
| _ -> None)
(function ((), proposed, acceptable) ->
Not_acceptable { proposed ; acceptable }) ;
case ~tag: 6
(obj4
(req "kind" (constant "unexpected_status_code"))
(req "code" uint16)
(req "content" string)
(opt "media_type" string))
(function
| Unexpected_status_code { code ; content ; media_type } ->
Some ((), Cohttp.Code.code_of_status code, content, media_type)
| _ -> None)
(function ((), code, content, media_type) ->
let code = Cohttp.Code.status_of_code code in
Unexpected_status_code { code ; content ; media_type }) ;
case ~tag: 7
(obj3
(req "kind" (constant "unexpected_content_type"))
(req "received" string)
(req "acceptable" (list string)))
(function
| Unexpected_content_type { received ; acceptable } ->
Some ((), received, acceptable)
| _ -> None)
(function ((), received, acceptable) ->
Unexpected_content_type { received ; acceptable }) ;
case ~tag: 8
(obj4
(req "kind" (constant "unexpected_content"))
(req "content" string)
(req "media_type" string)
(req "error" string))
(function
| Unexpected_content { content ; media_type ; error } ->
Some ((), content, media_type, error)
| _ -> None)
(function ((), content, media_type, error) ->
Unexpected_content { content ; media_type ; error }) ;
]
let pp_rest_error ppf err =
match err with
| Empty_answer ->
Format.fprintf ppf
"The server answered with an empty response."
| Connection_failed msg ->
Format.fprintf ppf
"Unable to connect to the node: \"%s\"" msg
| Not_found ->
Format.fprintf ppf
"404 Not Found"
| Bad_request msg ->
Format.fprintf ppf
"@[<v 2>Oups! It looks like we forged an invalid HTTP request.@,%s@]"
msg
| Method_not_allowed meths ->
Format.fprintf ppf
"@[<v 2>The requested service only accepts the following method:@ %a@]"
(Format.pp_print_list
(fun ppf m -> Format.pp_print_string ppf (RPC.string_of_meth m)))
meths
| Unsupported_media_type None ->
Format.fprintf ppf
"@[<v 2>The server wants to known the media type we used.@]"
| Unsupported_media_type (Some media) ->
Format.fprintf ppf
"@[<v 2>The server does not support the media type we used: %s.@]"
media
| Not_acceptable { proposed ; acceptable } ->
Format.fprintf ppf
"@[<v 2>No intersection between the media types we accept and \
\ the ones the server is able to send.@,\
\ We proposed: %s@,\
\ The server is only able to serve: %s."
proposed acceptable
| Unexpected_status_code { code ; content ; _ } ->
Format.fprintf ppf
"@[<v 2>Unexpected error %d:@,%S"
(Cohttp.Code.code_of_status code) content
| Unexpected_content_type { received ; acceptable = _ } ->
Format.fprintf ppf
"The server answered with a media type we do not understand: %s" received
| Unexpected_content { content ; media_type ; error } ->
Format.fprintf ppf
"@[<v 2>Failed to parse the answer (%s):@,@[<v 2>error:@ %s@]@,@[<v 2>content:@ %S@]@]"
media_type error content
| Generic_error ->
Format.fprintf ppf
"Generic error"
type error +=
| Request_failed of { meth: RPC.meth ;
uri: Uri.t ;
error: rest_error }
let uri_encoding =
let open Data_encoding in
conv
Uri.to_string
Uri.of_string
string
let () =
register_error_kind `Permanent
~id:"rpc_client.request_failed"
~title:""
~description:""
~pp:(fun ppf (meth, uri, error) ->
Format.fprintf ppf
"@[<v 2>Rpc request failed:@ \
\ - meth: %s@ \
\ - uri: %s@ \
\ - error: %a@]"
(RPC.string_of_meth meth)
(Uri.to_string uri)
pp_rest_error error)
Data_encoding.(obj3
(req "meth" RPC.meth_encoding)
(req "uri" uri_encoding)
(req "error" rest_error_encoding))
(function
| Request_failed { uri ; error ; meth } -> Some (meth, uri, error)
| _ -> None)
(fun (meth, uri, error) -> Request_failed { uri ; meth ; error })
let request_failed meth uri error =
let meth = ( meth : [< RPC.meth ] :> RPC.meth) in
fail (Request_failed { meth ; uri ; error })
let generic_call ?logger ?accept ?body ?media meth uri : (content, content) rest_result Lwt.t =
Client.generic_call meth ?logger ?accept ?body ?media uri >>= function
| `Ok (Some v) -> return (`Ok v)
| `Ok None -> request_failed meth uri Empty_answer
| `Conflict _
| `Error _
| `Forbidden _
| `Unauthorized _
| `Not_found _ as v -> return v
| `Unexpected_status_code (code, (content, _, media_type)) ->
let media_type = Option.map media_type ~f:Media_type.name in
Cohttp_lwt.Body.to_string content >>= fun content ->
request_failed meth uri
(Unexpected_status_code { code ; content ; media_type })
| `Method_not_allowed allowed ->
let allowed = List.filter_map RPC.meth_of_string allowed in
request_failed meth uri (Method_not_allowed allowed)
| `Unsupported_media_type ->
let media = Option.map media ~f:Media_type.name in
request_failed meth uri (Unsupported_media_type media)
| `Not_acceptable acceptable ->
let proposed =
Option.unopt_map accept ~default:"" ~f:Media_type.accept_header in
request_failed meth uri (Not_acceptable { proposed ; acceptable })
| `Bad_request msg ->
request_failed meth uri (Bad_request msg)
| `Connection_failed msg ->
request_failed meth uri (Connection_failed msg)
let handle_error meth uri (body, media, _) f =
Cohttp_lwt.Body.is_empty body >>= fun empty ->
if empty then
return (f None)
else
match media with
| Some ("application", "json") | None -> begin
Cohttp_lwt.Body.to_string body >>= fun body ->
match Data_encoding_ezjsonm.from_string body with
| Ok body -> return (f (Some body))
| Error msg ->
request_failed meth uri
(Unexpected_content { content = body ;
media_type = Media_type.(name json) ;
error = msg })
end
| Some (l, r) ->
request_failed meth uri
(Unexpected_content_type { received = l^"/"^r ;
acceptable = [Media_type.(name json)] })
let generic_json_call ?logger ?body meth uri : (Data_encoding.json, Data_encoding.json option) rest_result Lwt.t =
let body =
Option.map body ~f:begin fun b ->
(Cohttp_lwt.Body.of_string (Data_encoding_ezjsonm.to_string b))
end in
let media = Media_type.json in
generic_call meth ?logger ~accept:[Media_type.json] ?body ~media uri >>=? function
| `Ok (body, (Some ("application", "json") | None), _) -> begin
Cohttp_lwt.Body.to_string body >>= fun body ->
match Data_encoding_ezjsonm.from_string body with
| Ok json -> return (`Ok json)
| Error msg ->
request_failed meth uri
(Unexpected_content { content = body ;
media_type = Media_type.(name json) ;
error = msg })
end
| `Ok (_body, Some (l, r), _) ->
request_failed meth uri
(Unexpected_content_type { received = l^"/"^r ;
acceptable = [Media_type.(name json)] })
| `Conflict body ->
handle_error meth uri body (fun v -> `Conflict v)
| `Error body ->
handle_error meth uri body (fun v -> `Error v)
| `Forbidden body ->
handle_error meth uri body (fun v -> `Forbidden v)
| `Not_found body ->
handle_error meth uri body (fun v -> `Not_found v)
| `Unauthorized body ->
handle_error meth uri body (fun v -> `Unauthorized v)
let handle accept (meth, uri, ans) =
match ans with
| `Ok (Some v) -> return v
| `Ok None -> request_failed meth uri Empty_answer
| `Not_found None -> request_failed meth uri Not_found
| `Conflict _ | `Error _ | `Forbidden _ | `Unauthorized _
| `Not_found (Some _) ->
request_failed meth uri Generic_error
| `Unexpected_status_code (code, (content, _, media_type)) ->
let media_type = Option.map media_type ~f:Media_type.name in
Cohttp_lwt.Body.to_string content >>= fun content ->
request_failed meth uri (Unexpected_status_code { code ; content ; media_type })
| `Method_not_allowed allowed ->
let allowed = List.filter_map RPC.meth_of_string allowed in
request_failed meth uri (Method_not_allowed allowed)
| `Unsupported_media_type ->
let name =
match Media_type.first_complete_media accept with
| None -> None
| Some ((l, r), _) -> Some (l^"/"^r) in
request_failed meth uri (Unsupported_media_type name)
| `Not_acceptable acceptable ->
let proposed =
Option.unopt_map (Some accept) ~default:"" ~f:Media_type.accept_header in
request_failed meth uri (Not_acceptable { proposed ; acceptable })
| `Bad_request msg ->
request_failed meth uri (Bad_request msg)
| `Unexpected_content ((content, media_type), error)
| `Unexpected_error_content ((content, media_type), error) ->
let media_type = Media_type.name media_type in
request_failed meth uri (Unexpected_content { content ; media_type ; error })
| `Unexpected_error_content_type (_, media)
| `Unexpected_content_type (_, media) ->
let received =
Option.unopt_map media ~default:"" ~f:(fun (l, r) -> l^"/"^r) in
request_failed meth uri
(Unexpected_content_type { received ;
acceptable = List.map Media_type.name accept })
| `Connection_failed msg ->
request_failed meth uri (Connection_failed msg)
let call_streamed_service
(type p q i o )
accept ?logger ~base (service : (_,_,p,q,i,o,_) RPC.Service.t)
~on_chunk ~on_close
(params : p) (query : q) (body : i) : (unit -> unit) tzresult Lwt.t =
Client.call_streamed_service
accept ?logger ~base ~on_chunk ~on_close
service params query body >>= fun ans ->
handle accept ans
let call_service
(type p q i o )
accept ?logger ~base (service : (_,_,p,q,i,o,_) RPC.Service.t)
(params : p)
(query : q) (body : i) : o tzresult Lwt.t =
Client.call_service
?logger ~base accept service params query body >>= fun ans ->
handle accept ans

90
lib_node_http/RPC_client.mli Normal file
View File

@ -0,0 +1,90 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
module type LOGGER = sig
type request
val log_empty_request: Uri.t -> request Lwt.t
val log_request:
?media:Media_type.t -> 'a Data_encoding.t ->
Uri.t -> string -> request Lwt.t
val log_response:
request -> ?media:Media_type.t -> 'a Data_encoding.t ->
Cohttp.Code.status_code -> string Lwt.t Lazy.t -> unit Lwt.t
end
type logger = (module LOGGER)
val null_logger: logger
val timings_logger: Format.formatter -> logger
val full_logger: Format.formatter -> logger
type ('o, 'e) rest_result =
[ `Ok of 'o
| `Conflict of 'e
| `Error of 'e
| `Forbidden of 'e
| `Not_found of 'e
| `Unauthorized of 'e ] tzresult
type content_type = (string * string)
type raw_content = Cohttp_lwt.Body.t * content_type option
type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
type rest_error =
| Empty_answer
| Connection_failed of string
| Not_found
| Bad_request of string
| Method_not_allowed of RPC.meth list
| Unsupported_media_type of string option
| Not_acceptable of { proposed: string ; acceptable: string }
| Unexpected_status_code of { code: Cohttp.Code.status_code ;
content: string ;
media_type: string option }
| Unexpected_content_type of { received: string ;
acceptable: string list }
| Unexpected_content of { content: string ;
media_type: string ;
error: string }
| Generic_error (* temporary *)
type error +=
| Request_failed of { meth: RPC.meth ;
uri: Uri.t ;
error: rest_error }
val generic_call :
?logger:logger ->
?accept:Media_type.t list ->
?body:Cohttp_lwt.Body.t ->
?media:Media_type.t ->
[< RPC.meth ] ->
Uri.t -> (content, content) rest_result Lwt.t
val generic_json_call :
?logger:logger ->
?body:Data_encoding.json ->
[< RPC.meth ] -> Uri.t ->
(Data_encoding.json, Data_encoding.json option) rest_result Lwt.t
val call_service :
Media_type.t list ->
?logger:logger ->
base:Uri.t ->
([< Resto.meth ], unit, 'p, 'q, 'i, 'o, 'e) RPC.Service.t ->
'p -> 'q -> 'i -> 'o tzresult Lwt.t
val call_streamed_service :
Media_type.t list ->
?logger:logger ->
base:Uri.t ->
([< Resto.meth ], unit, 'p, 'q, 'i, 'o, 'e) RPC.Service.t ->
on_chunk: ('o -> unit) ->
on_close: (unit -> unit) ->
'p -> 'q -> 'i -> (unit -> unit) tzresult Lwt.t

21
lib_node_http/media_type.ml
View File

@ -12,8 +12,19 @@ include Resto_cohttp.Media_type.Make(RPC.Data)
let json = {
name = Cohttp.Accept.MediaType ("application", "json") ;
q = Some 1000 ;
pp = begin fun _enc ppf raw ->
match Data_encoding_ezjsonm.from_string raw with
| Error err ->
Format.fprintf ppf
"@[Invalid JSON:@ \
\ - @[<v 2>Error:@ %s@]\
\ - @[<v 2>Raw data:@ %s@]@]"
err raw
| Ok json ->
Data_encoding_ezjsonm.pp ppf json
end ;
construct = begin fun enc v ->
Data_encoding_ezjsonm.to_string @@
Data_encoding_ezjsonm.to_string ~minify:true @@
Data_encoding.Json.construct enc v
end ;
destruct = begin fun enc body ->
@ -31,6 +42,14 @@ let json = {
let octet_stream = {
name = Cohttp.Accept.MediaType ("application", "octet-stream") ;
q = Some 500 ;
pp = begin fun enc ppf raw ->
match Data_encoding.Binary.of_bytes enc (MBytes.of_string raw) with
| None -> Format.fprintf ppf "Invalid bonary data."
| Some v ->
Format.fprintf ppf
";; binary equivalent of the following json@.%a"
Data_encoding_ezjsonm.pp (Data_encoding.Json.construct enc v)
end ;
construct = begin fun enc v ->
MBytes.to_string @@
Data_encoding.Binary.to_bytes enc v

3
lib_node_http/media_type.mli
View File

@ -10,10 +10,13 @@
type t = Resto_cohttp.Media_type.Make(RPC.Data).t = {
name: Cohttp.Accept.media_range ;
q: int option ;
pp: 'a. 'a Data_encoding.t -> Format.formatter -> string -> unit ;
construct: 'a. 'a Data_encoding.t -> 'a -> string ;
destruct: 'a. 'a Data_encoding.t -> string -> ('a, string) result ;
}
val name : t -> string
val json : t
val octet_stream : t

18
lib_node_services/RPC.ml
View File

@ -7,10 +7,20 @@
(* *)
(**************************************************************************)
let meth_encoding =
Data_encoding.string_enum
[ "GET", `GET ;
"POST", `POST ;
"DELETE", `DELETE ;
"PUT", `PUT ;
"PATCH", `PATCH ]
module Data = struct
type 'a t = 'a Data_encoding.t
type schema = Data_encoding.json_schema
let unit = Data_encoding.empty
let untyped = Data_encoding.(obj1 (req "untyped" string))
let conv f g t = Data_encoding.conv ~schema:(Data_encoding.Json.schema t) f g t
let schema = Data_encoding.Json.schema
module StringMap = Resto.StringMap
@ -24,14 +34,6 @@ module Data = struct
open Resto.Description
let meth_encoding =
Data_encoding.string_enum
[ "GET", `GET ;
"POST", `POST ;
"DELETE", `DELETE ;
"PUT", `PUT ;
"PATCH", `PATCH ]
let path_item_encoding =
let open Data_encoding in
union [

1
lib_node_services/RPC.mli
View File

@ -15,3 +15,4 @@ module Data : Resto.ENCODING with type 'a t = 'a Data_encoding.t
include (module type of struct include Resto end)
module Service : (module type of struct include Resto.MakeService(Data) end)
val meth_encoding: meth Data_encoding.t

2
test/utils/test_data_encoding.ml
View File

@ -113,7 +113,7 @@ let test_json testdir =
let open Data_encoding_ezjsonm in
let file = testdir // "testing_data_encoding.tezos" in
let v = `Float 42. in
let f_str = to_string v in
let f_str = to_string ~minify:false v in
Assert.equal_string ~msg:__LOC__ f_str "[\n 42\n]";
read_file (testdir // "NONEXISTINGFILE") >>= fun rf ->
Assert.is_error ~msg:__LOC__ rf ;

361
vendors/ocplib-resto/lib_resto-cohttp/client.ml vendored Normal file
View File

@ -0,0 +1,361 @@
(**************************************************************************)
(* *)
(* Copyright (c) 2014 - 2017. *)
(* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *)
(* *)
(* All rights reserved. No warranty, explicit or implicit, provided. *)
(* *)
(**************************************************************************)
open Lwt.Infix
module Make (Encoding : Resto.ENCODING) = struct
open Cohttp
module Media_type = Media_type.Make(Encoding)
module Service = Resto.MakeService(Encoding)
type content_type = (string * string)
type raw_content = Cohttp_lwt.Body.t * content_type option
type content = Cohttp_lwt.Body.t * content_type option * Media_type.t option
type ('o, 'e) generic_rest_result =
[ `Ok of 'o option
| `Conflict of 'e
| `Error of 'e
| `Forbidden of 'e
| `Not_found of 'e
| `Unauthorized of 'e
| `Bad_request of string
| `Method_not_allowed of string list
| `Unsupported_media_type
| `Not_acceptable of string
| `Unexpected_status_code of Cohttp.Code.status_code * content
| `Connection_failed of string ]
type ('o, 'e) service_result =
[ ('o, 'e option) generic_rest_result
| `Unexpected_content_type of raw_content
| `Unexpected_content of (string * Media_type.t) * string
| `Unexpected_error_content_type of raw_content
| `Unexpected_error_content of (string * Media_type.t) * string ]
module type LOGGER = sig
type request
val log_empty_request: Uri.t -> request Lwt.t
val log_request:
?media:Media_type.t -> 'a Encoding.t ->
Uri.t -> string -> request Lwt.t
val log_response:
request -> ?media:Media_type.t -> 'a Encoding.t ->
Cohttp.Code.status_code -> string Lwt.t Lazy.t -> unit Lwt.t
end
type logger = (module LOGGER)
let null_logger =
(module struct
type request = unit
let log_empty_request = (fun _ -> Lwt.return_unit)
let log_request = (fun ?media:_ _ _ _-> Lwt.return_unit)
let log_response = (fun _ ?media:_ _ _ _ -> Lwt.return_unit)
end : LOGGER)
let timings_logger ppf =
(module struct
type request = string * float
let log_empty_request uri =
let tzero = Unix.gettimeofday () in
Lwt.return (Uri.to_string uri, tzero)
let log_request ?media:_ _enc uri _body = log_empty_request uri
let log_response (uri, tzero) ?media:_ _enc _code _body =
let time = Unix.gettimeofday () -. tzero in
Format.fprintf ppf "Request to %s succeeded in %gs@." uri time ;
Lwt.return_unit
end : LOGGER)
let faked_media = {
Media_type.name = AnyMedia ;
q = None ;
pp = (fun _enc ppf s -> Format.pp_print_string ppf s) ;
construct = (fun _ -> assert false) ;
destruct = (fun _ -> assert false) ;
}
let full_logger ppf =
(module struct
let cpt = ref 0
type request = int * string
let log_empty_request uri =
let id = !cpt in
let uri = Uri.to_string uri in
incr cpt ;
Format.fprintf ppf ">>>>%d: %s@." id uri ;
Lwt.return (id, uri)
let log_request ?(media = faked_media) enc uri body =
let id = !cpt in
let uri = Uri.to_string uri in
incr cpt ;
Format.fprintf ppf "@[<2>>>>>%d: %s@,%a@]@." id uri (media.pp enc) body ;
Lwt.return (id, uri)
let log_response (id, _uri) ?(media = faked_media) enc code body =
Lazy.force body >>= fun body ->
Format.fprintf ppf "@[<2><<<<%d: %s@,%a@]@."
id (Cohttp.Code.string_of_status code) (media.pp enc) body ;
Lwt.return_unit
end : LOGGER)
let find_media received media_types =
match received with
| Some received ->
Media_type.find_media received media_types
| None ->
match media_types with
| [] -> None
| m :: _ -> Some m
let clone_body = function
| `Stream s -> `Stream (Lwt_stream.clone s)
| x -> x
let generic_call meth ?(logger = null_logger) ?accept ?body ?media uri : (content, content) generic_rest_result Lwt.t =
let module Logger = (val logger) in
let headers = Header.init () in
begin
match body with
| None->
Logger.log_empty_request uri
| Some (`Stream _) ->
Logger.log_request Encoding.untyped uri "<stream>"
| Some body ->
Cohttp_lwt.Body.to_string body >>= fun body ->
Logger.log_request ?media Encoding.untyped uri body
end >>= fun log_request ->
let body, headers =
match body, media with
| None, _ -> Cohttp_lwt.Body.empty, headers
| Some body, None ->
body, headers
| Some body, Some media ->
body, Header.add headers "content-type" (Media_type.name media) in
let headers =
match accept with
| None -> headers
| Some ranges ->
Header.add headers "accept" (Media_type.accept_header ranges) in
Lwt.catch begin fun () ->
Cohttp_lwt_unix.Client.call
~headers
(meth :> Code.meth) ~body uri >>= fun (response, ansbody) ->
let headers = Response.headers response in
let media_name =
match Header.get headers "content-type" with
| None -> None
| Some s ->
match Utils.split_path s with
| [x ; y] -> Some (x, y)
| _ -> None (* ignored invalid *) in
let media =
match accept with
| None -> None
| Some media_types -> find_media media_name media_types in
let status = Response.status response in
let log_ansbody = clone_body ansbody in
Logger.log_response log_request ?media Encoding.untyped status
(lazy (Cohttp_lwt.Body.to_string log_ansbody)) >>= fun () ->
match status with
| `OK -> Lwt.return (`Ok (Some (ansbody, media_name, media)))
| `No_content -> Lwt.return (`Ok None)
| `Created ->
(* TODO handle redirection ?? *)
failwith "Resto_cohttp_client.generic_json_call: unimplemented"
| `Unauthorized -> Lwt.return (`Unauthorized (ansbody, media_name, media))
| `Forbidden -> Lwt.return (`Forbidden (ansbody, media_name, media))
| `Not_found -> Lwt.return (`Not_found (ansbody, media_name, media))
| `Conflict -> Lwt.return (`Conflict (ansbody, media_name, media))
| `Internal_server_error -> Lwt.return (`Error (ansbody, media_name, media))
| `Bad_request ->
Cohttp_lwt.Body.to_string body >>= fun body ->
Lwt.return (`Bad_request body)
| `Method_not_allowed ->
let allowed = Cohttp.Header.get_multi headers "accept" in
Lwt.return (`Method_not_allowed allowed)
| `Unsupported_media_type ->
Lwt.return `Unsupported_media_type
| `Not_acceptable ->
Cohttp_lwt.Body.to_string body >>= fun body ->
Lwt.return (`Not_acceptable body)
| code ->
Lwt.return
(`Unexpected_status_code (code, (ansbody, media_name, media)))
end begin fun exn ->
let msg =
match exn with
| Unix.Unix_error (e, _, _) -> Unix.error_message e
| Failure msg -> msg
| Invalid_argument msg -> msg
| e -> Printexc.to_string e in
Lwt.return (`Connection_failed msg)
end
type log = {
log:
'a. ?media:Media_type.t -> 'a Encoding.t -> Cohttp.Code.status_code ->
string Lwt.t Lazy.t -> unit Lwt.t ;
}
let handle_error log service (body, media_name, media) status f =
Cohttp_lwt.Body.is_empty body >>= fun empty ->
if empty then
log.log Encoding.untyped status (lazy (Lwt.return "")) >>= fun () ->
Lwt.return (f None)
else
match media with
| None ->
Lwt.return (`Unexpected_error_content_type (body, media_name))
| Some media ->
Cohttp_lwt.Body.to_string body >>= fun body ->
let error = Service.error_encoding service in
log.log ~media error status (lazy (Lwt.return body)) >>= fun () ->
match media.Media_type.destruct error body with
| Ok body -> Lwt.return (f (Some body))
| Error msg ->
Lwt.return (`Unexpected_error_content ((body, media), msg))
let prepare (type i)
media_types ?(logger = null_logger) ?base
(service : (_,_,_,_,i,_,_) Service.t) params query body =
let module Logger = (val logger : LOGGER) in
let media =
match Media_type.first_complete_media media_types with
| None -> invalid_arg "Resto_cohttp_client.call_service"
| Some (_, m) -> m in
let { Service.meth ; uri ; input } =
Service.forge_request ?base service params query in
begin
match input with
| Service.No_input ->
Logger.log_empty_request uri >>= fun log_request ->
Lwt.return (None, None, log_request)
| Service.Input input ->
let body = media.Media_type.construct input body in
Logger.log_request ~media input uri body >>= fun log_request ->
Lwt.return (Some (Cohttp_lwt.Body.of_string body),
Some media,
log_request)
end >>= fun (body, media, log_request) ->
let log = { log = fun ?media -> Logger.log_response log_request ?media } in
Lwt.return (log, meth, uri, body, media)
let call_service media_types
?logger ?base service params query body =
prepare
media_types ?logger ?base
service params query body >>= fun (log, meth, uri, body, media) ->
begin
generic_call ~accept:media_types meth ?body ?media uri >>= function
| `Ok None ->
log.log Encoding.untyped `No_content (lazy (Lwt.return "")) >>= fun () ->
Lwt.return (`Ok None)
| `Ok (Some (body, media_name, media)) -> begin
match media with
| None ->
Lwt.return (`Unexpected_content_type (body, media_name))
| Some media ->
Cohttp_lwt.Body.to_string body >>= fun body ->
let output = Service.output_encoding service in
log.log ~media output `OK (lazy (Lwt.return body)) >>= fun () ->
match media.destruct output body with
| Ok body -> Lwt.return (`Ok (Some body))
| Error msg ->
Lwt.return (`Unexpected_content ((body, media), msg))
end
| `Conflict body ->
handle_error log service body `Conflict (fun v -> `Conflict v)
| `Error body ->
handle_error log service body `Internal_server_error (fun v -> `Error v)
| `Forbidden body ->
handle_error log service body `Forbidden (fun v -> `Forbidden v)
| `Not_found body ->
handle_error log service body `Not_found (fun v -> `Not_found v)
| `Unauthorized body ->
handle_error log service body `Unauthorized (fun v -> `Unauthorized v)
| `Bad_request _
| `Method_not_allowed _
| `Unsupported_media_type
| `Not_acceptable _
| `Unexpected_status_code _
| `Connection_failed _ as err -> Lwt.return err
end >>= fun ans ->
Lwt.return (meth, uri, ans)
let call_streamed_service media_types
?logger ?base service ~on_chunk ~on_close params query body =
prepare
media_types ?logger ?base
service params query body >>= fun (log, meth, uri, body, media) ->
begin
generic_call ~accept:media_types meth ?body ?media uri >>= function
| `Ok None ->
on_close () ;
log.log Encoding.untyped `No_content (lazy (Lwt.return "")) >>= fun () ->
Lwt.return (`Ok None)
| `Ok (Some (body, media_name, media)) -> begin
match media with
| None ->
Lwt.return (`Unexpected_content_type (body, media_name))
| Some media ->
let stream = Cohttp_lwt.Body.to_stream body in
Lwt_stream.get stream >>= function
| None ->
on_close () ;
Lwt.return (`Ok None)
| Some chunk ->
let output = Service.output_encoding service in
log.log ~media output
`OK (lazy (Lwt.return chunk)) >>= fun () ->
match media.destruct output chunk with
| Error msg ->
Lwt.return (`Unexpected_content ((chunk, media), msg))
| Ok body ->
on_chunk body ;
let rec loop () =
Lwt_stream.get stream >>= function
| None -> on_close () ; Lwt.return_unit
| Some chunk ->
log.log ~media output
`OK (lazy (Lwt.return chunk)) >>= fun () ->
match media.destruct output chunk with
| Ok body -> on_chunk body ; loop ()
| Error _msg ->
(* TODO log error. *)
ignore (Lwt_stream.junk_while (fun _ -> true) stream
: unit Lwt.t) ;
on_close () ; Lwt.return_unit in
ignore (loop () : unit Lwt.t) ;
Lwt.return (`Ok (Some (fun () ->
ignore (Lwt_stream.junk_while (fun _ -> true) stream
: unit Lwt.t) ;
())))
end
| `Conflict body ->
handle_error log service body `Conflict (fun v -> `Conflict v)
| `Error body ->
handle_error log service body `Internal_server_error (fun v -> `Error v)
| `Forbidden body ->
handle_error log service body `Forbidden (fun v -> `Forbidden v)
| `Not_found body ->
handle_error log service body `Not_found (fun v -> `Not_found v)
| `Unauthorized body ->
handle_error log service body `Unauthorized (fun v -> `Unauthorized v)
| `Bad_request _
| `Method_not_allowed _
| `Unsupported_media_type
| `Not_acceptable _
| `Unexpected_status_code _
| `Connection_failed _ as err -> Lwt.return err
end >>= fun ans ->
Lwt.return (meth, uri, ans)
end

85
vendors/ocplib-resto/lib_resto-cohttp/client.mli vendored Normal file
View File

@ -0,0 +1,85 @@
(**************************************************************************)
(* ocplib-resto *)
(* Copyright (C) 2016, OCamlPro. *)
(* *)
(* All rights reserved. This file is distributed under the terms *)
(* of the GNU Lesser General Public License version 2.1, with the *)
(* special exception on linking described in the file LICENSE. *)
(* *)
(**************************************************************************)
(** Typed RPC services: client implementation. *)
module Make (Encoding : Resto.ENCODING) : sig
module Service : (module type of (struct include Resto.MakeService(Encoding) end))
type content_type = (string * string)
type raw_content = Cohttp_lwt.Body.t * content_type option
type content =
Cohttp_lwt.Body.t * content_type option * Media_type.Make(Encoding).t option
type ('o, 'e) generic_rest_result =
[ `Ok of 'o option
| `Conflict of 'e
| `Error of 'e
| `Forbidden of 'e
| `Not_found of 'e
| `Unauthorized of 'e
| `Bad_request of string
| `Method_not_allowed of string list
| `Unsupported_media_type
| `Not_acceptable of string
| `Unexpected_status_code of Cohttp.Code.status_code * content
| `Connection_failed of string ]
module type LOGGER = sig
type request
val log_empty_request: Uri.t -> request Lwt.t
val log_request:
?media:Media_type.Make(Encoding).t -> 'a Encoding.t ->
Uri.t -> string -> request Lwt.t
val log_response:
request -> ?media:Media_type.Make(Encoding).t -> 'a Encoding.t ->
Cohttp.Code.status_code -> string Lwt.t Lazy.t -> unit Lwt.t
end
type logger = (module LOGGER)
val null_logger: logger
val timings_logger: Format.formatter -> logger
val full_logger: Format.formatter -> logger
val generic_call:
[< Resto.meth ] ->
?logger:logger ->
?accept:Media_type.Make(Encoding).t list ->
?body:Cohttp_lwt.Body.t ->
?media:Media_type.Make(Encoding).t ->
Uri.t -> (content, content) generic_rest_result Lwt.t
type ('o, 'e) service_result =
[ ('o, 'e option) generic_rest_result
| `Unexpected_content_type of raw_content
| `Unexpected_content of (string * Media_type.Make(Encoding).t) * string
| `Unexpected_error_content_type of raw_content
| `Unexpected_error_content of (string * Media_type.Make(Encoding).t) * string ]
val call_service:
Media_type.Make(Encoding).t list ->
?logger:logger ->
?base:Uri.t ->
([< Resto.meth ], unit, 'p, 'q, 'i, 'o, 'e) Service.t ->
'p -> 'q -> 'i -> (Resto.meth * Uri.t * ('o, 'e) service_result) Lwt.t
val call_streamed_service:
Media_type.Make(Encoding).t list ->
?logger:logger ->
?base:Uri.t ->
([< Resto.meth ], unit, 'p, 'q, 'i, 'o, 'e) Service.t ->
on_chunk: ('o -> unit) ->
on_close: (unit -> unit) ->
'p -> 'q -> 'i ->
(Resto.meth * Uri.t * (unit -> unit, 'e) service_result) Lwt.t
end

1
vendors/ocplib-resto/lib_resto-cohttp/media_type.ml vendored
View File

@ -15,6 +15,7 @@ module Make (Encoding : Resto.ENCODING) = struct
type t = {
name: Cohttp.Accept.media_range ;
q: int option ;
pp: 'a. 'a Encoding.t -> Format.formatter -> string -> unit ;
construct: 'a. 'a Encoding.t -> 'a -> string ;
destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
}

1
vendors/ocplib-resto/lib_resto-cohttp/media_type.mli vendored
View File

@ -13,6 +13,7 @@ module Make (Encoding : Resto.ENCODING) : sig
type t = {
name: Cohttp.Accept.media_range ;
q: int option ;
pp: 'a. 'a Encoding.t -> Format.formatter -> string -> unit ;
construct: 'a. 'a Encoding.t -> 'a -> string ;
destruct: 'a. 'a Encoding.t -> string -> ('a, string) result ;
}

2
vendors/ocplib-resto/lib_resto-json/resto_json.ml vendored
View File

@ -13,6 +13,8 @@ module Encoding = struct
include Json_encoding
type 'a t = 'a encoding
type schema = Json_schema.schema
let untyped = obj1 (req "untyped" string)
let conv f g t = conv ~schema:(schema t) f g t
module StringMap = Map.Make(String)

2
vendors/ocplib-resto/lib_resto/resto.ml vendored
View File

@ -532,6 +532,8 @@ module type ENCODING = sig
type 'a t
type schema
val unit : unit t
val untyped : string t
val conv : ('a -> 'b) -> ('b -> 'a) -> 'b t -> 'a t
val schema : 'a t -> schema
val description_request_encoding : Description.request t
val description_answer_encoding : schema Description.directory t

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

@ -247,6 +247,8 @@ module type ENCODING = sig
type 'a t
type schema
val unit : unit t
val untyped : string t
val conv : ('a -> 'b) -> ('b -> 'a) -> 'b t -> 'a t
val schema : 'a t -> schema
val description_request_encoding : Description.request t
val description_answer_encoding : schema Description.directory t