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
* Added support for `path` on `BaseUrl`.
* `client` now takes an explicit `Manager` argument.
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.Text (unpack)
import GHC.TypeLits
import Network.HTTP.Client (Response)
import Network.HTTP.Client (Response, Manager)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
@ -52,9 +52,9 @@ import Servant.Common.Req
-- >
-- > getAllBooks :: 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
client :: HasClient layout => Proxy layout -> BaseUrl -> Client layout
client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout
client p baseurl = clientWithRoute p defReq baseurl
-- | 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'.
class HasClient layout where
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
-- one function for querying @a@ and another one for querying @b@,
@ -78,13 +77,13 @@ class HasClient layout where
-- >
-- > getAllBooks :: 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
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy a) req baseurl :<|>
clientWithRoute (Proxy :: Proxy b) req baseurl
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|>
clientWithRoute (Proxy :: Proxy b) req baseurl manager
-- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@ -103,7 +102,7 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > myApi = Proxy
-- >
-- > getBook :: Text -> ExceptT String IO Book
-- > getBook = client myApi host
-- > getBook = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToText a, HasClient sublayout)
@ -112,10 +111,11 @@ instance (KnownSymbol capture, ToText a, HasClient sublayout)
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req baseurl val =
clientWithRoute Proxy req baseurl manager val =
clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req)
baseurl
manager
where p = unpack (toText val)
@ -127,11 +127,10 @@ instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPABLE #-}
#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
type Client (Delete cts' a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
clientWithRoute Proxy req baseurl manager =
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
-- HTTP header.
@ -141,8 +140,8 @@ instance
#endif
HasClient (Delete cts ()) where
type Client (Delete cts ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodDelete req [204] baseurl
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodDelete req [204] baseurl manager
-- | If you have a 'Delete xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
@ -150,12 +149,11 @@ instance
#if MIN_VERSION_base(4,8,0)
{-# OVERLAPPING #-}
#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)
) => HasClient (Delete cts' (Headers ls a)) where
type Client (Delete cts' (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodDelete req [200, 202] baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -170,8 +168,8 @@ instance
#endif
(MimeUnrender ct result) => HasClient (Get (ct ': cts) result) where
type Client (Get (ct ': cts) result) = ExceptT ServantError IO result
clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203] baseurl
clientWithRoute Proxy req baseurl manager =
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
-- HTTP status.
@ -181,8 +179,8 @@ instance
#endif
HasClient (Get (ct ': cts) ()) where
type Client (Get (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl =
performRequestNoBody H.methodGet req [204] baseurl
clientWithRoute Proxy req baseurl manager =
performRequestNoBody H.methodGet req [204] baseurl manager
-- | If you have a 'Get xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
@ -193,8 +191,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Get (ct ': cts) (Headers ls a)) where
type Client (Get (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodGet req [200, 203, 204] baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -231,13 +229,14 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
clientWithRoute Proxy req baseurl mval =
clientWithRoute Proxy req baseurl manager mval =
clientWithRoute (Proxy :: Proxy sublayout)
(maybe req
(\value -> Servant.Common.Req.addHeader hname value req)
mval
)
baseurl
manager
where hname = symbolVal (Proxy :: Proxy sym)
@ -251,8 +250,8 @@ instance
#endif
(MimeUnrender ct a) => HasClient (Post (ct ': cts) a) where
type Client (Post (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPost req [200,201] baseurl
clientWithRoute Proxy req baseurl manager =
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
-- HTTP header.
@ -262,8 +261,8 @@ instance
#endif
HasClient (Post (ct ': cts) ()) where
type Client (Post (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodPost req [204] baseurl
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPost req [204] baseurl manager
-- | If you have a 'Post xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
@ -274,8 +273,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Post (ct ': cts) (Headers ls a)) where
type Client (Post (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPost req [200, 201] baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -290,8 +289,8 @@ instance
#endif
(MimeUnrender ct a) => HasClient (Put (ct ': cts) a) where
type Client (Put (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPut req [200,201] baseurl
clientWithRoute Proxy req baseurl manager =
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
-- HTTP header.
@ -301,8 +300,8 @@ instance
#endif
HasClient (Put (ct ': cts) ()) where
type Client (Put (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodPut req [204] baseurl
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPut req [204] baseurl manager
-- | If you have a 'Put xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
@ -313,8 +312,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Put (ct ': cts) (Headers ls a)) where
type Client (Put (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl
clientWithRoute Proxy req baseurl manager= do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPut req [200, 201] baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -329,8 +328,8 @@ instance
#endif
(MimeUnrender ct a) => HasClient (Patch (ct ': cts) a) where
type Client (Patch (ct ': cts) a) = ExceptT ServantError IO a
clientWithRoute Proxy req baseurl =
snd <$> performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200,201] baseurl
clientWithRoute Proxy req baseurl manager =
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
-- HTTP header.
@ -340,8 +339,8 @@ instance
#endif
HasClient (Patch (ct ': cts) ()) where
type Client (Patch (ct ': cts) ()) = ExceptT ServantError IO ()
clientWithRoute Proxy req baseurl =
void $ performRequestNoBody H.methodPatch req [204] baseurl
clientWithRoute Proxy req baseurl manager =
void $ performRequestNoBody H.methodPatch req [204] baseurl manager
-- | If you have a 'Patch xs (Headers ls x)' endpoint, the client expects the
-- corresponding headers.
@ -352,8 +351,8 @@ instance
( MimeUnrender ct a, BuildHeadersTo ls
) => HasClient (Patch (ct ': cts) (Headers ls a)) where
type Client (Patch (ct ': cts) (Headers ls a)) = ExceptT ServantError IO (Headers ls a)
clientWithRoute Proxy req baseurl = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl
clientWithRoute Proxy req baseurl manager = do
(hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) H.methodPatch req [200, 201, 204] baseurl manager
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@ -391,13 +390,14 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
Maybe a -> Client sublayout
-- 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)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
baseurl
manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@ -437,13 +437,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req baseurl paramlist =
clientWithRoute Proxy req baseurl manager paramlist =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
baseurl
baseurl manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@ -477,13 +477,13 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req baseurl flag =
clientWithRoute Proxy req baseurl manager flag =
clientWithRoute (Proxy :: Proxy sublayout)
(if flag
then appendToQueryString paramname Nothing req
else req
)
baseurl
baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -520,13 +520,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
Maybe a -> Client sublayout
-- 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)
(maybe req
(flip (appendToMatrixParams pname . Just) req)
mparamText
)
baseurl
baseurl manager
where pname = symbolVal (Proxy :: Proxy sym)
mparamText = fmap (cs . toText) mparam
@ -565,13 +565,13 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
type Client (MatrixParams sym a :> sublayout) =
[a] -> Client sublayout
clientWithRoute Proxy req baseurl paramlist =
clientWithRoute Proxy req baseurl manager paramlist =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' value -> maybe req' (flip (appendToMatrixParams pname) req' . Just . cs) value)
req
paramlist'
)
baseurl
baseurl manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@ -590,6 +590,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
--
-- > type MyApi = "books" :> MatrixFlag "published" :> Get '[JSON] [Book]
-- >
-- >
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
@ -605,13 +606,13 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (MatrixFlag sym :> sublayout) =
Bool -> Client sublayout
clientWithRoute Proxy req baseurl flag =
clientWithRoute Proxy req baseurl manager flag =
clientWithRoute (Proxy :: Proxy sublayout)
(if flag
then appendToMatrixParams paramname Nothing req
else req
)
baseurl
baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@ -620,9 +621,9 @@ instance (KnownSymbol sym, HasClient sublayout)
instance HasClient Raw where
type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Client Raw
clientWithRoute Proxy req baseurl httpMethod = do
performRequest httpMethod req (const True) baseurl
clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
clientWithRoute Proxy req baseurl manager httpMethod = do
performRequest httpMethod req (const True) baseurl manager
-- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@ -640,7 +641,7 @@ instance HasClient Raw where
-- > myApi = Proxy
-- >
-- > addBook :: Book -> ExceptT String IO Book
-- > addBook = client myApi host
-- > addBook = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout)
@ -649,40 +650,40 @@ instance (MimeRender ct a, HasClient sublayout)
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
clientWithRoute Proxy req baseurl body =
clientWithRoute Proxy req baseurl manager body =
clientWithRoute (Proxy :: Proxy sublayout)
(let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body)
(contentType ctProxy)
req
)
baseurl
baseurl manager
-- | 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
clientWithRoute Proxy req baseurl =
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req)
baseurl
baseurl manager
where p = symbolVal (Proxy :: Proxy path)
instance HasClient api => HasClient (Vault :> api) where
type Client (Vault :> api) = Client api
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy api) req baseurl
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager
instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy api) req baseurl
clientWithRoute Proxy req baseurl manager =
clientWithRoute (Proxy :: Proxy api) req baseurl manager
instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api
clientWithRoute Proxy req baseurl =
clientWithRoute (Proxy :: Proxy api) req baseurl
clientWithRoute Proxy req baseurl manager =
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.Trans.Except
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.IORef
import Data.String
import Data.String.Conversions
import Data.Proxy
@ -21,7 +20,6 @@ import Data.Text (Text)
import Data.Text.Encoding
import Data.Typeable
import Network.HTTP.Client hiding (Proxy, path)
import Network.HTTP.Client.TLS
import Network.HTTP.Media
import Network.HTTP.Types
import qualified Network.HTTP.Types.Header as HTTP
@ -29,7 +27,6 @@ import Network.URI hiding (path)
import Servant.API.ContentTypes
import Servant.Common.BaseUrl
import Servant.Common.Text
import System.IO.Unsafe
import qualified Network.HTTP.Client as Client
@ -129,31 +126,21 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
-- * 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 httpmethod = "HTTP " ++ cs httpmethod ++ " request"
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> Manager
-> ExceptT ServantError IO ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
performRequest reqMethod req isWantedStatus reqHost = do
performRequest reqMethod req isWantedStatus reqHost manager = do
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod
, checkStatus = \ _status _headers _cookies -> Nothing
}
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
catchConnectionError $
Client.httpLbs request manager
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of
Left err ->
throwE . ConnectionError $ SomeException err
@ -174,20 +161,19 @@ performRequest reqMethod req isWantedStatus reqHost = do
performRequestCT :: MimeUnrender ct result =>
Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req wantedStatus reqHost = do
Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ([HTTP.Header], result)
performRequestCT ct reqMethod req wantedStatus reqHost manager = do
let acceptCT = contentType ct
(_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
case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hrds, val)
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost = do
_ <- performRequest reqMethod req (`elem` wantedStatus) reqHost
return ()
performRequestNoBody :: Method -> Req -> [Int] -> BaseUrl -> Manager -> ExceptT ServantError IO ()
performRequestNoBody reqMethod req wantedStatus reqHost manager =
void $ performRequest reqMethod req (`elem` wantedStatus) reqHost manager
catchConnectionError :: IO a -> IO (Either ServantError a)
catchConnectionError action =

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

@ -144,6 +144,7 @@ withFailServer action = withWaiDaemon (return failServer) action
spec :: IO ()
spec = withServer $ \ baseUrl -> do
manager <- C.newManager C.defaultManagerSettings
let getGet :: ExceptT ServantError IO Person
getDeleteEmpty :: ExceptT ServantError IO ()
getCapture :: String -> ExceptT ServantError IO Person
@ -174,7 +175,7 @@ spec = withServer $ \ baseUrl -> do
:<|> getMultiple
:<|> getRespHeaders
:<|> getDeleteContentType)
= client api baseUrl
= client api baseUrl manager
hspec $ do
it "Servant.API.Get" $ do
@ -264,7 +265,7 @@ spec = withServer $ \ baseUrl -> do
withWaiDaemon (return (serve api (throwE $ ServantErr 500 "error message" "" []))) $
\ host -> do
let getResponse :: ExceptT ServantError IO ()
getResponse = client api host
getResponse = client api host manager
Left FailureResponse{..} <- runExceptT getResponse
responseStatus `shouldBe` (Status 500 "error message")
mapM_ test $
@ -276,6 +277,7 @@ spec = withServer $ \ baseUrl -> do
failSpec :: IO ()
failSpec = withFailServer $ \ baseUrl -> do
manager <- C.newManager C.defaultManagerSettings
let getGet :: ExceptT ServantError IO Person
getDeleteEmpty :: ExceptT ServantError IO ()
getCapture :: String -> ExceptT ServantError IO Person
@ -285,9 +287,9 @@ failSpec = withFailServer $ \ baseUrl -> do
:<|> getCapture
:<|> getBody
:<|> _ )
= client api baseUrl
= client api baseUrl manager
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
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.Text (Text)
import GHC.Generics
import Network.HTTP.Client (Manager, defaultManagerSettings,
newManager)
import System.IO.Unsafe (unsafePerformIO)
import Servant.API
import Servant.Client
@ -55,10 +58,16 @@ instance FromJSON Package
hackageAPI :: Proxy HackageAPI
hackageAPI = Proxy
{-# NOINLINE manager #-}
manager :: Manager
manager = unsafePerformIO $ newManager defaultManagerSettings
getUsers :: ExceptT ServantError IO [UserSummary]
getUser :: Username -> ExceptT ServantError IO UserDetailed
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 = print =<< uselessNumbers
@ -71,7 +80,7 @@ uselessNumbers = runExceptT $ do
user <- liftIO $ do
putStrLn "Enter a valid hackage username"
T.getLine
userDetailed <- (getUser user)
userDetailed <- getUser user
liftIO . T.putStrLn $ user <> " maintains " <> T.pack (show (length $ groups userDetailed)) <> " packages"
packages <- getPackages

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

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

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

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

1
servant/CHANGELOG.md
View file

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

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

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