{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}

-- | Making HTTP requests using an API inspired by Elm's elm/http.
module Http
  ( -- * Handlers
    Handler,
    handler,

    -- * Requests
    get,
    post,
    request,
    Internal.Request' (..),
    Internal.Request,
    Internal.Error (..),

    -- * Header
    Internal.Header,
    header,

    -- * Body
    Internal.Body,
    emptyBody,
    stringBody,
    jsonBody,
    bytesBody,

    -- * Expect
    Expect,
    expectJson,
    expectText,
    expectWhatever,

    -- * Elaborate Expectations
    Expect',
    expectTextResponse,
    expectBytesResponse,
    Internal.Response (..),
    Internal.Metadata (..),

    -- * Use with external libraries
    withThirdParty,
    withThirdPartyIO,
  )
where

import qualified Conduit
import qualified Control.Exception.Safe as Exception
import Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy
import qualified Data.CaseInsensitive as CI
import qualified Data.Dynamic as Dynamic
import Data.String (fromString)
import qualified Data.Text.Encoding
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Encoding
import qualified Dict
import Http.Internal (Body, Expect, Handler, Expect')
import qualified Http.Internal as Internal
import qualified Log.HttpRequest as HttpRequest
import qualified Maybe
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.Internal as HTTP.Internal
import qualified Network.HTTP.Client.TLS as TLS
import qualified Network.HTTP.Types.Status as Status
import qualified Network.URI
import qualified Platform
import qualified Task
import Prelude (Either (Left, Right), IO, fromIntegral, pure)

-- | Create a 'Handler' for making HTTP requests.
handler :: Conduit.Acquire Handler
handler :: Acquire Handler
handler = do
  Handler
doAnything <- IO Handler -> Acquire Handler
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Handler
Platform.doAnythingHandler
  Manager
manager <- Acquire Manager
forall (m :: * -> *). MonadIO m => m Manager
TLS.newTlsManager
  Handler -> Acquire Handler
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Handler -> Acquire Handler) -> Handler -> Acquire Handler
forall a b. (a -> b) -> a -> b
<| (forall e expect.
 (Typeable expect, Typeable e) =>
 Request' e expect -> Task e expect)
-> (forall e a. (Manager -> Task e a) -> Task e a)
-> (forall a. LogHandler -> (Manager -> IO a) -> IO a)
-> Handler
Internal.Handler
      (Handler -> Manager -> Request' e expect -> Task e expect
forall x expect.
Handler -> Manager -> Request' x expect -> Task x expect
_request Handler
doAnything Manager
manager)
      (Manager -> (Manager -> Task e a) -> Task e a
forall e a. Manager -> (Manager -> Task e a) -> Task e a
_withThirdParty Manager
manager)
      (Manager -> LogHandler -> (Manager -> IO a) -> IO a
forall a. Manager -> LogHandler -> (Manager -> IO a) -> IO a
_withThirdPartyIO Manager
manager)

-- | Third party libraries that make HTTP requests often take a 'HTTP.Manager'.
-- This helper allows us to call such a library using a 'Handler'.
--
-- The benefit over using this over using a separate 'HTTP.Manager' for the
-- external library, is that 'withThirdParty' will ensure HTTP requests made
-- by the external library will get logged.
withThirdParty :: Handler -> (HTTP.Manager -> Task e a) -> Task e a
withThirdParty :: Handler -> (Manager -> Task e a) -> Task e a
withThirdParty Internal.Handler {handlerWithThirdParty :: Handler -> forall e a. (Manager -> Task e a) -> Task e a
Internal.handlerWithThirdParty = forall e a. (Manager -> Task e a) -> Task e a
wtp} Manager -> Task e a
library =
  (Manager -> Task e a) -> Task e a
forall e a. (Manager -> Task e a) -> Task e a
wtp Manager -> Task e a
library

_withThirdParty :: HTTP.Manager -> (HTTP.Manager -> Task e a) -> Task e a
_withThirdParty :: Manager -> (Manager -> Task e a) -> Task e a
_withThirdParty Manager
manager Manager -> Task e a
library = do
  Manager
requestManager <- Manager -> Task e Manager
forall e. Manager -> Task e Manager
prepareManagerForRequest Manager
manager
  Manager -> Task e a
library Manager
requestManager

-- | Like `withThirdParty`, but runs in `IO`.
withThirdPartyIO :: Platform.LogHandler -> Handler -> (HTTP.Manager -> IO a) -> IO a
withThirdPartyIO :: LogHandler -> Handler -> (Manager -> IO a) -> IO a
withThirdPartyIO LogHandler
log Internal.Handler {handlerWithThirdPartyIO :: Handler -> forall a. LogHandler -> (Manager -> IO a) -> IO a
Internal.handlerWithThirdPartyIO = forall a. LogHandler -> (Manager -> IO a) -> IO a
wtp} Manager -> IO a
library =
  LogHandler -> (Manager -> IO a) -> IO a
forall a. LogHandler -> (Manager -> IO a) -> IO a
wtp LogHandler
log Manager -> IO a
library

_withThirdPartyIO :: HTTP.Manager -> Platform.LogHandler -> (HTTP.Manager -> IO a) -> IO a
_withThirdPartyIO :: Manager -> LogHandler -> (Manager -> IO a) -> IO a
_withThirdPartyIO Manager
manager LogHandler
log Manager -> IO a
library = do
  Manager
requestManager <- Manager -> Task Never Manager
forall e. Manager -> Task e Manager
prepareManagerForRequest Manager
manager Task Never Manager
-> (Task Never Manager -> IO Manager) -> IO Manager
forall a b. a -> (a -> b) -> b
|> LogHandler -> Task Never Manager -> IO Manager
forall a. LogHandler -> Task Never a -> IO a
Task.perform LogHandler
log
  Manager -> IO a
library Manager
requestManager

-- QUICKS

-- | Create a @GET@ request.
get :: (Dynamic.Typeable x, Dynamic.Typeable a) => Handler -> Text -> Expect' x a -> Task x a
get :: Handler -> Text -> Expect' x a -> Task x a
get Handler
handler' Text
url Expect' x a
expect =
  Handler -> Request' x a -> Task x a
forall x expect.
(Typeable x, Typeable expect) =>
Handler -> Request' x expect -> Task x expect
request
    Handler
handler'
    Request :: forall x a.
Text
-> [Header]
-> Text
-> Body
-> Maybe Int
-> Expect' x a
-> Request' x a
Internal.Request
      { method :: Text
Internal.method = Text
"GET",
        headers :: [Header]
Internal.headers = [],
        url :: Text
Internal.url = Text
url,
        body :: Body
Internal.body = Body
emptyBody,
        timeout :: Maybe Int
Internal.timeout = Maybe Int
forall a. Maybe a
Nothing,
        expect :: Expect' x a
Internal.expect = Expect' x a
expect
      }

-- | Create a @POST@ request.
post :: (Dynamic.Typeable x, Dynamic.Typeable a) => Handler -> Text -> Body -> Expect' x a -> Task x a
post :: Handler -> Text -> Body -> Expect' x a -> Task x a
post Handler
handler' Text
url Body
body Expect' x a
expect =
  Handler -> Request' x a -> Task x a
forall x expect.
(Typeable x, Typeable expect) =>
Handler -> Request' x expect -> Task x expect
request
    Handler
handler'
    Request :: forall x a.
Text
-> [Header]
-> Text
-> Body
-> Maybe Int
-> Expect' x a
-> Request' x a
Internal.Request
      { method :: Text
Internal.method = Text
"POST",
        headers :: [Header]
Internal.headers = [],
        url :: Text
Internal.url = Text
url,
        body :: Body
Internal.body = Body
body,
        timeout :: Maybe Int
Internal.timeout = Maybe Int
forall a. Maybe a
Nothing,
        expect :: Expect' x a
Internal.expect = Expect' x a
expect
      }

-- REQUEST

-- | Create a 'Header'.
header :: Text -> Text -> Internal.Header
header :: Text -> Text -> Header
header Text
key Text
val =
  Header -> Header
Internal.Header
    (String -> HeaderName
forall a. IsString a => String -> a
fromString (Text -> String
Text.toList Text
key), String -> ByteString
forall a. IsString a => String -> a
fromString (Text -> String
Text.toList Text
val))

-- | Create an empty body for your Request. This is useful for GET requests and
-- POST requests where you are not sending any data.
emptyBody :: Body
emptyBody :: Body
emptyBody =
  Body :: ByteString -> Maybe ByteString -> Body
Internal.Body
    { bodyContents :: ByteString
Internal.bodyContents = ByteString
"",
      bodyContentType :: Maybe ByteString
Internal.bodyContentType = Maybe ByteString
forall a. Maybe a
Nothing
    }

-- | Put some string in the body of your Request.
--
-- The first argument is a MIME type of the body. Some servers are strict about
-- this!
stringBody :: Text -> Text -> Body
stringBody :: Text -> Text -> Body
stringBody Text
mimeType Text
text =
  Body :: ByteString -> Maybe ByteString -> Body
Internal.Body
    { bodyContents :: ByteString
Internal.bodyContents = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
text ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
Data.ByteString.Lazy.fromStrict,
      bodyContentType :: Maybe ByteString
Internal.bodyContentType = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
mimeType)
    }

