Pass in Manager as argument to 'client'
This commit is contained in:
Julian K. Arni
parent
1d248a573f
commit
de447dfe22
3 changed files with 85 additions and 96 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue