@@ -13,10 +13,12 @@ import Data.Aeson
1313import Data.Aeson.Parser
1414import Data.Aeson.Types
1515import Data.Attoparsec.ByteString
16−import Data.ByteString.Lazy hiding (pack)
16+import Data.ByteString.Lazy hiding (pack, filter, map)
17+import qualified Data.ByteString as BS
18+import qualified Data.ByteString.Char8 as BSC
1719import Data.String
1820import Data.String.Conversions
19−import Data.Text
21+import Data.Text (Text)
2022import Data.Text.Encoding
2123import Network.HTTP.Client
2224import Network.HTTP.Client.TLS
@@ -30,14 +32,15 @@ import System.IO.Unsafe
3032import qualified Network.HTTP.Client as Client
3133
3234data Req = Req
33− { reqPath :: String
34− , qs :: QueryText
35− , reqBody :: Maybe (ByteString, MediaType)
36− , headers :: [(String, Text)]
35+ { reqPath :: String
36+ , qs :: QueryText
37+ , reqBody :: Maybe (ByteString, MediaType)
38+ , reqAccept :: [MediaType]
39+ , headers :: [(String, Text)]
3740 }
3841
3942defReq :: Req
40−defReq = Req "" [] Nothing []
43+defReq = Req "" [] Nothing [] []
4144
4245appendToPath :: String -> Req -> Req
4346appendToPath p req =
@@ -68,7 +71,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
6871
6972reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
7073reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
71− fmap (setheaders . setrqb . setQS ) $ parseUrl url
74+ fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
7275
7376 where url = show $ nullURI { uriScheme = case reqScheme of
7477 Http -> "http:"
@@ -84,11 +87,15 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
8487 setrqb r = case (reqBody req) of
8588 Nothing -> r
8689 Just (b,t) -> r { requestBody = RequestBodyLBS b
87− , requestHeaders = [(hContentType, cs . show $ t)] }
90+ , requestHeaders = requestHeaders r
91+ ++ [(hContentType, cs . show $ t)] }
8892 setQS = setQueryString $ queryTextToQuery (qs req)
8993 setheaders r = r { requestHeaders = requestHeaders r
9094 ++ Prelude.map toProperHeader (headers req) }
91−
95+ setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
96+ ++ [("Accept", BS.intercalate ", " (map renderAccept $ reqAccept req))] }
97+ renderAccept :: MediaType -> BS.ByteString
98+ renderAccept m = BSC.pack (show m)
9299 toProperHeader (name, val) =
93100 (fromString name, encodeUtf8 val)
94101
@@ -142,7 +149,8 @@ performRequest reqMethod req isWantedStatus reqHost = do
142149performRequestJSON :: FromJSON result =>
143150 Method -> Req -> Int -> BaseUrl -> EitherT String IO result
144151performRequestJSON reqMethod req wantedStatus reqHost = do
145− (_status, respBody, contentType) <- performRequest reqMethod req (== wantedStatus) reqHost
152+ (_status, respBody, contentType) <-
153+ performRequest reqMethod (req { reqAccept = ["application"//"json"] }) (== wantedStatus) reqHost
146154 unless (matches contentType ("application"//"json")) $
147155 left $ "requested Content-Type application/json, but got " <> show contentType
148156 either