From 4517022332eaa186a145ade6b8f8acb3214ebc15 Mon Sep 17 00:00:00 2001 From: Christian Klinger Date: Sun, 4 Sep 2016 10:50:08 +0200 Subject: [PATCH] added ClientEnv data type and runClientM --- doc/tutorial/Client.lhs | 24 +++++++++--------------- servant-client/src/Servant/Client.hs | 21 ++++++++++++--------- servant-client/src/Servant/Common/Req.hs | 18 +++++++++++++----- 3 files changed, 34 insertions(+), 29 deletions(-) diff --git a/doc/tutorial/Client.lhs b/doc/tutorial/Client.lhs index a40ca7c6..e7543ddb 100644 --- a/doc/tutorial/Client.lhs +++ b/doc/tutorial/Client.lhs @@ -71,19 +71,13 @@ 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" - -> Manager -- ^ the HTTP client to use - -> BaseUrl -- ^ the URL at which the API can be found - -> ExceptT ServantError IO Position + -> ClientM Position hello :: Maybe String -- ^ an optional value for "name" - -> Manager -- ^ the HTTP client to use - -> BaseUrl -- ^ the URL at which the API can be found - -> ExceptT ServantError IO HelloMessage + -> ClientM HelloMessage marketing :: ClientInfo -- ^ value for the request body - -> Manager -- ^ the HTTP client to use - -> BaseUrl -- ^ the URL at which the API can be found - -> ExceptT ServantError IO Email + -> ClientM Email ``` Each function makes available as an argument any value that the response may @@ -120,17 +114,17 @@ data BaseUrl = BaseUrl That's it. Let's now write some code that uses our client functions. ``` haskell -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 +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"]) return (pos, message, em) run :: IO () run = do manager <- newManager defaultManagerSettings - res <- runExceptT (queries manager (BaseUrl Http "localhost" 8081 "")) + res <- runClientM queries (ClientEnv manager (BaseUrl Http "localhost" 8081 "")) case res of Left err -> putStrLn $ "Error: " ++ show err Right (pos, message, em) -> do diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index ebe9e559..87b819b2 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -20,6 +20,8 @@ module Servant.Client , client , HasClient(..) , ClientM + , runClientM + , ClientEnv (ClientEnv) , mkAuthenticateReq , ServantError(..) , module Servant.Common.BaseUrl @@ -28,6 +30,7 @@ module Servant.Client #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif +import Control.Monad.Reader (ask) import Data.ByteString.Lazy (ByteString) import Data.List import Data.Proxy @@ -154,16 +157,16 @@ 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) = Manager -> BaseUrl -> ClientM a - clientWithRoute Proxy req manager baseurl = - snd <$> performRequestCT (Proxy :: Proxy ct) method req + type Client (Verb method status cts' a) = ClientM a + clientWithRoute Proxy req = do + 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) - = Manager -> BaseUrl -> ClientM NoContent - clientWithRoute Proxy req manager baseurl = + = ClientM NoContent + clientWithRoute Proxy req = do performRequestNoBody method req >> return NoContent where method = reflectMethod (Proxy :: Proxy method) @@ -172,8 +175,8 @@ instance OVERLAPPING_ ( 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)) - = Manager -> BaseUrl -> ClientM (Headers ls a) - clientWithRoute Proxy req manager baseurl = do + = ClientM (Headers ls a) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp @@ -184,8 +187,8 @@ instance OVERLAPPING_ ( BuildHeadersTo ls, ReflectMethod method ) => HasClient (Verb method status cts (Headers ls NoContent)) where type Client (Verb method status cts (Headers ls NoContent)) - = Manager -> BaseUrl -> ClientM (Headers ls NoContent) - clientWithRoute Proxy req manager baseurl = do + = ClientM (Headers ls NoContent) + clientWithRoute Proxy req = do let method = reflectMethod (Proxy :: Proxy method) hdrs <- performRequestNoBody method req return $ Headers { getResponse = NoContent diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 2911e861..447a20a3 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -152,23 +152,31 @@ parseRequest url = liftM disableStatusCheck (parseUrl url) displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" +-- previously: --type ClientM = ExceptT ServantError IO -newtype ClientM a = ClientM (ReaderT (Manager, BaseUrl) (ExceptT ServantError IO) a ) +data ClientEnv + = ClientEnv + { manager :: Manager + , baseUrl :: BaseUrl + } + +newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a } deriving ( Functor, Applicative, Monad, MonadIO - , MonadReader (Manager, BaseUrl) + , MonadReader ClientEnv , MonadError ServantError ) -runClientM :: ClientM a -> (Manager, BaseUrl) -> (ExceptT ServantError IO) a -runClientM = undefined +runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) +runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm performRequest :: Method -> Req -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) performRequest reqMethod req = do - (manager, reqHost) <- ask + manager <- asks manager + reqHost <- asks baseUrl partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod }