RPC: introduce Resto_cohttp.Client and RPC_clients.

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)

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

lib_node_http/RPC_client.ml

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

lib_node_http/RPC_client.mli

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

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:@ \
+          \ - @[<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

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
 

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 [

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

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 ;

vendors/ocplib-resto/lib_resto-cohttp/client.ml

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

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

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

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

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)
 

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

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