Source file client.ml

(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.com>     *)
(* Copyright (c) 2020-2021 Nomadic Labs <contact@nomadic-labs.com>           *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

open Lwt.Infix

module type CALL = sig
  val call :
    ?headers:Cohttp.Header.t ->
    ?body:Cohttp_lwt.Body.t ->
    Cohttp.Code.meth ->
    Uri.t ->
    (Cohttp.Response.t * Cohttp_lwt.Body.t) Lwt.t
end

module OfCohttp (Client : Cohttp_lwt.S.Client) : CALL = struct
  let call ?headers ?body meth uri = Client.call ?headers ?body meth uri
end

module Make (Encoding : Resto.ENCODING) (Call : CALL) = 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
    | `Gone 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
    | `OCaml_exception of string
    | `Unauthorized_host of string option ]

  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 _ = Lwt.return_unit

      let log_request ?media:_ _ _ _ = Lwt.return_unit

      let log_response _ ?media:_ _ _ _ = Lwt.return_unit
    end : LOGGER )

  let timings_logger ~gettimeofday ppf =
    ( module struct
      type request = string * float

      let log_empty_request uri =
        let tzero = 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 = 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.fprintf ppf "@[<h 0>%a@]" Format.pp_print_text s);
      construct = (fun _ -> assert false);
      construct_seq = (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
          "@[<v 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
          "@[<v 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 )

  type log = {
    log :
      'a. ?media:Media_type.t -> 'a Encoding.t -> Cohttp.Code.status_code ->
      string Lwt.t Lazy.t -> unit Lwt.t;
  }

  let generic_call meth ?(headers = []) ?accept ?body ?media uri :
      (content, content) generic_rest_result Lwt.t =
    let host =
      match (Uri.host uri, Uri.port uri) with
      | (None, _) ->
          None
      | (Some host, None) ->
          Some host
      | (Some host, Some port) ->
          Some (host ^ ":" ^ string_of_int port)
    in
    let init_headers =
      match host with
      | None ->
          Header.init ()
      | Some host ->
          Header.replace (Header.init ()) "host" host
    in
    let headers =
      List.fold_left
        (fun headers (header, value) ->
          let header = String.lowercase_ascii header in
          if
            header <> "host"
            && (String.length header < 2 || String.sub header 0 2 <> "x-")
          then
            invalid_arg
              "Resto_cohttp.Client.call: only headers \"host\" or starting \
               with \"x-\" are supported"
          else Header.replace headers header value)
        init_headers
        headers
    in
    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
      (fun () ->
        Call.call ~headers (meth :> Code.meth) ~body uri
        >>= fun (response, ansbody) ->
        let headers = Response.headers response in
        let media_name =
          match Header.get_media_type headers with
          | None ->
              None
          | Some s -> (
            match Resto.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
        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 when Cohttp.Header.mem headers "X-OCaml-Resto-CORS-Error"
          ->
            Lwt.return (`Unauthorized_host host)
        | `Forbidden ->
            Lwt.return (`Forbidden (ansbody, media_name, media))
        | `Not_found ->
            Lwt.return (`Not_found (ansbody, media_name, media))
        | `Gone ->
            Lwt.return (`Gone (ansbody, media_name, media))
        | `Conflict ->
            Lwt.return (`Conflict (ansbody, media_name, media))
        | `Internal_server_error ->
            if media_name = Some ("text", "ocaml.exception") then
              Cohttp_lwt.Body.to_string ansbody
              >>= fun msg -> Lwt.return (`OCaml_exception msg)
            else Lwt.return (`Error (ansbody, media_name, media))
        | `Bad_request ->
            Cohttp_lwt.Body.to_string ansbody
            >>= 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 ansbody
            >>= fun body -> Lwt.return (`Not_acceptable body)
        | code ->
            Lwt.return
              (`Unexpected_status_code (code, (ansbody, media_name, media))))
      (fun exn ->
        let msg =
          match exn with
          | Failure msg ->
              msg
          | Invalid_argument msg ->
              msg
          | e ->
              Printexc.to_string e
        in
        Lwt.return (`Connection_failed msg))

  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
    ( 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) )
    >>= 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 ?headers ?base service params query body
      =
    prepare media_types ?logger ?base service params query body
    >>= fun (log, meth, uri, body, media) ->
    generic_call meth ?headers ~accept:media_types ?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)) -> (
            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)) ) )
          | `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)
          | `Gone body ->
              handle_error log service body `Gone (fun v -> `Gone 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 _
            | `OCaml_exception _
            | `Unauthorized_host _ ) as err ->
              Lwt.return err)
    >>= fun ans -> Lwt.return (meth, uri, ans)

  let call_streamed_service media_types ?logger ?headers ?base service
      ~on_chunk ~on_close params query body =
    prepare media_types ?logger ?base service params query body
    >>= fun (log, meth, uri, body, media) ->
    generic_call meth ?headers ~accept:media_types ?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)) -> (
            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 buffer = Buffer.create 2048 in
                    let output = Service.output_encoding service in
                    let rec loop = function
                      | None ->
                          on_close () ; Lwt.return_unit
                      | Some chunk -> (
                          Buffer.add_string buffer chunk ;
                          let data = Buffer.contents buffer in
                          log.log ~media output `OK (lazy (Lwt.return chunk))
                          >>= fun () ->
                          match media.destruct output data with
                          | Ok body ->
                              Buffer.reset buffer ;
                              on_chunk body ;
                              Lwt_stream.get stream >>= loop
                          | Error _msg ->
                              Lwt_stream.get stream >>= loop )
                    in
                    ignore (loop (Some chunk) : unit Lwt.t) ;
                    Lwt.return
                      (`Ok
                        (Some
                           (fun () ->
                             ignore
                               ( Lwt_stream.junk_while (fun _ -> true) stream
                                 : unit Lwt.t ) ;
                             ()))) ) )
          | `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)
          | `Gone body ->
              handle_error log service body `Gone (fun v -> `Gone 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 _
            | `OCaml_exception _
            | `Unauthorized_host _ ) as err ->
              Lwt.return err)
    >>= fun ans -> Lwt.return (meth, uri, ans)
end