{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
module Http
(
Handler,
handler,
get,
post,
request,
Internal.Request' (..),
Internal.Request,
Internal.Error (..),
Internal.Header,
header,
Internal.Body,
emptyBody,
stringBody,
jsonBody,
bytesBody,
Expect,
expectJson,
expectText,
expectWhatever,
Expect',
expectTextResponse,
expectBytesResponse,
Internal.Response (..),
Internal.Metadata (..),
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)
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)
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
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
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
}
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
}
header :: Text -> Text -> Internal.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))
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
}
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)
}
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"
}
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)
}
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)
}
expectJson :: Aeson.FromJSON a => Expect a
expectJson :: Expect a
expectJson = Expect a
forall a. FromJSON a => Expect a
Internal.ExpectJson
expectText :: Expect Text
expectText :: Expect Text
expectText = Expect Text
Internal.ExpectText
expectWhatever :: Expect ()
expectWhatever :: Expect ()
expectWhatever = Expect ()
Internal.ExpectWhatever
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
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
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
{
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),
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)
)
)