diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 65983a3d..c394b708 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -47,12 +47,14 @@ library , http-client-tls >= 0.2.2 && < 0.4 , http-media >= 0.6.2 && < 0.7 , http-types >= 0.8.6 && < 0.10 + , monad-control >= 1.0.0.4 && < 1.1 , network-uri >= 2.6 && < 2.7 , safe >= 0.3.9 && < 0.4 , servant == 0.9.* , string-conversions >= 0.3 && < 0.5 , text >= 1.2 && < 1.3 , transformers >= 0.3 && < 0.6 + , transformers-base >= 0.4.4 && < 0.5 , transformers-compat >= 0.4 && < 0.6 , mtl hs-source-dirs: src diff --git a/servant-client/src/Servant/Common/Req.hs b/servant-client/src/Servant/Common/Req.hs index 57471967..7d107c7c 100644 --- a/servant-client/src/Servant/Common/Req.hs +++ b/servant-client/src/Servant/Common/Req.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Servant.Common.Req where @@ -24,8 +26,10 @@ import Control.Monad.Trans.Except import GHC.Generics +import Control.Monad.Base (MonadBase (..)) import Control.Monad.IO.Class () import Control.Monad.Reader +import Control.Monad.Trans.Control (MonadBaseControl (..)) import Data.ByteString.Lazy hiding (pack, filter, map, null, elem, any) import Data.String import Data.String.Conversions @@ -180,6 +184,18 @@ newtype ClientM a = ClientM { runClientM' :: ReaderT ClientEnv (ExceptT ServantE , MonadThrow, MonadCatch ) +instance MonadBase IO ClientM where + liftBase = ClientM . liftBase + +instance MonadBaseControl IO ClientM where + type StM ClientM a = Either ServantError a + + -- liftBaseWith :: (RunInBase ClientM IO -> IO a) -> ClientM a + liftBaseWith f = ClientM (liftBaseWith (\g -> f (g . runClientM'))) + + -- restoreM :: StM ClientM a -> ClientM a + restoreM st = ClientM (restoreM st) + runClientM :: ClientM a -> ClientEnv -> IO (Either ServantError a) runClientM cm env = runExceptT $ (flip runReaderT env) $ runClientM' cm