Record accessors for ServantError

This commit is contained in:
Timo von Holtz 2015-03-09 08:37:09 +11:00
parent ba46ecc0a9
commit 8015906b53

View file

@ -28,11 +28,27 @@ import System.IO.Unsafe
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
data ServantError data ServantError
= FailureResponse Status MediaType ByteString = FailureResponse
| DecodeFailure String MediaType ByteString { responseStatus :: Status
| UnsupportedContentType MediaType ByteString , responseContentType :: MediaType
| ConnectionError HttpException , responseBody :: ByteString
| InvalidContentTypeHeader String }
| DecodeFailure
{ decodeError :: String
, responseContentType :: MediaType
, responseBody :: ByteString
}
| UnsupportedContentType
{ responseContentType :: MediaType
, responseBody :: ByteString
}
| ConnectionError
{ connectionError :: HttpException
}
| InvalidContentTypeHeader
{ responseContentTypeHeader :: ByteString
, responseBody :: ByteString
}
deriving (Show) deriving (Show)
data Req = Req data Req = Req
@ -139,7 +155,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> left . InvalidContentTypeHeader . cs $ t Nothing -> left $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t' Just t' -> pure t'
unless (isWantedStatus status_code) $ unless (isWantedStatus status_code) $
left $ FailureResponse status ct body left $ FailureResponse status ct body