module Control.Monad.Http.Class (
MonadHttp(..),
BodyReaderM,
httpLbs,
brConsume,
) where
import Prelude ()
import Prelude.Compat
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as L
import qualified Network.HTTP.Client as H
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import Control.Monad.Trans.Identity (IdentityT (..))
import Control.Monad.Trans.Maybe (MaybeT (..))
import Control.Monad.Trans.Error (Error, ErrorT (..))
import Control.Monad.Trans.Reader (ReaderT (..))
import Control.Monad.Trans.RWS (RWST (..))
import Control.Monad.Trans.State (StateT (..))
import Control.Monad.Trans.Writer (WriterT (..))
import qualified Control.Monad.Trans.RWS.Strict as Strict (RWST (..))
import qualified Control.Monad.Trans.State.Strict as Strict (StateT (..))
import qualified Control.Monad.Trans.Writer.Strict as Strict (WriterT (..))
import Control.Monad.CryptoRandom (CRandT (..))
import Control.Monad.Logger (LoggingT (..), NoLoggingT (..))
import Control.Monad.Random (RandT, liftRandT, runRandT)
#if !MIN_VERSION_MonadRandom(0, 4, 0)
import Control.Monad.Random (RandomGen)
#endif
import Control.Monad.Trans.Http (HttpT (..), liftHttpT)
type BodyReaderM m = m S.ByteString
class
#if MIN_VERSION_base(4,8,0)
Monad m
#else
(Applicative m, Monad m)
#endif
=> MonadHttp m where
withResponse :: H.Request -> (H.Response (BodyReaderM m) -> m a) -> m a
brRead :: BodyReaderM m -> m S.ByteString
brRead = id
instance MonadHttp m => MonadHttp (IdentityT m) where
withResponse req f = lift $ withResponse req (runIdentityT . f . fmap lift)
instance MonadHttp m => MonadHttp (ReaderT r m) where
withResponse req f =
ReaderT $ \r ->
withResponse req $ \res ->
runReaderT (f $ fmap lift res) r
instance MonadHttp m => MonadHttp (StateT r m) where
withResponse req f =
StateT $ \s ->
withResponse req $ \res ->
runStateT (f $ fmap lift res) s
instance MonadHttp m => MonadHttp (Strict.StateT r m) where
withResponse req f =
Strict.StateT $ \s ->
withResponse req $ \res ->
Strict.runStateT (f $ fmap lift res) s
instance (MonadHttp m, Monoid w) => MonadHttp (WriterT w m) where
withResponse req f =
WriterT $ withResponse req $ \res ->
runWriterT (f $ fmap lift res)
instance (MonadHttp m, Monoid w) => MonadHttp (Strict.WriterT w m) where
withResponse req f =
Strict.WriterT $ withResponse req $ \res ->
Strict.runWriterT (f $ fmap lift res)
instance (MonadHttp m, Monoid w) => MonadHttp (RWST r w s m) where
withResponse req f =
RWST $ \r s ->
withResponse req $ \res ->
runRWST (f $ fmap lift res) r s
instance (MonadHttp m, Monoid w) => MonadHttp (Strict.RWST r w s m) where
withResponse req f =
Strict.RWST $ \r s ->
withResponse req $ \res ->
Strict.runRWST (f $ fmap lift res) r s
instance MonadHttp m => MonadHttp (MaybeT m) where
withResponse req f =
MaybeT $ withResponse req $ \res ->
runMaybeT (f $ fmap lift res)
instance MonadHttp m => MonadHttp (ExceptT e m) where
withResponse req f =
ExceptT $ withResponse req $ \res ->
runExceptT (f $ fmap lift res)
instance (MonadHttp m, Error e) => MonadHttp (ErrorT e m) where
withResponse req f =
ErrorT $ withResponse req $ \res ->
runErrorT (f $ fmap lift res)
instance
#if MIN_VERSION_MonadRandom(0, 4, 0)
MonadHttp m
#else
(MonadHttp m, RandomGen g)
#endif
=> MonadHttp (RandT g m) where
withResponse req f =
liftRandT $ \r ->
withResponse req $ \res ->
runRandT (f $ fmap lift res) r
#if MIN_VERSION_monadcryptorandom(0, 7, 0)
instance MonadHttp m => MonadHttp (CRandT g e m) where
withResponse req f =
CRandT $ withResponse req $ \res ->
unCRandT (f $ fmap CRandT res)
#else
instance (MonadHttp m, Error e) => MonadHttp (CRandT g e m) where
withResponse req f =
CRandT $ withResponse req $ \res ->
unCRandT (f $ fmap CRandT res)
#endif
instance MonadHttp m => MonadHttp (LoggingT m) where
withResponse req f =
LoggingT $ \r ->
withResponse req $ \res ->
runLoggingT (f $ fmap lift res) r
instance MonadHttp m => MonadHttp (NoLoggingT m) where
withResponse req f = lift $ withResponse req (runNoLoggingT . f . fmap lift)
httpLbs :: MonadHttp m => H.Request -> m (H.Response L.ByteString)
httpLbs req = withResponse req $ \res -> do
bss <- brConsume $ H.responseBody res
return res { H.responseBody = L.fromChunks bss }
brConsume :: MonadHttp m => BodyReaderM m -> m [S.ByteString]
brConsume brRead' =
go id
where
go front = do
x <- brRead'
if S.null x
then return $ front []
else go (front . (x:))
instance m ~ IO => MonadHttp (HttpT m) where
withResponse req f = HttpT (\mgr -> H.withResponse req mgr (flip runHttpT mgr . f . fmap liftHttpT))