@@ -13,10 +13,12 @@ import Data.Aeson
13import Data.Aeson.Parser
13import Data.Aeson.Parser
14import Data.Aeson.Types
14import Data.Aeson.Types
15import Data.Attoparsec.ByteString
15import 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
17import Data.String
19import Data.String
18import Data.String.Conversions
20import Data.String.Conversions
19−import Data.Text
21+import Data.Text (Text)
20import Data.Text.Encoding
22import Data.Text.Encoding
21import Network.HTTP.Client
23import Network.HTTP.Client
22import Network.HTTP.Client.TLS
24import Network.HTTP.Client.TLS
@@ -30,14 +32,15 @@ import System.IO.Unsafe
30import qualified Network.HTTP.Client as Client
32import qualified Network.HTTP.Client as Client
32data Req = Req
34data Req = Req
33− { reqPath :: String
35+ { reqPath :: String
34− , qs :: QueryText
36+ , qs :: QueryText
35− , reqBody :: Maybe (ByteString, MediaType)
37+ , reqBody :: Maybe (ByteString, MediaType)
38+ , reqAccept :: [MediaType]
36− , headers :: [(String, Text)]
39+ , headers :: [(String, Text)]
39defReq :: Req
42defReq :: Req
40−defReq = Req "" [] Nothing []
43+defReq = Req "" [] Nothing [] []
42appendToPath :: String -> Req -> Req
45appendToPath :: String -> Req -> Req
43appendToPath p req =
46appendToPath p req =
@@ -68,7 +71,7 @@ setRQBody b t req = req { reqBody = Just (b, t) }
69reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
72reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
70reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
73reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
71− fmap (setheaders . setrqb . setQS ) $ parseUrl url
74+ fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
73 where url = show $ nullURI { uriScheme = case reqScheme of
76 where url = show $ nullURI { uriScheme = case reqScheme of
74 Http -> "http:"
77 Http -> "http:"
@@ -84,11 +87,15 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
84 setrqb r = case (reqBody req) of
87 setrqb r = case (reqBody req) of
85 Nothing -> r
88 Nothing -> r
86 Just (b,t) -> r { requestBody = RequestBodyLBS b
89 Just (b,t) -> r { requestBody = RequestBodyLBS b
90+ , requestHeaders = requestHeaders r
87− , requestHeaders = [(hContentType, cs . show $ t)] }
91+ ++ [(hContentType, cs . show $ t)] }
88 setQS = setQueryString $ queryTextToQuery (qs req)
92 setQS = setQueryString $ queryTextToQuery (qs req)
89 setheaders r = r { requestHeaders = requestHeaders r
93 setheaders r = r { requestHeaders = requestHeaders r
90 ++ Prelude.map toProperHeader (headers req) }
94 ++ 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)
92 toProperHeader (name, val) =
99 toProperHeader (name, val) =
93 (fromString name, encodeUtf8 val)
100 (fromString name, encodeUtf8 val)
@@ -142,7 +149,8 @@ performRequest reqMethod req isWantedStatus reqHost = do
142performRequestJSON :: FromJSON result =>
149performRequestJSON :: FromJSON result =>
143 Method -> Req -> Int -> BaseUrl -> EitherT String IO result
150 Method -> Req -> Int -> BaseUrl -> EitherT String IO result
144performRequestJSON reqMethod req wantedStatus reqHost = do
151performRequestJSON reqMethod req wantedStatus reqHost = do
152+ (_status, respBody, contentType) <-
145− (_status, respBody, contentType) <- performRequest reqMethod req (== wantedStatus) reqHost
153+ performRequest reqMethod (req { reqAccept = ["application"//"json"] }) (== wantedStatus) reqHost
146 unless (matches contentType ("application"//"json")) $
154 unless (matches contentType ("application"//"json")) $
147 left $ "requested Content-Type application/json, but got " <> show contentType
155 left $ "requested Content-Type application/json, but got " <> show contentType