{-# LANGUAGE TemplateHaskell #-}
module Wire.EmailSending.SMTP
( initSMTP,
emailViaSMTPInterpreter,
sendMailWithDuration,
initSMTP',
SMTPConnType (..),
SMTP (..),
Username (..),
Password (..),
SMTPPoolException (..),
)
where
import Control.Concurrent.Async (wait, withAsyncWithUnmask)
import Control.Exception qualified as CE (throw)
import Control.Monad.Catch
import Control.Timeout (timeout)
import Data.Aeson
import Data.Aeson.TH
import Data.Pool
import Data.Text (unpack)
import Data.Time.Units
import Imports
import Network.HaskellNet.SMTP qualified as SMTP
import Network.HaskellNet.SMTP.SSL qualified as SMTP
import Network.Mail.Mime
import Network.Socket (PortNumber)
import Polysemy
import System.Logger qualified as Logger
import System.Logger.Class hiding (create)
import Wire.EmailSending
emailViaSMTPInterpreter :: (Member (Embed IO) r) => Logger -> SMTP -> InterpreterFor EmailSending r
emailViaSMTPInterpreter :: forall (r :: EffectRow).
Member (Embed IO) r =>
Logger -> SMTP -> InterpreterFor EmailSending r
emailViaSMTPInterpreter Logger
logger SMTP
smtp = (forall (rInitial :: EffectRow) x.
EmailSending (Sem rInitial) x -> Sem r x)
-> Sem (EmailSending : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
SendMail Mail
mail -> Logger -> SMTP -> Mail -> Sem r ()
forall (m :: * -> *). MonadIO m => Logger -> SMTP -> Mail -> m ()
sendMailImpl Logger
logger SMTP
smtp Mail
mail
newtype Username = Username Text
newtype Password = Password Text
data SMTP = SMTP {SMTP -> Pool SMTPConnection
pool :: !(Pool SMTP.SMTPConnection)}
data SMTPConnType
= Plain
| TLS
| SSL
deriving (SMTPConnType -> SMTPConnType -> Bool
(SMTPConnType -> SMTPConnType -> Bool)
-> (SMTPConnType -> SMTPConnType -> Bool) -> Eq SMTPConnType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMTPConnType -> SMTPConnType -> Bool
== :: SMTPConnType -> SMTPConnType -> Bool
$c/= :: SMTPConnType -> SMTPConnType -> Bool
/= :: SMTPConnType -> SMTPConnType -> Bool
Eq, Int -> SMTPConnType -> ShowS
[SMTPConnType] -> ShowS
SMTPConnType -> String
(Int -> SMTPConnType -> ShowS)
-> (SMTPConnType -> String)
-> ([SMTPConnType] -> ShowS)
-> Show SMTPConnType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMTPConnType -> ShowS
showsPrec :: Int -> SMTPConnType -> ShowS
$cshow :: SMTPConnType -> String
show :: SMTPConnType -> String
$cshowList :: [SMTPConnType] -> ShowS
showList :: [SMTPConnType] -> ShowS
Show)
data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
deriving (SMTPPoolException -> SMTPPoolException -> Bool
(SMTPPoolException -> SMTPPoolException -> Bool)
-> (SMTPPoolException -> SMTPPoolException -> Bool)
-> Eq SMTPPoolException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SMTPPoolException -> SMTPPoolException -> Bool
== :: SMTPPoolException -> SMTPPoolException -> Bool
$c/= :: SMTPPoolException -> SMTPPoolException -> Bool
/= :: SMTPPoolException -> SMTPPoolException -> Bool
Eq, Int -> SMTPPoolException -> ShowS
[SMTPPoolException] -> ShowS
SMTPPoolException -> String
(Int -> SMTPPoolException -> ShowS)
-> (SMTPPoolException -> String)
-> ([SMTPPoolException] -> ShowS)
-> Show SMTPPoolException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SMTPPoolException -> ShowS
showsPrec :: Int -> SMTPPoolException -> ShowS
$cshow :: SMTPPoolException -> String
show :: SMTPPoolException -> String
$cshowList :: [SMTPPoolException] -> ShowS
showList :: [SMTPPoolException] -> ShowS
Show)
instance Exception SMTPPoolException
initSMTP ::
Logger ->
Text ->
Maybe PortNumber ->
Maybe (Username, Password) ->
SMTPConnType ->
IO SMTP
initSMTP :: Logger
-> Text
-> Maybe PortNumber
-> Maybe (Username, Password)
-> SMTPConnType
-> IO SMTP
initSMTP = Second
-> Logger
-> Text
-> Maybe PortNumber
-> Maybe (Username, Password)
-> SMTPConnType
-> IO SMTP
forall t.
TimeUnit t =>
t
-> Logger
-> Text
-> Maybe PortNumber
-> Maybe (Username, Password)
-> SMTPConnType
-> IO SMTP
initSMTP' Second
defaultTimeoutDuration
initSMTP' ::
(TimeUnit t) =>
t ->
Logger ->
Text ->
Maybe PortNumber ->
Maybe (Username, Password) ->
SMTPConnType ->
IO SMTP
initSMTP' :: forall t.
TimeUnit t =>
t
-> Logger
-> Text
-> Maybe PortNumber
-> Maybe (Username, Password)
-> SMTPConnType
-> IO SMTP
initSMTP' t
timeoutDuration Logger
lg Text
host Maybe PortNumber
port Maybe (Username, Password)
credentials SMTPConnType
connType = do
SMTPConnection
con <-
IO SMTPConnection
-> (SomeException -> IO SMTPConnection) -> IO SMTPConnection
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch
( Logger -> String -> IO SMTPConnection -> IO SMTPConnection
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Logger -> String -> m a -> m a
logExceptionOrResult
Logger
lg
(String
"Checking test connection to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
host String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" on startup")
IO SMTPConnection
establishConnection
)
( \(SomeException
e :: SomeException) -> do
Logger -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> m ()
flush Logger
lg
String -> IO SMTPConnection
forall a. HasCallStack => String -> a
error (String -> IO SMTPConnection) -> String -> IO SMTPConnection
forall a b. (a -> b) -> a -> b
$ String
"Failed to establish test connection with SMTP server: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
)
IO () -> (SomeException -> IO ()) -> IO ()
forall e a.
(HasCallStack, Exception e) =>
IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
catch
( Logger -> String -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Logger -> String -> m a -> m a
logExceptionOrResult Logger
lg String
"Closing test connection on startup" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
t -> IO () -> IO ()
forall (m :: * -> *) t a.
(MonadIO m, MonadCatch m, TimeUnit t) =>
t -> m a -> m a
ensureSMTPConnectionTimeout t
timeoutDuration (SMTPConnection -> IO ()
SMTP.gracefullyCloseSMTP SMTPConnection
con)
)
( \(SomeException
e :: SomeException) -> do
Logger -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> m ()
flush Logger
lg
String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Failed to close test connection with SMTP server: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
)
Pool SMTPConnection -> SMTP
SMTP (Pool SMTPConnection -> SMTP)
-> IO (Pool SMTPConnection) -> IO SMTP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PoolConfig SMTPConnection -> IO (Pool SMTPConnection)
forall a. PoolConfig a -> IO (Pool a)
newPool (Maybe Int -> PoolConfig SMTPConnection -> PoolConfig SMTPConnection
forall a. Maybe Int -> PoolConfig a -> PoolConfig a
setNumStripes (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1) (IO SMTPConnection
-> (SMTPConnection -> IO ())
-> Double
-> Int
-> PoolConfig SMTPConnection
forall a. IO a -> (a -> IO ()) -> Double -> Int -> PoolConfig a
defaultPoolConfig IO SMTPConnection
create SMTPConnection -> IO ()
destroy Double
5 Int
5))
where
ensureTimeout :: IO a -> IO a
ensureTimeout :: forall a. IO a -> IO a
ensureTimeout = t -> IO a -> IO a
forall (m :: * -> *) t a.
(MonadIO m, MonadCatch m, TimeUnit t) =>
t -> m a -> m a
ensureSMTPConnectionTimeout t
timeoutDuration
establishConnection :: IO SMTP.SMTPConnection
establishConnection :: IO SMTPConnection
establishConnection = do
SMTPConnection
conn <- IO SMTPConnection -> IO SMTPConnection
forall a. IO a -> IO a
ensureTimeout (IO SMTPConnection -> IO SMTPConnection)
-> IO SMTPConnection -> IO SMTPConnection
forall a b. (a -> b) -> a -> b
$ case (SMTPConnType
connType, Maybe PortNumber
port) of
(SMTPConnType
Plain, Maybe PortNumber
Nothing) -> String -> IO SMTPConnection
SMTP.connectSMTP (Text -> String
unpack Text
host)
(SMTPConnType
Plain, Just PortNumber
p) -> String -> PortNumber -> IO SMTPConnection
SMTP.connectSMTPPort (Text -> String
unpack Text
host) PortNumber
p
(SMTPConnType
TLS, Maybe PortNumber
Nothing) -> String -> IO SMTPConnection
SMTP.connectSMTPSTARTTLS (Text -> String
unpack Text
host)
(SMTPConnType
TLS, Just PortNumber
p) ->
String -> Settings -> IO SMTPConnection
SMTP.connectSMTPSTARTTLSWithSettings (Text -> String
unpack Text
host) (Settings -> IO SMTPConnection) -> Settings -> IO SMTPConnection
forall a b. (a -> b) -> a -> b
$
Settings
SMTP.defaultSettingsSMTPSTARTTLS {SMTP.sslPort = p}
(SMTPConnType
SSL, Maybe PortNumber
Nothing) -> String -> IO SMTPConnection
SMTP.connectSMTPSSL (Text -> String
unpack Text
host)
(SMTPConnType
SSL, Just PortNumber
p) ->
String -> Settings -> IO SMTPConnection
SMTP.connectSMTPSSLWithSettings (Text -> String
unpack Text
host) (Settings -> IO SMTPConnection) -> Settings -> IO SMTPConnection
forall a b. (a -> b) -> a -> b
$
Settings
SMTP.defaultSettingsSMTPSSL {SMTP.sslPort = p}
Bool
ok <- case Maybe (Username, Password)
credentials of
(Just (Username Text
u, Password Text
p)) ->
IO Bool -> IO Bool
forall a. IO a -> IO a
ensureTimeout (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
AuthType -> String -> String -> SMTPConnection -> IO Bool
SMTP.authenticate AuthType
SMTP.LOGIN (Text -> String
unpack Text
u) (Text -> String
unpack Text
p) SMTPConnection
conn
Maybe (Username, Password)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
if Bool
ok
then SMTPConnection -> IO SMTPConnection
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SMTPConnection
conn
else SMTPPoolException -> IO SMTPConnection
forall a e. Exception e => e -> a
CE.throw SMTPPoolException
SMTPUnauthorized
create :: IO SMTP.SMTPConnection
create :: IO SMTPConnection
create =
Logger -> String -> IO SMTPConnection -> IO SMTPConnection
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Logger -> String -> m a -> m a
logExceptionOrResult
Logger
lg
(String
"Creating pooled SMTP connection to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
host)
IO SMTPConnection
establishConnection
destroy :: SMTP.SMTPConnection -> IO ()
destroy :: SMTPConnection -> IO ()
destroy SMTPConnection
c =
((forall a. IO a -> IO a) -> IO ()) -> (Async () -> IO ()) -> IO ()
forall a b.
((forall a. IO a -> IO a) -> IO a) -> (Async a -> IO b) -> IO b
withAsyncWithUnmask
do
\forall a. IO a -> IO a
unmask -> do
Logger -> String -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Logger -> String -> m a -> m a
logExceptionOrResult Logger
lg (String
"Closing pooled SMTP connection to " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
host) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
IO () -> IO ()
forall a. IO a -> IO a
unmask do
IO () -> IO ()
forall a. IO a -> IO a
ensureTimeout (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ SMTPConnection -> IO ()
SMTP.gracefullyCloseSMTP SMTPConnection
c
do Async () -> IO ()
forall a. Async a -> IO a
wait
logExceptionOrResult :: (MonadIO m, MonadCatch m) => Logger -> String -> m a -> m a
logExceptionOrResult :: forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Logger -> String -> m a -> m a
logExceptionOrResult Logger
lg String
actionString m a
action = do
a
res <-
m a -> [Handler m a] -> m a
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m a
catches
m a
action
[ (SMTPPoolException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler
\(SMTPPoolException
e :: SMTPPoolException) -> do
let resultLog :: String
resultLog = case SMTPPoolException
e of
SMTPPoolException
SMTPUnauthorized ->
(String
"Failed to establish connection, check your credentials." :: String)
SMTPPoolException
SMTPConnectionTimeout -> (String
"Connection timeout." :: String)
Level -> String -> m ()
forall (m :: * -> *). MonadIO m => Level -> String -> m ()
doLog Level
Logger.Warn String
resultLog
SMTPPoolException -> m a
forall a e. Exception e => e -> a
CE.throw SMTPPoolException
e,
(SomeException -> m a) -> Handler m a
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler
\(SomeException
e :: SomeException) -> do
Level -> String -> m ()
forall (m :: * -> *). MonadIO m => Level -> String -> m ()
doLog Level
Logger.Warn (String
"Caught exception : " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
SomeException -> m a
forall a e. Exception e => e -> a
CE.throw SomeException
e
]
Level -> String -> m ()
forall (m :: * -> *). MonadIO m => Level -> String -> m ()
doLog Level
Logger.Debug (String
"Succeeded." :: String)
a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res
where
doLog :: (MonadIO m) => Logger.Level -> String -> m ()
doLog :: forall (m :: * -> *). MonadIO m => Level -> String -> m ()
doLog Level
lvl String
result =
let msg' :: Msg -> Msg
msg' = String -> Msg -> Msg
forall a. ToBytes a => a -> Msg -> Msg
msg (String
"SMTP connection result" :: String)
in Logger -> Level -> (Msg -> Msg) -> m ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Logger.log Logger
lg Level
lvl (Msg -> Msg
msg' (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"action" String
actionString (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String -> Msg -> Msg
forall a. ToBytes a => ByteString -> a -> Msg -> Msg
field ByteString
"result" String
result)
defaultTimeoutDuration :: Second
defaultTimeoutDuration :: Second
defaultTimeoutDuration = Second
15
ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m a
ensureSMTPConnectionTimeout :: forall (m :: * -> *) t a.
(MonadIO m, MonadCatch m, TimeUnit t) =>
t -> m a -> m a
ensureSMTPConnectionTimeout t
timeoutDuration m a
action =
t -> m a -> m (Maybe a)
forall t (m :: * -> *) a.
(TimeUnit t, MonadIO m, MonadCatch m) =>
t -> m a -> m (Maybe a)
timeout t
timeoutDuration m a
action m (Maybe a) -> (Maybe a -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (SMTPPoolException -> m a
forall a e. Exception e => e -> a
CE.throw SMTPPoolException
SMTPConnectionTimeout) a -> m a
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
sendMailImpl :: (MonadIO m) => Logger -> SMTP -> Mail -> m ()
sendMailImpl :: forall (m :: * -> *). MonadIO m => Logger -> SMTP -> Mail -> m ()
sendMailImpl = Second -> Logger -> SMTP -> Mail -> m ()
forall t (m :: * -> *).
(MonadIO m, TimeUnit t) =>
t -> Logger -> SMTP -> Mail -> m ()
sendMailWithDuration Second
defaultTimeoutDuration
sendMailWithDuration :: forall t m. (MonadIO m, TimeUnit t) => t -> Logger -> SMTP -> Mail -> m ()
sendMailWithDuration :: forall t (m :: * -> *).
(MonadIO m, TimeUnit t) =>
t -> Logger -> SMTP -> Mail -> m ()
sendMailWithDuration t
timeoutDuration Logger
lg SMTP
smtp Mail
m = IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Pool SMTPConnection -> (SMTPConnection -> IO ()) -> IO ()
forall a r. Pool a -> (a -> IO r) -> IO r
withResource SMTP
smtp.pool SMTPConnection -> IO ()
sendMailWithConn
where
sendMailWithConn :: SMTP.SMTPConnection -> IO ()
sendMailWithConn :: SMTPConnection -> IO ()
sendMailWithConn SMTPConnection
c =
Logger -> String -> IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
Logger -> String -> m a -> m a
logExceptionOrResult Logger
lg String
"Sending mail via SMTP" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
t -> IO () -> IO ()
forall (m :: * -> *) t a.
(MonadIO m, MonadCatch m, TimeUnit t) =>
t -> m a -> m a
ensureSMTPConnectionTimeout t
timeoutDuration (HasCallStack => Mail -> SMTPConnection -> IO ()
Mail -> SMTPConnection -> IO ()
SMTP.sendMail Mail
m SMTPConnection
c)
deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType