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

Merge pull request #242 from haskell-servant/jkarni/http-client-manager

Browse source 
Pass in Manager as argument to 'client'
This commit is contained in:
Julian Arni 2015-09-30 13:36:51 +02:00
commit 52b58d0fe9
9 changed files with 118 additions and 102 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client/CHANGELOG.md
View file

@ -3,6 +3,7 @@ HEAD
* Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Added support for `path` on `BaseUrl`. * Added support for `path` on `BaseUrl`.
* `client` now takes an explicit `Manager` argument.
0.4.1 0.4.1
----- -----

139
servant-client/src/Servant/Client.hs
View file

@ -32,7 +32,7 @@ import Data.Proxy
import Data.String.Conversions import Data.String.Conversions
import Data.Text (unpack) import Data.Text (unpack)
import GHC.TypeLits import GHC.TypeLits
import Network.HTTP.Client (Response) import Network.HTTP.Client (Response, Manager)
import Network.HTTP.Media import Network.HTTP.Media
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
@ -52,9 +52,9 @@ import Servant.Common.Req
-- > -- >
-- > getAllBooks :: ExceptT String IO [Book] -- > getAllBooks :: ExceptT String IO [Book]
-- > postNewBook :: Book -> ExceptT String IO Book -- > postNewBook :: Book -> ExceptT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi host -- > (getAllBooks :<|> postNewBook) = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080 -- > where host = BaseUrl Http "localhost" 8080
client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout
client p baseurl = clientWithRoute p defReq baseurl client p baseurl = clientWithRoute p defReq baseurl
-- | This class lets us define how each API combinator -- | This class lets us define how each API combinator
@ -62,9 +62,8 @@ client p baseurl = clientWithRoute p defReq baseurl
-- 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 -> BaseUrl -> Client layout clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout
{-type Client layout = Client 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@,
@ -78,13 +77,13 @@ class HasClient layout where
-- > -- >
-- > getAllBooks :: ExceptT String IO [Book] -- > getAllBooks :: ExceptT String IO [Book]
-- > postNewBook :: Book -> ExceptT String IO Book -- > postNewBook :: Book -> ExceptT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi host -- > (getAllBooks :<|> postNewBook) = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080 -- > where host = BaseUrl Http "localhost" 8080
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 baseurl = clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy a) req baseurl :<|> clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|>
clientWithRoute (Proxy :: Proxy b) req baseurl clientWithRoute (Proxy :: Proxy b) req baseurl manager
-- | If you use a 'Capture' in one of your endpoints in your API, -- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -103,7 +102,7 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > getBook :: Text -> ExceptT String IO Book -- > getBook :: Text -> ExceptT String IO Book
-- > getBook = client myApi host -- > getBook = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080 -- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "getBook" to query that endpoint -- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToText a, HasClient sublayout) instance (KnownSymbol capture, ToText a, HasClient sublayout)
@ -112,10 +111,11 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
type Client (Capture capture a :> sublayout) = type Client (Capture capture a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req baseurl val = clientWithRoute Proxy req baseurl manager val =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req) (appendToPath p req)
baseurl baseurl
manager
where p = unpack (toText val) where p = unpack (toText val)
@ -127,11 +127,10 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-} {-# OVERLAPPABLE #-}
#endif #endif
-- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
(MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where (MimeUnrender ct a, cts' ~ (ct ': cts)) => HasClient (Delete cts' a) where
type Client (Delete cts' a) = ExceptT ServantError IO a type Client (Delete cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager
-- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content -- | If you have a 'Delete xs ()' endpoint, the client expects a 204 No Content
-- HTTP header. -- HTTP header.
@ -141,8 +140,8 @@ instance
#endif #endif
HasClient (Delete cts ()) where HasClient (Delete cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO () type Client (Delete cts ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodDelete req [204] baseurl void $ performRequestNoBody H.methodDelete req [204] baseurl manager
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -150,12 +149,11 @@ instance
#if MIN_VERSION_base(4,8,0) #if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-} {-# OVERLAPPING #-}
#endif #endif
-- See https://downloads.haskell.org/~ghc/7.8.2/docs/html/users_guide/type-class-extensions.html#undecidable-instances
( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts) ( MimeUnrender ct a, BuildHeadersTo ls, cts' ~ (ct ': cts)
) => HasClient (Delete cts' (Headers ls a)) where ) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -170,8 +168,8 @@ instance
#endif #endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where (MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = ExceptT ServantError IO result type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl manager
-- | 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 status. -- HTTP status.
@ -181,8 +179,8 @@ instance
#endif #endif
HasClient (Get (ct ': cts) ()) where HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO () type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
performRequestNoBody H.methodGet req [204] baseurl performRequestNoBody H.methodGet req [204] baseurl manager
-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -193,8 +191,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where ) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl manager
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -231,13 +229,14 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (Header sym a :> sublayout) = type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout Maybe a -> Client sublayout
clientWithRoute Proxy req baseurl mval = clientWithRoute Proxy req baseurl manager mval =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(maybe req (maybe req
(\value -> Servant.Common.Req.addHeader hname value req) (\value -> Servant.Common.Req.addHeader hname value req)
mval mval
) )
baseurl baseurl
manager
where hname = symbolVal (Proxy :: Proxy sym) where hname = symbolVal (Proxy :: Proxy sym)
@ -251,8 +250,8 @@ instance
#endif #endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = ExceptT ServantError IO a type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl manager
-- | 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.
@ -262,8 +261,8 @@ instance
#endif #endif
HasClient (Post (ct ': cts) ()) where HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = ExceptT ServantError IO () type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPost req [204] baseurl void $ performRequestNoBody H.methodPost req [204] baseurl manager
-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -274,8 +273,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where ) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl manager
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -290,8 +289,8 @@ instance
#endif #endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = ExceptT ServantError IO a type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl manager
-- | 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.
@ -301,8 +300,8 @@ instance
#endif #endif
HasClient (Put (ct ': cts) ()) where HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = ExceptT ServantError IO () type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPut req [204] baseurl void $ performRequestNoBody H.methodPut req [204] baseurl manager
-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -313,8 +312,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where ) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do clientWithRoute Proxy req baseurl manager= do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl manager
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -329,8 +328,8 @@ instance
#endif #endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where (MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl manager
-- | 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.
@ -340,8 +339,8 @@ instance
#endif #endif
HasClient (Patch (ct ': cts) ()) where HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO () type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPatch req [204] baseurl void $ performRequestNoBody H.methodPatch req [204] baseurl manager
-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the -- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers. -- corresponding headers.
@ -352,8 +351,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls ( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where ) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a) type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl manager
return $ Headers { getResponse = resp return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -391,13 +390,14 @@ instance (KnownSymbol sym, ToText a, HasClient 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 baseurl mparam = clientWithRoute Proxy req baseurl manager mparam =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(maybe req (maybe req
(flip (appendToQueryString pname) req . Just) (flip (appendToQueryString pname) req . Just)
mparamText mparamText
) )
baseurl baseurl
manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -437,13 +437,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (QueryParams sym a :> sublayout) = type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout [a] -> Client sublayout
clientWithRoute Proxy req baseurl paramlist = clientWithRoute Proxy req baseurl manager paramlist =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just)) (foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req req
paramlist' paramlist'
) )
baseurl baseurl manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -477,13 +477,13 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (QueryFlag sym :> sublayout) = type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout Bool -> Client sublayout
clientWithRoute Proxy req baseurl flag = clientWithRoute Proxy req baseurl manager flag =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(if flag (if flag
then appendToQueryString paramname Nothing req then appendToQueryString paramname Nothing req
else req else req
) )
baseurl baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -520,13 +520,13 @@ instance (KnownSymbol sym, ToText a, HasClient 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 baseurl mparam = clientWithRoute Proxy req baseurl manager mparam =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(maybe req (maybe req
(flip (appendToMatrixParams pname . Just) req) (flip (appendToMatrixParams pname . Just) req)
mparamText mparamText
) )
baseurl baseurl manager
where pname = symbolVal (Proxy :: Proxy sym) where pname = symbolVal (Proxy :: Proxy sym)
mparamText = fmap (cs . toText) mparam mparamText = fmap (cs . toText) mparam
@ -565,13 +565,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (MatrixParams sym a :> sublayout) = type Client (MatrixParams sym a :> sublayout) =
[a] -> Client sublayout [a] -> Client sublayout
clientWithRoute Proxy req baseurl paramlist = clientWithRoute Proxy req baseurl manager paramlist =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value) (foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)
req req
paramlist' paramlist'
) )
baseurl baseurl manager
where pname = cs pname' where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym) pname' = symbolVal (Proxy :: Proxy sym)
@ -590,6 +590,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
-- --
-- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book] -- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book]
-- > -- >
-- >
-- > myApi :: Proxy MyApi -- > myApi :: Proxy MyApi
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
@ -605,13 +606,13 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (MatrixFlag sym :> sublayout) = type Client (MatrixFlag sym :> sublayout) =
Bool -> Client sublayout Bool -> Client sublayout
clientWithRoute Proxy req baseurl flag = clientWithRoute Proxy req baseurl manager flag =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(if flag (if flag
then appendToMatrixParams paramname Nothing req then appendToMatrixParams paramname Nothing req
else req else req
) )
baseurl baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym) where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -620,9 +621,9 @@ instance (KnownSymbol sym, HasClient sublayout)
instance HasClient Raw where instance HasClient Raw where
type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
clientWithRoute Proxy req baseurl httpMethod = do clientWithRoute Proxy req baseurl manager httpMethod = do
performRequest httpMethod req (const True) baseurl performRequest httpMethod req (const True) baseurl manager
-- | If you use a 'ReqBody' in one of your endpoints in your API, -- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take -- the corresponding querying function will automatically take
@ -640,7 +641,7 @@ instance HasClient Raw where
-- > myApi = Proxy -- > myApi = Proxy
-- > -- >
-- > addBook :: Book -> ExceptT String IO Book -- > addBook :: Book -> ExceptT String IO Book
-- > addBook = client myApi host -- > addBook = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080 -- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "addBook" to query that endpoint -- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout) instance (MimeRender ct a, HasClient sublayout)
@ -649,40 +650,40 @@ instance (MimeRender ct a, HasClient sublayout)
type Client (ReqBody (ct ': cts) a :> sublayout) = type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout a -> Client sublayout
clientWithRoute Proxy req baseurl body = clientWithRoute Proxy req baseurl manager body =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(let ctProxy = Proxy :: Proxy ct (let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body) in setRQBody (mimeRender ctProxy body)
(contentType ctProxy) (contentType ctProxy)
req req
) )
baseurl baseurl manager
-- | 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 baseurl = clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy sublayout) clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req) (appendToPath p req)
baseurl baseurl manager
where p = symbolVal (Proxy :: Proxy path) where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api type Client (Vault :> api) = Client api
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl clientWithRoute (Proxy :: Proxy api) req baseurl manager
instance HasClient api => HasClient (RemoteHost :> api) where instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl clientWithRoute (Proxy :: Proxy api) req baseurl manager
instance HasClient api => HasClient (IsSecure :> api) where instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req baseurl = clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl clientWithRoute (Proxy :: Proxy api) req baseurl manager

32
servant-client/src/Servant/Common/Req.hs
View file

@ -13,7 +13,6 @@ import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.IORef
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
import Data.Proxy import Data.Proxy
@ -21,7 +20,6 @@ import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Data.Typeable import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path) import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Client.TLS
import Network.HTTP.Media import Network.HTTP.Media
import Network.HTTP.Types import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP import qualified Network.HTTP.Types.Header as HTTP
@ -29,7 +27,6 @@ import Network.URI hiding (path)
import Servant.API.ContentTypes import Servant.API.ContentTypes
import Servant.Common.BaseUrl import Servant.Common.BaseUrl
import Servant.Common.Text import Servant.Common.Text
import System.IO.Unsafe
import qualified Network.HTTP.Client as Client import qualified Network.HTTP.Client as Client
@ -129,31 +126,21 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
-- * performing requests -- * performing requests
{-# NOINLINE __manager #-}
__manager :: IORef Manager
__manager = unsafePerformIO (newManager tlsManagerSettings >>= newIORef)
__withGlobalManager :: (Manager -> IO a) -> IO a
__withGlobalManager action = readIORef __manager >>= action
displayHttpRequest :: Method -> String displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> Manager
-> ExceptT ServantError IO ( Int, ByteString, MediaType -> ExceptT ServantError IO ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString) , [HTTP.Header], Response ByteString)
performRequest reqMethod req isWantedStatus reqHost = do performRequest reqMethod req isWantedStatus reqHost manager = do
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod let request = partialRequest { Client.method = reqMethod
, checkStatus = \ _status _headers _cookies -> Nothing , checkStatus = \ _status _headers _cookies -> Nothing
} }
eResponse <- liftIO $ __withGlobalManager $ \ manager -> eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
catchConnectionError $
Client.httpLbs request manager
case eResponse of case eResponse of
Left err -> Left err ->
throwE . ConnectionError $ SomeException err throwE . ConnectionError $ SomeException err
@ -174,20 +161,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> ExceptT ServantError IO ([HTTP.Header], result) Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req wantedStatus reqHost = do performRequestCT ct reqMethod req wantedStatus reqHost manager = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hrds, _response) <- (_status, respBody, respCT, hrds, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost manager
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hrds, val) Right val -> return (hrds, val)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> ExceptT ServantError IO () performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost = do performRequestNoBody reqMethod req wantedStatus reqHost manager =
_ <- performRequest reqMethod req (`elem` wantedStatus) reqHost void $ performRequest reqMethod req (`elem` wantedStatus) reqHost manager
return ()
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action = catchConnectionError action =