-- | Put some JSON value in the body of your Request. This will automatically
-- add the Content-Type: application/json header.
jsonBody :: Aeson.ToJSON body => body -> Body
jsonBody :: body -> Body
jsonBody body
json =
  Body :: ByteString -> Maybe ByteString -> Body
Internal.Body
    { bodyContents :: ByteString
Internal.bodyContents = body -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode body
json,
      bodyContentType :: Maybe ByteString
Internal.bodyContentType = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"application/json"
    }

-- | Put some Bytes in the body of your Request. This allows you to use
-- ByteString to have full control over the binary representation of the data
-- you are sending.
--
-- The first argument is a MIME type of the body. In other scenarios you may
-- want to use MIME types like image/png or image/jpeg instead.
bytesBody :: Text -> ByteString -> Body
bytesBody :: Text -> ByteString -> Body
bytesBody Text
mimeType ByteString
bytes =
  Body :: ByteString -> Maybe ByteString -> Body
Internal.Body
    { bodyContents :: ByteString
Internal.bodyContents = ByteString -> ByteString
Data.ByteString.Lazy.fromStrict ByteString
bytes,
      bodyContentType :: Maybe ByteString
Internal.bodyContentType = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
mimeType)
    }

-- | Create a custom request.
request ::
  ( Dynamic.Typeable x,
    Dynamic.Typeable expect
  ) =>
  Handler ->
  Internal.Request' x expect ->
  Task x expect
