From 2ec3a7356c5ccd1d660957a08fc478f925a2619a Mon Sep 17 00:00:00 2001 From: Christian Klinger Date: Sun, 4 Sep 2016 10:13:43 +0200 Subject: [PATCH] change ClientM to be a ReaderT (Manager, BaseUrl) ... --- servant-client/servant-client.cabal | 1 + servant-client/src/Servant/Client.hs | 10 ++--- servant-client/src/Servant/Common/Req.hs | 48 +++++++++++++++--------- 3 files changed, 36 insertions(+), 23 deletions(-) diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index edbca092..c49cfe0e 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -53,6 +53,7 @@ library , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 , transformers-compat >= 0.4 && < 0.6 + , mtl hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 18581075..ebe9e559 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -156,7 +156,7 @@ instance OVERLAPPABLE_ ) => 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 manager baseurl + snd <$> performRequestCT (Proxy :: Proxy ct) method req where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ @@ -164,7 +164,7 @@ instance OVERLAPPING_ type Client (Verb method status cts NoContent) = Manager -> BaseUrl -> ClientM NoContent clientWithRoute Proxy req manager baseurl = - performRequestNoBody method req manager baseurl >> return NoContent + performRequestNoBody method req >> return NoContent where method = reflectMethod (Proxy :: Proxy method) instance OVERLAPPING_ @@ -175,7 +175,7 @@ instance OVERLAPPING_ = 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 manager baseurl + (hdrs, resp) <- performRequestCT (Proxy :: Proxy ct) method req return $ Headers { getResponse = resp , getHeadersHList = buildHeadersTo hdrs } @@ -187,7 +187,7 @@ instance OVERLAPPING_ = Manager -> BaseUrl -> ClientM (Headers ls NoContent) clientWithRoute Proxy req manager baseurl = do let method = reflectMethod (Proxy :: Proxy method) - hdrs <- performRequestNoBody method req manager baseurl + hdrs <- performRequestNoBody method req return $ Headers { getResponse = NoContent , getHeadersHList = buildHeadersTo hdrs } @@ -372,7 +372,7 @@ instance (KnownSymbol sym, HasClient api) -- back the full `Response`. instance HasClient Raw where type Client Raw - = H.Method -> Manager -> BaseUrl -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) + = H.Method -> ClientM (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy Raw -> Req -> Client Raw clientWithRoute Proxy req httpMethod = do diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index ea610cce..2911e861 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -2,6 +2,8 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Servant.Common.Req where #if !MIN_VERSION_base(4,8,0) @@ -10,8 +12,9 @@ import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Catch (MonadThrow) -import Control.Monad.IO.Class -import Control.Monad.Trans.Except +import Control.Monad.Except +import Control.Monad.IO.Class () +import Control.Monad.Reader import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.String import Data.String.Conversions @@ -149,12 +152,23 @@ parseRequest url = liftM disableStatusCheck (parseUrl url) displayHttpRequest :: Method -> String displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" -type ClientM = ExceptT ServantError IO +--type ClientM = ExceptT ServantError IO -performRequest :: Method -> Req -> Manager -> BaseUrl +newtype ClientM a = ClientM (ReaderT (Manager, BaseUrl) (ExceptT ServantError IO) a ) + deriving ( Functor, Applicative, Monad, MonadIO + , MonadReader (Manager, BaseUrl) + , MonadError ServantError + ) + +runClientM :: ClientM a -> (Manager, BaseUrl) -> (ExceptT ServantError IO) a +runClientM = undefined + + +performRequest :: Method -> Req -> ClientM ( Int, ByteString, MediaType , [HTTP.Header], Response ByteString) -performRequest reqMethod req manager reqHost = do +performRequest reqMethod req = do + (manager, reqHost) <- ask partialRequest <- liftIO $ reqToRequest req reqHost let request = partialRequest { Client.method = reqMethod } @@ -162,7 +176,7 @@ performRequest reqMethod req manager reqHost = 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 @@ -172,28 +186,26 @@ performRequest reqMethod req manager reqHost = 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 -> Manager -> BaseUrl +performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req -> ClientM ([HTTP.Header], result) -performRequestCT ct reqMethod req manager reqHost = do +performRequestCT ct reqMethod req = do let acceptCT = contentType ct (_status, respBody, respCT, hdrs, _response) <- - performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost - 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 -> Manager -> BaseUrl - -> ClientM [HTTP.Header] -performRequestNoBody reqMethod req manager reqHost = do - (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost +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)