10
servant-client/test/Servant/ClientSpec.hs
View file

@ -144,6 +144,7 @@ withFailServer action = withWaiDaemon (return failServer) action
spec :: IO () spec :: IO ()
spec = withServer $ \ baseUrl -> do spec = withServer $ \ baseUrl -> do
manager <- C.newManager C.defaultManagerSettings
let getGet :: ExceptT ServantError IO Person let getGet :: ExceptT ServantError IO Person
getDeleteEmpty :: ExceptT ServantError IO () getDeleteEmpty :: ExceptT ServantError IO ()
getCapture :: String -> ExceptT ServantError IO Person getCapture :: String -> ExceptT ServantError IO Person
@ -174,7 +175,7 @@ spec = withServer $ \ baseUrl -> do
:<|> getMultiple :<|> getMultiple
:<|> getRespHeaders :<|> getRespHeaders
:<|> getDeleteContentType) :<|> getDeleteContentType)
= client api baseUrl = client api baseUrl manager
hspec $ do hspec $ do
it "Servant.API.Get" $ do it "Servant.API.Get" $ do
@ -264,7 +265,7 @@ spec = withServer $ \ baseUrl -> do
withWaiDaemon (return (serve api (throwE $ ServantErr 500 "error message" "" []))) $ withWaiDaemon (return (serve api (throwE $ ServantErr 500 "error message" "" []))) $
\ host -> do \ host -> do
let getResponse :: ExceptT ServantError IO () let getResponse :: ExceptT ServantError IO ()
getResponse = client api host getResponse = client api host manager
Left FailureResponse{..} <- runExceptT getResponse Left FailureResponse{..} <- runExceptT getResponse
responseStatus `shouldBe` (Status 500 "error message") responseStatus `shouldBe` (Status 500 "error message")
mapM_ test $ mapM_ test $
@ -276,6 +277,7 @@ spec = withServer $ \ baseUrl -> do
failSpec :: IO () failSpec :: IO ()
failSpec = withFailServer $ \ baseUrl -> do failSpec = withFailServer $ \ baseUrl -> do
manager <- C.newManager C.defaultManagerSettings
let getGet :: ExceptT ServantError IO Person let getGet :: ExceptT ServantError IO Person
getDeleteEmpty :: ExceptT ServantError IO () getDeleteEmpty :: ExceptT ServantError IO ()
getCapture :: String -> ExceptT ServantError IO Person getCapture :: String -> ExceptT ServantError IO Person
@ -285,9 +287,9 @@ failSpec = withFailServer $ \ baseUrl -> do
:<|> getCapture :<|> getCapture
:<|> getBody :<|> getBody
:<|> _ ) :<|> _ )
= client api baseUrl = client api baseUrl manager
getGetWrongHost :: ExceptT ServantError IO Person getGetWrongHost :: ExceptT ServantError IO Person
(getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager
hspec $ do hspec $ do
context "client returns errors appropriately" $ do context "client returns errors appropriately" $ do

13
servant-examples/hackage/hackage.hs
View file

@ -12,6 +12,9 @@ import Data.Monoid
import Data.Proxy import Data.Proxy
import Data.Text (Text) import Data.Text (Text)
import GHC.Generics import GHC.Generics
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import System.IO.Unsafe (unsafePerformIO)
import Servant.API import Servant.API
import Servant.Client import Servant.Client
@ -55,10 +58,16 @@ instance FromJSON Package
hackageAPI :: Proxy HackageAPI hackageAPI :: Proxy HackageAPI
hackageAPI = Proxy hackageAPI = Proxy
{-# NOINLINE manager #-}
manager :: Manager
manager = unsafePerformIO $ newManager defaultManagerSettings
getUsers :: ExceptT ServantError IO [UserSummary] getUsers :: ExceptT ServantError IO [UserSummary]
getUser :: Username -> ExceptT ServantError IO UserDetailed getUser :: Username -> ExceptT ServantError IO UserDetailed
getPackages :: ExceptT ServantError IO [Package] getPackages :: ExceptT ServantError IO [Package]
getUsers :<|> getUser :<|> getPackages = client hackageAPI $ BaseUrl Http "hackage.haskell.org" 80 "" getUsers :<|> getUser :<|> getPackages =
client hackageAPI (BaseUrl Http "hackage.haskell.org" 80 "") manager
main :: IO () main :: IO ()
main = print =<< uselessNumbers main = print =<< uselessNumbers
@ -71,7 +80,7 @@ uselessNumbers = runExceptT $ do
user <- liftIO $ do user <- liftIO $ do
putStrLn "Enter a valid hackage username" putStrLn "Enter a valid hackage username"
T.getLine T.getLine
userDetailed <- (getUser user) userDetailed <- getUser user
liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages" liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
packages <- getPackages packages <- getPackages

2
servant-examples/servant-examples.cabal
View file

@ -53,6 +53,7 @@ executable t8-main
build-depends: build-depends:
aeson aeson
, base >= 4.7 && < 5 , base >= 4.7 && < 5
, http-client > 0.4 && < 0.5
, servant == 0.5.* , servant == 0.5.*
, servant-client == 0.5.* , servant-client == 0.5.*
, servant-server == 0.5.* , servant-server == 0.5.*
@ -65,6 +66,7 @@ executable hackage
build-depends: build-depends:
aeson >= 0.8 aeson >= 0.8
, base >=4.7 && < 5 , base >=4.7 && < 5
, http-client > 0.4 && < 0.5
, servant == 0.5.* , servant == 0.5.*
, servant-client == 0.5.* , servant-client == 0.5.*
, text , text

9
servant-examples/tutorial/T8.hs
View file

@ -4,8 +4,11 @@
module T8 where module T8 where
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import Servant import Servant
import Servant.Client import Servant.Client
import System.IO.Unsafe (unsafePerformIO)
import T3 import T3
@ -19,11 +22,15 @@ hello :: Maybe String -- ^ an optional value for "name"
marketing :: ClientInfo -- ^ value for the request body marketing :: ClientInfo -- ^ value for the request body
-> ExceptT ServantError IO Email -> ExceptT ServantError IO Email
position :<|> hello :<|> marketing = client api baseUrl position :<|> hello :<|> marketing = client api baseUrl manager
baseUrl :: BaseUrl baseUrl :: BaseUrl
baseUrl = BaseUrl Http "localhost" 8081 "" baseUrl = BaseUrl Http "localhost" 8081 ""
{-# NOINLINE manager #-}
manager :: Manager
manager = unsafePerformIO $ newManager defaultManagerSettings
queries :: ExceptT ServantError IO (Position, HelloMessage, Email) queries :: ExceptT ServantError IO (Position, HelloMessage, Email)
queries = do queries = do
pos <- position 10 10 pos <- position 10 10

1
servant/CHANGELOG.md
View file

@ -3,6 +3,7 @@ HEAD
* Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators
* Fix safeLink, so Header is not in fact required. * Fix safeLink, so Header is not in fact required.
* Added more instances for (:<|>)
0.4.2 0.4.2
----- -----

9
servant/src/Servant/API/Alternative.hs
View file

@ -1,11 +1,18 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
#if !MIN_VERSION_base(4,8,0)
{-# LANGUAGE DeriveFoldable #-}
#endif
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_HADDOCK not-home #-}
module Servant.API.Alternative ((:<|>)(..)) where module Servant.API.Alternative ((:<|>)(..)) where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Data.Monoid (Monoid (..)) import Data.Monoid (Monoid (..))
import Data.Traversable (Traversable)
import Data.Foldable (Foldable)
#endif #endif
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
-- | Union of two APIs, first takes precedence in case of overlap. -- | Union of two APIs, first takes precedence in case of overlap.
@ -17,7 +24,7 @@ import Data.Typeable (Typeable)
-- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books -- :<|> "books" :> ReqBody '[JSON] Book :> Post '[JSON] () -- POST /books
-- :} -- :}
data a :<|> b = a :<|> b data a :<|> b = a :<|> b
deriving (Typeable, Eq, Show) deriving (Typeable, Eq, Show, Functor, Traversable, Foldable, Bounded)
infixr 8 :<|> infixr 8 :<|>
instance (Monoid a, Monoid b) => Monoid (a :<|> b) where instance (Monoid a, Monoid b) => Monoid (a :<|> b) where