@@ -13,38 +13,23 @@ import Prelude ()
1313import Prelude.Compat
1414
1515import Control.Exception
16−import Control.Monad
17−import Control.Monad.Catch (MonadThrow, MonadCatch)
18−import Data.Foldable (toList)
19−import Data.Functor.Alt (Alt (..))
16+import Control.Monad.Catch (MonadThrow)
2017import Data.Semigroup ((<>))
2118
22−import Control.Monad.Error.Class (MonadError(..))
23−import Control.Monad.Trans.Except
24−
25−import GHC.Generics
26−import Control.Monad.Base (MonadBase (..))
2719import Control.Monad.IO.Class ()
28−import Control.Monad.Reader
29−import Control.Monad.Trans.Control (MonadBaseControl (..))
3020import qualified Data.ByteString.Builder as BS
3121import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any)
3222import Data.String
3323import Data.String.Conversions (cs)
34−import Data.Proxy
3524import Data.Text (Text)
3625import Data.Text.Encoding
3726import Data.Typeable
3827import Network.HTTP.Media
3928import Network.HTTP.Types
4029import Network.HTTP.Client hiding (Proxy, path)
41−import qualified Network.HTTP.Types.Header as HTTP
4230import Network.URI hiding (path)
43−import Servant.API.ContentTypes
4431import Servant.Common.BaseUrl
4532
46−import qualified Network.HTTP.Client as Client
47−
4833import Web.HttpApiData
4934
5035data ServantError
@@ -196,90 +181,3 @@ parseRequest url = liftM disableStatusCheck (parseUrl url)
196181
197182displayHttpRequest :: Method -> String
198183displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
199−
200−data ClientEnv
201− = ClientEnv
202− { manager :: Manager
203− , baseUrl :: BaseUrl
204− }
205−
206−
207−-- | @ClientM@ is the monad in which client functions run. Contains the
208−-- 'Manager' and 'BaseUrl' used for requests in the reader environment.
209−
210−newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantError IO) a }
211− deriving ( Functor, Applicative, Monad, MonadIO, Generic
212− , MonadReader ClientEnv
213− , MonadError ServantError
214− , MonadThrow, MonadCatch
215− )
216−
217−instance MonadBase IO ClientM where
218− liftBase = ClientM . liftBase
219−
220−instance MonadBaseControl IO ClientM where
221− type StM ClientM a = Either ServantError a
222−
223− -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a
224− liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM')))
225−
226− -- restoreM :: StM ClientM a -> ClientM a
227− restoreM st = ClientM (restoreM st)
228−
229−-- | Try clients in order, last error is preserved.
230−instance Alt ClientM where
231− a <!> b = a `catchError` \_ -> b
232−
233−runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a)
234−runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm
235−
236−
237−performRequest :: Method -> Req
238− -> ClientM ( Int, ByteString, MediaType
239− , [HTTP.Header], Response ByteString)
240−performRequest reqMethod req = do
241− m <- asks manager
242− reqHost <- asks baseUrl
243− partialRequest <- liftIO $ reqToRequest req reqHost
244−
245− let request = partialRequest { Client.method = reqMethod }
246−
247− eResponse <- liftIO $ catchConnectionError $ Client.httpLbs request m
248− case eResponse of
249− Left err ->
250− throwError . ConnectionError $ SomeException err
251−
252− Right response -> do
253− let status = Client.responseStatus response
254− body = Client.responseBody response
255− hdrs = Client.responseHeaders response
256− status_code = statusCode status
257− ct <- case lookup "Content-Type" $ Client.responseHeaders response of
258− Nothing -> pure $ "application"//"octet-stream"
259− Just t -> case parseAccept t of
260− Nothing -> throwError $ InvalidContentTypeHeader (cs t) body
261− Just t' -> pure t'
262− unless (status_code >= 200 && status_code < 300) $
263− throwError $ FailureResponse (UrlReq reqHost req) status ct body
264− return (status_code, body, ct, hdrs, response)
265−
266−performRequestCT :: MimeUnrender ct result => Proxy ct -> Method -> Req
267− -> ClientM ([HTTP.Header], result)
268−performRequestCT ct reqMethod req = do
269− let acceptCTS = contentTypes ct
270− (_status, respBody, respCT, hdrs, _response) <-
271− performRequest reqMethod (req { reqAccept = toList acceptCTS })
272− unless (any (matches respCT) acceptCTS) $ throwError $ UnsupportedContentType respCT respBody
273− case mimeUnrender ct respBody of
274− Left err -> throwError $ DecodeFailure err respCT respBody
275− Right val -> return (hdrs, val)
276−
277−performRequestNoBody :: Method -> Req -> ClientM [HTTP.Header]
278−performRequestNoBody reqMethod req = do
279− (_status, _body, _ct, hdrs, _response) <- performRequest reqMethod req
280− return hdrs
281−
282−catchConnectionError :: IO a -> IO (Either ServantError a)
283−catchConnectionError action =
284− catch (Right <$> action) $ \e ->
285− pure . Left . ConnectionError $ SomeException (e :: HttpException)