eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

change ClientM to be a ReaderT (Manager, BaseUrl) ...

Browse source
This commit is contained in:
Christian Klinger 2016-09-04 10:13:43 +02:00
parent bf824a3889
commit 2ec3a7356c
3 changed files with 36 additions and 23 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
servant-client/servant-client.cabal
View file

@ -53,6 +53,7 @@ library
, text >= 1.2 && < 1.3 , text >= 1.2 && < 1.3
, transformers >= 0.3 && < 0.6 , transformers >= 0.3 && < 0.6
, transformers-compat >= 0.4 && < 0.6 , transformers-compat >= 0.4 && < 0.6
, mtl
hs-source-dirs: src hs-source-dirs: src
default-language: Haskell2010 default-language: Haskell2010
ghc-options: -Wall ghc-options: -Wall

10
servant-client/src/Servant/Client.hs
View file

@ -156,7 +156,7 @@ instance OVERLAPPABLE_
) => HasClient (Verb method status cts' a) where ) => HasClient (Verb method status cts' a) where
type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a type Client (Verb method status cts' a) = Manager -> BaseUrl -> ClientM a
clientWithRoute Proxy req manager baseurl = 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) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
@ -164,7 +164,7 @@ instance OVERLAPPING_
type Client (Verb method status cts NoContent) type Client (Verb method status cts NoContent)
= Manager -> BaseUrl -> ClientM NoContent = Manager -> BaseUrl -> ClientM NoContent
clientWithRoute Proxy req manager baseurl = clientWithRoute Proxy req manager baseurl =
performRequestNoBody method req manager baseurl >> return NoContent performRequestNoBody method req >> return NoContent
where method = reflectMethod (Proxy :: Proxy method) where method = reflectMethod (Proxy :: Proxy method)
instance OVERLAPPING_ instance OVERLAPPING_
@ -175,7 +175,7 @@ instance OVERLAPPING_
= Manager -> BaseUrl -> ClientM (Headers ls a) = Manager -> BaseUrl -> ClientM (Headers ls a)
clientWithRoute Proxy req manager baseurl = do clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method) 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 return $ Headers { getResponse = resp
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -187,7 +187,7 @@ instance OVERLAPPING_
= Manager -> BaseUrl -> ClientM (Headers ls NoContent) = Manager -> BaseUrl -> ClientM (Headers ls NoContent)
clientWithRoute Proxy req manager baseurl = do clientWithRoute Proxy req manager baseurl = do
let method = reflectMethod (Proxy :: Proxy method) let method = reflectMethod (Proxy :: Proxy method)
hdrs <- performRequestNoBody method req manager baseurl hdrs <- performRequestNoBody method req
return $ Headers { getResponse = NoContent return $ Headers { getResponse = NoContent
, getHeadersHList = buildHeadersTo hdrs , getHeadersHList = buildHeadersTo hdrs
} }
@ -372,7 +372,7 @@ instance (KnownSymbol sym, HasClient api)
-- back the full `Response`. -- back the full `Response`.
instance HasClient Raw where instance HasClient Raw where
type Client Raw 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 Raw -> Req -> Client Raw
clientWithRoute Proxy req httpMethod = do clientWithRoute Proxy req httpMethod = do

48
servant-client/src/Servant/Common/Req.hs
View file

@ -2,6 +2,8 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Servant.Common.Req where module Servant.Common.Req where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
@ -10,8 +12,9 @@ import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad import Control.Monad
import Control.Monad.Catch (MonadThrow) import Control.Monad.Catch (MonadThrow)
import Control.Monad.IO.Class import Control.Monad.Except
import Control.Monad.Trans.Except import Control.Monad.IO.Class ()
import Control.Monad.Reader
import Data.ByteString.Lazy hiding (pack, filter, map, null, elem) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem)
import Data.String import Data.String
import Data.String.Conversions import Data.String.Conversions
@ -149,12 +152,23 @@ parseRequest url = liftM disableStatusCheck (parseUrl url)
displayHttpRequest :: Method -> String displayHttpRequest :: Method -> String
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request" 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 -> ClientM ( Int, ByteString, MediaType
, [HTTP.Header], Response ByteString) , [HTTP.Header], Response ByteString)
performRequest reqMethod req manager reqHost = do performRequest reqMethod req = do
(manager, reqHost) <- ask
partialRequest <- liftIO $ reqToRequest req reqHost partialRequest <- liftIO $ reqToRequest req reqHost
let request = partialRequest { Client.method = reqMethod } let request = partialRequest { Client.method = reqMethod }
@ -162,7 +176,7 @@ performRequest reqMethod req manager reqHost = do
eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request manager
case eResponse of case eResponse of
Left err -> Left err ->
throwE . ConnectionError $ SomeException err throwError . ConnectionError $ SomeException err
Right response -> do Right response -> do
let status = Client.responseStatus response let status = Client.responseStatus response
@ -172,28 +186,26 @@ performRequest reqMethod req manager reqHost = do
ct <- case lookup "Content-Type" $ Client.responseHeaders response of ct <- case lookup "Content-Type" $ Client.responseHeaders response of
Nothing -> pure $ "application"//"octet-stream" Nothing -> pure $ "application"//"octet-stream"
Just t -> case parseAccept t of Just t -> case parseAccept t of
Nothing -> throwE $ InvalidContentTypeHeader (cs t) body Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
Just t' -> pure t' Just t' -> pure t'
unless (status_code >= 200 && status_code < 300) $ unless (status_code >= 200 && status_code < 300) $
throwE $ FailureResponse status ct body throwError $ FailureResponse status ct body
return (status_code, body, ct, hdrs, response) return (status_code, body, ct, hdrs, response)
performRequestCT :: MimeUnrender ct result => performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
Proxy ct -> Method -> Req -> Manager -> BaseUrl
-> ClientM ([HTTP.Header], result) -> ClientM ([HTTP.Header], result)
performRequestCT ct reqMethod req manager reqHost = do performRequestCT ct reqMethod req = do
let acceptCT = contentType ct let acceptCT = contentType ct
(_status, respBody, respCT, hdrs, _response) <- (_status, respBody, respCT, hdrs, _response) <-
performRequest reqMethod (req { reqAccept = [acceptCT] }) manager reqHost performRequest reqMethod (req { reqAccept = [acceptCT] })
unless (matches respCT (acceptCT)) $ throwE $ UnsupportedContentType respCT respBody unless (matches respCT (acceptCT)) $ throwError $ UnsupportedContentType respCT respBody
case mimeUnrender ct respBody of case mimeUnrender ct respBody of
Left err -> throwE $ DecodeFailure err respCT respBody Left err -> throwError $ DecodeFailure err respCT respBody
Right val -> return (hdrs, val) Right val -> return (hdrs, val)
performRequestNoBody :: Method -> Req -> Manager -> BaseUrl performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
-> ClientM [HTTP.Header] performRequestNoBody reqMethod req = do
performRequestNoBody reqMethod req manager reqHost = do (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
(_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req manager reqHost
return hdrs return hdrs
catchConnectionError :: IO a -> IO (Either ServantError a) catchConnectionError :: IO a -> IO (Either ServantError a)