Fix missing canonicalize changes

This commit is contained in:
Julian K. Arni 2015-04-19 18:31:23 +02:00
parent eae2f5f282
commit d7fcf2b19b
3 changed files with 44 additions and 43 deletions

View file

@ -13,6 +13,7 @@
module Servant.Client module Servant.Client
( client ( client
, HasClient(..) , HasClient(..)
, Client
, ServantError(..) , ServantError(..)
, module Servant.Common.BaseUrl , module Servant.Common.BaseUrl
) where ) where
@ -130,7 +131,7 @@ instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
instance HasClient (Get (ct ': cts) ()) where instance HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client' (Get (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestNoBody H.methodGet req [204] host performRequestNoBody H.methodGet req [204] host
@ -167,7 +168,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
clientWithRoute Proxy req mval = clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout) $ clientWithRoute (Proxy :: Proxy sublayout) $
maybe req (\value -> addHeader hname value req) mval maybe req (\value -> Servant.Common.Req.addHeader hname value req) mval
where hname = symbolVal (Proxy :: Proxy sym) where hname = symbolVal (Proxy :: Proxy sym)
@ -184,7 +185,7 @@ instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
-- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Post xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
instance HasClient (Post (ct ': cts) ()) where instance HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client' (Post (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPost req [204] host void $ performRequestNoBody H.methodPost req [204] host
@ -201,7 +202,7 @@ instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
-- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Put xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
instance HasClient (Put (ct ': cts) ()) where instance HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client' (Put (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPut req [204] host void $ performRequestNoBody H.methodPut req [204] host
@ -210,7 +211,7 @@ instance HasClient (Put (ct ': cts) ()) where
-- will just require an argument that specifies the scheme, host -- will just require an argument that specifies the scheme, host
-- and port to send the request to. -- and port to send the request to.
instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a type Client' (Patch (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
@ -218,7 +219,7 @@ instance (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
-- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Patch xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
instance HasClient (Patch (ct ': cts) ()) where instance HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO () type Client' (Patch (ct ': cts) ()) = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host = clientWithRoute Proxy req host =
void $ performRequestNoBody H.methodPatch req [204] host void $ performRequestNoBody H.methodPatch req [204] host
@ -489,7 +490,7 @@ instance (MimeRender ct a, HasClient sublayout)
clientWithRoute Proxy req body = clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $ do clientWithRoute (Proxy :: Proxy sublayout) $ do
let ctProxy = Proxy :: Proxy ct let ctProxy = Proxy :: Proxy ct
setRQBody (toByteString ctProxy body) (contentType ctProxy) req setRQBody (mimeRender 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

@ -172,7 +172,7 @@ performRequestCT ct reqMethod req wantedStatus reqHost = do
either either
(left . (\s -> DecodeFailure s respCT respBody)) (left . (\s -> DecodeFailure s respCT respBody))
return return
(fromByteString ct respBody) (mimeUnrender ct respBody)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO () performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost = do performRequestNoBody reqMethod req wantedStatus reqHost = do

View file

@ -1,11 +1,11 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fcontext-stack=25 #-} {-# OPTIONS_GHC -fcontext-stack=25 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.ClientSpec where module Servant.ClientSpec where
@ -289,8 +289,8 @@ spec = do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a, WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) => HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
Proxy api -> WrappedApi Proxy api -> WrappedApi