eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Send the correct Accept header

Browse source
This commit is contained in:
Timo von Holtz 2015-02-17 11:51:59 +11:00
parent e6e67b275b
commit c444ec8374
1 changed files with 19 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
src/Servant/Common/Req.hs
View file

@ -13,10 +13,12 @@ import Data.Aeson
import Data.Aeson.Parser import Data.Aeson.Parser
import Data.Aeson.Types import Data.Aeson.Types
import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString
import Data.ByteString.Lazy hiding (pack) import Data.ByteString.Lazy hiding (pack, filter, map)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
import Data.Text import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Network.HTTP.Client import Network.HTTP.Client
import Network.HTTP.Client.TLS import Network.HTTP.Client.TLS
@ -33,11 +35,12 @@ data Req = Req
{ reqPath :: String { reqPath :: String
, qs :: QueryText , qs :: QueryText
, reqBody :: Maybe (ByteString, MediaType) , reqBody :: Maybe (ByteString, MediaType)
, reqAccept :: [MediaType]
, headers :: [(String, Text)] , headers :: [(String, Text)]
} }
defReq :: Req defReq :: Req
defReq = Req "" [] Nothing [] defReq = Req "" [] Nothing [] []
appendToPath :: String -> Req -> Req appendToPath :: String -> Req -> Req
appendToPath p req = appendToPath p req =
@ -68,7 +71,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
reqToRequest req (BaseUrl reqScheme reqHost reqPort) = reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
fmap (setheaders . setrqb . setQS ) $ parseUrl url fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
where url = show $ nullURI { uriScheme = case reqScheme of where url = show $ nullURI { uriScheme = case reqScheme of
Http -> "http:" Http -> "http:"
@ -84,11 +87,15 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
setrqb r = case (reqBody req) of setrqb r = case (reqBody req) of
Nothing -> r Nothing -> r
Just (b,t) -> r { requestBody = RequestBodyLBS b Just (b,t) -> r { requestBody = RequestBodyLBS b
, requestHeaders = [(hContentType, cs . show $ t)] } , requestHeaders = requestHeaders r
++ [(hContentType, cs . show $ t)] }
setQS = setQueryString $ queryTextToQuery (qs req) setQS = setQueryString $ queryTextToQuery (qs req)
setheaders r = r { requestHeaders = requestHeaders r setheaders r = r { requestHeaders = requestHeaders r
++ Prelude.map toProperHeader (headers req) } ++ Prelude.map toProperHeader (headers req) }
setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
++ [("Accept", BS.intercalate ", " (map renderAccept $ reqAccept req))] }
renderAccept :: MediaType -> BS.ByteString
renderAccept m = BSC.pack (show m)
toProperHeader (name, val) = toProperHeader (name, val) =
(fromString name, encodeUtf8 val) (fromString name, encodeUtf8 val)
@ -142,7 +149,8 @@ performRequest reqMethod req isWantedStatus reqHost = do
performRequestJSON :: FromJSON result => performRequestJSON :: FromJSON result =>
Method -> Req -> Int -> BaseUrl -> EitherT String IO result Method -> Req -> Int -> BaseUrl -> EitherT String IO result
performRequestJSON reqMethod req wantedStatus reqHost = do performRequestJSON reqMethod req wantedStatus reqHost = do
(_status, respBody, contentType) <- performRequest reqMethod req (== wantedStatus) reqHost (_status, respBody, contentType) <-
performRequest reqMethod (req { reqAccept = ["application"//"json"] }) (== wantedStatus) reqHost
unless (matches contentType ("application"//"json")) $ unless (matches contentType ("application"//"json")) $
left $ "requested Content-Type application/json, but got " <> show contentType left $ "requested Content-Type application/json, but got " <> show contentType
either either