Don't ignore the content-type in ReqBody

This commit is contained in:
Timo von Holtz 2015-02-25 09:30:31 +11:00
parent 48030a6a1b
commit 40a941e0e3
3 changed files with 8 additions and 15 deletions

View file

@ -50,7 +50,6 @@ library
, network-uri >= 2.6 , network-uri >= 2.6
, safe , safe
, servant >= 0.2.2 , servant >= 0.2.2
, servant-server
, string-conversions , string-conversions
, text , text
, transformers , transformers

View file

@ -26,8 +26,8 @@ import GHC.TypeLits
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import Servant.API import Servant.API
import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
import Servant.Server.ContentTypes
import Servant.Common.Req import Servant.Common.Req
import Servant.Common.Text import Servant.Common.Text
@ -438,15 +438,16 @@ instance HasClient Raw where
-- > addBook :: Book -> BaseUrl -> EitherT String IO Book -- > addBook :: Book -> BaseUrl -> EitherT String IO Book
-- > addBook = client myApi -- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint -- > -- then you can just use "addBook" to query that endpoint
instance (ToJSON a, HasClient sublayout) instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where => HasClient (ReqBody (ct ': cts) a :> sublayout) where
type Client (ReqBody (ct ': cts) a :> sublayout) = type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req body = clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $ do
setRQBody (encode body) ("application" // "json" /: ("charset", "utf-8")) req let ctProxy = Proxy :: Proxy ct
setRQBody (toByteString ctProxy body) (contentType ctProxy) req
-- | Make the querying function append @path@ to the request path. -- | Make the querying function append @path@ to the request path.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where

View file

@ -24,9 +24,9 @@ import Network.HTTP.Client.TLS
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types import Network.HTTP.Types
import Network.URI import Network.URI
import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
import Servant.Common.Text import Servant.Common.Text
import Servant.Server.ContentTypes
import System.IO.Unsafe import System.IO.Unsafe
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
@ -152,8 +152,8 @@ performRequestCT ct reqMethod req wantedStatus reqHost = do
performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost
unless (matches respCT (acceptCT)) $ unless (matches respCT (acceptCT)) $
left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT
maybe either
(left (displayHttpRequest reqMethod ++ " returned invalid response of type: " ++ show respCT)) (left . ((displayHttpRequest reqMethod ++ " returned invalid response of type" ++ show respCT) ++))
return return
(fromByteString ct respBody) (fromByteString ct respBody)
@ -164,10 +164,3 @@ catchStatusCodeException action =
case e of case e of
Client.StatusCodeException status _ _ -> return $ Left status Client.StatusCodeException status _ _ -> return $ Left status
exc -> throwIO exc exc -> throwIO exc
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
-- objects and arrays.
decodeLenient :: FromJSON a => ByteString -> Either String a
decodeLenient input = do
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
parseEither parseJSON v