ligo/lib_rpc-http/RPC_client.ml

(**************************************************************************)
(*                                                                        *)
(*    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_encoding)

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_service.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_service.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_service.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_service.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_service.string_of_meth meth)
          (Uri.to_string uri)
          pp_rest_error error)
    Data_encoding.(obj3
                     (req "meth" RPC_service.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_service.meth ] :> RPC_service.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_service.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_service.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