{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Observe.Event.Servant.Client
(
ClientM (..),
runClientM,
RunRequest (..),
runRequestJSON,
RunRequestField (..),
runRequestFieldJSON,
clientErrorJSON,
responseJSON,
)
where
import Control.Monad.Base
import Control.Monad.Catch
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Trans.Control
import Data.Aeson
import Data.Binary.Builder
import Data.ByteString.Lazy hiding (null)
import Data.ByteString.Lazy.Internal (ByteString (..))
import Data.CaseInsensitive
import Data.Coerce
import Data.Functor.Alt
import Data.Map.Strict (mapKeys)
import Data.Text.Encoding
import GHC.Generics
import Network.HTTP.Media.MediaType
import Network.HTTP.Media.RenderHeader
import Network.HTTP.Types.Status
import Network.HTTP.Types.Version
import Observe.Event
import Observe.Event.Render.JSON
import Servant.Client hiding (ClientM, runClientM)
import Servant.Client.Core.Request
import Servant.Client.Core.RunClient hiding (RunRequest)
import Servant.Client.Internal.HttpClient hiding (ClientM, runClientM)
import qualified Servant.Client.Internal.HttpClient as S
newtype ClientM r a = ClientM (ReaderT (EventBackend S.ClientM r RunRequest) S.ClientM a)
deriving newtype (forall {r}. Applicative (ClientM r)
forall a. a -> ClientM r a
forall r a. a -> ClientM r a
forall a b. ClientM r a -> ClientM r b -> ClientM r b
forall a b. ClientM r a -> (a -> ClientM r b) -> ClientM r b
forall r a b. ClientM r a -> ClientM r b -> ClientM r b
forall r a b. ClientM r a -> (a -> ClientM r b) -> ClientM r b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ClientM r a
$creturn :: forall r a. a -> ClientM r a
>> :: forall a b. ClientM r a -> ClientM r b -> ClientM r b
$c>> :: forall r a b. ClientM r a -> ClientM r b -> ClientM r b
>>= :: forall a b. ClientM r a -> (a -> ClientM r b) -> ClientM r b
$c>>= :: forall r a b. ClientM r a -> (a -> ClientM r b) -> ClientM r b
Monad, forall a b. a -> ClientM r b -> ClientM r a
forall a b. (a -> b) -> ClientM r a -> ClientM r b
forall r a b. a -> ClientM r b -> ClientM r a
forall r a b. (a -> b) -> ClientM r a -> ClientM r b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ClientM r b -> ClientM r a
$c<$ :: forall r a b. a -> ClientM r b -> ClientM r a
fmap :: forall a b. (a -> b) -> ClientM r a -> ClientM r b
$cfmap :: forall r a b. (a -> b) -> ClientM r a -> ClientM r b
Functor, forall r. Functor (ClientM r)
forall a. a -> ClientM r a
forall r a. a -> ClientM r a
forall a b. ClientM r a -> ClientM r b -> ClientM r a
forall a b. ClientM r a -> ClientM r b -> ClientM r b
forall a b. ClientM r (a -> b) -> ClientM r a -> ClientM r b
forall r a b. ClientM r a -> ClientM r b -> ClientM r a
forall r a b. ClientM r a -> ClientM r b -> ClientM r b
forall r a b. ClientM r (a -> b) -> ClientM r a -> ClientM r b
forall a b c.
(a -> b -> c) -> ClientM r a -> ClientM r b -> ClientM r c
forall r a b c.
(a -> b -> c) -> ClientM r a -> ClientM r b -> ClientM r c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ClientM r a -> ClientM r b -> ClientM r a
$c<* :: forall r a b. ClientM r a -> ClientM r b -> ClientM r a
*> :: forall a b. ClientM r a -> ClientM r b -> ClientM r b
$c*> :: forall r a b. ClientM r a -> ClientM r b -> ClientM r b
liftA2 :: forall a b c.
(a -> b -> c) -> ClientM r a -> ClientM r b -> ClientM r c
$cliftA2 :: forall r a b c.
(a -> b -> c) -> ClientM r a -> ClientM r b -> ClientM r c
<*> :: forall a b. ClientM r (a -> b) -> ClientM r a -> ClientM r b
$c<*> :: forall r a b. ClientM r (a -> b) -> ClientM r a -> ClientM r b
pure :: forall a. a -> ClientM r a
$cpure :: forall r a. a -> ClientM r a
Applicative, forall r. Monad (ClientM r)
forall a. IO a -> ClientM r a
forall r a. IO a -> ClientM r a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> ClientM r a
$cliftIO :: forall r a. IO a -> ClientM r a
MonadIO, forall r. Monad (ClientM r)
forall e a. Exception e => e -> ClientM r a
forall r e a. Exception e => e -> ClientM r a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> ClientM r a
$cthrowM :: forall r e a. Exception e => e -> ClientM r a
MonadThrow, forall r. MonadThrow (ClientM r)
forall e a.
Exception e =>
ClientM r a -> (e -> ClientM r a) -> ClientM r a
forall r e a.
Exception e =>
ClientM r a -> (e -> ClientM r a) -> ClientM r a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
ClientM r a -> (e -> ClientM r a) -> ClientM r a
$ccatch :: forall r e a.
Exception e =>
ClientM r a -> (e -> ClientM r a) -> ClientM r a
MonadCatch, MonadError ClientError, MonadBase IO, MonadReader (EventBackend S.ClientM r RunRequest))
deriving stock (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall r a x. Rep (ClientM r a) x -> ClientM r a
forall r a x. ClientM r a -> Rep (ClientM r a) x
$cto :: forall r a x. Rep (ClientM r a) x -> ClientM r a
$cfrom :: forall r a x. ClientM r a -> Rep (ClientM r a) x
Generic)
instance MonadBaseControl IO (ClientM r) where
type StM (ClientM r) a = Either ClientError a
liftBaseWith :: forall a. (RunInBase (ClientM r) IO -> IO a) -> ClientM r a
liftBaseWith RunInBase (ClientM r) IO -> IO a
go = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \EventBackend ClientM r RunRequest
backend -> forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
(RunInBase m b -> b a) -> m a
liftBaseWith (\RunInBase ClientM IO
run -> RunInBase (ClientM r) IO -> IO a
go (RunInBase ClientM IO
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT EventBackend ClientM r RunRequest
backend forall b c a. (b -> c) -> (a -> b) -> a -> c
. coerce :: forall a b. Coercible a b => a -> b
coerce))
restoreM :: forall a. StM (ClientM r) a -> ClientM r a
restoreM = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (b :: * -> *) (m :: * -> *) a.
MonadBaseControl b m =>
StM m a -> m a
restoreM
instance Alt (ClientM r) where
ClientM r a
x <!> :: forall a. ClientM r a -> ClientM r a -> ClientM r a
<!> ClientM r a
y = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \EventBackend ClientM r RunRequest
backend -> (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (coerce :: forall a b. Coercible a b => a -> b
coerce ClientM r a
x) EventBackend ClientM r RunRequest
backend) forall (f :: * -> *) a. Alt f => f a -> f a -> f a
<!> (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (coerce :: forall a b. Coercible a b => a -> b
coerce ClientM r a
y) EventBackend ClientM r RunRequest
backend)
some :: forall a. Applicative (ClientM r) => ClientM r a -> ClientM r [a]
some ClientM r a
x = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \EventBackend ClientM r RunRequest
backend -> forall (f :: * -> *) a. (Alt f, Applicative f) => f a -> f [a]
some (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (coerce :: forall a b. Coercible a b => a -> b
coerce ClientM r a
x) EventBackend ClientM r RunRequest
backend)
many :: forall a. Applicative (ClientM r) => ClientM r a -> ClientM r [a]
many ClientM r a
x = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \EventBackend ClientM r RunRequest
backend -> forall (f :: * -> *) a. (Alt f, Applicative f) => f a -> f [a]
many (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (coerce :: forall a b. Coercible a b => a -> b
coerce ClientM r a
x) EventBackend ClientM r RunRequest
backend)
instance RunClient (ClientM r) where
runRequestAcceptStatus :: Maybe [Status] -> Request -> ClientM r Response
runRequestAcceptStatus Maybe [Status]
stats Request
req = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT \EventBackend ClientM r RunRequest
backend -> forall a. ReaderT ClientEnv (ExceptT ClientError IO) a -> ClientM a
S.ClientM forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) r (s :: * -> *) a.
MonadMask m =>
EventBackend m r s
-> forall f. s f -> (Event m r s f -> m a) -> m a
withEvent (forall (m :: * -> *) (n :: * -> *) r (s :: * -> *).
(Functor m, Functor n) =>
(forall x. m x -> n x) -> EventBackend m r s -> EventBackend n r s
hoistEventBackend forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM EventBackend ClientM r RunRequest
backend) RunRequest RunRequestField
RunRequest \Event
(ReaderT ClientEnv (ExceptT ClientError IO))
r
RunRequest
RunRequestField
ev -> do
forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField Event
(ReaderT ClientEnv (ExceptT ClientError IO))
r
RunRequest
RunRequestField
ev forall a b. (a -> b) -> a -> b
$ Request -> RunRequestField
ReqField Request
req
Response
res <- forall a. ClientM a -> ReaderT ClientEnv (ExceptT ClientError IO) a
unClientM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
RunClient m =>
Maybe [Status] -> Request -> m Response
runRequestAcceptStatus Maybe [Status]
stats Request
req
forall (m :: * -> *) r (s :: * -> *) f. Event m r s f -> f -> m ()
addField Event
(ReaderT ClientEnv (ExceptT ClientError IO))
r
RunRequest
RunRequestField
ev forall a b. (a -> b) -> a -> b
$ Response -> RunRequestField
ResField Response
res
forall (f :: * -> *) a. Applicative f => a -> f a
pure Response
res
throwClientError :: forall a. ClientError -> ClientM r a
throwClientError = forall r a.
ReaderT (EventBackend ClientM r RunRequest) ClientM a
-> ClientM r a
ClientM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. RunClient m => ClientError -> m a
throwClientError
runClientM :: EventBackend S.ClientM r RunRequest -> ClientM r a -> ClientEnv -> IO (Either ClientError a)
runClientM :: forall r a.
EventBackend ClientM r RunRequest
-> ClientM r a -> ClientEnv -> IO (Either ClientError a)
runClientM EventBackend ClientM r RunRequest
backend ClientM r a
c = forall a. ClientM a -> ClientEnv -> IO (Either ClientError a)
S.runClientM (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (coerce :: forall a b. Coercible a b => a -> b
coerce ClientM r a
c) EventBackend ClientM r RunRequest
backend)
data RunRequest f where
RunRequest :: RunRequest RunRequestField
runRequestJSON :: RenderSelectorJSON RunRequest
runRequestJSON :: RenderSelectorJSON RunRequest
runRequestJSON RunRequest f
RunRequest = (Key
"run-request", RenderFieldJSON RunRequestField
runRequestFieldJSON)
data RunRequestField
= ReqField Request
| ResField Response
runRequestFieldJSON :: RenderFieldJSON RunRequestField
runRequestFieldJSON :: RenderFieldJSON RunRequestField
runRequestFieldJSON (ReqField Request {Maybe (RequestBody, MediaType)
ByteString
Builder
Seq QueryItem
Seq Header
Seq MediaType
HttpVersion
requestPath :: forall body path. RequestF body path -> path
requestQueryString :: forall body path. RequestF body path -> Seq QueryItem
requestBody :: forall body path. RequestF body path -> Maybe (body, MediaType)
requestAccept :: forall body path. RequestF body path -> Seq MediaType
requestHeaders :: forall body path. RequestF body path -> Seq Header
requestHttpVersion :: forall body path. RequestF body path -> HttpVersion
requestMethod :: forall body path. RequestF body path -> ByteString
requestMethod :: ByteString
requestHttpVersion :: HttpVersion
requestHeaders :: Seq Header
requestAccept :: Seq MediaType
requestBody :: Maybe (RequestBody, MediaType)
requestQueryString :: Seq QueryItem
requestPath :: Builder
..}) =
( Key
"request",
Object -> Value
Object
( Key
"path" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (ByteString -> ByteString
toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
requestPath)
forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq QueryItem
requestQueryString
then forall a. Monoid a => a
mempty
else
Key
"query"
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ( ( \(ByteString
k, Maybe ByteString
mv) ->
Object -> Value
Object
( Key
"key" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
k
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty ((Key
"value" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) Maybe ByteString
mv
)
)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq QueryItem
requestQueryString
)
)
forall a. Semigroup a => a -> a -> a
<> case Maybe (RequestBody, MediaType)
requestBody of
Maybe (RequestBody, MediaType)
Nothing -> forall a. Monoid a => a
mempty
Just (RequestBody
body, MediaType
ty) ->
( Key
"content-type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (forall h. RenderHeader h => h -> ByteString
renderHeader MediaType
ty)
forall a. Semigroup a => a -> a -> a
<> case RequestBody
body of
RequestBodyBS ByteString
bs -> Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
bs
RequestBodyLBS ByteString
Empty -> Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
False
RequestBodyLBS (Chunk ByteString
bs ByteString
Empty) -> Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
bs
RequestBody
_ -> forall a. Monoid a => a
mempty
)
forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq MediaType
requestAccept
then forall a. Monoid a => a
mempty
else Key
"accept" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall h. RenderHeader h => h -> ByteString
renderHeader) Seq MediaType
requestAccept
)
forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq Header
requestHeaders
then forall a. Monoid a => a
mempty
else Key
"headers" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CI ByteString
nm, ByteString
val) -> Object -> Value
Object (Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (forall s. CI s -> s
original CI ByteString
nm) forall a. Semigroup a => a -> a -> a
<> (if CI ByteString
nm forall a. Eq a => a -> a -> Bool
== CI ByteString
"Authorization" then forall a. Monoid a => a
mempty else Key
"val" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
val))) Seq Header
requestHeaders
)
forall a. Semigroup a => a -> a -> a
<> Key
"http-version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object (Key
"major" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Int
httpMajor HttpVersion
requestHttpVersion forall a. Semigroup a => a -> a -> a
<> Key
"minor" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Int
httpMinor HttpVersion
requestHttpVersion)
forall a. Semigroup a => a -> a -> a
<> Key
"method" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
requestMethod
)
)
runRequestFieldJSON (ResField Response
res) =
( Key
"response",
Response -> Bool -> Value
responseJSON Response
res Bool
False
)
clientErrorJSON :: RenderFieldJSON ClientError
clientErrorJSON :: RenderFieldJSON ClientError
clientErrorJSON (FailureResponse RequestF () (BaseUrl, ByteString)
_ Response
res) = (Key
"failure-response", Response -> Bool -> Value
responseJSON Response
res Bool
True)
clientErrorJSON (DecodeFailure Text
err Response
res) = (Key
"decode-failure", Object -> Value
Object (Key
"response" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Response -> Bool -> Value
responseJSON Response
res Bool
True forall a. Semigroup a => a -> a -> a
<> Key
"err" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
err))
clientErrorJSON (UnsupportedContentType MediaType
ty Response
res) =
( Key
"unsupported-content-type",
Object -> Value
Object
( Key
"response" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Response -> Bool -> Value
responseJSON Response
res Bool
True
forall a. Semigroup a => a -> a -> a
<> Key
"main-type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (forall s. CI s -> s
original forall a b. (a -> b) -> a -> b
$ MediaType -> CI ByteString
mainType MediaType
ty)
forall a. Semigroup a => a -> a -> a
<> Key
"sub-type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (forall s. CI s -> s
original forall a b. (a -> b) -> a -> b
$ MediaType -> CI ByteString
subType MediaType
ty)
forall a. Semigroup a => a -> a -> a
<> Key
"parameters" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
original) (forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
mapKeys (ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. CI s -> s
original) forall a b. (a -> b) -> a -> b
$ MediaType -> Parameters
parameters MediaType
ty)
)
)
clientErrorJSON (InvalidContentTypeHeader Response
res) = (Key
"invalid-content-type-header", Response -> Bool -> Value
responseJSON Response
res Bool
True)
clientErrorJSON (ConnectionError SomeException
e) = (Key
"connection-error", forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show SomeException
e)
responseJSON :: Response -> Bool -> Value
responseJSON :: Response -> Bool -> Value
responseJSON Response {ByteString
Seq Header
HttpVersion
Status
responseHttpVersion :: forall a. ResponseF a -> HttpVersion
responseStatusCode :: forall a. ResponseF a -> Status
responseBody :: forall a. ResponseF a -> a
responseHeaders :: forall a. ResponseF a -> Seq Header
responseBody :: ByteString
responseHttpVersion :: HttpVersion
responseHeaders :: Seq Header
responseStatusCode :: Status
..} Bool
forceBody =
Object -> Value
Object
( Key
"status" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Status -> Int
statusCode Status
responseStatusCode
forall a. Semigroup a => a -> a -> a
<> ( if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq Header
responseHeaders
then forall a. Monoid a => a
mempty
else Key
"headers" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(CI ByteString
nm, ByteString
val) -> Object -> Value
Object (Key
"name" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 (forall s. CI s -> s
original CI ByteString
nm) forall a. Semigroup a => a -> a -> a
<> (if CI ByteString
nm forall a. Eq a => a -> a -> Bool
== CI ByteString
"Cookie" then forall a. Monoid a => a
mempty else Key
"val" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
val))) Seq Header
responseHeaders
)
forall a. Semigroup a => a -> a -> a
<> Key
"http-version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Object -> Value
Object (Key
"major" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Int
httpMajor HttpVersion
responseHttpVersion forall a. Semigroup a => a -> a -> a
<> Key
"minor" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HttpVersion -> Int
httpMinor HttpVersion
responseHttpVersion)
forall a. Semigroup a => a -> a -> a
<> ( if Bool
forceBody
then Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (ByteString -> Text
decodeUtf8 forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
toStrict ByteString
responseBody)
else case ByteString
responseBody of
ByteString
Empty -> Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Bool
False
Chunk ByteString
bs ByteString
Empty -> Key
"body" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= ByteString -> Text
decodeUtf8 ByteString
bs
ByteString
_ -> forall a. Monoid a => a
mempty
)
)