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

Cleanup

Browse source
This commit is contained in:
Timo von Holtz 2015-02-17 13:50:50 +11:00
parent a23204e134
commit 6c99dfcb6c
1 changed files with 4 additions and 6 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -14,8 +14,6 @@ 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, filter, map, null) import Data.ByteString.Lazy hiding (pack, filter, map, null)
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 (Text) import Data.Text (Text)
@ -84,16 +82,16 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
, uriPath = reqPath req , uriPath = reqPath req
} }
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 = requestHeaders r , requestHeaders = requestHeaders r
++ [(hContentType, cs . show $ t)] } ++ [(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) } <> fmap toProperHeader (headers req) }
setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r) setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
++ [("Accept", renderHeader $ reqAccept req) <> [("Accept", renderHeader $ reqAccept req)
| not . null . reqAccept $ req] } | not . null . reqAccept $ req] }
toProperHeader (name, val) = toProperHeader (name, val) =
(fromString name, encodeUtf8 val) (fromString name, encodeUtf8 val)
@ -139,7 +137,7 @@ performRequest reqMethod req isWantedStatus reqHost = do
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> left $ "invalid Content-Type header: " <> cs t Nothing -> left $ "invalid Content-Type header: " <> cs t
Just t' -> pure t' Just t' -> pure t'
return $ (statusCode status, Client.responseBody response, ct) return (statusCode status, Client.responseBody response, ct)
where where
showStatus (Status code message) = showStatus (Status code message) =
show code ++ " - " ++ cs message show code ++ " - " ++ cs message