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

Merge pull request #25 from haskell-servant/canonical-types-rebased

Browse source 
Canonical types rebased
This commit is contained in:
Alp Mestanogullari 2015-04-20 09:37:40 +03:00
commit 0173087166
4 changed files with 78 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
CHANGELOG.md
View file

@ -7,6 +7,7 @@
* Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
* Support for PATCH
* Make () instances expect No Content status code, and not try to decode body.
* `Canonicalize` API types before generating client functions for them
0.2.2
-----

78
src/Servant/Client.hs
View file

@ -2,6 +2,7 @@
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverlappingInstances #-}
@ -12,6 +13,7 @@
module Servant.Client
( client
, HasClient(..)
, Client
, ServantError(..)
, module Servant.Common.BaseUrl
) where
@ -45,15 +47,17 @@ import Servant.Common.Req
-- > getAllBooks :: BaseUrl -> EitherT String IO [Book]
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
client :: HasClient (Canonicalize layout) => Proxy layout -> Client layout
client p = clientWithRoute (canonicalize p) defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'.
class HasClient layout where
type Client layout :: *
clientWithRoute :: Proxy layout -> Req -> Client layout
type Client' layout :: *
clientWithRoute :: Proxy layout -> Req -> Client' layout
type Client layout = Client' (Canonicalize layout)
-- | A client querying function for @a ':<|>' b@ will actually hand you
-- one function for querying @a@ and another one for querying @b@,
@ -69,7 +73,7 @@ class HasClient layout where
-- > postNewBook :: Book -> BaseUrl -> EitherT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
type Client' (a :<|> b) = Client' a :<|> Client' b
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy a) req :<|>
clientWithRoute (Proxy :: Proxy b) req
@ -96,8 +100,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
instance (KnownSymbol capture, ToText a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
type Client' (Capture capture a :> sublayout) =
a -> Client' sublayout
clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -110,7 +114,7 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance HasClient Delete where
type Client Delete = BaseUrl -> EitherT ServantError IO ()
type Client' Delete = BaseUrl -> EitherT ServantError IO ()
clientWithRoute Proxy req host =
void $ performRequest H.methodDelete req (`elem` [200, 202, 204]) host
@ -120,14 +124,14 @@ instance HasClient Delete where
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
type Client' (Get (ct ': cts) result) = BaseUrl -> EitherT ServantError IO result
clientWithRoute Proxy req host =
performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] host
-- | If you have a 'Get xs ()' endpoint, the client expects a 204 No Content
-- HTTP header.
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 =
performRequestNoBody H.methodGet req [204] host
@ -159,12 +163,12 @@ instance HasClient (Get (ct ': cts) ()) where
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (Header sym a :> sublayout) where
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
type Client' (Header sym a :> sublayout) =
Maybe a -> Client' sublayout
clientWithRoute Proxy req mval =
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)
@ -173,7 +177,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
type Client' (Post (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req uri =
performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] uri
@ -181,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
-- HTTP header.
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 =
void $ performRequestNoBody H.methodPost req [204] host
@ -190,7 +194,7 @@ instance HasClient (Post (ct ': cts) ()) where
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
instance (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
type Client' (Put (ct ': cts) a) = BaseUrl -> EitherT ServantError IO a
clientWithRoute Proxy req host =
performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] host
@ -198,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
-- HTTP header.
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 =
void $ performRequestNoBody H.methodPut req [204] host
@ -207,7 +211,7 @@ instance HasClient (Put (ct ': cts) ()) where
-- will just require an argument that specifies the scheme, host
-- and port to send the request to.
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 =
performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] host
@ -215,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
-- HTTP header.
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 =
void $ performRequestNoBody H.methodPatch req [204] host
@ -247,8 +251,8 @@ instance HasClient (Patch (ct ': cts) ()) where
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParam sym a :> sublayout) where
type Client (QueryParam sym a :> sublayout) =
Maybe a -> Client sublayout
type Client' (QueryParam sym a :> sublayout) =
Maybe a -> Client' sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
@ -289,8 +293,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (QueryParams sym a :> sublayout) where
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
type Client' (QueryParams sym a :> sublayout) =
[a] -> Client' sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -324,8 +328,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (QueryFlag sym :> sublayout) where
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
type Client' (QueryFlag sym :> sublayout) =
Bool -> Client' sublayout
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -363,8 +367,8 @@ instance (KnownSymbol sym, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParam sym a :> sublayout) where
type Client (MatrixParam sym a :> sublayout) =
Maybe a -> Client sublayout
type Client' (MatrixParam sym a :> sublayout) =
Maybe a -> Client' sublayout
-- if mparam = Nothing, we don't add it to the query string
clientWithRoute Proxy req mparam =
@ -404,8 +408,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, ToText a, HasClient sublayout)
=> HasClient (MatrixParams sym a :> sublayout) where
type Client (MatrixParams sym a :> sublayout) =
[a] -> Client sublayout
type Client' (MatrixParams sym a :> sublayout) =
[a] -> Client' sublayout
clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -439,8 +443,8 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
instance (KnownSymbol sym, HasClient sublayout)
=> HasClient (MatrixFlag sym :> sublayout) where
type Client (MatrixFlag sym :> sublayout) =
Bool -> Client sublayout
type Client' (MatrixFlag sym :> sublayout) =
Bool -> Client' sublayout
clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout) $
@ -453,9 +457,9 @@ instance (KnownSymbol sym, HasClient sublayout)
-- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`.
instance HasClient Raw where
type Client Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
type Client' Raw = H.Method -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType, Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute :: Proxy Raw -> Req -> Client' Raw
clientWithRoute Proxy req httpMethod host = do
performRequest httpMethod req (const True) host
@ -480,17 +484,17 @@ instance HasClient Raw where
instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
type Client' (ReqBody (ct ': cts) a :> sublayout) =
a -> Client' sublayout
clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout) $ do
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.
instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
type Client (path :> sublayout) = Client sublayout
type Client' (path :> sublayout) = Client' sublayout
clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout) $

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

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

70
test/Servant/ClientSpec.hs
View file

@ -1,42 +1,42 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fcontext-stack=25 #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Servant.ClientSpec where
import Control.Applicative
import qualified Control.Arrow as Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad.Trans.Either
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Char
import Data.Foldable (forM_)
import Data.Monoid
import Data.Proxy
import qualified Data.Text as T
import GHC.Generics
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
import Network.HTTP.Types
import Network.Socket
import Network.Wai hiding (Response)
import Network.Wai.Handler.Warp
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.HUnit
import Test.QuickCheck
import Control.Applicative
import qualified Control.Arrow as Arrow
import Control.Concurrent
import Control.Exception
import Control.Monad.Trans.Either
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Char
import Data.Foldable (forM_)
import Data.Monoid
import Data.Proxy
import qualified Data.Text as T
import GHC.Generics
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
import Network.HTTP.Types
import Network.Socket
import Network.Wai hiding (Response)
import Network.Wai.Handler.Warp
import Test.Hspec
import Test.Hspec.QuickCheck
import Test.HUnit
import Test.QuickCheck
import Servant.API
import Servant.Client
import Servant.Server
import Servant.API
import Servant.Client
import Servant.Server
-- * test data types
@ -289,8 +289,8 @@ spec = do
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer api, Server api ~ EitherT (Int, String) IO a,
HasClient api, Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
WrappedApi :: (HasServer (Canonicalize api), Server api ~ EitherT (Int, String) IO a,
HasClient (Canonicalize api), Client api ~ (BaseUrl -> EitherT ServantError IO ())) =>
Proxy api -> WrappedApi