From 7379b7486abebb6be2347710cc14754601dbfd66 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Mon, 28 Mar 2016 14:11:50 +0100
Subject: [PATCH 1/8] Moved BaseUrl and Manager parameters from the client
function to the Client type as discussed in #428
---
servant-client/src/Servant/Client.hs | 93 +++++++++++-------------
servant-client/src/Servant/Common/Req.hs | 46 +++++++-----
2 files changed, 70 insertions(+), 69 deletions(-)
diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index e73c05a4..fb94fccb 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -27,14 +27,13 @@ module Servant.Client
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
-import Control.Monad.Trans.Except
import Data.ByteString.Lazy (ByteString)
import Data.List
import Data.Proxy
import Data.String.Conversions
import Data.Text (unpack)
import GHC.TypeLits
-import Network.HTTP.Client (Response, Manager)
+import Network.HTTP.Client (Response)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
@@ -58,15 +57,15 @@ import Servant.Common.Req
-- > postNewBook :: Book -> ExceptT String IO Book
-- > (getAllBooks :<|> postNewBook) = client myApi host manager
-- > where host = BaseUrl Http "localhost" 8080
-client :: HasClient layout => Proxy layout -> BaseUrl -> Manager -> Client layout
-client p baseurl = clientWithRoute p defReq baseurl
+client :: HasClient layout => Proxy layout -> Client layout
+client p = clientWithRoute p defReq
-- | This class lets us define how each API combinator
-- influences the creation of an HTTP request. It's mostly
-- an internal class, you can just use 'client'.
class HasClient layout where
type Client layout :: *
- clientWithRoute :: Proxy layout -> Req -> BaseUrl -> Manager -> Client layout
+ clientWithRoute :: Proxy layout -> Req -> Client layout
-- | A client querying function for @a ':<|>' b@ will actually hand you
@@ -85,9 +84,9 @@ class HasClient layout where
-- > 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 manager =
- clientWithRoute (Proxy :: Proxy a) req baseurl manager :<|>
- clientWithRoute (Proxy :: Proxy b) req baseurl manager
+ clientWithRoute Proxy req =
+ clientWithRoute (Proxy :: Proxy a) req :<|>
+ clientWithRoute (Proxy :: Proxy b) req
-- | If you use a 'Capture' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@@ -115,11 +114,9 @@ instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
type Client (Capture capture a :> sublayout) =
a -> Client sublayout
- clientWithRoute Proxy req baseurl manager val =
+ clientWithRoute Proxy req val =
clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req)
- baseurl
- manager
where p = unpack (toUrlPiece val)
@@ -127,27 +124,26 @@ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
- type Client (Verb method status cts' a) = ExceptT ServantError IO a
- clientWithRoute Proxy req baseurl manager =
- snd <$> performRequestCT (Proxy :: Proxy ct) method req baseurl manager
+ type Client (Verb method status cts' a) = ClientM a
+ clientWithRoute Proxy req =
+ snd <$> performRequestCT (Proxy :: Proxy ct) method req
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
- type Client (Verb method status cts NoContent) = ExceptT ServantError IO NoContent
- clientWithRoute Proxy req baseurl manager =
- performRequestNoBody method req baseurl manager >> return NoContent
+ type Client (Verb method status cts NoContent) = ClientM NoContent
+ clientWithRoute Proxy req =
+ performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
-- Note [Non-Empty Content Types]
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
- type Client (Verb method status cts' (Headers ls a))
- = ExceptT ServantError IO (Headers ls a)
- clientWithRoute Proxy req baseurl manager = do
+ type Client (Verb method status cts' (Headers ls a)) = ClientM (Headers ls a)
+ clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req baseurl manager
+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@@ -156,10 +152,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
- = ExceptT ServantError IO (Headers ls NoContent)
- clientWithRoute Proxy req baseurl manager = do
+ = ClientM (Headers ls NoContent)
+ clientWithRoute Proxy req = do
let method = reflectMethod (Proxy :: Proxy method)
- hdrs <- performRequestNoBody method req baseurl manager
+ hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
@@ -197,14 +193,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
type Client (Header sym a :> sublayout) =
Maybe a -> Client sublayout
- clientWithRoute Proxy req baseurl manager mval =
+ clientWithRoute Proxy req mval =
clientWithRoute (Proxy :: Proxy sublayout)
(maybe req
(\value -> Servant.Common.Req.addHeader hname value req)
mval
)
- baseurl
- manager
where hname = symbolVal (Proxy :: Proxy sym)
@@ -252,14 +246,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
Maybe a -> Client sublayout
-- if mparam = Nothing, we don't add it to the query string
- clientWithRoute Proxy req baseurl manager mparam =
+ clientWithRoute Proxy req mparam =
clientWithRoute (Proxy :: Proxy sublayout)
(maybe req
(flip (appendToQueryString pname) req . Just)
mparamText
)
- baseurl
- manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@@ -299,13 +291,12 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
type Client (QueryParams sym a :> sublayout) =
[a] -> Client sublayout
- clientWithRoute Proxy req baseurl manager paramlist =
+ clientWithRoute Proxy req paramlist =
clientWithRoute (Proxy :: Proxy sublayout)
(foldl' (\ req' -> maybe req' (flip (appendToQueryString pname) req' . Just))
req
paramlist'
)
- baseurl manager
where pname = cs pname'
pname' = symbolVal (Proxy :: Proxy sym)
@@ -339,13 +330,12 @@ instance (KnownSymbol sym, HasClient sublayout)
type Client (QueryFlag sym :> sublayout) =
Bool -> Client sublayout
- clientWithRoute Proxy req baseurl manager flag =
+ clientWithRoute Proxy req flag =
clientWithRoute (Proxy :: Proxy sublayout)
(if flag
then appendToQueryString paramname Nothing req
else req
)
- baseurl manager
where paramname = cs $ symbolVal (Proxy :: Proxy sym)
@@ -353,11 +343,12 @@ instance (KnownSymbol sym, HasClient sublayout)
-- | Pick a 'Method' and specify where the server you want to query is. You get
-- back the full `Response`.
instance HasClient Raw where
- type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
+ type Client Raw
+ = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
- clientWithRoute :: Proxy Raw -> Req -> BaseUrl -> Manager -> Client Raw
- clientWithRoute Proxy req baseurl manager httpMethod = do
- performRequest httpMethod req baseurl manager
+ clientWithRoute :: Proxy Raw -> Req -> Client Raw
+ clientWithRoute Proxy req httpMethod = do
+ performRequest httpMethod req
-- | If you use a 'ReqBody' in one of your endpoints in your API,
-- the corresponding querying function will automatically take
@@ -384,43 +375,41 @@ instance (MimeRender ct a, HasClient sublayout)
type Client (ReqBody (ct ': cts) a :> sublayout) =
a -> Client sublayout
- clientWithRoute Proxy req baseurl manager body =
+ clientWithRoute Proxy req body =
clientWithRoute (Proxy :: Proxy sublayout)
(let ctProxy = Proxy :: Proxy ct
in setRQBody (mimeRender ctProxy body)
(contentType ctProxy)
req
)
- 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 manager =
+ clientWithRoute Proxy req =
clientWithRoute (Proxy :: Proxy sublayout)
(appendToPath p req)
- 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 manager =
- clientWithRoute (Proxy :: Proxy api) req baseurl manager
+ clientWithRoute Proxy req =
+ clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (RemoteHost :> api) where
type Client (RemoteHost :> api) = Client api
- clientWithRoute Proxy req baseurl manager =
- clientWithRoute (Proxy :: Proxy api) req baseurl manager
+ clientWithRoute Proxy req =
+ clientWithRoute (Proxy :: Proxy api) req
instance HasClient api => HasClient (IsSecure :> api) where
type Client (IsSecure :> api) = Client api
- clientWithRoute Proxy req baseurl manager =
- clientWithRoute (Proxy :: Proxy api) req baseurl manager
+ clientWithRoute Proxy req =
+ clientWithRoute (Proxy :: Proxy api) req
instance HasClient subapi =>
HasClient (WithNamedContext name context subapi) where
@@ -433,16 +422,16 @@ instance ( HasClient api
type Client (AuthProtect tag :> api)
= AuthenticateReq (AuthProtect tag) -> Client api
- clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) =
- clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager
+ clientWithRoute Proxy req (AuthenticateReq (val,func)) =
+ clientWithRoute (Proxy :: Proxy api) (func val req)
-- * Basic Authentication
instance HasClient api => HasClient (BasicAuth realm usr :> api) where
type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
- clientWithRoute Proxy req baseurl manager val =
- clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
+ clientWithRoute Proxy req val =
+ clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req)
{- Note [Non-Empty Content Types]
diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index 3d72acd9..44551464 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/servant-client/src/Servant/Common/Req.hs
@@ -11,7 +11,9 @@ import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
+import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
+import Control.Monad.Trans.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String
import Data.String.Conversions
@@ -123,11 +125,21 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
+type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO))
-performRequest :: Method -> Req -> BaseUrl -> Manager
- -> ExceptT ServantError IO ( Int, ByteString, MediaType
- , [HTTP.Header], Response ByteString)
-performRequest reqMethod req reqHost manager = do
+runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a)
+runClientM m baseUrl manager = runExceptT (runReaderT (runReaderT m baseUrl) manager)
+
+-- to avoid adding a dependency on mtl
+throwError :: ServantError -> ClientM a
+throwError = lift . lift . throwE
+
+performRequest :: Method -> Req
+ -> ClientM ( Int, ByteString, MediaType
+ , [HTTP.Header], Response ByteString)
+performRequest reqMethod req = do
+ reqHost <- ask
+ manager <- lift ask
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod
@@ -137,7 +149,7 @@ performRequest reqMethod req reqHost manager = do
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of
Left err ->
- throwE . ConnectionError $ SomeException err
+ throwError . ConnectionError $ SomeException err
Right response -> do
let status = Client.responseStatus response
@@ -147,29 +159,29 @@ performRequest reqMethod req reqHost manager = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of
- Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
+ Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
- throwE $ FailureResponse status ct body
+ throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result =>
- Proxy ct -> Method -> Req -> BaseUrl -> Manager
- -> ExceptT ServantError IO ([HTTP.Header], result)
-performRequestCT ct reqMethod req reqHost manager = do
+ Proxy ct -> Method -> Req
+ -> ClientM ([HTTP.Header], result)
+performRequestCT ct reqMethod req = do
let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <-
- performRequest reqMethod (req { reqAccept = [acceptCT] }) reqHost manager
- unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
+ performRequest reqMethod (req { reqAccept = [acceptCT] })
+ unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
- Left err -> throwE $ DecodeFailure err respCT respBody
+ Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)
-performRequestNoBody :: Method -> Req -> BaseUrl -> Manager
- -> ExceptT ServantError IO [HTTP.Header]
-performRequestNoBody reqMethod req reqHost manager = do
- (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req reqHost manager
+performRequestNoBody :: Method -> Req
+ -> ClientM [HTTP.Header]
+performRequestNoBody reqMethod req = do
+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)
From 89b0758dc85465b7ff1f85a145ea96700ddaddb6 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Mon, 28 Mar 2016 14:52:33 +0100
Subject: [PATCH 2/8] Changed servant-client tests to reflect the changes to
the client function
---
servant-client/test/Servant/ClientSpec.hs | 99 ++++++++++++-----------
1 file changed, 50 insertions(+), 49 deletions(-)
diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs
index 0ad3b70e..f998fb31 100644
--- a/servant-client/test/Servant/ClientSpec.hs
+++ b/servant-client/test/Servant/ClientSpec.hs
@@ -28,7 +28,7 @@ import Control.Applicative ((<$>))
import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
-import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
+import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
@@ -208,47 +208,48 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do
- let getGet = getNth (Proxy :: Proxy 0) $ client api baseUrl manager
- (left show <$> runExceptT getGet) `shouldReturn` Right alice
+ let getGet = getNth (Proxy :: Proxy 0) $ client api
+ (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
- let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api baseUrl manager
- (left show <$> runExceptT getDeleteEmpty) `shouldReturn` Right NoContent
+ let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api
+ (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
- let getDeleteContentType = getLast $ client api baseUrl manager
- (left show <$> runExceptT getDeleteContentType) `shouldReturn` Right NoContent
+ let getDeleteContentType :: SCR.ClientM NoContent
+ getDeleteContentType = getLast $ client api
+ (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
- let getCapture = getNth (Proxy :: Proxy 2) $ client api baseUrl manager
- (left show <$> runExceptT (getCapture "Paula")) `shouldReturn` Right (Person "Paula" 0)
+ let getCapture = getNth (Proxy :: Proxy 2) $ client api
+ (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
- getBody = getNth (Proxy :: Proxy 3) $ client api baseUrl manager
- (left show <$> runExceptT (getBody p)) `shouldReturn` Right p
+ getBody = getNth (Proxy :: Proxy 3) $ client api
+ (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
- let getQueryParam = getNth (Proxy :: Proxy 4) $ client api baseUrl manager
- left show <$> runExceptT (getQueryParam (Just "alice")) `shouldReturn` Right alice
- Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob"))
+ let getQueryParam = getNth (Proxy :: Proxy 4) $ client api
+ left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice
+ Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager
responseStatus `shouldBe` Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
- let getQueryParams = getNth (Proxy :: Proxy 5) $ client api baseUrl manager
- (left show <$> runExceptT (getQueryParams [])) `shouldReturn` Right []
- (left show <$> runExceptT (getQueryParams ["alice", "bob"]))
+ let getQueryParams = getNth (Proxy :: Proxy 5) $ client api
+ (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right []
+ (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager)
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
- let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api baseUrl manager
- (left show <$> runExceptT (getQueryFlag flag)) `shouldReturn` Right flag
+ let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api
+ (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
- let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api baseUrl manager
- res <- runExceptT (getRawSuccess methodGet)
+ let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api
+ res <- SCR.runClientM (getRawSuccess methodGet) baseUrl manager
case res of
Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do
@@ -257,8 +258,8 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseStatus response `shouldBe` ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
- let getRawFailure = getNth (Proxy :: Proxy 8) $ client api baseUrl manager
- res <- runExceptT (getRawFailure methodGet)
+ let getRawFailure = getNth (Proxy :: Proxy 8) $ client api
+ res <- SCR.runClientM (getRawFailure methodGet) baseUrl manager
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left e -> do
@@ -266,18 +267,18 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do
- let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api baseUrl manager
- res <- runExceptT getRespHeaders
+ let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api
+ res <- SCR.runClientM getRespHeaders baseUrl manager
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
- let getMultiple = getNth (Proxy :: Proxy 9) $ client api baseUrl manager
+ let getMultiple = getNth (Proxy :: Proxy 9) $ client api
in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
- result <- left show <$> runExceptT (getMultiple cap num flag body)
+ result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager
return $
result === Right (cap, num, flag, body)
@@ -289,9 +290,9 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
- let getResponse :: ExceptT ServantError IO ()
- getResponse = client api baseUrl manager
- Left FailureResponse{..} <- runExceptT getResponse
+ let getResponse :: SCR.ClientM ()
+ getResponse = client api
+ Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager
responseStatus `shouldBe` (Status 500 "error message")
in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@@ -305,43 +306,43 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do
- let (_ :<|> getDeleteEmpty :<|> _) = client api baseUrl manager
- Left res <- runExceptT getDeleteEmpty
+ let (_ :<|> getDeleteEmpty :<|> _) = client api
+ Left res <- SCR.runClientM getDeleteEmpty baseUrl manager
case res of
FailureResponse (Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do
- let (_ :<|> _ :<|> getCapture :<|> _) = client api baseUrl manager
- Left res <- runExceptT (getCapture "foo")
+ let (_ :<|> _ :<|> getCapture :<|> _) = client api
+ Left res <- SCR.runClientM (getCapture "foo") baseUrl manager
case res of
DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do
- let (getGetWrongHost :<|> _) = client api (BaseUrl Http "127.0.0.1" 19872 "") manager
- Left res <- runExceptT getGetWrongHost
+ let (getGetWrongHost :<|> _) = client api
+ Left res <- SCR.runClientM getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") manager
case res of
ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
- let (getGet :<|> _ ) = client api baseUrl manager
- Left res <- runExceptT getGet
+ let (getGet :<|> _ ) = client api
+ Left res <- SCR.runClientM getGet baseUrl manager
case res of
UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
- let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api baseUrl manager
- Left res <- runExceptT (getBody alice)
+ let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
+ Left res <- SCR.runClientM (getBody alice) baseUrl manager
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
- HasClient api, Client api ~ ExceptT ServantError IO ()) =>
+ HasClient api, Client api ~ SCR.ClientM ()) =>
Proxy api -> WrappedApi
basicAuthSpec :: Spec
@@ -349,16 +350,16 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
- let getBasic = client basicAuthAPI baseUrl manager
+ let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server"
- (left show <$> runExceptT (getBasic basicAuthData)) `shouldReturn` Right alice
+ (left show <$> SCR.runClientM (getBasic basicAuthData) baseUrl manager) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
- let getBasic = client basicAuthAPI baseUrl manager
+ let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password"
- Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
+ Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager
responseStatus `shouldBe` Status 403 "Forbidden"
genAuthSpec :: Spec
@@ -366,16 +367,16 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
context "Authentication works when requests are properly authenticated" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
- let getProtected = client genAuthAPI baseUrl manager
+ let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
- (left show <$> runExceptT (getProtected authRequest)) `shouldReturn` Right alice
+ (left show <$> SCR.runClientM (getProtected authRequest) baseUrl manager) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
- let getProtected = client genAuthAPI baseUrl manager
+ let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
- Left FailureResponse{..} <- runExceptT (getProtected authRequest)
+ Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager
responseStatus `shouldBe` (Status 401 "Unauthorized")
-- * utils
From 316737c16daa7fa06ebf90490a921285ece18f82 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Mon, 28 Mar 2016 14:56:50 +0100
Subject: [PATCH 3/8] Updated documentation in Client.hs to reflect the changes
to the client function
---
servant-client/src/Servant/Client.hs | 44 ++++++++++++----------------
1 file changed, 18 insertions(+), 26 deletions(-)
diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index fb94fccb..91c07bcb 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -53,10 +53,9 @@ import Servant.Common.Req
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getAllBooks :: ExceptT String IO [Book]
--- > postNewBook :: Book -> ExceptT String IO Book
--- > (getAllBooks :<|> postNewBook) = client myApi host manager
--- > where host = BaseUrl Http "localhost" 8080
+-- > getAllBooks :: ClientM [Book]
+-- > postNewBook :: Book -> ClientM Book
+-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
@@ -78,10 +77,9 @@ class HasClient layout where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getAllBooks :: ExceptT String IO [Book]
--- > postNewBook :: Book -> ExceptT String IO Book
--- > (getAllBooks :<|> postNewBook) = client myApi host manager
--- > where host = BaseUrl Http "localhost" 8080
+-- > getAllBooks :: ClientM [Book]
+-- > postNewBook :: Book -> ClientM Book
+-- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
clientWithRoute Proxy req =
@@ -104,9 +102,8 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBook :: Text -> ExceptT String IO Book
--- > getBook = client myApi host manager
--- > where host = BaseUrl Http "localhost" 8080
+-- > getBook :: Text -> ClientM Book
+-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
=> HasClient (Capture capture a :> sublayout) where
@@ -182,9 +179,8 @@ instance OVERLAPPING_
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > viewReferer :: Maybe Referer -> ExceptT String IO Book
--- > viewReferer = client myApi host
--- > where host = BaseUrl Http "localhost" 8080
+-- > viewReferer :: Maybe Referer -> ClientM Book
+-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
@@ -233,9 +229,8 @@ instance HasClient sublayout
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBooksBy :: Maybe Text -> ExceptT String IO [Book]
--- > getBooksBy = client myApi host
--- > where host = BaseUrl Http "localhost" 8080
+-- > getBooksBy :: Maybe Text -> ClientM [Book]
+-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books
-- > -- 'getBooksBy (Just "Isaac Asimov")' to get all books by Isaac Asimov
@@ -278,9 +273,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBooksBy :: [Text] -> ExceptT String IO [Book]
--- > getBooksBy = client myApi host
--- > where host = BaseUrl Http "localhost" 8080
+-- > getBooksBy :: [Text] -> ClientM [Book]
+-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy []' for all books
-- > -- 'getBooksBy ["Isaac Asimov", "Robert A. Heinlein"]'
@@ -318,9 +312,8 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBooks :: Bool -> ExceptT String IO [Book]
--- > getBooks = client myApi host
--- > where host = BaseUrl Http "localhost" 8080
+-- > getBooks :: Bool -> ClientM [Book]
+-- > getBooks = client myApi
-- > -- then you can just use "getBooks" to query that endpoint.
-- > -- 'getBooksBy False' for all books
-- > -- 'getBooksBy True' to only get _already published_ books
@@ -365,9 +358,8 @@ instance HasClient Raw where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > addBook :: Book -> ExceptT String IO Book
--- > addBook = client myApi host manager
--- > where host = BaseUrl Http "localhost" 8080
+-- > addBook :: Book -> ClientM Book
+-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout)
=> HasClient (ReqBody (ct ': cts) a :> sublayout) where
From 19a4e037d8c262da47c5be735392fdd7210499d8 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Mon, 28 Mar 2016 15:27:51 +0100
Subject: [PATCH 4/8] Updated tutorial to reflect the updated `client` function
in servant-client
---
doc/tutorial/Client.lhs | 32 ++++++++++----------------------
1 file changed, 10 insertions(+), 22 deletions(-)
diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs
index 9cb38a0e..67f38357 100644
--- a/doc/tutorial/Client.lhs
+++ b/doc/tutorial/Client.lhs
@@ -15,14 +15,13 @@ need to have some language extensions and imports:
module Client where
-import Control.Monad.Trans.Except
import Data.Aeson
import Data.Proxy
import GHC.Generics
-import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
+import Network.HTTP.Client (newManager, defaultManagerSettings)
import Servant.API
import Servant.Client
-import System.IO.Unsafe
+import Servant.Common.Req (ClientM, runClientM)
```
Also, we need examples for some domain specific data types:
@@ -72,40 +71,28 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell
position :: Int -- ^ value for "x"
-> Int -- ^ value for "y"
- -> ExceptT ServantError IO Position
+ -> ClientM Position
hello :: Maybe String -- ^ an optional value for "name"
- -> ExceptT ServantError IO HelloMessage
+ -> ClientM HelloMessage
marketing :: ClientInfo -- ^ value for the request body
- -> ExceptT ServantError IO Email
+ -> ClientM Email
```
Each function makes available as an argument any value that the response may
depend on, as evidenced in the API type. How do we get these functions? By calling
-the function `client`. It takes three arguments:
+the function `client`. It takes one argument:
- a `Proxy` to your API,
-- a `BaseUrl`, consisting of the protocol, the host, the port and an optional subpath --
- this basically tells `client` where the service that you want to query is hosted,
-- a `Manager`, (from [http-client](http://hackage.haskell.org/package/http-client))
-which manages http connections.
``` haskell
api :: Proxy API
api = Proxy
-{-# NOINLINE __manager #-}
-__manager :: Manager
-__manager = unsafePerformIO $ newManager defaultManagerSettings
-
-position :<|> hello :<|> marketing =
- client api (BaseUrl Http "localhost" 8081 "") __manager
+position :<|> hello :<|> marketing = client api
```
-(Yes, the usage of `unsafePerformIO` is very ugly, we know. Hopefully soon it'll
-be possible to do without.)
-
As you can see in the code above, we just "pattern match our way" to these functions. If we try to derive less or more functions than there are endpoints in the API, we obviously get an error. The `BaseUrl` value there is just:
``` haskell ignore
@@ -127,7 +114,7 @@ data BaseUrl = BaseUrl
That's it. Let's now write some code that uses our client functions.
``` haskell
-queries :: ExceptT ServantError IO (Position, HelloMessage, Email)
+queries :: ClientM (Position, HelloMessage, Email)
queries = do
pos <- position 10 10
message <- hello (Just "servant")
@@ -136,7 +123,8 @@ queries = do
run :: IO ()
run = do
- res <- runExceptT queries
+ manager <- newManager defaultManagerSettings
+ res <- runClientM queries (BaseUrl Http "localhost" 8081 "") manager
case res of
Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do
From 41129e98b3459d3ebf0153c186462f2b69aa72a0 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Mon, 28 Mar 2016 18:01:53 +0100
Subject: [PATCH 5/8] Removed GetNth and GetLast type classes
---
servant-client/test/Servant/ClientSpec.hs | 117 ++++++++++++----------
1 file changed, 64 insertions(+), 53 deletions(-)
diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs
index f998fb31..999c69c9 100644
--- a/servant-client/test/Servant/ClientSpec.hs
+++ b/servant-client/test/Servant/ClientSpec.hs
@@ -30,17 +30,16 @@ import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson
+import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
import Data.Foldable (forM_)
import Data.Monoid hiding (getLast)
import Data.Proxy
import qualified Data.Text as T
import GHC.Generics (Generic)
-import GHC.TypeLits
import qualified Network.HTTP.Client as C
import Network.HTTP.Media
-import Network.HTTP.Types (Status (..), badRequest400,
- methodGet, ok200, status400)
+import qualified Network.HTTP.Types as HTTP
import Network.Socket
import Network.Wai (Application, Request,
requestHeaders, responseLBS)
@@ -120,6 +119,53 @@ type Api =
api :: Proxy Api
api = Proxy
+getGet :: SCR.ClientM Person
+getDeleteEmpty :: SCR.ClientM NoContent
+getCapture :: String
+ -> SCR.ClientM Person
+getBody :: Person
+ -> SCR.ClientM Person
+getQueryParam :: Maybe String
+ -> SCR.ClientM Person
+getQueryParams :: [String]
+ -> SCR.ClientM [Person]
+getQueryFlag :: Bool
+ -> SCR.ClientM Bool
+getRawSuccess :: HTTP.Method
+ -> SCR.ClientM ( Int
+ , BS.ByteString
+ , MediaType
+ , [HTTP.Header]
+ , C.Response BS.ByteString )
+getRawFailure :: HTTP.Method
+ -> SCR.ClientM ( Int
+ , BS.ByteString
+ , MediaType
+ , [HTTP.Header]
+ , C.Response BS.ByteString )
+getMultiple :: String
+ -> Maybe Int
+ -> Bool
+ -> [(String, [Rational])]
+ -> SCR.ClientM ( String
+ , Maybe Int
+ , Bool
+ , [(String, [Rational])] )
+getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
+getDeleteContentType :: SCR.ClientM NoContent
+getGet
+ :<|> getDeleteEmpty
+ :<|> getCapture
+ :<|> getBody
+ :<|> getQueryParam
+ :<|> getQueryParams
+ :<|> getQueryFlag
+ :<|> getRawSuccess
+ :<|> getRawFailure
+ :<|> getMultiple
+ :<|> getRespHeaders
+ :<|> getDeleteContentType = client api
+
server :: Application
server = serve api (
return alice
@@ -132,8 +178,8 @@ server = serve api (
Nothing -> throwE $ ServantErr 400 "missing parameter" "" [])
:<|> (\ names -> return (zipWith Person names [0..]))
:<|> return
- :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess")
- :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure")
+ :<|> (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "rawSuccess")
+ :<|> (\ _request respond -> respond $ responseLBS HTTP.badRequest400 [] "rawFailure")
:<|> (\ a b c d -> return (a, b, c, d))
:<|> (return $ addHeader 1729 $ addHeader "eg2" True)
:<|> return NoContent
@@ -149,9 +195,9 @@ failApi = Proxy
failServer :: Application
failServer = serve failApi (
- (\ _request respond -> respond $ responseLBS ok200 [] "")
- :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")
- :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
+ (\ _request respond -> respond $ responseLBS HTTP.ok200 [] "")
+ :<|> (\ _capture _request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "application/json")] "")
+ :<|> (\_request respond -> respond $ responseLBS HTTP.ok200 [("content-type", "fooooo")] "")
)
-- * basic auth stuff
@@ -208,66 +254,54 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do
- let getGet = getNth (Proxy :: Proxy 0) $ client api
(left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
- let getDeleteEmpty = getNth (Proxy :: Proxy 1) $ client api
(left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
- let getDeleteContentType :: SCR.ClientM NoContent
- getDeleteContentType = getLast $ client api
(left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
- let getCapture = getNth (Proxy :: Proxy 2) $ client api
(left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
- getBody = getNth (Proxy :: Proxy 3) $ client api
(left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
- let getQueryParam = getNth (Proxy :: Proxy 4) $ client api
left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice
Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager
- responseStatus `shouldBe` Status 400 "bob not found"
+ responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
- let getQueryParams = getNth (Proxy :: Proxy 5) $ client api
(left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right []
(left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager)
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
- let getQueryFlag = getNth (Proxy :: Proxy 6) $ client api
(left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
- let getRawSuccess = getNth (Proxy :: Proxy 7) $ client api
- res <- SCR.runClientM (getRawSuccess methodGet) baseUrl manager
+ res <- SCR.runClientM (getRawSuccess HTTP.methodGet) baseUrl manager
case res of
Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do
(code, body, ct) `shouldBe` (200, "rawSuccess", "application"//"octet-stream")
C.responseBody response `shouldBe` body
- C.responseStatus response `shouldBe` ok200
+ C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
- let getRawFailure = getNth (Proxy :: Proxy 8) $ client api
- res <- SCR.runClientM (getRawFailure methodGet) baseUrl manager
+ res <- SCR.runClientM (getRawFailure HTTP.methodGet) baseUrl manager
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left e -> do
- Servant.Client.responseStatus e `shouldBe` status400
+ Servant.Client.responseStatus e `shouldBe` HTTP.status400
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do
- let getRespHeaders = getNth (Proxy :: Proxy 10) $ client api
res <- SCR.runClientM getRespHeaders baseUrl manager
case res of
Left e -> assertFailure $ show e
@@ -275,8 +309,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
modifyMaxSuccess (const 20) $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
- let getMultiple = getNth (Proxy :: Proxy 9) $ client api
- in property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
+ property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager
return $
@@ -293,7 +326,7 @@ wrappedApiSpec = describe "error status codes" $ do
let getResponse :: SCR.ClientM ()
getResponse = client api
Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager
- responseStatus `shouldBe` (Status 500 "error message")
+ responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
(WrappedApi (Proxy :: Proxy (Get '[JSON] ())), "Get") :
@@ -309,7 +342,7 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
let (_ :<|> getDeleteEmpty :<|> _) = client api
Left res <- SCR.runClientM getDeleteEmpty baseUrl manager
case res of
- FailureResponse (Status 404 "Not Found") _ _ -> return ()
+ FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do
@@ -360,7 +393,7 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password"
Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager
- responseStatus `shouldBe` Status 403 "Forbidden"
+ responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
@@ -377,7 +410,7 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager
- responseStatus `shouldBe` (Status 401 "Unauthorized")
+ responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
-- * utils
@@ -408,25 +441,3 @@ pathGen = fmap NonEmpty path
filter (not . (`elem` ("?%[]/#;" :: String))) $
filter isPrint $
map chr [0..127]
-
-class GetNth (n :: Nat) a b | n a -> b where
- getNth :: Proxy n -> a -> b
-
-instance OVERLAPPING_
- GetNth 0 (x :<|> y) x where
- getNth _ (x :<|> _) = x
-
-instance OVERLAPPING_
- (GetNth (n - 1) x y) => GetNth n (a :<|> x) y where
- getNth _ (_ :<|> x) = getNth (Proxy :: Proxy (n - 1)) x
-
-class GetLast a b | a -> b where
- getLast :: a -> b
-
-instance OVERLAPPING_
- (GetLast b c) => GetLast (a :<|> b) c where
- getLast (_ :<|> b) = getLast b
-
-instance OVERLAPPING_
- GetLast a a where
- getLast a = a
From 9e1ba9221d980353d86fc836f7efc673ecc2329a Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Wed, 30 Mar 2016 22:41:39 +0100
Subject: [PATCH 6/8] Manager and BaseUrl are now explicit parameters of all
client functions, instead of ReaderTs
---
servant-client/src/Servant/Client.hs | 50 ++++-----
servant-client/src/Servant/Common/Req.hs | 39 +++----
servant-client/test/Servant/ClientSpec.hs | 125 +++++++++-------------
3 files changed, 93 insertions(+), 121 deletions(-)
diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs
index 91c07bcb..9c2fcfbc 100644
--- a/servant-client/src/Servant/Client.hs
+++ b/servant-client/src/Servant/Client.hs
@@ -33,7 +33,7 @@ import Data.Proxy
import Data.String.Conversions
import Data.Text (unpack)
import GHC.TypeLits
-import Network.HTTP.Client (Response)
+import Network.HTTP.Client (Manager, Response)
import Network.HTTP.Media
import qualified Network.HTTP.Types as H
import qualified Network.HTTP.Types.Header as HTTP
@@ -53,8 +53,8 @@ import Servant.Common.Req
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getAllBooks :: ClientM [Book]
--- > postNewBook :: Book -> ClientM Book
+-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
+-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
client :: HasClient layout => Proxy layout -> Client layout
client p = clientWithRoute p defReq
@@ -77,8 +77,8 @@ class HasClient layout where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getAllBooks :: ClientM [Book]
--- > postNewBook :: Book -> ClientM Book
+-- > getAllBooks :: Manager -> BaseUrl -> ClientM [Book]
+-- > postNewBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > (getAllBooks :<|> postNewBook) = client myApi
instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
type Client (a :<|> b) = Client a :<|> Client b
@@ -102,7 +102,7 @@ instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBook :: Text -> ClientM Book
+-- > getBook :: Text -> Manager -> BaseUrl -> ClientM Book
-- > getBook = client myApi
-- > -- then you can just use "getBook" to query that endpoint
instance (KnownSymbol capture, ToHttpApiData a, HasClient sublayout)
@@ -121,26 +121,28 @@ instance OVERLAPPABLE_
-- Note [Non-Empty Content Types]
(MimeUnrender ct a, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' a) where
- type Client (Verb method status cts' a) = ClientM a
- clientWithRoute Proxy req =
- snd <$> performRequestCT (Proxy :: Proxy ct) method req
+ type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
+ clientWithRoute Proxy req manager baseurl =
+ snd <$> performRequestCT (Proxy :: Proxy ct) method req manager baseurl
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
(ReflectMethod method) => HasClient (Verb method status cts NoContent) where
- type Client (Verb method status cts NoContent) = ClientM NoContent
- clientWithRoute Proxy req =
- performRequestNoBody method req >> return NoContent
+ type Client (Verb method status cts NoContent)
+ = Manager -> BaseUrl -> ClientM NoContent
+ clientWithRoute Proxy req manager baseurl =
+ performRequestNoBody method req manager baseurl >> return NoContent
where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_
-- Note [Non-Empty Content Types]
( MimeUnrender ct a, BuildHeadersTo ls, ReflectMethod method, cts' ~ (ct ': cts)
) => HasClient (Verb method status cts' (Headers ls a)) where
- type Client (Verb method status cts' (Headers ls a)) = ClientM (Headers ls a)
- clientWithRoute Proxy req = do
+ type Client (Verb method status cts' (Headers ls a))
+ = Manager -> BaseUrl -> ClientM (Headers ls a)
+ clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method)
- (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req
+ (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req manager baseurl
return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs
}
@@ -149,10 +151,10 @@ instance OVERLAPPING_
( BuildHeadersTo ls, ReflectMethod method
) => HasClient (Verb method status cts (Headers ls NoContent)) where
type Client (Verb method status cts (Headers ls NoContent))
- = ClientM (Headers ls NoContent)
- clientWithRoute Proxy req = do
+ = Manager -> BaseUrl -> ClientM (Headers ls NoContent)
+ clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method)
- hdrs <- performRequestNoBody method req
+ hdrs <- performRequestNoBody method req manager baseurl
return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs
}
@@ -179,7 +181,7 @@ instance OVERLAPPING_
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > viewReferer :: Maybe Referer -> ClientM Book
+-- > viewReferer :: Maybe Referer -> Manager -> BaseUrl -> ClientM Book
-- > viewReferer = client myApi
-- > -- then you can just use "viewRefer" to query that endpoint
-- > -- specifying Nothing or e.g Just "http://haskell.org/" as arguments
@@ -229,7 +231,7 @@ instance HasClient sublayout
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBooksBy :: Maybe Text -> ClientM [Book]
+-- > getBooksBy :: Maybe Text -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy Nothing' for all books
@@ -273,7 +275,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBooksBy :: [Text] -> ClientM [Book]
+-- > getBooksBy :: [Text] -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooksBy = client myApi
-- > -- then you can just use "getBooksBy" to query that endpoint.
-- > -- 'getBooksBy []' for all books
@@ -312,7 +314,7 @@ instance (KnownSymbol sym, ToHttpApiData a, HasClient sublayout)
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > getBooks :: Bool -> ClientM [Book]
+-- > getBooks :: Bool -> Manager -> BaseUrl -> ClientM [Book]
-- > getBooks = client myApi
-- > -- then you can just use "getBooks" to query that endpoint.
-- > -- 'getBooksBy False' for all books
@@ -337,7 +339,7 @@ instance (KnownSymbol sym, HasClient sublayout)
-- back the full `Response`.
instance HasClient Raw where
type Client Raw
- = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
+ = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString)
clientWithRoute :: Proxy Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do
@@ -358,7 +360,7 @@ instance HasClient Raw where
-- > myApi :: Proxy MyApi
-- > myApi = Proxy
-- >
--- > addBook :: Book -> ClientM Book
+-- > addBook :: Book -> Manager -> BaseUrl -> ClientM Book
-- > addBook = client myApi
-- > -- then you can just use "addBook" to query that endpoint
instance (MimeRender ct a, HasClient sublayout)
diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs
index 44551464..52398637 100644
--- a/servant-client/src/Servant/Common/Req.hs
+++ b/servant-client/src/Servant/Common/Req.hs
@@ -11,9 +11,7 @@ import Control.Exception
import Control.Monad
import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class
-import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
-import Control.Monad.Trans.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String
import Data.String.Conversions
@@ -125,21 +123,12 @@ reqToRequest req (BaseUrl reqScheme reqHost reqPort path) =
displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
-type ClientM = ReaderT BaseUrl (ReaderT Manager (ExceptT ServantError IO))
+type ClientM = ExceptT ServantError IO
-runClientM :: ClientM a -> BaseUrl -> Manager -> IO (Either ServantError a)
-runClientM m baseUrl manager = runExceptT (runReaderT (runReaderT m baseUrl) manager)
-
--- to avoid adding a dependency on mtl
-throwError :: ServantError -> ClientM a
-throwError = lift . lift . throwE
-
-performRequest :: Method -> Req
+performRequest :: Method -> Req -> Manager -> BaseUrl
-> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString)
-performRequest reqMethod req = do
- reqHost <- ask
- manager <- lift ask
+performRequest reqMethod req manager reqHost = do
partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod
@@ -149,7 +138,7 @@ performRequest reqMethod req = do
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of
Left err ->
- throwError . ConnectionError $ SomeException err
+ throwE . ConnectionError $ SomeException err
Right response -> do
let status = Client.responseStatus response
@@ -159,29 +148,29 @@ performRequest reqMethod req = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of
- Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
+ Nothing -> throwE $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $
- throwError $ FailureResponse status ct body
+ throwE $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result =>
- Proxy ct -> Method -> Req
+ Proxy ct -> Method -> Req -> Manager -> BaseUrl
-> ClientM ([HTTP.Header], result)
-performRequestCT ct reqMethod req = do
+performRequestCT ct reqMethod req manager reqHost = do
let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <-
- performRequest reqMethod (req { reqAccept = [acceptCT] })
- unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
+ performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost
+ unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of
- Left err -> throwError $ DecodeFailure err respCT respBody
+ Left err -> throwE $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val)
-performRequestNoBody :: Method -> Req
+performRequestNoBody :: Method -> Req -> Manager -> BaseUrl
-> ClientM [HTTP.Header]
-performRequestNoBody reqMethod req = do
- (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
+performRequestNoBody reqMethod req manager reqHost = do
+ (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a)
diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs
index 999c69c9..2263e9e2 100644
--- a/servant-client/test/Servant/ClientSpec.hs
+++ b/servant-client/test/Servant/ClientSpec.hs
@@ -28,7 +28,7 @@ import Control.Applicative ((<$>))
import Control.Arrow (left)
import Control.Concurrent (forkIO, killThread, ThreadId)
import Control.Exception (bracket)
-import Control.Monad.Trans.Except (ExceptT, throwE)
+import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)
import Data.Aeson
import qualified Data.ByteString.Lazy as BS
import Data.Char (chr, isPrint)
@@ -119,52 +119,33 @@ type Api =
api :: Proxy Api
api = Proxy
-getGet :: SCR.ClientM Person
-getDeleteEmpty :: SCR.ClientM NoContent
-getCapture :: String
- -> SCR.ClientM Person
-getBody :: Person
- -> SCR.ClientM Person
-getQueryParam :: Maybe String
- -> SCR.ClientM Person
-getQueryParams :: [String]
- -> SCR.ClientM [Person]
-getQueryFlag :: Bool
- -> SCR.ClientM Bool
-getRawSuccess :: HTTP.Method
- -> SCR.ClientM ( Int
- , BS.ByteString
- , MediaType
- , [HTTP.Header]
- , C.Response BS.ByteString )
-getRawFailure :: HTTP.Method
- -> SCR.ClientM ( Int
- , BS.ByteString
- , MediaType
- , [HTTP.Header]
- , C.Response BS.ByteString )
-getMultiple :: String
- -> Maybe Int
- -> Bool
- -> [(String, [Rational])]
- -> SCR.ClientM ( String
- , Maybe Int
- , Bool
- , [(String, [Rational])] )
-getRespHeaders :: SCR.ClientM (Headers TestHeaders Bool)
-getDeleteContentType :: SCR.ClientM NoContent
+getGet :: C.Manager -> BaseUrl -> SCR.ClientM Person
+getDeleteEmpty :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
+getCapture :: String -> C.Manager -> BaseUrl -> SCR.ClientM Person
+getBody :: Person -> C.Manager -> BaseUrl -> SCR.ClientM Person
+getQueryParam :: Maybe String -> C.Manager -> BaseUrl -> SCR.ClientM Person
+getQueryParams :: [String] -> C.Manager -> BaseUrl -> SCR.ClientM [Person]
+getQueryFlag :: Bool -> C.Manager -> BaseUrl -> SCR.ClientM Bool
+getRawSuccess :: HTTP.Method -> C.Manager -> BaseUrl
+ -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
+getRawFailure :: HTTP.Method -> C.Manager -> BaseUrl
+ -> SCR.ClientM (Int, BS.ByteString, MediaType, [HTTP.Header], C.Response BS.ByteString)
+getMultiple :: String -> Maybe Int -> Bool -> [(String, [Rational])] -> C.Manager -> BaseUrl
+ -> SCR.ClientM (String, Maybe Int, Bool, [(String, [Rational])])
+getRespHeaders :: C.Manager -> BaseUrl -> SCR.ClientM (Headers TestHeaders Bool)
+getDeleteContentType :: C.Manager -> BaseUrl -> SCR.ClientM NoContent
getGet
- :<|> getDeleteEmpty
- :<|> getCapture
- :<|> getBody
- :<|> getQueryParam
- :<|> getQueryParams
- :<|> getQueryFlag
- :<|> getRawSuccess
- :<|> getRawFailure
- :<|> getMultiple
- :<|> getRespHeaders
- :<|> getDeleteContentType = client api
+ :<|> getDeleteEmpty
+ :<|> getCapture
+ :<|> getBody
+ :<|> getQueryParam
+ :<|> getQueryParams
+ :<|> getQueryFlag
+ :<|> getRawSuccess
+ :<|> getRawFailure
+ :<|> getMultiple
+ :<|> getRespHeaders
+ :<|> getDeleteContentType = client api
server :: Application
server = serve api (
@@ -254,38 +235,38 @@ sucessSpec :: Spec
sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "Servant.API.Get" $ \(_, baseUrl) -> do
- (left show <$> SCR.runClientM getGet baseUrl manager) `shouldReturn` Right alice
+ (left show <$> runExceptT (getGet manager baseUrl)) `shouldReturn` Right alice
describe "Servant.API.Delete" $ do
it "allows empty content type" $ \(_, baseUrl) -> do
- (left show <$> SCR.runClientM getDeleteEmpty baseUrl manager) `shouldReturn` Right NoContent
+ (left show <$> runExceptT (getDeleteEmpty manager baseUrl)) `shouldReturn` Right NoContent
it "allows content type" $ \(_, baseUrl) -> do
- (left show <$> SCR.runClientM getDeleteContentType baseUrl manager) `shouldReturn` Right NoContent
+ (left show <$> runExceptT (getDeleteContentType manager baseUrl)) `shouldReturn` Right NoContent
it "Servant.API.Capture" $ \(_, baseUrl) -> do
- (left show <$> SCR.runClientM (getCapture "Paula") baseUrl manager) `shouldReturn` Right (Person "Paula" 0)
+ (left show <$> runExceptT (getCapture "Paula" manager baseUrl)) `shouldReturn` Right (Person "Paula" 0)
it "Servant.API.ReqBody" $ \(_, baseUrl) -> do
let p = Person "Clara" 42
- (left show <$> SCR.runClientM (getBody p) baseUrl manager) `shouldReturn` Right p
+ (left show <$> runExceptT (getBody p manager baseUrl)) `shouldReturn` Right p
it "Servant.API.QueryParam" $ \(_, baseUrl) -> do
- left show <$> SCR.runClientM (getQueryParam (Just "alice")) baseUrl manager `shouldReturn` Right alice
- Left FailureResponse{..} <- SCR.runClientM (getQueryParam (Just "bob")) baseUrl manager
+ left show <$> runExceptT (getQueryParam (Just "alice") manager baseUrl) `shouldReturn` Right alice
+ Left FailureResponse{..} <- runExceptT (getQueryParam (Just "bob") manager baseUrl)
responseStatus `shouldBe` HTTP.Status 400 "bob not found"
it "Servant.API.QueryParam.QueryParams" $ \(_, baseUrl) -> do
- (left show <$> SCR.runClientM (getQueryParams []) baseUrl manager) `shouldReturn` Right []
- (left show <$> SCR.runClientM (getQueryParams ["alice", "bob"]) baseUrl manager)
+ (left show <$> runExceptT (getQueryParams [] manager baseUrl)) `shouldReturn` Right []
+ (left show <$> runExceptT (getQueryParams ["alice", "bob"] manager baseUrl))
`shouldReturn` Right [Person "alice" 0, Person "bob" 1]
context "Servant.API.QueryParam.QueryFlag" $
forM_ [False, True] $ \ flag -> it (show flag) $ \(_, baseUrl) -> do
- (left show <$> SCR.runClientM (getQueryFlag flag) baseUrl manager) `shouldReturn` Right flag
+ (left show <$> runExceptT (getQueryFlag flag manager baseUrl)) `shouldReturn` Right flag
it "Servant.API.Raw on success" $ \(_, baseUrl) -> do
- res <- SCR.runClientM (getRawSuccess HTTP.methodGet) baseUrl manager
+ res <- runExceptT (getRawSuccess HTTP.methodGet manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right (code, body, ct, _, response) -> do
@@ -294,7 +275,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
C.responseStatus response `shouldBe` HTTP.ok200
it "Servant.API.Raw should return a Left in case of failure" $ \(_, baseUrl) -> do
- res <- SCR.runClientM (getRawFailure HTTP.methodGet) baseUrl manager
+ res <- runExceptT (getRawFailure HTTP.methodGet manager baseUrl)
case res of
Right _ -> assertFailure "expected Left, but got Right"
Left e -> do
@@ -302,7 +283,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
Servant.Client.responseBody e `shouldBe` "rawFailure"
it "Returns headers appropriately" $ \(_, baseUrl) -> do
- res <- SCR.runClientM getRespHeaders baseUrl manager
+ res <- runExceptT (getRespHeaders manager baseUrl)
case res of
Left e -> assertFailure $ show e
Right val -> getHeaders val `shouldBe` [("X-Example1", "1729"), ("X-Example2", "eg2")]
@@ -311,7 +292,7 @@ sucessSpec = beforeAll (startWaiApp server) $ afterAll endWaiApp $ do
it "works for a combination of Capture, QueryParam, QueryFlag and ReqBody" $ \(_, baseUrl) ->
property $ forAllShrink pathGen shrink $ \(NonEmpty cap) num flag body ->
ioProperty $ do
- result <- left show <$> SCR.runClientM (getMultiple cap num flag body) baseUrl manager
+ result <- left show <$> runExceptT (getMultiple cap num flag body manager baseUrl)
return $
result === Right (cap, num, flag, body)
@@ -323,9 +304,9 @@ wrappedApiSpec = describe "error status codes" $ do
let test :: (WrappedApi, String) -> Spec
test (WrappedApi api, desc) =
it desc $ bracket (startWaiApp $ serveW api) endWaiApp $ \(_, baseUrl) -> do
- let getResponse :: SCR.ClientM ()
+ let getResponse :: C.Manager -> BaseUrl -> SCR.ClientM ()
getResponse = client api
- Left FailureResponse{..} <- SCR.runClientM getResponse baseUrl manager
+ Left FailureResponse{..} <- runExceptT (getResponse manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 500 "error message")
in mapM_ test $
(WrappedApi (Proxy :: Proxy (Delete '[JSON] ())), "Delete") :
@@ -340,42 +321,42 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
context "client returns errors appropriately" $ do
it "reports FailureResponse" $ \(_, baseUrl) -> do
let (_ :<|> getDeleteEmpty :<|> _) = client api
- Left res <- SCR.runClientM getDeleteEmpty baseUrl manager
+ Left res <- runExceptT (getDeleteEmpty manager baseUrl)
case res of
FailureResponse (HTTP.Status 404 "Not Found") _ _ -> return ()
_ -> fail $ "expected 404 response, but got " <> show res
it "reports DecodeFailure" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> getCapture :<|> _) = client api
- Left res <- SCR.runClientM (getCapture "foo") baseUrl manager
+ Left res <- runExceptT (getCapture "foo" manager baseUrl)
case res of
DecodeFailure _ ("application/json") _ -> return ()
_ -> fail $ "expected DecodeFailure, but got " <> show res
it "reports ConnectionError" $ \_ -> do
let (getGetWrongHost :<|> _) = client api
- Left res <- SCR.runClientM getGetWrongHost (BaseUrl Http "127.0.0.1" 19872 "") manager
+ Left res <- runExceptT (getGetWrongHost manager (BaseUrl Http "127.0.0.1" 19872 ""))
case res of
ConnectionError _ -> return ()
_ -> fail $ "expected ConnectionError, but got " <> show res
it "reports UnsupportedContentType" $ \(_, baseUrl) -> do
let (getGet :<|> _ ) = client api
- Left res <- SCR.runClientM getGet baseUrl manager
+ Left res <- runExceptT (getGet manager baseUrl)
case res of
UnsupportedContentType ("application/octet-stream") _ -> return ()
_ -> fail $ "expected UnsupportedContentType, but got " <> show res
it "reports InvalidContentTypeHeader" $ \(_, baseUrl) -> do
let (_ :<|> _ :<|> _ :<|> getBody :<|> _) = client api
- Left res <- SCR.runClientM (getBody alice) baseUrl manager
+ Left res <- runExceptT (getBody alice manager baseUrl)
case res of
InvalidContentTypeHeader "fooooo" _ -> return ()
_ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
data WrappedApi where
WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
- HasClient api, Client api ~ SCR.ClientM ()) =>
+ HasClient api, Client api ~ (C.Manager -> BaseUrl -> SCR.ClientM ())) =>
Proxy api -> WrappedApi
basicAuthSpec :: Spec
@@ -385,14 +366,14 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "servant" "server"
- (left show <$> SCR.runClientM (getBasic basicAuthData) baseUrl manager) `shouldReturn` Right alice
+ (left show <$> runExceptT (getBasic basicAuthData manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
let getBasic = client basicAuthAPI
let basicAuthData = BasicAuthData "not" "password"
- Left FailureResponse{..} <- SCR.runClientM (getBasic basicAuthData) baseUrl manager
+ Left FailureResponse{..} <- runExceptT (getBasic basicAuthData manager baseUrl)
responseStatus `shouldBe` HTTP.Status 403 "Forbidden"
genAuthSpec :: Spec
@@ -402,14 +383,14 @@ genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
- (left show <$> SCR.runClientM (getProtected authRequest) baseUrl manager) `shouldReturn` Right alice
+ (left show <$> runExceptT (getProtected authRequest manager baseUrl)) `shouldReturn` Right alice
context "Authentication is rejected when requests are not authenticated properly" $ do
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
let getProtected = client genAuthAPI
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
- Left FailureResponse{..} <- SCR.runClientM (getProtected authRequest) baseUrl manager
+ Left FailureResponse{..} <- runExceptT (getProtected authRequest manager baseUrl)
responseStatus `shouldBe` (HTTP.Status 401 "Unauthorized")
-- * utils
From a9200cd0501e9359141c2f55536b3d1364a6d476 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Wed, 30 Mar 2016 22:50:29 +0100
Subject: [PATCH 7/8] Modified the tutorial to reflect the changes to
servant-client (explicit parameters)
---
doc/tutorial/Client.lhs | 28 +++++++++++++++++-----------
1 file changed, 17 insertions(+), 11 deletions(-)
diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs
index 67f38357..a40ca7c6 100644
--- a/doc/tutorial/Client.lhs
+++ b/doc/tutorial/Client.lhs
@@ -15,13 +15,13 @@ need to have some language extensions and imports:
module Client where
+import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Data.Aeson
import Data.Proxy
import GHC.Generics
-import Network.HTTP.Client (newManager, defaultManagerSettings)
+import Network.HTTP.Client (Manager, newManager, defaultManagerSettings)
import Servant.API
import Servant.Client
-import Servant.Common.Req (ClientM, runClientM)
```
Also, we need examples for some domain specific data types:
@@ -71,13 +71,19 @@ What we are going to get with **servant-client** here is 3 functions, one to que
``` haskell
position :: Int -- ^ value for "x"
-> Int -- ^ value for "y"
- -> ClientM Position
+ -> Manager -- ^ the HTTP client to use
+ -> BaseUrl -- ^ the URL at which the API can be found
+ -> ExceptT ServantError IO Position
hello :: Maybe String -- ^ an optional value for "name"
- -> ClientM HelloMessage
+ -> Manager -- ^ the HTTP client to use
+ -> BaseUrl -- ^ the URL at which the API can be found
+ -> ExceptT ServantError IO HelloMessage
marketing :: ClientInfo -- ^ value for the request body
- -> ClientM Email
+ -> Manager -- ^ the HTTP client to use
+ -> BaseUrl -- ^ the URL at which the API can be found
+ -> ExceptT ServantError IO Email
```
Each function makes available as an argument any value that the response may
@@ -114,17 +120,17 @@ data BaseUrl = BaseUrl
That's it. Let's now write some code that uses our client functions.
``` haskell
-queries :: ClientM (Position, HelloMessage, Email)
-queries = do
- pos <- position 10 10
- message <- hello (Just "servant")
- em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"])
+queries :: Manager -> BaseUrl -> ExceptT ServantError IO (Position, HelloMessage, Email)
+queries manager baseurl = do
+ pos <- position 10 10 manager baseurl
+ message <- hello (Just "servant") manager baseurl
+ em <- marketing (ClientInfo "Alp" "alp@foo.com" 26 ["haskell", "mathematics"]) manager baseurl
return (pos, message, em)
run :: IO ()
run = do
manager <- newManager defaultManagerSettings
- res <- runClientM queries (BaseUrl Http "localhost" 8081 "") manager
+ res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 ""))
case res of
Left err -> putStrLn $ "Error: " ++ show err
Right (pos, message, em) -> do
From 6fd1e21580b0679ca19e5e3f7130e3f0c3deb4b8 Mon Sep 17 00:00:00 2001
From: mbg <michael.gale@cl.cam.ac.uk>
Date: Wed, 30 Mar 2016 22:51:08 +0100
Subject: [PATCH 8/8] Updated changelog to reflect that client no longer
requires BaseUrl and Manager arguments
---
servant-client/CHANGELOG.md | 3 +++
1 file changed, 3 insertions(+)
diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md
index 0cddd5ea..cb2b720d 100644
--- a/servant-client/CHANGELOG.md
+++ b/servant-client/CHANGELOG.md
@@ -1,3 +1,6 @@
+
+* `client` no longer takes `BaseUrl` and `Manager` arguments. Instead, each function returned by `client` requires these two arguments.
+
0.5
----