request :: Handler -> Request' x expect -> Task x expect
request Internal.Handler {forall e expect.
(Typeable expect, Typeable e) =>
Request' e expect -> Task e expect
handlerRequest :: Handler
-> forall e expect.
   (Typeable expect, Typeable e) =>
   Request' e expect -> Task e expect
handlerRequest :: forall e expect.
(Typeable expect, Typeable e) =>
Request' e expect -> Task e expect
Internal.handlerRequest} Request' x expect
settings = Request' x expect -> Task x expect
forall e expect.
(Typeable expect, Typeable e) =>
Request' e expect -> Task e expect
handlerRequest Request' x expect
settings

_request :: Platform.DoAnythingHandler -> HTTP.Manager -> Internal.Request' x expect -> Task x expect
_request :: Handler -> Manager -> Request' x expect -> Task x expect
_request Handler
doAnythingHandler Manager
manager Request' x expect
settings = do
  Manager
requestManager <- Manager -> Task x Manager
forall e. Manager -> Task e Manager
prepareManagerForRequest Manager
manager
  Handler -> IO (Result x expect) -> Task x expect
forall e a. Handler -> IO (Result e a) -> Task e a
Platform.doAnything Handler
doAnythingHandler (IO (Result x expect) -> Task x expect)
-> IO (Result x expect) -> Task x expect
forall a b. (a -> b) -> a -> b
<| do
    Either HttpException (Response ByteString)
response <-
      IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
Exception.try (IO (Response ByteString)
 -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
<| do
        Request
basicRequest <-
          String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
HTTP.parseUrlThrow (String -> IO Request) -> String -> IO Request
forall a b. (a -> b) -> a -> b
<| Text -> String
Text.toList (Request' x expect -> Text
forall x a. Request' x a -> Text
Internal.url Request' x expect
settings)
        let finalRequest :: Request
finalRequest =
              Request
basicRequest
                { method :: ByteString
HTTP.method = Text -> ByteString
Data.Text.Encoding.encodeUtf8 (Request' x expect -> Text
forall x a. Request' x a -> Text
Internal.method Request' x expect
settings),
                  requestHeaders :: RequestHeaders
HTTP.requestHeaders = case Body -> Maybe ByteString
Internal.bodyContentType (Request' x expect -> Body
forall x a. Request' x a -> Body
Internal.body Request' x expect
settings) of
                    Maybe ByteString
Nothing ->
                      Request' x expect -> [Header]
forall x a. Request' x a -> [Header]
Internal.headers Request' x expect
settings
                        [Header] -> ([Header] -> RequestHeaders) -> RequestHeaders
forall a b. a -> (a -> b) -> b
|> (Header -> Header) -> [Header] -> RequestHeaders
forall a b. (a -> b) -> List a -> List b
List.map Header -> Header
Internal.unHeader
                    Just ByteString
mimeType ->
                      (HeaderName
"content-type", ByteString
mimeType) Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:
                      (Header -> Header) -> [Header] -> RequestHeaders
forall a b. (a -> b) -> List a -> List b
List.map Header -> Header
Internal.unHeader (Request' x expect -> [Header]
forall x a. Request' x a -> [Header]
Internal.headers Request' x expect
settings),
                  requestBody :: RequestBody
HTTP.requestBody = ByteString -> RequestBody
HTTP.RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
<| Body -> ByteString
Internal.bodyContents (Request' x expect -> Body
forall x a. Request' x a -> Body
Internal.body Request' x expect
settings),
                  responseTimeout :: ResponseTimeout
HTTP.responseTimeout =
                    Request' x expect -> Maybe Int
forall x a. Request' x a -> Maybe Int
Internal.timeout Request' x expect
settings
                      Maybe Int -> (Maybe Int -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
Maybe.withDefault (Int
30 Int -> Int -> Int
forall number. Num number => number -> number -> number
* Int
1000)
                      Int -> (Int -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Int -> Int -> Int
forall number. Num number => number -> number -> number
(*) Int
1000
                      Int -> (Int -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                      Int -> (Int -> ResponseTimeout) -> ResponseTimeout
forall a b. a -> (a -> b) -> b
|> Int -> ResponseTimeout
HTTP.responseTimeoutMicro
                }
        Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
finalRequest Manager
requestManager
    Result x expect -> IO (Result x expect)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result x expect -> IO (Result x expect))
-> Result x expect -> IO (Result x expect)
forall a b. (a -> b) -> a -> b
<| Expect' x expect
-> Either HttpException (Response ByteString) -> Result x expect
forall x a.
Expect' x a
-> Either HttpException (Response ByteString) -> Result x a
handleResponse (Request' x expect -> Expect' x expect
forall x a. Request' x a -> Expect' x a
Internal.expect Request' x expect
settings) Either HttpException (Response ByteString)
response

handleResponse :: Expect' x a -> Either HTTP.HttpException (HTTP.Response Data.ByteString.Lazy.ByteString) -> Result x a
handleResponse :: Expect' x a
-> Either HttpException (Response ByteString) -> Result x a
handleResponse Expect' x a
expect Either HttpException (Response ByteString)
response =
  case Either HttpException (Response ByteString)
response of
    Right Response ByteString
okResponse ->
      let bytes :: ByteString
bytes = Response ByteString -> ByteString
forall body. Response body -> body
HTTP.responseBody Response ByteString
okResponse
          bodyAsText :: Text
bodyAsText = Text -> Text
Data.Text.Lazy.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
<| ByteString -> Text
Data.Text.Lazy.Encoding.decodeUtf8 ByteString
bytes
       in case Expect' x a
expect of
            Expect' x a
Internal.ExpectJson ->
              case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
bytes of
                Left String
err -> Error -> Result Error a
forall error value. error -> Result error value
Err (Text -> Error
Internal.BadBody (String -> Text
Text.fromList String
err))
                Right a
x -> a -> Result x a
forall error value. value -> Result error value
Ok a
x
            Expect' x a
Internal.ExpectText -> Text -> Result x Text
forall error value. value -> Result error value
Ok Text
bodyAsText
            Expect' x a
Internal.ExpectWhatever -> () -> Result x ()
forall error value. value -> Result error value
Ok ()
            Internal.ExpectTextResponse Response Text -> Result x a
mkResult -> Response Text -> Result x a
mkResult (Metadata -> Text -> Response Text
forall body. Metadata -> body -> Response body
Internal.GoodStatus_ (Response ByteString -> Metadata
forall a. Response a -> Metadata
mkMetadata Response ByteString
okResponse) Text
bodyAsText)
            Internal.ExpectBytesResponse Response ByteString -> Result x a
mkResult -> Response ByteString -> Result x a
mkResult (Metadata -> ByteString -> Response ByteString
forall body. Metadata -> body -> Response body
Internal.GoodStatus_ (Response ByteString -> Metadata
forall a. Response a -> Metadata
mkMetadata Response ByteString
okResponse) (ByteString -> ByteString
Data.ByteString.Lazy.toStrict ByteString
bytes))
    Left HttpException
exception ->
      case Expect' x a
expect of
        Internal.ExpectTextResponse Response Text -> Result x a
mkResult ->
          HttpException
exception
            HttpException -> (HttpException -> Response Text) -> Response Text
forall a b. a -> (a -> b) -> b
|> (ByteString -> Text) -> HttpException -> Response Text
forall a. (ByteString -> a) -> HttpException -> Response a
exceptionToResponse ByteString -> Text
Data.Text.Encoding.decodeUtf8
            Response Text -> (Response Text -> Result x a) -> Result x a
forall a b. a -> (a -> b) -> b
|> Response Text -> Result x a
mkResult
        Internal.ExpectBytesResponse Response ByteString -> Result x a
mkResult ->
          HttpException
exception
            HttpException
-> (HttpException -> Response ByteString) -> Response ByteString
forall a b. a -> (a -> b) -> b
|> (ByteString -> ByteString) -> HttpException -> Response ByteString
forall a. (ByteString -> a) -> HttpException -> Response a
exceptionToResponse ByteString -> ByteString
forall a. a -> a
identity
            Response ByteString
-> (Response ByteString -> Result x a) -> Result x a
forall a b. a -> (a -> b) -> b
|> Response ByteString -> Result x a
mkResult
        Expect' x a
Internal.ExpectJson ->
          Error -> Result Error a
forall error value. error -> Result error value
Err (HttpException -> Error
exceptionToError HttpException
exception)
        Expect' x a
Internal.ExpectText ->
          Error -> Result Error a
forall error value. error -> Result error value
Err (HttpException -> Error
exceptionToError HttpException
exception)
        Expect' x a
Internal.ExpectWhatever ->
          Error -> Result Error a
forall error value. error -> Result error value
Err (HttpException -> Error
exceptionToError HttpException
exception)

exceptionToError :: HTTP.HttpException -> Error
exceptionToError :: HttpException -> Error
exceptionToError HttpException
exception =
  case HttpException
exception of
    HTTP.InvalidUrlException String
_ String
message ->
      Text -> Error
Internal.BadUrl (String -> Text
Text.fromList String
message)
    HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
content ->
      case HttpExceptionContent
content of
        HTTP.StatusCodeException Response ()
res ByteString
_ ->
          Response ()
res
            Response () -> (Response () -> Status) -> Status
forall a b. a -> (a -> b) -> b
|> Response () -> Status
forall body. Response body -> Status
HTTP.responseStatus
            Status -> (Status -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Status -> Int
Status.statusCode
            Int -> (Int -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
            Int -> (Int -> Error) -> Error
forall a b. a -> (a -> b) -> b
|> Int -> Error
Internal.BadStatus
        HttpExceptionContent
HTTP.ResponseTimeout ->
          Error
Internal.Timeout
        HttpExceptionContent
HTTP.ConnectionTimeout ->
          Text -> Error
Internal.NetworkError Text
"ConnectionTimeout"
        HTTP.ConnectionFailure SomeException
err ->
          SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
err
            String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
Text.fromList
            Text -> (Text -> Error) -> Error
forall a b. a -> (a -> b) -> b
|> Text -> Error
Internal.NetworkError
        HttpExceptionContent
err ->
          Text -> Error
Internal.NetworkError (HttpExceptionContent -> Text
forall a. Show a => a -> Text
Debug.toString HttpExceptionContent
err)

exceptionToResponse :: (ByteString -> a) -> HTTP.HttpException -> Internal.Response a
exceptionToResponse :: (ByteString -> a) -> HttpException -> Response a
exceptionToResponse ByteString -> a
toBody HttpException
exception =
  case HttpException
exception of
    HTTP.InvalidUrlException String
_ String
message ->
      Text -> Response a
forall body. Text -> Response body
Internal.BadUrl_ (String -> Text
Text.fromList String
message)
    HTTP.HttpExceptionRequest Request
_ HttpExceptionContent
content ->
      case HttpExceptionContent
content of
        HTTP.StatusCodeException Response ()
res ByteString
bytes ->
          Metadata -> a -> Response a
forall body. Metadata -> body -> Response body
Internal.BadStatus_ (Response () -> Metadata
forall a. Response a -> Metadata
mkMetadata Response ()
res) (ByteString -> a
toBody ByteString
bytes)
        HttpExceptionContent
HTTP.ResponseTimeout ->
          Response a
forall body. Response body
Internal.Timeout_
        HttpExceptionContent
HTTP.ConnectionTimeout ->
          Text -> Response a
forall body. Text -> Response body
Internal.NetworkError_ Text
"ConnectionTimeout"
        HTTP.ConnectionFailure SomeException
err ->
          Text -> Response a
forall body. Text -> Response body
Internal.NetworkError_ (String -> Text
Text.fromList (SomeException -> String
forall e. Exception e => e -> String
Exception.displayException SomeException
err))
        HttpExceptionContent
err ->
          Text -> Response a
forall body. Text -> Response body
Internal.NetworkError_ (HttpExceptionContent -> Text
forall a. Show a => a -> Text
Debug.toString HttpExceptionContent
err)

mkMetadata :: HTTP.Response a -> Internal.Metadata
mkMetadata :: Response a -> Metadata
mkMetadata Response a
response =
  let status :: Status
status = Response a -> Status
forall body. Response body -> Status
HTTP.responseStatus Response a
response
   in Metadata :: Int -> Text -> Dict Text Text -> Metadata
Internal.Metadata
        { metadataStatusCode :: Int
Internal.metadataStatusCode = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
<| Status -> Int
Status.statusCode Status
status,
          metadataStatusText :: Text
Internal.metadataStatusText =
            Status
status
              Status -> (Status -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Status -> ByteString
Status.statusMessage
              ByteString -> (ByteString -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> ByteString -> Text
Data.Text.Encoding.decodeUtf8,
          metadataHeaders :: Dict Text Text
Internal.metadataHeaders =
            (Header -> Dict Text Text -> Dict Text Text)
-> Dict Text Text -> RequestHeaders -> Dict Text Text
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldl
              ( \(HeaderName
name, ByteString
valueBS) ->
                  let value :: Text
value = ByteString -> Text
Data.Text.Encoding.decodeUtf8 ByteString
valueBS
                   in Text
-> (Maybe Text -> Maybe Text) -> Dict Text Text -> Dict Text Text
forall comparable v.
Ord comparable =>
comparable
-> (Maybe v -> Maybe v) -> Dict comparable v -> Dict comparable v
Dict.update
                        (ByteString -> Text
Data.Text.Encoding.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
<| HeaderName -> ByteString
forall s. CI s -> s
CI.original HeaderName
name)
                        ( \Maybe Text
current ->
                            Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
<| case Maybe Text
current of
                              Just Text
current_ -> Text
current_ Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
", " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
value
                              Maybe Text
Nothing -> Text
value
                        )
              )
              Dict Text Text
forall k v. Dict k v
Dict.empty
              (Response a -> RequestHeaders
forall body. Response body -> RequestHeaders
HTTP.responseHeaders Response a
response)
        }

-- |
-- Expect the response body to be JSON.
expectJson :: Aeson.FromJSON a => Expect a
expectJson :: Expect a
expectJson = Expect a
forall a. FromJSON a => Expect a
Internal.ExpectJson

-- |
-- Expect the response body to be a `Text`.
expectText :: Expect Text
expectText :: Expect Text
expectText = Expect Text
Internal.ExpectText

-- |
-- Expect the response body to be whatever. It does not matter. Ignore it!
expectWhatever :: Expect ()
expectWhatever :: Expect ()
expectWhatever = Expect ()
Internal.ExpectWhatever

-- |
-- Expect a `Response` with a `Text` body.
expectTextResponse :: (Internal.Response Text -> Result x a) -> Expect' x a
expectTextResponse :: (Response Text -> Result x a) -> Expect' x a
expectTextResponse = (Response Text -> Result x a) -> Expect' x a
forall x a. (Response Text -> Result x a) -> Expect' x a
Internal.ExpectTextResponse

-- |
-- Expect a `Response` with a `ByteString` body
expectBytesResponse :: (Internal.Response ByteString -> Result x a) -> Expect' x a
expectBytesResponse :: (Response ByteString -> Result x a) -> Expect' x a
expectBytesResponse = (Response ByteString -> Result x a) -> Expect' x a
forall x a. (Response ByteString -> Result x a) -> Expect' x a
Internal.ExpectBytesResponse

-- |
type Error = Internal.Error

-- Our Task type carries around some context values which should influence in
-- minor ways the logic of sending a request. In this function we modify a
-- manager to apply these modifications (see the comments below for the exact
-- nature of the modifications).
--
-- We're changing settings on the manager that originally get set during the
-- creation of the manager. We cannot set these settings once during creation
-- because they will be different for each outgoing request, and for performance
-- reasons we're encouraged to reuse a manager as much as possible. Modifying a
-- manager in this way does require use of the `Network.HTTP.Client.Internal`
-- module, which on account of being an internal module increases the risk of
-- this code breaking in future versions of the `http-client` package. There's
-- an outstanding PR for motivating these Manager modification functions are
-- moved to the stable API: https://github.com/snoyberg/http-client/issues/426
prepareManagerForRequest :: HTTP.Manager -> Task e HTTP.Manager
prepareManagerForRequest :: Manager -> Task e Manager
prepareManagerForRequest Manager
manager = do
  LogHandler
log <- Task e LogHandler
forall e. Task e LogHandler
Platform.logHandler
  Text
requestId <- Task e Text
forall e. Task e Text
Platform.requestId
  Manager -> Task e Manager
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Manager
manager
      { -- To be able to correlate events and logs belonging to a single
        -- original user request we pass around a request ID on HTTP requests
        -- between services. Below we add this request ID to all outgoing HTTP
        -- requests.
        mModifyRequest :: Request -> IO Request
HTTP.Internal.mModifyRequest = \Request
req ->
          Manager -> Request -> IO Request
HTTP.Internal.mModifyRequest Manager
manager Request
req
            IO Request -> (IO Request -> IO Request) -> IO Request
forall a b. a -> (a -> b) -> b
|> (Request -> IO Request) -> IO Request -> IO Request
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
andThen (Text -> Request -> IO Request
modifyRequest Text
requestId),
        -- We trace outgoing HTTP requests. This comes down to measuring how
        -- long they take and passing that information to some dashboard. This
        -- dashboard can then draw nice graphs showing how the time responding
        -- to a request it divided between different activities, such as sending
        -- HTTP requests. We can use the `mWrapException` for this purpose,
        -- although in our case we're not wrapping because of exceptions.
        mWrapException :: forall a. Request -> IO a -> IO a
HTTP.Internal.mWrapException = \Request
req IO a
io ->
          Manager -> Request -> IO a -> IO a
Manager -> forall a. Request -> IO a -> IO a
HTTP.Internal.mWrapException Manager
manager Request
req IO a
io
            IO a -> (IO a -> IO a) -> IO a
forall a b. a -> (a -> b) -> b
|> LogHandler -> Request -> IO a -> IO a
forall a. LogHandler -> Request -> IO a -> IO a
wrapException LogHandler
log Request
req
      }
  where
    modifyRequest :: Text -> HTTP.Request -> IO HTTP.Request
    modifyRequest :: Text -> Request -> IO Request
modifyRequest Text
requestId Request
req =
      case Text
requestId of
        Text
"" -> Request -> IO Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure Request
req
        Text
_ ->
          Request -> IO Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            Request
req
              { requestHeaders :: RequestHeaders
HTTP.requestHeaders =
                  (HeaderName
"x-request-id", Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
requestId) Header -> RequestHeaders -> RequestHeaders
forall a. a -> [a] -> [a]
:
                  Request -> RequestHeaders
HTTP.requestHeaders Request
req
              }
    wrapException :: forall a. Platform.LogHandler -> HTTP.Request -> IO a -> IO a
    wrapException :: LogHandler -> Request -> IO a -> IO a
wrapException LogHandler
log Request
req IO a
io =
      let uri :: URI
uri = Request -> URI
HTTP.getUri Request
req
          host :: Text
host =
            URI -> String
Network.URI.uriScheme URI
uri
              String -> String -> String
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ ( URI -> Maybe URIAuth
Network.URI.uriAuthority URI
uri
                     Maybe URIAuth
-> (Maybe URIAuth -> String -> String) -> String -> String
forall a b. a -> (a -> b) -> b
|> (String -> String) -> Maybe URIAuth -> String -> String
Network.URI.uriAuthToString (\String
_ -> String
"*****")
                     (String -> String) -> ((String -> String) -> String) -> String
forall a b. a -> (a -> b) -> b
|> (\String -> String
showS -> String -> String
showS String
"")
                 )
              String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
Text.fromList
          method :: Text
method =
            Request -> ByteString
HTTP.method Request
req
              ByteString -> (ByteString -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> ByteString -> Text
Data.Text.Encoding.decodeUtf8
          spanDetails :: Outgoing
spanDetails =
            Details -> Outgoing
HttpRequest.Outgoing
              Details
HttpRequest.emptyDetails
                { host :: Maybe Text
HttpRequest.host = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
host,
                  path :: Maybe Text
HttpRequest.path =
                    URI -> String
Network.URI.uriPath URI
uri
                      String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
Text.fromList
                      Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Text
forall a. a -> Maybe a
Just,
                  queryString :: Maybe Text
HttpRequest.queryString =
                    URI -> String
Network.URI.uriQuery URI
uri
                      String -> (String -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> String -> Text
Text.fromList
                      Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Text
forall a. a -> Maybe a
Just,
                  method :: Maybe Text
HttpRequest.method = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
method
                }
          uriStr :: Text
uriStr =
            Request -> URI
HTTP.getUri Request
req
              URI -> (URI -> String -> String) -> String -> String
forall a b. a -> (a -> b) -> b
|> (String -> String) -> URI -> String -> String
Network.URI.uriToString (\String
_ -> String
"*****")
              (String -> String) -> ((String -> String) -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> (\String -> String
showS -> String -> Text
Text.fromList (String -> String
showS String
""))
       in LogHandler -> Text -> (LogHandler -> IO a) -> IO a
forall a.
HasCallStack =>
LogHandler -> Text -> (LogHandler -> IO a) -> IO a
Platform.tracingSpanIO
            LogHandler
log
            Text
"Outgoing HTTP Request"
            ( \LogHandler
log' ->
                IO a -> IO () -> IO a
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
Exception.finally
                  IO a
io
                  ( do
                      LogHandler -> Outgoing -> IO ()
LogHandler -> forall d. TracingSpanDetails d => d -> IO ()
Platform.setTracingSpanDetailsIO LogHandler
log' Outgoing
spanDetails
                      LogHandler -> Text -> IO ()
Platform.setTracingSpanSummaryIO
                        LogHandler
log'
                        (Text
method Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
" " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
uriStr)
                  )
            )