From 4aa1b14ba6de531f4e961c2272c295355e793b33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gr=C3=A9goire=20Henry?= Date: Thu, 7 Dec 2017 17:43:21 +0100 Subject: [PATCH] RPC: introduce `Resto_cohttp.Client` and `RPC_clients`. --- lib_base/data_encoding_ezjsonm.ml | 4 +- lib_base/data_encoding_ezjsonm.mli | 4 +- lib_node_http/RPC_client.ml | 358 +++++++++++++++++ lib_node_http/RPC_client.mli | 90 +++++ lib_node_http/media_type.ml | 21 +- lib_node_http/media_type.mli | 3 + lib_node_services/RPC.ml | 18 +- lib_node_services/RPC.mli | 1 + test/utils/test_data_encoding.ml | 2 +- .../ocplib-resto/lib_resto-cohttp/client.ml | 361 ++++++++++++++++++ .../ocplib-resto/lib_resto-cohttp/client.mli | 85 +++++ .../lib_resto-cohttp/media_type.ml | 1 + .../lib_resto-cohttp/media_type.mli | 1 + .../ocplib-resto/lib_resto-json/resto_json.ml | 2 + vendors/ocplib-resto/lib_resto/resto.ml | 2 + vendors/ocplib-resto/lib_resto/resto.mli | 2 + 16 files changed, 943 insertions(+), 12 deletions(-) create mode 100644 lib_node_http/RPC_client.ml create mode 100644 lib_node_http/RPC_client.mli create mode 100644 vendors/ocplib-resto/lib_resto-cohttp/client.ml create mode 100644 vendors/ocplib-resto/lib_resto-cohttp/client.mli diff --git a/lib_base/data_encoding_ezjsonm.ml b/lib_base/data_encoding_ezjsonm.ml index 910851ab3..c88df5c69 100644 --- a/lib_base/data_encoding_ezjsonm.ml +++ b/lib_base/data_encoding_ezjsonm.ml @@ -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) diff --git a/lib_base/data_encoding_ezjsonm.mli b/lib_base/data_encoding_ezjsonm.mli index f0cc56a10..baa9a77d3 100644 --- a/lib_base/data_encoding_ezjsonm.mli +++ b/lib_base/data_encoding_ezjsonm.mli @@ -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 diff --git a/lib_node_http/RPC_client.ml b/lib_node_http/RPC_client.ml new file mode 100644 index 000000000..d3472c2d2 --- /dev/null +++ b/lib_node_http/RPC_client.ml @@ -0,0 +1,358 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 + "@[Oups! It looks like we forged an invalid HTTP request.@,%s@]" + msg + | Method_not_allowed meths -> + Format.fprintf ppf + "@[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 + "@[The server wants to known the media type we used.@]" + | Unsupported_media_type (Some media) -> + Format.fprintf ppf + "@[The server does not support the media type we used: %s.@]" + media + | Not_acceptable { proposed ; acceptable } -> + Format.fprintf ppf + "@[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 + "@[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 + "@[Failed to parse the answer (%s):@,@[error:@ %s@]@,@[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 + "@[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 diff --git a/lib_node_http/RPC_client.mli b/lib_node_http/RPC_client.mli new file mode 100644 index 000000000..d0f79f9ed --- /dev/null +++ b/lib_node_http/RPC_client.mli @@ -0,0 +1,90 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 diff --git a/lib_node_http/media_type.ml b/lib_node_http/media_type.ml index 472423d7e..17de025dc 100644 --- a/lib_node_http/media_type.ml +++ b/lib_node_http/media_type.ml @@ -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:@ \ + \ - @[Error:@ %s@]\ + \ - @[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 diff --git a/lib_node_http/media_type.mli b/lib_node_http/media_type.mli index a023388e6..1b84e846c 100644 --- a/lib_node_http/media_type.mli +++ b/lib_node_http/media_type.mli @@ -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 diff --git a/lib_node_services/RPC.ml b/lib_node_services/RPC.ml index 5cff548b0..168ce971d 100644 --- a/lib_node_services/RPC.ml +++ b/lib_node_services/RPC.ml @@ -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 [ diff --git a/lib_node_services/RPC.mli b/lib_node_services/RPC.mli index 497a1548e..a7df996fc 100644 --- a/lib_node_services/RPC.mli +++ b/lib_node_services/RPC.mli @@ -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 diff --git a/test/utils/test_data_encoding.ml b/test/utils/test_data_encoding.ml index 8d3f0121b..b26019475 100644 --- a/test/utils/test_data_encoding.ml +++ b/test/utils/test_data_encoding.ml @@ -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 ; diff --git a/vendors/ocplib-resto/lib_resto-cohttp/client.ml b/vendors/ocplib-resto/lib_resto-cohttp/client.ml new file mode 100644 index 000000000..9b9c33d01 --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/client.ml @@ -0,0 +1,361 @@ +(**************************************************************************) +(* *) +(* Copyright (c) 2014 - 2017. *) +(* Dynamic Ledger Solutions, Inc. *) +(* *) +(* 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 "" + | 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 diff --git a/vendors/ocplib-resto/lib_resto-cohttp/client.mli b/vendors/ocplib-resto/lib_resto-cohttp/client.mli new file mode 100644 index 000000000..14fb4d6a8 --- /dev/null +++ b/vendors/ocplib-resto/lib_resto-cohttp/client.mli @@ -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 diff --git a/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml b/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml index ede3a9150..7515de1b1 100644 --- a/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml +++ b/vendors/ocplib-resto/lib_resto-cohttp/media_type.ml @@ -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 ; } diff --git a/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli b/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli index b00b90ea5..9f9ef1d8b 100644 --- a/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli +++ b/vendors/ocplib-resto/lib_resto-cohttp/media_type.mli @@ -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 ; } diff --git a/vendors/ocplib-resto/lib_resto-json/resto_json.ml b/vendors/ocplib-resto/lib_resto-json/resto_json.ml index 01791eabe..b49fc7232 100644 --- a/vendors/ocplib-resto/lib_resto-json/resto_json.ml +++ b/vendors/ocplib-resto/lib_resto-json/resto_json.ml @@ -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) diff --git a/vendors/ocplib-resto/lib_resto/resto.ml b/vendors/ocplib-resto/lib_resto/resto.ml index ca1aa3877..214e3ed26 100644 --- a/vendors/ocplib-resto/lib_resto/resto.ml +++ b/vendors/ocplib-resto/lib_resto/resto.ml @@ -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 diff --git a/vendors/ocplib-resto/lib_resto/resto.mli b/vendors/ocplib-resto/lib_resto/resto.mli index 54c7a7ce2..b0d7e1dfa 100644 --- a/vendors/ocplib-resto/lib_resto/resto.mli +++ b/vendors/ocplib-resto/lib_resto/resto.mli @@ -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