module Servant.Haxl.Client.Req
( Req
, ServantError
, ServantResponse
, ServantConnectionError
, defReq
, appendToPath
, appendToMatrixParams
, appendToQueryString
, addHeader
, setRQBody
, displayHttpRequest
, initServantClientState
, performRequest
, performRequestCT
, performRequestNoBody
) where
import Control.Monad
import Control.Monad.Catch
import Data.ByteString.Lazy hiding (elem, filter, map,
null, pack)
import Data.Proxy
import Data.String.Conversions
import Data.Text (Text)
import Haxl.Core hiding (Request, catch)
import Network.HTTP.Media
import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP
import Servant.API.ContentTypes
import Servant.Common.Text
import Servant.Haxl.Client.BaseUrl
import Servant.Haxl.Client.Internal
import Servant.Haxl.Client.Internal.Error
import Servant.Haxl.Client.Types
defReq :: Req
defReq = Req "" [] Nothing [] []
appendToPath :: String -> Req -> Req
appendToPath p req =
req { reqPath = reqPath req ++ "/" ++ p }
appendToMatrixParams :: String
-> Maybe String
-> Req
-> Req
appendToMatrixParams pname pvalue req =
req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue }
appendToQueryString :: Text
-> Maybe Text
-> Req
-> Req
appendToQueryString pname pvalue req =
req { qs = qs req ++ [(pname, pvalue)]
}
addHeader :: ToText a => String -> a -> Req -> Req
addHeader name val req = req { headers = headers req
++ [(name, toText val)]
}
setRQBody :: ByteString -> MediaType -> Req -> Req
setRQBody b t req = req { reqBody = Just (b, t) }
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () (Int, ByteString, MediaType, [HTTP.Header], ServantResponse)
performRequest m r w h = dataFetch $ ServantRequest m r w h
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () ([HTTP.Header], result)
performRequestCT ct reqMethod req wantedStatus reqHost = do
let acceptCT = contentType ct
(_status, respBody, respCT, hrds, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) wantedStatus reqHost
unless (matches respCT acceptCT) $ throwM $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
Left err -> throwM $ DecodeFailure err respCT respBody
Right val -> return (hrds, val)
performRequestNoBody :: Method -> Req -> WantedStatusCodes -> BaseUrl -> GenHaxl () ()
performRequestNoBody reqMethod req wantedStatus reqHost = do
_ <- performRequest reqMethod req wantedStatus reqHost
return ()