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) * Make the clients for `Raw` endpoints return the whole `Response` value (to be able to access response headers for example)
* Support for PATCH * Support for PATCH
* Make () instances expect No Content status code, and not try to decode body. * 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 0.2.2
----- -----

78
src/Servant/Client.hs
View file

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

2
src/Servant/Common/Req.hs
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

12
test/Servant/ClientSpec.hs
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