{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
#if __GLASGOW_HASKELL__ >= 801
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
{-# OPTIONS_HADDOCK show-extensions #-}
module Network.Mail.Assumpta.Trans.Smtp
(
module Conn
, SmtpT(..)
, liftSmtpT
, mapSmtpT
, MonadSmtp
, runSmtpEither
, runSmtp
, withSmtpConnection
, rethrow
)
where
import Control.Monad.Catch (bracket, MonadMask)
import Control.Monad.Except
import Control.Monad.Reader
import Network.Mail.Assumpta.Connection as Conn
import Network.Mail.Assumpta.Types
import Network.Mail.Assumpta.MonadSmtp as MonadSmtp
import Network.Mail.Assumpta.ParseResponse as P (getReply)
{-# ANN module ("HLint: ignore Eta reduce" :: String) #-}
newtype SmtpT conn m a = SmtpT {
unSmtpT :: ReaderT conn (ExceptT SmtpError m) a
}
deriving (Functor, Applicative, Monad, MonadIO, MonadFix
, MonadError SmtpError, MonadReader conn
)
instance (Connection conn, cstr ~ Cstrt conn, Monad m, cstr (SmtpT conn m))
=> MonadSmtp.MonadSmtp (SmtpT conn m)
where
send bs = ask >>= (`Conn.send` bs)
getReply = asks recv >>= P.getReply
tlsUpgrade = ask >>= upgrade
liftSmtpT :: Monad m => m a -> SmtpT conn m a
liftSmtpT = SmtpT . lift . lift
instance MonadTrans (SmtpT conn) where
lift = liftSmtpT
rethrow :: MonadError e m => ExceptT e m b -> m b
rethrow = (>>= either throwError return) . runExceptT
mapSmtpT ::
(m1 (Either SmtpError a1) -> m2 (Either SmtpError a2))
-> SmtpT conn m1 a1 -> SmtpT conn m2 a2
mapSmtpT f (SmtpT x) = SmtpT (mapBoth f x)
where
mapBoth = mapReaderT . mapExceptT
runSmtpEither :: conn -> SmtpT conn m a -> m (Either SmtpError a)
runSmtpEither c = runExceptT . flip runReaderT c . unSmtpT
runSmtp :: MonadError SmtpError m => conn -> SmtpT conn m b -> m b
runSmtp c =
rethrow . flip runReaderT c . unSmtpT
withSmtpConnection
:: (Cstrt c m, MonadMask m, Connection c, MonadSmtp.MonadSmtp m) =>
Params c -> (c -> m b) -> m b
withSmtpConnection = withConnection
withSmtpRunner ::
(MonadMask m, Cstrt conn m, Connection conn) =>
Params conn -> (conn -> (forall n . MonadSmtp.MonadSmtp n => n b) -> m b) -> (forall n . MonadSmtp.MonadSmtp n => n b) -> m b
withSmtpRunner params f a =
bracket acquire release (`f` a)
where
acquire = open params
release = close