servant/servant-client/src/Servant/Common/Req.hs

176 lines
6.4 KiB
Haskell
Raw Normal View History

2015-05-27 22:25:08 +02:00
{-# LANGUAGE DeriveDataTypeable #-}
2015-04-20 19:52:29 +02:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Servant.Common.Req where
2015-04-20 19:52:29 +02:00
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
2015-04-20 19:52:29 +02:00
#endif
import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
2015-09-12 14:11:24 +02:00
import Control.Monad.Trans.Except
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
2014-12-08 12:52:30 +01:00
import Data.String
import Data.String.Conversions
import Data.Proxy
2015-02-17 01:51:59 +01:00
import Data.Text (Text)
2014-12-08 12:52:30 +01:00
import Data.Text.Encoding
2015-05-27 22:25:08 +02:00
import Data.Typeable
2015-08-25 04:26:15 +02:00
import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Media
import Network.HTTP.Types
2015-05-02 03:21:03 +02:00
import qualified Network.HTTP.Types.Header as HTTP
2015-08-25 04:26:15 +02:00
import Network.URI hiding (path)
import Servant.API.ContentTypes
import Servant.Common.BaseUrl
import qualified Network.HTTP.Client as Client
import Web.HttpApiData
data ServantError
2015-03-08 22:37:09 +01:00
= FailureResponse
{ responseStatus :: Status
, responseContentType :: MediaType
, responseBody :: ByteString
}
| DecodeFailure
{ decodeError :: String
, responseContentType :: MediaType
, responseBody :: ByteString
}
| UnsupportedContentType
{ responseContentType :: MediaType
, responseBody :: ByteString
}
| InvalidContentTypeHeader
{ responseContentTypeHeader :: ByteString
, responseBody :: ByteString
}
2015-05-25 09:51:35 +02:00
| ConnectionError
{ connectionError :: SomeException
2015-05-25 09:51:35 +02:00
}
2015-05-27 22:25:08 +02:00
deriving (Show, Typeable)
instance Exception ServantError
data Req = Req
2015-02-17 01:51:59 +01:00
{ reqPath :: String
, qs :: QueryText
, reqBody :: Maybe (ByteString, MediaType)
, reqAccept :: [MediaType]
, headers :: [(String, Text)]
}
defReq :: Req
2015-02-17 01:51:59 +01:00
defReq = Req "" [] Nothing [] []
appendToPath :: String -> Req -> Req
appendToPath p req =
req { reqPath = reqPath req ++ "/" ++ p }
appendToQueryString :: Text -- ^ param name
-> Maybe Text -- ^ param value
-> Req
-> Req
appendToQueryString pname pvalue req =
req { qs = qs req ++ [(pname, pvalue)]
}
addHeader :: ToHttpApiData a => String -> a -> Req -> Req
2014-12-08 12:52:30 +01:00
addHeader name val req = req { headers = headers req
++ [(name, decodeUtf8 (toHeader val))]
2014-12-08 12:52:30 +01:00
}
setRQBody :: ByteString -> MediaType -> Req -> Req
setRQBody b t req = req { reqBody = Just (b, t) }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
2015-08-25 04:26:15 +02:00
reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
2015-08-17 23:50:42 +02:00
setheaders . setAccept . setrqb . setQS <$> parseUrl url
where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:"
Https -> "https:"
, uriAuthority = Just $
URIAuth { uriUserInfo = ""
, uriRegName = reqHost
, uriPort = ":" ++ show reqPort
}
2015-08-25 04:26:15 +02:00
, uriPath = path ++ reqPath req
}
2015-02-17 03:50:50 +01:00
setrqb r = case reqBody req of
Nothing -> r
Just (b,t) -> r { requestBody = RequestBodyLBS b
2015-02-17 01:51:59 +01:00
, requestHeaders = requestHeaders r
++ [(hContentType, cs . show $ t)] }
setQS = setQueryString $ queryTextToQuery (qs req)
setheaders r = r { requestHeaders = requestHeaders r
2015-02-17 03:50:50 +01:00
<> fmap toProperHeader (headers req) }
2015-02-17 01:51:59 +01:00
setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
2015-02-17 03:50:50 +01:00
<> [("Accept", renderHeader $ reqAccept req)
| not . null . reqAccept $ req] }
2014-12-08 12:52:30 +01:00
toProperHeader (name, val) =
2015-02-06 09:34:59 +01:00
(fromString name, encodeUtf8 val)
-- * performing requests
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> BaseUrl -> Manager
2015-09-12 14:11:24 +02:00
-> ExceptT ServantError IO ( Int, ByteString, MediaType
2015-05-02 03:21:03 +02:00
, [HTTP.Header], Response ByteString)
performRequest reqMethod req reqHost manager = do
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod
, checkStatus = \ _status _headers _cookies -> Nothing
}
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of
Left err ->
2015-09-12 14:11:24 +02:00
throwE . ConnectionError $ SomeException err
Right response -> do
let status = Client.responseStatus response
body = Client.responseBody response
2015-05-03 00:32:59 +02:00
hrds = Client.responseHeaders response
status_code = statusCode status
2015-02-17 00:32:15 +01:00
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of
2015-09-12 14:11:24 +02:00
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
2015-02-17 00:32:15 +01:00
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
2015-09-12 14:11:24 +02:00
throwE $ FailureResponse status ct body
2015-05-03 00:32:59 +02:00
return (status_code, body, ct, hrds, response)
2015-05-02 03:21:03 +02:00
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req reqHost manager = do
let acceptCT = contentType ct
2015-05-03 00:32:59 +02:00
(_status, respBody, respCT, hrds, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
2015-09-12 14:11:24 +02:00
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
2015-05-02 03:21:03 +02:00
case mimeUnrender ct respBody of
2015-09-12 14:11:24 +02:00
Left err -> throwE $ DecodeFailure err respCT respBody
2015-05-03 00:32:59 +02:00
Right val -> return (hrds, val)
performRequestNoBody :: Method -> Req -> BaseUrl -> Manager -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req reqHost manager =
void $ performRequest reqMethod req reqHost manager
2015-05-25 09:51:35 +02:00
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =
catch (Right <$> action) $ \e ->
pure . Left . ConnectionError $ SomeException (e :: HttpException)