From 7dc43cb2d925ece6a70b1150b63ebe60acdb3dc7 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 11:28:31 +0200
Subject: [PATCH 01/38] Add more logging and error handling for SMTP

---
 services/brig/brig.cabal             |   2 +
 services/brig/src/Brig/Email.hs      |   7 +-
 services/brig/src/Brig/SMTP.hs       | 102 ++++++++++++++++++++++-----
 services/brig/src/Brig/User/Email.hs |  12 +++-
 4 files changed, 103 insertions(+), 20 deletions(-)

diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal
index 0fd8a01535..d00fcb9ef9 100644
--- a/services/brig/brig.cabal
+++ b/services/brig/brig.cabal
@@ -287,6 +287,8 @@ library
     , text                       >=0.11
     , text-icu-translit          >=0.1
     , time                       >=1.1
+    , time-out
+    , time-units
     , tinylog                    >=0.10
     , transformers               >=0.3
     , types-common               >=0.16
diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs
index 00ce2c1ce4..26faabe634 100644
--- a/services/brig/src/Brig/Email.hs
+++ b/services/brig/src/Brig/Email.hs
@@ -40,19 +40,20 @@ module Brig.Email
 where
 
 import qualified Brig.AWS as AWS
-import Brig.App (Env, awsEnv, smtpEnv)
+import Brig.App (Env, applog, awsEnv, smtpEnv)
 import qualified Brig.SMTP as SMTP
 import Control.Lens (view)
+import Control.Monad.Catch
 import qualified Data.Text as Text
 import Imports
 import Network.Mail.Mime
 import Wire.API.User
 
 -------------------------------------------------------------------------------
-sendMail :: (MonadIO m, MonadReader Env m) => Mail -> m ()
+sendMail :: (MonadIO m, MonadCatch m, MonadReader Env m) => Mail -> m ()
 sendMail m =
   view smtpEnv >>= \case
-    Just smtp -> SMTP.sendMail smtp m
+    Just smtp -> view applog >>= \logger -> SMTP.sendMail logger smtp m
     Nothing -> view awsEnv >>= \e -> AWS.execute e $ AWS.sendMail m
 
 -------------------------------------------------------------------------------
diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 920752199b..fe2a869b0c 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -19,11 +19,17 @@
 
 module Brig.SMTP where
 
+import qualified Control.Exception as CE (handle, throw)
 import Control.Lens
+import Control.Monad.Catch
+import Control.Monad.Trans.Except
+import Control.Timeout (timeout)
 import Data.Aeson
 import Data.Aeson.TH
+import Data.Either.Extra
 import Data.Pool
 import Data.Text (unpack)
+import Data.Time.Units
 import Imports
 import qualified Network.HaskellNet.SMTP as SMTP
 import qualified Network.HaskellNet.SMTP.SSL as SMTP
@@ -50,17 +56,40 @@ deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType
 
 makeLenses ''SMTP
 
+data SMTPFailure = Unauthorized | ConnectionTimeout | CaughtException SomeException
+
+data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
+  deriving (Show)
+
+instance Exception SMTPPoolException
+
 initSMTP :: Logger -> Text -> Maybe PortNumber -> Maybe (Username, Password) -> SMTPConnType -> IO SMTP
 initSMTP lg host port credentials connType = do
   -- Try to initiate a connection and fail badly right away in case of bad auth
   -- otherwise config errors will be detected "too late"
-  (success, _) <- connect
-  unless success $
-    error "Failed to authenticate against the SMTP server"
-  SMTP <$> createPool create destroy 1 5 5
+  res <- runExceptT establishConnection
+  logResult res
+  case res of
+    Left Unauthorized ->
+      error "Failed to authenticate against the SMTP server"
+    Left ConnectionTimeout ->
+      error "Failed to connect to SMTP server. Connection timeout."
+    Left (CaughtException e) ->
+      error $ "Caught exception while trying to connect to SMTP server : " ++ show e
+    Right con -> do
+      -- TODO: gracefullyCloseSMTP may throw
+      SMTP.gracefullyCloseSMTP con
+      SMTP <$> createPool create destroy 1 5 5
   where
-    connect = do
-      conn <- case (connType, port) of
+    liftSMTP :: IO a -> ExceptT SMTPFailure IO a
+    liftSMTP action =
+      ExceptT $
+        CE.handle (\e -> (pure . Left . CaughtException) e) $
+          maybeToEither ConnectionTimeout <$> ensureSMTPConnectionTimeout action
+
+    establishConnection :: ExceptT SMTPFailure IO SMTP.SMTPConnection
+    establishConnection = do
+      conn <- liftSMTP $ case (connType, port) of
         (Plain, Nothing) -> SMTP.connectSMTP (unpack host)
         (Plain, Just p) -> SMTP.connectSMTPPort (unpack host) p
         (TLS, Nothing) -> SMTP.connectSMTPSTARTTLS (unpack host)
@@ -72,18 +101,59 @@ initSMTP lg host port credentials connType = do
           SMTP.connectSMTPSSLWithSettings (unpack host) $
             SMTP.defaultSettingsSMTPSSL {SMTP.sslPort = p}
       ok <- case credentials of
-        (Just (Username u, Password p)) -> SMTP.authenticate SMTP.LOGIN (unpack u) (unpack p) conn
+        (Just (Username u, Password p)) -> liftSMTP $ SMTP.authenticate SMTP.LOGIN (unpack u) (unpack p) conn
         _ -> pure True
-      pure (ok, conn)
-    create = do
-      (ok, conn) <- connect
       if ok
-        then Logger.log lg Logger.Debug (msg $ val "Established connection to: " +++ host)
-        else Logger.log lg Logger.Warn (msg $ val "Failed to established connection, check your credentials to connect to: " +++ host)
-      pure conn
+        then pure conn
+        else throwE Unauthorized
+
+    create :: IO SMTP.SMTPConnection
+    create = do
+      res <- runExceptT establishConnection
+      logResult res
+      case res of
+        Left Unauthorized -> do
+          CE.throw SMTPUnauthorized
+        Left ConnectionTimeout -> do
+          CE.throw SMTPConnectionTimeout
+        Left (CaughtException e) -> do
+          CE.throw e
+        Right con -> do
+          pure con
+
+    logResult :: MonadIO m => Either SMTPFailure SMTP.SMTPConnection -> m ()
+    logResult res =
+      case res of
+        Left Unauthorized -> do
+          Logger.log lg Logger.Warn (msg $ val "Failed to established connection, check your credentials to connect to: " +++ host)
+        Left ConnectionTimeout -> do
+          Logger.log lg Logger.Warn (msg $ (val "Failed to connect to : " +++ host) +++ val " . Connection timeout.")
+        Left (CaughtException e) -> do
+          Logger.log lg Logger.Warn (msg $ val "Caught exception while trying to connect to SMTP server : " +++ show e)
+        Right _ -> do
+          Logger.log lg Logger.Debug (msg $ val "Established connection to: " +++ host)
+
     destroy c = do
-      SMTP.closeSMTP c
       Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host)
+      -- TODO: gracefullyCloseSMTP may throw
+      r <- ensureSMTPConnectionTimeout $ SMTP.gracefullyCloseSMTP c
+      if isJust r
+        then Logger.log lg Logger.Debug (msg $ val "Closed connection to: " +++ host)
+        else Logger.log lg Logger.Debug (msg $ val "Closing connection to " +++ host +++ val " timed out")
+
+sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
+sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
+  where
+    sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleTimeout
+    handleTimeout r =
+      if isJust r
+        then do
+          Logger.log lg Logger.Debug (msg $ val "Sent mail")
+          pure ()
+        else do
+          Logger.log lg Logger.Debug (msg $ val "Sending mail timed out. Mail not sent.")
+          CE.throw SMTPConnectionTimeout
 
-sendMail :: MonadIO m => SMTP -> Mail -> m ()
-sendMail s m = liftIO $ withResource (s ^. pool) $ SMTP.sendMail m
+-- TODO: Timeout may throw
+ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)
+ensureSMTPConnectionTimeout action = timeout (15 :: Second) action
diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs
index 73063a10c9..5d200af829 100644
--- a/services/brig/src/Brig/User/Email.hs
+++ b/services/brig/src/Brig/User/Email.hs
@@ -42,6 +42,7 @@ import Brig.Types.Activation (ActivationPair)
 import Brig.Types.User (PasswordResetPair)
 import Brig.User.Template
 import Control.Lens (view)
+import Control.Monad.Catch
 import qualified Data.Code as Code
 import Data.Json.Util (fromUTCTimeMillis)
 import Data.Range
@@ -55,6 +56,7 @@ import Wire.API.User.Password
 
 sendVerificationMail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Email ->
@@ -69,7 +71,8 @@ sendVerificationMail to pair loc = do
 
 sendLoginVerificationMail ::
   ( MonadReader Env m,
-    MonadIO m
+    MonadIO m,
+    MonadCatch m
   ) =>
   Email ->
   Code.Value ->
@@ -82,6 +85,7 @@ sendLoginVerificationMail email code mbLocale = do
 
 sendCreateScimTokenVerificationMail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Email ->
@@ -95,6 +99,7 @@ sendCreateScimTokenVerificationMail email code mbLocale = do
 
 sendTeamDeletionVerificationMail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Email ->
@@ -108,6 +113,7 @@ sendTeamDeletionVerificationMail email code mbLocale = do
 
 sendActivationMail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Email ->
@@ -129,6 +135,7 @@ sendActivationMail to name pair loc ident = do
 
 sendPasswordResetMail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Email ->
@@ -143,6 +150,7 @@ sendPasswordResetMail to pair loc = do
 
 sendDeletionEmail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Name ->
@@ -158,6 +166,7 @@ sendDeletionEmail name email key code locale = do
 
 sendNewClientEmail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Name ->
@@ -172,6 +181,7 @@ sendNewClientEmail name email client locale = do
 
 sendTeamActivationMail ::
   ( MonadIO m,
+    MonadCatch m,
     MonadReader Env m
   ) =>
   Email ->

From e78deeaba24faaf208fe9818cf7637617d2e89f5 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 11:53:10 +0200
Subject: [PATCH 02/38] Catch in ensureSMTPConnectionTimeout

---
 services/brig/src/Brig/SMTP.hs | 17 +++++++++++------
 1 file changed, 11 insertions(+), 6 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index fe2a869b0c..9710a31ff9 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -85,7 +85,7 @@ initSMTP lg host port credentials connType = do
     liftSMTP action =
       ExceptT $
         CE.handle (\e -> (pure . Left . CaughtException) e) $
-          maybeToEither ConnectionTimeout <$> ensureSMTPConnectionTimeout action
+          maybeToEither ConnectionTimeout <$> ensureSMTPConnectionTimeout lg action
 
     establishConnection :: ExceptT SMTPFailure IO SMTP.SMTPConnection
     establishConnection = do
@@ -136,7 +136,7 @@ initSMTP lg host port credentials connType = do
     destroy c = do
       Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host)
       -- TODO: gracefullyCloseSMTP may throw
-      r <- ensureSMTPConnectionTimeout $ SMTP.gracefullyCloseSMTP c
+      r <- ensureSMTPConnectionTimeout lg $ SMTP.gracefullyCloseSMTP c
       if isJust r
         then Logger.log lg Logger.Debug (msg $ val "Closed connection to: " +++ host)
         else Logger.log lg Logger.Debug (msg $ val "Closing connection to " +++ host +++ val " timed out")
@@ -144,7 +144,7 @@ initSMTP lg host port credentials connType = do
 sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
 sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
   where
-    sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleTimeout
+    sendMail' c = ensureSMTPConnectionTimeout lg (SMTP.sendMail m c) >>= handleTimeout
     handleTimeout r =
       if isJust r
         then do
@@ -154,6 +154,11 @@ sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
           Logger.log lg Logger.Debug (msg $ val "Sending mail timed out. Mail not sent.")
           CE.throw SMTPConnectionTimeout
 
--- TODO: Timeout may throw
-ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)
-ensureSMTPConnectionTimeout action = timeout (15 :: Second) action
+ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => Logger -> m a -> m (Maybe a)
+ensureSMTPConnectionTimeout lg action =
+  catch
+    (timeout (15 :: Second) action)
+    ( \(e :: SomeException) ->
+        Logger.log lg Logger.Warn (msg $ val "Caught exception while trying to connect to SMTP server : " +++ show e)
+          >> pure Nothing
+    )

From 040f64e757fb446108d806a6f49efead9f10b0b9 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 12:53:42 +0200
Subject: [PATCH 03/38] Improve logging

---
 services/brig/src/Brig/SMTP.hs | 77 ++++++++++++++++------------------
 1 file changed, 36 insertions(+), 41 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 9710a31ff9..24987dfb54 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -68,14 +68,10 @@ initSMTP lg host port credentials connType = do
   -- Try to initiate a connection and fail badly right away in case of bad auth
   -- otherwise config errors will be detected "too late"
   res <- runExceptT establishConnection
-  logResult res
+  logResult lg ("Checking connection to " ++ unpack host ++ "on startup") res
   case res of
-    Left Unauthorized ->
-      error "Failed to authenticate against the SMTP server"
-    Left ConnectionTimeout ->
-      error "Failed to connect to SMTP server. Connection timeout."
-    Left (CaughtException e) ->
-      error $ "Caught exception while trying to connect to SMTP server : " ++ show e
+    Left _ ->
+      error "Failed to establish connection with SMTP server."
     Right con -> do
       -- TODO: gracefullyCloseSMTP may throw
       SMTP.gracefullyCloseSMTP con
@@ -84,8 +80,7 @@ initSMTP lg host port credentials connType = do
     liftSMTP :: IO a -> ExceptT SMTPFailure IO a
     liftSMTP action =
       ExceptT $
-        CE.handle (\e -> (pure . Left . CaughtException) e) $
-          maybeToEither ConnectionTimeout <$> ensureSMTPConnectionTimeout lg action
+        CE.handle (\e -> (pure . Left . CaughtException) e) $ ensureSMTPConnectionTimeout action
 
     establishConnection :: ExceptT SMTPFailure IO SMTP.SMTPConnection
     establishConnection = do
@@ -110,7 +105,7 @@ initSMTP lg host port credentials connType = do
     create :: IO SMTP.SMTPConnection
     create = do
       res <- runExceptT establishConnection
-      logResult res
+      logResult lg "Creating connection for connection pool" res
       case res of
         Left Unauthorized -> do
           CE.throw SMTPUnauthorized
@@ -121,44 +116,44 @@ initSMTP lg host port credentials connType = do
         Right con -> do
           pure con
 
-    logResult :: MonadIO m => Either SMTPFailure SMTP.SMTPConnection -> m ()
-    logResult res =
-      case res of
-        Left Unauthorized -> do
-          Logger.log lg Logger.Warn (msg $ val "Failed to established connection, check your credentials to connect to: " +++ host)
-        Left ConnectionTimeout -> do
-          Logger.log lg Logger.Warn (msg $ (val "Failed to connect to : " +++ host) +++ val " . Connection timeout.")
-        Left (CaughtException e) -> do
-          Logger.log lg Logger.Warn (msg $ val "Caught exception while trying to connect to SMTP server : " +++ show e)
-        Right _ -> do
-          Logger.log lg Logger.Debug (msg $ val "Established connection to: " +++ host)
-
     destroy c = do
       Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host)
-      -- TODO: gracefullyCloseSMTP may throw
-      r <- ensureSMTPConnectionTimeout lg $ SMTP.gracefullyCloseSMTP c
-      if isJust r
+      r <- ensureSMTPConnectionTimeout $ SMTP.gracefullyCloseSMTP c
+      if isRight r
         then Logger.log lg Logger.Debug (msg $ val "Closed connection to: " +++ host)
         else Logger.log lg Logger.Debug (msg $ val "Closing connection to " +++ host +++ val " timed out")
 
+logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
+logResult lg actionString res =
+  case res of
+    Left Unauthorized -> do
+      Logger.log lg Logger.Warn (msg $ concatToVal actionString "Failed to established connection, check your credentials.")
+    Left ConnectionTimeout -> do
+      Logger.log lg Logger.Warn (msg $ concatToVal actionString "Connection timeout.")
+    Left (CaughtException e) -> do
+      Logger.log lg Logger.Warn (msg $ concatToVal actionString ("Caught exception : " ++ show e))
+    Right _ -> do
+      Logger.log lg Logger.Debug (msg $ concatToVal actionString "Succeeded.")
+  where
+    concatToVal :: ToBytes s1 => s1 -> String -> Builder
+    concatToVal a b = a +++ (" : " :: String) +++ b
+
 sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
 sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
   where
-    sendMail' c = ensureSMTPConnectionTimeout lg (SMTP.sendMail m c) >>= handleTimeout
-    handleTimeout r =
-      if isJust r
-        then do
-          Logger.log lg Logger.Debug (msg $ val "Sent mail")
-          pure ()
-        else do
-          Logger.log lg Logger.Debug (msg $ val "Sending mail timed out. Mail not sent.")
-          CE.throw SMTPConnectionTimeout
+    sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleTimeout
 
-ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => Logger -> m a -> m (Maybe a)
-ensureSMTPConnectionTimeout lg action =
+    handleTimeout :: MonadIO m => Either SMTPFailure a -> m ()
+    handleTimeout r =
+      logResult lg "Sending mail" r
+        >> if isRight r
+          then do
+            pure ()
+          else do
+            CE.throw SMTPConnectionTimeout
+
+ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Either SMTPFailure a)
+ensureSMTPConnectionTimeout action =
   catch
-    (timeout (15 :: Second) action)
-    ( \(e :: SomeException) ->
-        Logger.log lg Logger.Warn (msg $ val "Caught exception while trying to connect to SMTP server : " +++ show e)
-          >> pure Nothing
-    )
+    (maybe (Left ConnectionTimeout) Right <$> timeout (15 :: Second) action)
+    (\(e :: SomeException) -> pure (Left (CaughtException e)))

From 93ae798f7662ac5a1b06e83317958fad1cab97b9 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 13:18:44 +0200
Subject: [PATCH 04/38] Remove unnecessary do-s

---
 services/brig/src/Brig/SMTP.hs | 15 ++++-----------
 1 file changed, 4 insertions(+), 11 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 24987dfb54..acd0936e9a 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -116,12 +116,9 @@ initSMTP lg host port credentials connType = do
         Right con -> do
           pure con
 
-    destroy c = do
-      Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host)
-      r <- ensureSMTPConnectionTimeout $ SMTP.gracefullyCloseSMTP c
-      if isRight r
-        then Logger.log lg Logger.Debug (msg $ val "Closed connection to: " +++ host)
-        else Logger.log lg Logger.Debug (msg $ val "Closing connection to " +++ host +++ val " timed out")
+    destroy c =
+      (ensureSMTPConnectionTimeout . SMTP.gracefullyCloseSMTP) c
+        >>= void . logResult lg ("Closing connection to " ++ unpack host)
 
 logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
 logResult lg actionString res =
@@ -146,11 +143,7 @@ sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
     handleTimeout :: MonadIO m => Either SMTPFailure a -> m ()
     handleTimeout r =
       logResult lg "Sending mail" r
-        >> if isRight r
-          then do
-            pure ()
-          else do
-            CE.throw SMTPConnectionTimeout
+        >> either (const (CE.throw SMTPConnectionTimeout)) (const (pure ())) r
 
 ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Either SMTPFailure a)
 ensureSMTPConnectionTimeout action =

From 2b0cb7d06f16c95beadd869b7027b5b1a0c13466 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 15:03:17 +0200
Subject: [PATCH 05/38] Add type signatures

---
 services/brig/src/Brig/SMTP.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index acd0936e9a..d4b4719ac7 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -116,6 +116,7 @@ initSMTP lg host port credentials connType = do
         Right con -> do
           pure con
 
+    destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
       (ensureSMTPConnectionTimeout . SMTP.gracefullyCloseSMTP) c
         >>= void . logResult lg ("Closing connection to " ++ unpack host)
@@ -138,6 +139,7 @@ logResult lg actionString res =
 sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
 sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
   where
+    sendMail' :: SMTP.SMTPConnection -> IO ()
     sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleTimeout
 
     handleTimeout :: MonadIO m => Either SMTPFailure a -> m ()

From 6fe26ee8f2a54c0d52c867695afa0734efe4f240 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 15:39:22 +0200
Subject: [PATCH 06/38] Simplify expressions

---
 services/brig/src/Brig/SMTP.hs | 21 +++++++++++----------
 1 file changed, 11 insertions(+), 10 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index d4b4719ac7..767262b16f 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -72,10 +72,11 @@ initSMTP lg host port credentials connType = do
   case res of
     Left _ ->
       error "Failed to establish connection with SMTP server."
-    Right con -> do
-      -- TODO: gracefullyCloseSMTP may throw
-      SMTP.gracefullyCloseSMTP con
-      SMTP <$> createPool create destroy 1 5 5
+    Right con ->
+      either
+        (error "Failed to establish connection with SMTP server.")
+        (const (SMTP <$> createPool create destroy 1 5 5))
+        =<< ensureSMTPConnectionTimeout (SMTP.gracefullyCloseSMTP con)
   where
     liftSMTP :: IO a -> ExceptT SMTPFailure IO a
     liftSMTP action =
@@ -136,6 +137,12 @@ logResult lg actionString res =
     concatToVal :: ToBytes s1 => s1 -> String -> Builder
     concatToVal a b = a +++ (" : " :: String) +++ b
 
+ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Either SMTPFailure a)
+ensureSMTPConnectionTimeout action =
+  catch
+    (maybe (Left ConnectionTimeout) Right <$> timeout (15 :: Second) action)
+    (\(e :: SomeException) -> pure (Left (CaughtException e)))
+
 sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
 sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
   where
@@ -146,9 +153,3 @@ sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
     handleTimeout r =
       logResult lg "Sending mail" r
         >> either (const (CE.throw SMTPConnectionTimeout)) (const (pure ())) r
-
-ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Either SMTPFailure a)
-ensureSMTPConnectionTimeout action =
-  catch
-    (maybe (Left ConnectionTimeout) Right <$> timeout (15 :: Second) action)
-    (\(e :: SomeException) -> pure (Left (CaughtException e)))

From 0185d32c7c02fc34bcee0fee94031e579c3eeb21 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 28 Oct 2022 15:58:41 +0200
Subject: [PATCH 07/38] Guard closing of the test connection

---
 services/brig/src/Brig/SMTP.hs | 34 +++++++++++++++++++++++-----------
 1 file changed, 23 insertions(+), 11 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 767262b16f..c6f9b619e2 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -19,7 +19,7 @@
 
 module Brig.SMTP where
 
-import qualified Control.Exception as CE (handle, throw)
+import qualified Control.Exception as CE (throw)
 import Control.Lens
 import Control.Monad.Catch
 import Control.Monad.Trans.Except
@@ -63,25 +63,32 @@ data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
 
 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 lg host port credentials connType = do
   -- Try to initiate a connection and fail badly right away in case of bad auth
   -- otherwise config errors will be detected "too late"
   res <- runExceptT establishConnection
-  logResult lg ("Checking connection to " ++ unpack host ++ "on startup") res
+  logResult lg ("Checking test connection to " ++ unpack host ++ "on startup") res
   case res of
     Left _ ->
-      error "Failed to establish connection with SMTP server."
+      error "Failed to establish test connection with SMTP server."
     Right con ->
       either
-        (error "Failed to establish connection with SMTP server.")
+        (error "Failed to establish test connection with SMTP server.")
         (const (SMTP <$> createPool create destroy 1 5 5))
-        =<< ensureSMTPConnectionTimeout (SMTP.gracefullyCloseSMTP con)
+        =<< do
+          r <- ensureSMTPConnectionTimeout (SMTP.gracefullyCloseSMTP con)
+          logResult lg "Closing test connection on startup" r
+          pure r
   where
     liftSMTP :: IO a -> ExceptT SMTPFailure IO a
-    liftSMTP action =
-      ExceptT $
-        CE.handle (\e -> (pure . Left . CaughtException) e) $ ensureSMTPConnectionTimeout action
+    liftSMTP action = ExceptT $ ensureSMTPConnectionTimeout action
 
     establishConnection :: ExceptT SMTPFailure IO SMTP.SMTPConnection
     establishConnection = do
@@ -97,7 +104,9 @@ initSMTP lg host port credentials connType = do
           SMTP.connectSMTPSSLWithSettings (unpack host) $
             SMTP.defaultSettingsSMTPSSL {SMTP.sslPort = p}
       ok <- case credentials of
-        (Just (Username u, Password p)) -> liftSMTP $ SMTP.authenticate SMTP.LOGIN (unpack u) (unpack p) conn
+        (Just (Username u, Password p)) ->
+          liftSMTP $
+            SMTP.authenticate SMTP.LOGIN (unpack u) (unpack p) conn
         _ -> pure True
       if ok
         then pure conn
@@ -126,7 +135,10 @@ logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
 logResult lg actionString res =
   case res of
     Left Unauthorized -> do
-      Logger.log lg Logger.Warn (msg $ concatToVal actionString "Failed to established connection, check your credentials.")
+      Logger.log
+        lg
+        Logger.Warn
+        (msg $ concatToVal actionString "Failed to established connection, check your credentials.")
     Left ConnectionTimeout -> do
       Logger.log lg Logger.Warn (msg $ concatToVal actionString "Connection timeout.")
     Left (CaughtException e) -> do

From 90c6dcce2f5ea28226d035d28670e9793f5bdc0f Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Mon, 31 Oct 2022 09:26:55 +0100
Subject: [PATCH 08/38] Better log prefix strings

---
 services/brig/src/Brig/SMTP.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index c6f9b619e2..69fa82ef8f 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -115,7 +115,7 @@ initSMTP lg host port credentials connType = do
     create :: IO SMTP.SMTPConnection
     create = do
       res <- runExceptT establishConnection
-      logResult lg "Creating connection for connection pool" res
+      logResult lg "Creating connection for SMTP connection pool" res
       case res of
         Left Unauthorized -> do
           CE.throw SMTPUnauthorized
@@ -129,7 +129,7 @@ initSMTP lg host port credentials connType = do
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
       (ensureSMTPConnectionTimeout . SMTP.gracefullyCloseSMTP) c
-        >>= void . logResult lg ("Closing connection to " ++ unpack host)
+        >>= void . logResult lg ("Closing SMTP connection to " ++ unpack host)
 
 logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
 logResult lg actionString res =
@@ -163,5 +163,5 @@ sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
 
     handleTimeout :: MonadIO m => Either SMTPFailure a -> m ()
     handleTimeout r =
-      logResult lg "Sending mail" r
+      logResult lg "Sending mail via SMTP" r
         >> either (const (CE.throw SMTPConnectionTimeout)) (const (pure ())) r

From 7f9603e5a45974b44eeda4c0bb99c99693ca62c9 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 10:40:54 +0100
Subject: [PATCH 09/38] Add postie to brig integration test dependencies

---
 nix/haskell-pins.nix                   |  8 ++++++++
 nix/manual-overrides.nix               |  3 +++
 services/brig/brig.cabal               |  3 +++
 services/brig/test/integration/SMTP.hs | 23 +++++++++++++++++++++++
 4 files changed, 37 insertions(+)
 create mode 100644 services/brig/test/integration/SMTP.hs

diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix
index 87875e4e3a..ce404aa232 100644
--- a/nix/haskell-pins.nix
+++ b/nix/haskell-pins.nix
@@ -203,6 +203,14 @@ let
         tasty-hunit = "hunit";
       };
     };
+    # This can be removed once postie 0.6.0.3 (or later) is in nixpkgs
+    postie = {
+      src = fetchgit {
+        url = "https://github.com/alexbiehl/postie.git";
+        rev = "c92702386f760fcaa65cd052dc8114889c001e3f";
+        sha256 = "sha256-yiw6hg3guRWS6CVdrUY8wyIDxoqfGjIVMrEtP+Fys0Y=";
+      };
+    };
   };
   hackagePins = {
     kind-generics = {
diff --git a/nix/manual-overrides.nix b/nix/manual-overrides.nix
index 0cecced516..1d5e8c8a44 100644
--- a/nix/manual-overrides.nix
+++ b/nix/manual-overrides.nix
@@ -58,4 +58,7 @@ hself: hsuper: {
 
   # Make hoogle static to reduce size of the hoogle image
   hoogle = hlib.justStaticExecutables hsuper.hoogle;
+
+  # Postie has been fixed upstream (master)
+  postie = hlib.markUnbroken (hlib.doJailbreak hsuper.postie);
 }
diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal
index d00fcb9ef9..22d2a1adae 100644
--- a/services/brig/brig.cabal
+++ b/services/brig/brig.cabal
@@ -465,6 +465,7 @@ executable brig-integration
     Federation.Util
     Index.Create
     Main
+    SMTP
     Util
     Util.AWS
 
@@ -554,6 +555,7 @@ executable brig-integration
     , lens-aeson
     , metrics-wai
     , mime                   >=0.4
+    , mime-mail
     , MonadRandom            >=0.5
     , mtl
     , network
@@ -561,6 +563,7 @@ executable brig-integration
     , pem
     , polysemy
     , polysemy-wire-zoo
+    , postie                 >=0.6
     , process
     , proto-lens
     , QuickCheck
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
new file mode 100644
index 0000000000..2f752c357a
--- /dev/null
+++ b/services/brig/test/integration/SMTP.hs
@@ -0,0 +1,23 @@
+module SMTP where
+
+import Bilge
+import Brig.SMTP
+import Imports
+import Network.Mail.Postie
+import qualified System.Logger as Logger
+import Test.Tasty
+import Util
+
+-- TODO: Is IO needed here?
+tests :: Manager -> Logger.Logger -> IO TestTree
+tests m lg =
+  pure $
+    testGroup
+      "SMTP"
+      [ test m "should send mail" $ testSendMail lg
+      ]
+
+-- TODO: Is Http the best Monad for this?
+testSendMail :: Logger.Logger -> Http ()
+testSendMail lg = do
+  initSMTP lg Text (Maybe PortNumber) (Maybe (Username, Password)) Plain

From 1006f8a49b1b92719fb320e79ea3720c5ea1c697 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 10:41:46 +0100
Subject: [PATCH 10/38] Add first SMTP test

---
 services/brig/src/Brig/SMTP.hs         | 30 ++++++++--------
 services/brig/test/integration/Main.hs | 49 ++++++++++++++------------
 services/brig/test/integration/SMTP.hs | 40 ++++++++++++++++++---
 3 files changed, 76 insertions(+), 43 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 69fa82ef8f..9ded6516b3 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -57,6 +57,7 @@ deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType
 makeLenses ''SMTP
 
 data SMTPFailure = Unauthorized | ConnectionTimeout | CaughtException SomeException
+  deriving (Show)
 
 data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
   deriving (Show)
@@ -76,8 +77,8 @@ initSMTP lg host port credentials connType = do
   res <- runExceptT establishConnection
   logResult lg ("Checking test connection to " ++ unpack host ++ "on startup") res
   case res of
-    Left _ ->
-      error "Failed to establish test connection with SMTP server."
+    Left e ->
+      error $ "Failed to establish test connection with SMTP server. " ++ show e
     Right con ->
       either
         (error "Failed to establish test connection with SMTP server.")
@@ -116,21 +117,20 @@ initSMTP lg host port credentials connType = do
     create = do
       res <- runExceptT establishConnection
       logResult lg "Creating connection for SMTP connection pool" res
-      case res of
-        Left Unauthorized -> do
-          CE.throw SMTPUnauthorized
-        Left ConnectionTimeout -> do
-          CE.throw SMTPConnectionTimeout
-        Left (CaughtException e) -> do
-          CE.throw e
-        Right con -> do
-          pure con
+      handleError res
 
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
       (ensureSMTPConnectionTimeout . SMTP.gracefullyCloseSMTP) c
         >>= void . logResult lg ("Closing SMTP connection to " ++ unpack host)
 
+handleError :: MonadIO m => Either SMTPFailure a -> m a
+handleError = \case
+  Left Unauthorized -> CE.throw SMTPUnauthorized
+  Left ConnectionTimeout -> CE.throw SMTPConnectionTimeout
+  Left (CaughtException e) -> CE.throw e
+  Right a -> pure a
+
 logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
 logResult lg actionString res =
   case res of
@@ -159,9 +159,9 @@ sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
 sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
   where
     sendMail' :: SMTP.SMTPConnection -> IO ()
-    sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleTimeout
+    sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleError'
 
-    handleTimeout :: MonadIO m => Either SMTPFailure a -> m ()
-    handleTimeout r =
+    handleError' :: MonadIO m => Either SMTPFailure a -> m ()
+    handleError' r =
       logResult lg "Sending mail via SMTP" r
-        >> either (const (CE.throw SMTPConnectionTimeout)) (const (pure ())) r
+        >> (void . handleError) r
diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs
index 7fab864c0a..eb90368b2b 100644
--- a/services/brig/test/integration/Main.hs
+++ b/services/brig/test/integration/Main.hs
@@ -54,6 +54,7 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
 import Network.Wai.Utilities.Server (compile)
 import OpenSSL (withOpenSSL)
 import Options.Applicative hiding (action)
+import qualified SMTP
 import System.Environment (withArgs)
 import qualified System.Environment.Blank as Blank
 import qualified System.Logger as Logger
@@ -150,35 +151,37 @@ runTests iConf brigOpts otherArgs = do
   federationEndpoints <- API.Federation.tests mg brigOpts b c fedBrigClient
   includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS"
   internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g
+  smtp <- SMTP.tests mg lg
 
   let versionApi = API.Version.tests mg brigOpts b
 
   let mlsApi = MLS.tests mg b brigOpts
 
-  withArgs otherArgs . defaultMain
-    $ testGroup
+  withArgs otherArgs . defaultMain $
+    testGroup
       "Brig API Integration"
-    $ [ testCase "sitemap" $
-          assertEqual
-            "inconcistent sitemap"
-            mempty
-            (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging),
-        userApi,
-        providerApi,
-        searchApis,
-        teamApis,
-        turnApi,
-        metricsApi,
-        settingsApi,
-        createIndex,
-        userPendingActivation,
-        browseTeam,
-        federationEndpoints,
-        internalApi,
-        versionApi,
-        mlsApi
-      ]
-      <> [federationEnd2End | includeFederationTests]
+      $ [ testCase "sitemap" $
+            assertEqual
+              "inconcistent sitemap"
+              mempty
+              (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging),
+          userApi,
+          providerApi,
+          searchApis,
+          teamApis,
+          turnApi,
+          metricsApi,
+          settingsApi,
+          createIndex,
+          userPendingActivation,
+          browseTeam,
+          federationEndpoints,
+          internalApi,
+          versionApi,
+          mlsApi,
+          smtp
+        ]
+        <> [federationEnd2End | includeFederationTests]
   where
     mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p
 
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 2f752c357a..de1fa6b6eb 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -2,10 +2,13 @@ module SMTP where
 
 import Bilge
 import Brig.SMTP
+import Control.Exception
 import Imports
-import Network.Mail.Postie
+import Network.Mail.Mime
+import qualified Network.Mail.Postie as Postie
 import qualified System.Logger as Logger
 import Test.Tasty
+import Test.Tasty.HUnit
 import Util
 
 -- TODO: Is IO needed here?
@@ -14,10 +17,37 @@ tests m lg =
   pure $
     testGroup
       "SMTP"
-      [ test m "should send mail" $ testSendMail lg
+      [ test m "should send no mail without receiver" $ testSendMailNoReceiver lg
       ]
 
 -- TODO: Is Http the best Monad for this?
-testSendMail :: Logger.Logger -> Http ()
-testSendMail lg = do
-  initSMTP lg Text (Maybe PortNumber) (Maybe (Username, Password)) Plain
+testSendMailNoReceiver :: Logger.Logger -> Http ()
+testSendMailNoReceiver lg = do
+  receivedMailRef <- liftIO $ newIORef Nothing
+  liftIO
+    . withMailServer (mailStoringApp receivedMailRef)
+    $ do
+      conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
+      caughtException <-
+        handle @SomeException
+          (const (pure True))
+          (sendMail lg conPool (emptyMail (Address Nothing "foo@example.com")) >> pure False)
+      caughtException @? "Expected exception due to missing mail receiver."
+
+--      traceM "Sent mail"
+--      mbMail <-
+--        retryWhileN 3 isJust $ do
+--          readIORef receivedMailRef
+--      isJust mbMail @? "Expected to receive mail"
+
+withMailServer :: Postie.Application -> IO () -> IO ()
+withMailServer app action =
+  bracket
+    (forkIO $ Postie.run 4242 app)
+    killThread
+    (const action)
+
+mailStoringApp :: IORef (Maybe Postie.Mail) -> Postie.Application
+mailStoringApp receivedMailRef mail =
+  writeIORef receivedMailRef (Just mail)
+    >> pure Postie.Accepted

From 7d832fe72abd765fbe95db23854d86b3cc2e8b4e Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 15:54:44 +0100
Subject: [PATCH 11/38] Adjust log strings

---
 services/brig/src/Brig/SMTP.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 9ded6516b3..b6330354cb 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -75,7 +75,7 @@ initSMTP lg host port credentials connType = do
   -- Try to initiate a connection and fail badly right away in case of bad auth
   -- otherwise config errors will be detected "too late"
   res <- runExceptT establishConnection
-  logResult lg ("Checking test connection to " ++ unpack host ++ "on startup") res
+  logResult lg ("Checking test connection to " ++ unpack host ++ " on startup") res
   case res of
     Left e ->
       error $ "Failed to establish test connection with SMTP server. " ++ show e
@@ -116,13 +116,13 @@ initSMTP lg host port credentials connType = do
     create :: IO SMTP.SMTPConnection
     create = do
       res <- runExceptT establishConnection
-      logResult lg "Creating connection for SMTP connection pool" res
+      logResult lg "Creating pooled SMTP connection" res
       handleError res
 
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
       (ensureSMTPConnectionTimeout . SMTP.gracefullyCloseSMTP) c
-        >>= void . logResult lg ("Closing SMTP connection to " ++ unpack host)
+        >>= void . logResult lg ("Closing pooled SMTP connection to " ++ unpack host)
 
 handleError :: MonadIO m => Either SMTPFailure a -> m a
 handleError = \case

From 1a22e54fb8184ee8d5da852f8a0a8adb61ec3272 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 15:55:32 +0100
Subject: [PATCH 12/38] Good case: Receive mail via SMTP

---
 services/brig/brig.cabal               |  1 +
 services/brig/test/integration/SMTP.hs | 81 +++++++++++++++++++++-----
 2 files changed, 69 insertions(+), 13 deletions(-)

diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal
index 22d2a1adae..4fbd943557 100644
--- a/services/brig/brig.cabal
+++ b/services/brig/brig.cabal
@@ -561,6 +561,7 @@ executable brig-integration
     , network
     , optparse-applicative
     , pem
+    , pipes
     , polysemy
     , polysemy-wire-zoo
     , postie                 >=0.6
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index de1fa6b6eb..fc0af3d50a 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -1,27 +1,33 @@
 module SMTP where
 
-import Bilge
+import qualified Bilge
 import Brig.SMTP
 import Control.Exception
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Char8 as C
+import Data.Text (unpack)
+import Data.Text.Lazy (toStrict)
 import Imports
 import Network.Mail.Mime
 import qualified Network.Mail.Postie as Postie
+import qualified Pipes.Prelude
 import qualified System.Logger as Logger
 import Test.Tasty
 import Test.Tasty.HUnit
 import Util
 
 -- TODO: Is IO needed here?
-tests :: Manager -> Logger.Logger -> IO TestTree
+tests :: Bilge.Manager -> Logger.Logger -> IO TestTree
 tests m lg =
   pure $
     testGroup
       "SMTP"
-      [ test m "should send no mail without receiver" $ testSendMailNoReceiver lg
+      [ test m "should send mail" $ testSendMail lg,
+        test m "should send no mail without receiver" $ testSendMailNoReceiver lg
       ]
 
 -- TODO: Is Http the best Monad for this?
-testSendMailNoReceiver :: Logger.Logger -> Http ()
+testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
 testSendMailNoReceiver lg = do
   receivedMailRef <- liftIO $ newIORef Nothing
   liftIO
@@ -34,11 +40,47 @@ testSendMailNoReceiver lg = do
           (sendMail lg conPool (emptyMail (Address Nothing "foo@example.com")) >> pure False)
       caughtException @? "Expected exception due to missing mail receiver."
 
---      traceM "Sent mail"
---      mbMail <-
---        retryWhileN 3 isJust $ do
---          readIORef receivedMailRef
---      isJust mbMail @? "Expected to receive mail"
+testSendMail :: Logger.Logger -> Bilge.Http ()
+testSendMail lg = do
+  receivedMailRef <- liftIO $ newIORef Nothing
+  liftIO
+    . withMailServer (mailStoringApp receivedMailRef)
+    $ do
+      conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
+      sendMail lg conPool mail
+      mbMail <-
+        retryWhileN 3 isJust $ do
+          readIORef receivedMailRef
+      isJust mbMail @? "Expected to receive mail"
+      postieAddressAsString . rmSender <$> mbMail
+        @=? (Just . unpack . addressEmail) sender
+      postieAddressAsString <$> (concat . maybeToList) (rmReceipients <$> mbMail)
+        @=? [(unpack . addressEmail) receiver]
+      let mailContent = (rmContent . fromJust) mbMail
+      elem ((unpack . toStrict) body) mailContent @? "Expected the SMTP server to receive the mail body."
+  where
+    receiver = Address Nothing "foo@example.com"
+    sender = Address Nothing "bar@example.com"
+    subject = "Some Subject"
+    body = "Some body"
+    mail =
+      simpleMail'
+        receiver
+        sender
+        subject
+        body
+    postieAddressAsString :: Postie.Address -> String
+    postieAddressAsString addr =
+      toString
+        ( B.concat
+            [ Postie.addressLocalPart addr,
+              C.singleton '@',
+              Postie.addressDomain addr
+            ]
+        )
+
+toString :: B.ByteString -> String
+toString bs = C.foldr (:) [] bs
 
 withMailServer :: Postie.Application -> IO () -> IO ()
 withMailServer app action =
@@ -47,7 +89,20 @@ withMailServer app action =
     killThread
     (const action)
 
-mailStoringApp :: IORef (Maybe Postie.Mail) -> Postie.Application
-mailStoringApp receivedMailRef mail =
-  writeIORef receivedMailRef (Just mail)
-    >> pure Postie.Accepted
+data ReceivedMail = ReceivedMail
+  { rmSender :: Postie.Address,
+    rmReceipients :: [Postie.Address],
+    rmContent :: [String]
+  }
+
+mailStoringApp :: IORef (Maybe ReceivedMail) -> Postie.Application
+mailStoringApp receivedMailRef mail = do
+  c <- Pipes.Prelude.toListM (Postie.mailBody mail)
+  let receivedMail =
+        ReceivedMail
+          { rmSender = Postie.mailSender mail,
+            rmReceipients = Postie.mailRecipients mail,
+            rmContent = C.unpack <$> c
+          }
+  writeIORef receivedMailRef (Just receivedMail)
+  pure Postie.Accepted

From 9eaa8ffec350229691670e23804189f8e6284166 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 16:11:51 +0100
Subject: [PATCH 13/38]     Ensure Subject is sent/received

---
 services/brig/test/integration/SMTP.hs | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index fc0af3d50a..87f5725c1e 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -58,6 +58,7 @@ testSendMail lg = do
         @=? [(unpack . addressEmail) receiver]
       let mailContent = (rmContent . fromJust) mbMail
       elem ((unpack . toStrict) body) mailContent @? "Expected the SMTP server to receive the mail body."
+      elem ("Subject: " ++ unpack subject) mailContent @? "Expected the SMTP server to receive the mail subject."
   where
     receiver = Address Nothing "foo@example.com"
     sender = Address Nothing "bar@example.com"
@@ -92,8 +93,12 @@ withMailServer app action =
 data ReceivedMail = ReceivedMail
   { rmSender :: Postie.Address,
     rmReceipients :: [Postie.Address],
+    -- | Contains all data sent to the SMTP server for this mail. (Including
+    -- /From:/, /To:/, /Subject:/, ... lines.) I.e. `Postie.mailBody` is half of
+    -- a lie; it's way more.
     rmContent :: [String]
   }
+  deriving (Eq, Show)
 
 mailStoringApp :: IORef (Maybe ReceivedMail) -> Postie.Application
 mailStoringApp receivedMailRef mail = do

From 178ec4efbd84835696ce163564ee8fc67335555e Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 16:32:25 +0100
Subject: [PATCH 14/38] Add TODO

---
 services/brig/test/integration/SMTP.hs | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 87f5725c1e..c9cdb6f8ec 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -23,6 +23,8 @@ tests m lg =
     testGroup
       "SMTP"
       [ test m "should send mail" $ testSendMail lg,
+        -- TODO: Needs better description string: Actually, the SMTP server
+        -- refuses to accept this mail.
         test m "should send no mail without receiver" $ testSendMailNoReceiver lg
       ]
 

From 6fd873e60be8aed7b2b8cb3446daa875c3abba0f Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 16:52:54 +0100
Subject: [PATCH 15/38] Test failed SMTP transaction

---
 services/brig/src/Brig/SMTP.hs         | 10 ++++++++-
 services/brig/test/integration/SMTP.hs | 29 +++++++++++++++++++++++++-
 2 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index b6330354cb..34dfab8c30 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -17,7 +17,15 @@
 -- You should have received a copy of the GNU Affero General Public License along
 -- with this program. If not, see <https://www.gnu.org/licenses/>.
 
-module Brig.SMTP where
+module Brig.SMTP
+  ( sendMail,
+    initSMTP,
+    SMTPConnType (..),
+    SMTP (..),
+    Username (..),
+    Password (..),
+  )
+where
 
 import qualified Control.Exception as CE (throw)
 import Control.Lens
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index c9cdb6f8ec..6e76f3eab6 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -25,7 +25,8 @@ tests m lg =
       [ test m "should send mail" $ testSendMail lg,
         -- TODO: Needs better description string: Actually, the SMTP server
         -- refuses to accept this mail.
-        test m "should send no mail without receiver" $ testSendMailNoReceiver lg
+        test m "should send no mail without receiver" $ testSendMailNoReceiver lg,
+        test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg
       ]
 
 -- TODO: Is Http the best Monad for this?
@@ -85,6 +86,29 @@ testSendMail lg = do
 toString :: B.ByteString -> String
 toString bs = C.foldr (:) [] bs
 
+testSendMailTransactionFailed :: Logger.Logger -> Bilge.Http ()
+testSendMailTransactionFailed lg = do
+  liftIO
+    . withMailServer mailRejectingApp
+    $ do
+      conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
+      caughtException <-
+        handle @SomeException
+          (const (pure True))
+          (sendMail lg conPool mail >> pure False)
+      caughtException @? "Expected exception due to missing mail receiver."
+  where
+    receiver = Address Nothing "foo@example.com"
+    sender = Address Nothing "bar@example.com"
+    subject = "Some Subject"
+    body = "Some body"
+    mail =
+      simpleMail'
+        receiver
+        sender
+        subject
+        body
+
 withMailServer :: Postie.Application -> IO () -> IO ()
 withMailServer app action =
   bracket
@@ -113,3 +137,6 @@ mailStoringApp receivedMailRef mail = do
           }
   writeIORef receivedMailRef (Just receivedMail)
   pure Postie.Accepted
+
+mailRejectingApp :: Postie.Application
+mailRejectingApp = const (pure Postie.Rejected)

From 9840f38d307e6b4411d780ab2885255a7e3cab03 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 2 Nov 2022 17:14:26 +0100
Subject: [PATCH 16/38] Formatting...

---
 services/brig/test/integration/Main.hs | 48 +++++++++++++-------------
 1 file changed, 24 insertions(+), 24 deletions(-)

diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs
index eb90368b2b..8c93734447 100644
--- a/services/brig/test/integration/Main.hs
+++ b/services/brig/test/integration/Main.hs
@@ -157,31 +157,31 @@ runTests iConf brigOpts otherArgs = do
 
   let mlsApi = MLS.tests mg b brigOpts
 
-  withArgs otherArgs . defaultMain $
-    testGroup
+  withArgs otherArgs . defaultMain
+    $ testGroup
       "Brig API Integration"
-      $ [ testCase "sitemap" $
-            assertEqual
-              "inconcistent sitemap"
-              mempty
-              (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging),
-          userApi,
-          providerApi,
-          searchApis,
-          teamApis,
-          turnApi,
-          metricsApi,
-          settingsApi,
-          createIndex,
-          userPendingActivation,
-          browseTeam,
-          federationEndpoints,
-          internalApi,
-          versionApi,
-          mlsApi,
-          smtp
-        ]
-        <> [federationEnd2End | includeFederationTests]
+    $ [ testCase "sitemap" $
+          assertEqual
+            "inconcistent sitemap"
+            mempty
+            (pathsConsistencyCheck . treeToPaths . compile $ Brig.API.sitemap @BrigCanonicalEffects @InternalPaging),
+        userApi,
+        providerApi,
+        searchApis,
+        teamApis,
+        turnApi,
+        metricsApi,
+        settingsApi,
+        createIndex,
+        userPendingActivation,
+        browseTeam,
+        federationEndpoints,
+        internalApi,
+        versionApi,
+        mlsApi,
+        smtp
+      ]
+      <> [federationEnd2End | includeFederationTests]
   where
     mkRequest (Endpoint h p) = host (encodeUtf8 h) . port p
 

From e22ba2c921d9f32bef0dd0b76b712aeb3c4ac3db Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 10:25:52 +0100
Subject: [PATCH 17/38] Add more tests

---
 services/brig/test/integration/SMTP.hs | 72 +++++++++++++++++++-------
 1 file changed, 54 insertions(+), 18 deletions(-)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 6e76f3eab6..d6dcd7190a 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -6,7 +6,7 @@ import Control.Exception
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C
 import Data.Text (unpack)
-import Data.Text.Lazy (toStrict)
+import Data.Text.Lazy (fromStrict)
 import Imports
 import Network.Mail.Mime
 import qualified Network.Mail.Postie as Postie
@@ -26,9 +26,35 @@ tests m lg =
         -- TODO: Needs better description string: Actually, the SMTP server
         -- refuses to accept this mail.
         test m "should send no mail without receiver" $ testSendMailNoReceiver lg,
-        test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg
+        test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg,
+        test m "should throw an error when the connection cannot be initiated on startup" $ testSendMailFailingConnectionOnStartup lg,
+        test m "should throw when the server cannot be reached on sending" $ testSendMailFailingConnectionOnSend lg
       ]
 
+testSendMailFailingConnectionOnSend :: Logger.Logger -> Bilge.Http ()
+testSendMailFailingConnectionOnSend lg = do
+  receivedMailRef <- liftIO $ newIORef Nothing
+  conPool <-
+    liftIO $
+      withMailServer
+        (mailStoringApp receivedMailRef)
+        (initSMTP lg "localhost" (Just 4242) Nothing Plain)
+  caughtException <-
+    liftIO $
+      handle @SomeException
+        (const (pure True))
+        (sendMail lg conPool someTestMail >> pure False)
+  liftIO $ caughtException @? "Expected exception (SMTP server unreachable.)"
+
+testSendMailFailingConnectionOnStartup :: Logger.Logger -> Bilge.Http ()
+testSendMailFailingConnectionOnStartup lg = do
+  caughtError <-
+    liftIO $
+      handle @ErrorCall
+        (const (pure True))
+        (initSMTP lg "localhost" (Just 4242) Nothing Plain >> pure False)
+  liftIO $ caughtError @? "Expected error (SMTP server unreachable.)"
+
 -- TODO: Is Http the best Monad for this?
 testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
 testSendMailNoReceiver lg = do
@@ -50,29 +76,19 @@ testSendMail lg = do
     . withMailServer (mailStoringApp receivedMailRef)
     $ do
       conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
-      sendMail lg conPool mail
+      sendMail lg conPool someTestMail
       mbMail <-
         retryWhileN 3 isJust $ do
           readIORef receivedMailRef
       isJust mbMail @? "Expected to receive mail"
       postieAddressAsString . rmSender <$> mbMail
-        @=? (Just . unpack . addressEmail) sender
+        @=? (Just . unpack . addressEmail) someTestSender
       postieAddressAsString <$> (concat . maybeToList) (rmReceipients <$> mbMail)
-        @=? [(unpack . addressEmail) receiver]
+        @=? [(unpack . addressEmail) someTestReceiver]
       let mailContent = (rmContent . fromJust) mbMail
-      elem ((unpack . toStrict) body) mailContent @? "Expected the SMTP server to receive the mail body."
-      elem ("Subject: " ++ unpack subject) mailContent @? "Expected the SMTP server to receive the mail subject."
+      elem (unpack someTestBody) mailContent @? "Expected the SMTP server to receive the mail body."
+      elem ("Subject: " ++ unpack someTestSubject) mailContent @? "Expected the SMTP server to receive the mail subject."
   where
-    receiver = Address Nothing "foo@example.com"
-    sender = Address Nothing "bar@example.com"
-    subject = "Some Subject"
-    body = "Some body"
-    mail =
-      simpleMail'
-        receiver
-        sender
-        subject
-        body
     postieAddressAsString :: Postie.Address -> String
     postieAddressAsString addr =
       toString
@@ -83,6 +99,26 @@ testSendMail lg = do
             ]
         )
 
+someTestReceiver :: Address
+someTestReceiver = Address Nothing "foo@example.com"
+
+someTestSender :: Address
+someTestSender = Address Nothing "bar@example.com"
+
+someTestSubject :: Text
+someTestSubject = "Some Subject"
+
+someTestBody :: Text
+someTestBody = "Some body"
+
+someTestMail :: Mail
+someTestMail =
+  simpleMail'
+    someTestReceiver
+    someTestSender
+    someTestSubject
+    (fromStrict someTestBody)
+
 toString :: B.ByteString -> String
 toString bs = C.foldr (:) [] bs
 
@@ -109,7 +145,7 @@ testSendMailTransactionFailed lg = do
         subject
         body
 
-withMailServer :: Postie.Application -> IO () -> IO ()
+withMailServer :: Postie.Application -> IO a -> IO a
 withMailServer app action =
   bracket
     (forkIO $ Postie.run 4242 app)

From 33a0f8645c6e80d091a3e23d027a0e5c9a139e54 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 10:27:46 +0100
Subject: [PATCH 18/38] Better test description

---
 services/brig/test/integration/SMTP.hs | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index d6dcd7190a..dc53a04206 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -23,9 +23,7 @@ tests m lg =
     testGroup
       "SMTP"
       [ test m "should send mail" $ testSendMail lg,
-        -- TODO: Needs better description string: Actually, the SMTP server
-        -- refuses to accept this mail.
-        test m "should send no mail without receiver" $ testSendMailNoReceiver lg,
+        test m "should throw exception when SMTP server refuses to send mail (mail without receiver)" $ testSendMailNoReceiver lg,
         test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg,
         test m "should throw an error when the connection cannot be initiated on startup" $ testSendMailFailingConnectionOnStartup lg,
         test m "should throw when the server cannot be reached on sending" $ testSendMailFailingConnectionOnSend lg

From 2c062d26b7f3ea8429e2d6153488da77d4f85e4a Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 10:30:27 +0100
Subject: [PATCH 19/38] Simplify test setup: Get rid on IO

---
 services/brig/test/integration/Main.hs |  7 +++----
 services/brig/test/integration/SMTP.hs | 19 +++++++++----------
 2 files changed, 12 insertions(+), 14 deletions(-)

diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs
index 8c93734447..dea31d0ff6 100644
--- a/services/brig/test/integration/Main.hs
+++ b/services/brig/test/integration/Main.hs
@@ -151,11 +151,10 @@ runTests iConf brigOpts otherArgs = do
   federationEndpoints <- API.Federation.tests mg brigOpts b c fedBrigClient
   includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS"
   internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g
-  smtp <- SMTP.tests mg lg
 
-  let versionApi = API.Version.tests mg brigOpts b
-
-  let mlsApi = MLS.tests mg b brigOpts
+  let smtp = SMTP.tests mg lg
+      versionApi = API.Version.tests mg brigOpts b
+      mlsApi = MLS.tests mg b brigOpts
 
   withArgs otherArgs . defaultMain
     $ testGroup
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index dc53a04206..c1b1f11a27 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -17,17 +17,16 @@ import Test.Tasty.HUnit
 import Util
 
 -- TODO: Is IO needed here?
-tests :: Bilge.Manager -> Logger.Logger -> IO TestTree
+tests :: Bilge.Manager -> Logger.Logger -> TestTree
 tests m lg =
-  pure $
-    testGroup
-      "SMTP"
-      [ test m "should send mail" $ testSendMail lg,
-        test m "should throw exception when SMTP server refuses to send mail (mail without receiver)" $ testSendMailNoReceiver lg,
-        test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg,
-        test m "should throw an error when the connection cannot be initiated on startup" $ testSendMailFailingConnectionOnStartup lg,
-        test m "should throw when the server cannot be reached on sending" $ testSendMailFailingConnectionOnSend lg
-      ]
+  testGroup
+    "SMTP"
+    [ test m "should send mail" $ testSendMail lg,
+      test m "should throw exception when SMTP server refuses to send mail (mail without receiver)" $ testSendMailNoReceiver lg,
+      test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg,
+      test m "should throw an error when the connection cannot be initiated on startup" $ testSendMailFailingConnectionOnStartup lg,
+      test m "should throw when the server cannot be reached on sending" $ testSendMailFailingConnectionOnSend lg
+    ]
 
 testSendMailFailingConnectionOnSend :: Logger.Logger -> Bilge.Http ()
 testSendMailFailingConnectionOnSend lg = do

From 67e4f7dc1250bc354f275fe569395db4f75f984e Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 17:01:35 +0100
Subject: [PATCH 20/38] More on tests

---
 services/brig/brig.cabal               |  1 +
 services/brig/src/Brig/SMTP.hs         | 65 ++++++++++++++---
 services/brig/test/integration/SMTP.hs | 96 ++++++++++++++++++++++----
 3 files changed, 138 insertions(+), 24 deletions(-)

diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal
index 4fbd943557..d8fa66a5f4 100644
--- a/services/brig/brig.cabal
+++ b/services/brig/brig.cabal
@@ -585,6 +585,7 @@ executable brig-integration
     , temporary              >=1.2.1
     , text
     , time                   >=1.5
+    , time-units
     , tinylog
     , transformers
     , types-common           >=0.3
diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 34dfab8c30..7e885705f8 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -20,10 +20,13 @@
 module Brig.SMTP
   ( sendMail,
     initSMTP,
+    sendMail',
+    initSMTP',
     SMTPConnType (..),
     SMTP (..),
     Username (..),
     Password (..),
+    SMTPPoolException (..),
   )
 where
 
@@ -68,10 +71,16 @@ data SMTPFailure = Unauthorized | ConnectionTimeout | CaughtException SomeExcept
   deriving (Show)
 
 data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
-  deriving (Show)
+  deriving (Eq, Show)
 
 instance Exception SMTPPoolException
 
+-- | Initiate the `SMTP` connection pool
+--
+-- Throws exceptions when the SMTP server is unreachable, authentication fails,
+-- a timeout happens and on every other network failure.
+--
+-- `defaultTimeoutDuration` is used as timeout duration for all actions.
 initSMTP ::
   Logger ->
   Text ->
@@ -79,7 +88,22 @@ initSMTP ::
   Maybe (Username, Password) ->
   SMTPConnType ->
   IO SMTP
-initSMTP lg host port credentials connType = do
+initSMTP = initSMTP' defaultTimeoutDuration
+
+-- | `initSMTP` with configurable timeout duration
+--
+-- This is mostly useful for testing. (We don't want to waste the amount of
+-- `defaultTimeoutDuration` in tests with waiting.)
+initSMTP' ::
+  (TimeUnit t) =>
+  t ->
+  Logger ->
+  Text ->
+  Maybe PortNumber ->
+  Maybe (Username, Password) ->
+  SMTPConnType ->
+  IO SMTP
+initSMTP' timeoutDuration lg host port credentials connType = do
   -- Try to initiate a connection and fail badly right away in case of bad auth
   -- otherwise config errors will be detected "too late"
   res <- runExceptT establishConnection
@@ -92,12 +116,12 @@ initSMTP lg host port credentials connType = do
         (error "Failed to establish test connection with SMTP server.")
         (const (SMTP <$> createPool create destroy 1 5 5))
         =<< do
-          r <- ensureSMTPConnectionTimeout (SMTP.gracefullyCloseSMTP con)
+          r <- ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
           logResult lg "Closing test connection on startup" r
           pure r
   where
     liftSMTP :: IO a -> ExceptT SMTPFailure IO a
-    liftSMTP action = ExceptT $ ensureSMTPConnectionTimeout action
+    liftSMTP action = ExceptT $ ensureSMTPConnectionTimeout timeoutDuration action
 
     establishConnection :: ExceptT SMTPFailure IO SMTP.SMTPConnection
     establishConnection = do
@@ -129,7 +153,7 @@ initSMTP lg host port credentials connType = do
 
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
-      (ensureSMTPConnectionTimeout . SMTP.gracefullyCloseSMTP) c
+      (ensureSMTPConnectionTimeout timeoutDuration . SMTP.gracefullyCloseSMTP) c
         >>= void . logResult lg ("Closing pooled SMTP connection to " ++ unpack host)
 
 handleError :: MonadIO m => Either SMTPFailure a -> m a
@@ -157,17 +181,36 @@ logResult lg actionString res =
     concatToVal :: ToBytes s1 => s1 -> String -> Builder
     concatToVal a b = a +++ (" : " :: String) +++ b
 
-ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m) => m a -> m (Either SMTPFailure a)
-ensureSMTPConnectionTimeout action =
+-- | Default timeout for all actions
+--
+-- It's arguable if this shouldn't become a configuration setting in future.
+defaultTimeoutDuration :: Second
+defaultTimeoutDuration = 15 :: Second
+
+ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m (Either SMTPFailure a)
+ensureSMTPConnectionTimeout timeoutDuration action =
   catch
-    (maybe (Left ConnectionTimeout) Right <$> timeout (15 :: Second) action)
+    (maybe (Left ConnectionTimeout) Right <$> timeout timeoutDuration action)
     (\(e :: SomeException) -> pure (Left (CaughtException e)))
 
+-- | Send a `Mail` via an existing `SMTP` connection pool
+--
+-- Throws exceptions when the SMTP server is unreachable, authentication fails,
+-- a timeout happens and on every other network failure.
+--
+-- `defaultTimeoutDuration` is used as timeout duration for all actions.
 sendMail :: (MonadIO m, MonadCatch m) => Logger -> SMTP -> Mail -> m ()
-sendMail lg s m = liftIO $ withResource (s ^. pool) sendMail'
+sendMail = sendMail' defaultTimeoutDuration
+
+-- | `sendMail` with configurable timeout duration
+--
+-- This is mostly useful for testing. (We don't want to waste the amount of
+-- `defaultTimeoutDuration` in tests with waiting.)
+sendMail' :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> Logger -> SMTP -> Mail -> m ()
+sendMail' timeoutDuration lg s m = liftIO $ withResource (s ^. pool) sendMail''
   where
-    sendMail' :: SMTP.SMTPConnection -> IO ()
-    sendMail' c = ensureSMTPConnectionTimeout (SMTP.sendMail m c) >>= handleError'
+    sendMail'' :: SMTP.SMTPConnection -> IO ()
+    sendMail'' c = ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c) >>= handleError'
 
     handleError' :: MonadIO m => Either SMTPFailure a -> m ()
     handleError' r =
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index c1b1f11a27..4c19278dda 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -7,16 +7,17 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Char8 as C
 import Data.Text (unpack)
 import Data.Text.Lazy (fromStrict)
+import Data.Time.Units
 import Imports
 import Network.Mail.Mime
 import qualified Network.Mail.Postie as Postie
+import Network.Socket
 import qualified Pipes.Prelude
 import qualified System.Logger as Logger
 import Test.Tasty
 import Test.Tasty.HUnit
 import Util
 
--- TODO: Is IO needed here?
 tests :: Bilge.Manager -> Logger.Logger -> TestTree
 tests m lg =
   testGroup
@@ -25,41 +26,75 @@ tests m lg =
       test m "should throw exception when SMTP server refuses to send mail (mail without receiver)" $ testSendMailNoReceiver lg,
       test m "should throw when an SMTP transaction is aborted (SMTP error 554: 'Transaction failed')" $ testSendMailTransactionFailed lg,
       test m "should throw an error when the connection cannot be initiated on startup" $ testSendMailFailingConnectionOnStartup lg,
-      test m "should throw when the server cannot be reached on sending" $ testSendMailFailingConnectionOnSend lg
+      test m "should throw when the server cannot be reached on sending" $ testSendMailFailingConnectionOnSend lg,
+      test m "should throw when sending times out" $ testSendMailTimeout lg,
+      test m "should throw an error the initiation times out" $ testSendMailTimeoutOnStartup lg
     ]
 
+-- TODO: Assert all exceptions on their type (not only they exist)
+testSendMailTimeoutOnStartup :: Logger.Logger -> Bilge.Http ()
+testSendMailTimeoutOnStartup lg = do
+  let port = 4242
+  mbException <-
+    liftIO $
+      everDelayingTCPServer port $
+        handle @ErrorCall
+          (\e -> pure (Just e))
+          (initSMTP' (500 :: Millisecond) lg "localhost" (Just port) Nothing Plain >> pure Nothing)
+  liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)"
+
+testSendMailTimeout :: Logger.Logger -> Bilge.Http ()
+testSendMailTimeout lg = do
+  let port = 4243
+  mbException <-
+    liftIO $
+      withMailServer port (delayingApp (3 :: Second)) $
+        do
+          conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
+          handle @SMTPPoolException
+            (\e -> pure (Just e))
+            (sendMail' (500 :: Millisecond) lg conPool someTestMail >> pure Nothing)
+  liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)"
+  liftIO $ mbException @?= Just SMTPConnectionTimeout
+
 testSendMailFailingConnectionOnSend :: Logger.Logger -> Bilge.Http ()
 testSendMailFailingConnectionOnSend lg = do
+  let port = 4244
   receivedMailRef <- liftIO $ newIORef Nothing
   conPool <-
     liftIO $
       withMailServer
+        port
         (mailStoringApp receivedMailRef)
-        (initSMTP lg "localhost" (Just 4242) Nothing Plain)
+        (initSMTP lg "localhost" (Just port) Nothing Plain)
   caughtException <-
     liftIO $
       handle @SomeException
         (const (pure True))
         (sendMail lg conPool someTestMail >> pure False)
   liftIO $ caughtException @? "Expected exception (SMTP server unreachable.)"
+  mbMail <- liftIO $ readIORef receivedMailRef
+  liftIO $ isNothing mbMail @? "No mail expected (if there is one, the test setup is broken.)"
 
 testSendMailFailingConnectionOnStartup :: Logger.Logger -> Bilge.Http ()
 testSendMailFailingConnectionOnStartup lg = do
+  let port = 4245
   caughtError <-
     liftIO $
       handle @ErrorCall
         (const (pure True))
-        (initSMTP lg "localhost" (Just 4242) Nothing Plain >> pure False)
+        (initSMTP lg "localhost" (Just port) Nothing Plain >> pure False)
   liftIO $ caughtError @? "Expected error (SMTP server unreachable.)"
 
 -- TODO: Is Http the best Monad for this?
 testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
 testSendMailNoReceiver lg = do
+  let port = 4246
   receivedMailRef <- liftIO $ newIORef Nothing
   liftIO
-    . withMailServer (mailStoringApp receivedMailRef)
+    . withMailServer port (mailStoringApp receivedMailRef)
     $ do
-      conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
+      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
       caughtException <-
         handle @SomeException
           (const (pure True))
@@ -68,11 +103,12 @@ testSendMailNoReceiver lg = do
 
 testSendMail :: Logger.Logger -> Bilge.Http ()
 testSendMail lg = do
+  let port = 4247
   receivedMailRef <- liftIO $ newIORef Nothing
   liftIO
-    . withMailServer (mailStoringApp receivedMailRef)
+    . withMailServer port (mailStoringApp receivedMailRef)
     $ do
-      conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
+      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
       sendMail lg conPool someTestMail
       mbMail <-
         retryWhileN 3 isJust $ do
@@ -121,10 +157,11 @@ toString bs = C.foldr (:) [] bs
 
 testSendMailTransactionFailed :: Logger.Logger -> Bilge.Http ()
 testSendMailTransactionFailed lg = do
+  let port = 4248
   liftIO
-    . withMailServer mailRejectingApp
+    . withMailServer port mailRejectingApp
     $ do
-      conPool <- initSMTP lg "localhost" (Just 4242) Nothing Plain
+      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
       caughtException <-
         handle @SomeException
           (const (pure True))
@@ -142,12 +179,14 @@ testSendMailTransactionFailed lg = do
         subject
         body
 
-withMailServer :: Postie.Application -> IO a -> IO a
-withMailServer app action =
+withMailServer :: PortNumber -> Postie.Application -> IO a -> IO a
+withMailServer port app action = do
   bracket
-    (forkIO $ Postie.run 4242 app)
+    (forkIO $ Postie.run (portNumberToInt port) app)
     killThread
     (const action)
+  where
+    portNumberToInt = fromInteger . toInteger
 
 data ReceivedMail = ReceivedMail
   { rmSender :: Postie.Address,
@@ -173,3 +212,34 @@ mailStoringApp receivedMailRef mail = do
 
 mailRejectingApp :: Postie.Application
 mailRejectingApp = const (pure Postie.Rejected)
+
+mailAcceptingApp :: Postie.Application
+mailAcceptingApp = const (pure Postie.Accepted)
+
+delayingApp :: (TimeUnit t) => t -> Postie.Application
+delayingApp delay =
+  const
+    ( (threadDelay . fromInteger . toMicroseconds) delay
+        >> pure Postie.Accepted
+    )
+
+everDelayingTCPServer :: PortNumber -> IO a -> IO a
+everDelayingTCPServer port action = withSocketsDo $ do
+  addr <- resolve
+  bracket (open addr) close (const action)
+  where
+    portString :: String
+    portString = (show . toInteger) port
+    resolve = do
+      let hints =
+            defaultHints
+              { addrFlags = [AI_PASSIVE],
+                addrSocketType = Stream
+              }
+      head <$> getAddrInfo (Just hints) Nothing (Just portString)
+    open addr = bracketOnError (openSocket addr) close $ \sock -> do
+      setSocketOption sock ReuseAddr 1
+      withFdSocket sock setCloseOnExecIfNeeded
+      bind sock $ addrAddress addr
+      listen sock 1024
+      pure sock

From 2a2cdac709d72b0e606b2a9ed5b072abb153745d Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 17:51:12 +0100
Subject: [PATCH 21/38] Flush log before error handling

---
 services/brig/src/Brig/SMTP.hs | 22 ++++++++++++++--------
 1 file changed, 14 insertions(+), 8 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 7e885705f8..649e513f09 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -108,9 +108,12 @@ initSMTP' timeoutDuration lg host port credentials connType = do
   -- otherwise config errors will be detected "too late"
   res <- runExceptT establishConnection
   logResult lg ("Checking test connection to " ++ unpack host ++ " on startup") res
+  -- Ensure that the logs are written: In case of failure, the errors thrown
+  -- below will kill the app (which could otherwise leave the logs unwritten).
+  flush lg
   case res of
     Left e ->
-      error $ "Failed to establish test connection with SMTP server. " ++ show e
+      error $ "Failed to establish test connection with SMTP server: " ++ show e
     Right con ->
       either
         (error "Failed to establish test connection with SMTP server.")
@@ -149,15 +152,15 @@ initSMTP' timeoutDuration lg host port credentials connType = do
     create = do
       res <- runExceptT establishConnection
       logResult lg "Creating pooled SMTP connection" res
-      handleError res
+      throwOnLeft res
 
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
       (ensureSMTPConnectionTimeout timeoutDuration . SMTP.gracefullyCloseSMTP) c
         >>= void . logResult lg ("Closing pooled SMTP connection to " ++ unpack host)
 
-handleError :: MonadIO m => Either SMTPFailure a -> m a
-handleError = \case
+throwOnLeft :: MonadIO m => Either SMTPFailure a -> m a
+throwOnLeft = \case
   Left Unauthorized -> CE.throw SMTPUnauthorized
   Left ConnectionTimeout -> CE.throw SMTPConnectionTimeout
   Left (CaughtException e) -> CE.throw e
@@ -184,6 +187,9 @@ logResult lg actionString res =
 -- | Default timeout for all actions
 --
 -- It's arguable if this shouldn't become a configuration setting in future.
+-- It's an almost obscenely long duration, as we just want to make sure SMTP
+-- servers / network components aren't playing tricks to us. Other cases should
+-- be handled by the network libraries themselves.
 defaultTimeoutDuration :: Second
 defaultTimeoutDuration = 15 :: Second
 
@@ -210,9 +216,9 @@ sendMail' :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> Logger -> SMTP -> Mai
 sendMail' timeoutDuration lg s m = liftIO $ withResource (s ^. pool) sendMail''
   where
     sendMail'' :: SMTP.SMTPConnection -> IO ()
-    sendMail'' c = ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c) >>= handleError'
+    sendMail'' c = ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c) >>= handleError
 
-    handleError' :: MonadIO m => Either SMTPFailure a -> m ()
-    handleError' r =
+    handleError :: MonadIO m => Either SMTPFailure a -> m ()
+    handleError r =
       logResult lg "Sending mail via SMTP" r
-        >> (void . handleError) r
+        >> (void . throwOnLeft) r

From 719a4c793a770445fae9ffcbea5e6449062f1cac Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 18:03:19 +0100
Subject: [PATCH 22/38] Resolve TODOs

---
 services/brig/test/integration/SMTP.hs | 2 --
 1 file changed, 2 deletions(-)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 4c19278dda..4c8a36610c 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -31,7 +31,6 @@ tests m lg =
       test m "should throw an error the initiation times out" $ testSendMailTimeoutOnStartup lg
     ]
 
--- TODO: Assert all exceptions on their type (not only they exist)
 testSendMailTimeoutOnStartup :: Logger.Logger -> Bilge.Http ()
 testSendMailTimeoutOnStartup lg = do
   let port = 4242
@@ -86,7 +85,6 @@ testSendMailFailingConnectionOnStartup lg = do
         (initSMTP lg "localhost" (Just port) Nothing Plain >> pure False)
   liftIO $ caughtError @? "Expected error (SMTP server unreachable.)"
 
--- TODO: Is Http the best Monad for this?
 testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
 testSendMailNoReceiver lg = do
   let port = 4246

From 4c018b0ed543b54001c9a7a75e830fa6e3cafd9b Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Thu, 3 Nov 2022 18:07:32 +0100
Subject: [PATCH 23/38] Add changelog

---
 changelog.d/2-features/smtp-logging | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 changelog.d/2-features/smtp-logging

diff --git a/changelog.d/2-features/smtp-logging b/changelog.d/2-features/smtp-logging
new file mode 100644
index 0000000000..496d0aebdd
--- /dev/null
+++ b/changelog.d/2-features/smtp-logging
@@ -0,0 +1 @@
+Add more logs to SMTP mail sending. Ensure that logs are written before the application fails due to SMTP misconfiguration.

From bde19599a350f0264fbeb2f141a9f845015842bf Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 4 Nov 2022 11:38:56 +0100
Subject: [PATCH 24/38] Use random port for SMTP server

---
 libs/types-common/src/Wire/Arbitrary.hs |  6 +++++-
 libs/types-common/types-common.cabal    |  1 +
 services/brig/test/integration/SMTP.hs  | 18 +++++++++++-------
 3 files changed, 17 insertions(+), 8 deletions(-)

diff --git a/libs/types-common/src/Wire/Arbitrary.hs b/libs/types-common/src/Wire/Arbitrary.hs
index ed591cca13..d5c874263f 100644
--- a/libs/types-common/src/Wire/Arbitrary.hs
+++ b/libs/types-common/src/Wire/Arbitrary.hs
@@ -42,9 +42,10 @@ import GHC.Generics (Rep)
 import Generic.Random (listOf', (:+) ((:+)))
 import qualified Generic.Random as Generic
 import Imports
+import Network.Socket (PortNumber)
 import Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
 import qualified Test.QuickCheck.Arbitrary as QC
-import Test.QuickCheck.Gen (Gen (MkGen))
+import Test.QuickCheck.Gen (Gen (MkGen), chooseBoundedIntegral)
 import Test.QuickCheck.Instances ()
 import Test.QuickCheck.Random
 
@@ -120,3 +121,6 @@ generateExample :: Arbitrary a => a
 generateExample =
   let (MkGen f) = arbitrary
    in f (mkQCGen 42) 42
+
+instance Arbitrary PortNumber where
+  arbitrary = chooseBoundedIntegral (minBound :: PortNumber, maxBound :: PortNumber)
diff --git a/libs/types-common/types-common.cabal b/libs/types-common/types-common.cabal
index 96fb5b5526..6a432b2d77 100644
--- a/libs/types-common/types-common.cabal
+++ b/libs/types-common/types-common.cabal
@@ -113,6 +113,7 @@ library
     , lens                   >=4.10
     , lens-datetime          >=0.3
     , mime                   >=0.4.0.2
+    , network
     , optparse-applicative   >=0.10
     , pem
     , protobuf               >=0.2
diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 4c8a36610c..6021d27b38 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -14,6 +14,7 @@ import qualified Network.Mail.Postie as Postie
 import Network.Socket
 import qualified Pipes.Prelude
 import qualified System.Logger as Logger
+import Test.QuickCheck
 import Test.Tasty
 import Test.Tasty.HUnit
 import Util
@@ -31,9 +32,12 @@ tests m lg =
       test m "should throw an error the initiation times out" $ testSendMailTimeoutOnStartup lg
     ]
 
+randomPortNumber :: MonadIO m => m PortNumber
+randomPortNumber = liftIO $ generate arbitrary
+
 testSendMailTimeoutOnStartup :: Logger.Logger -> Bilge.Http ()
 testSendMailTimeoutOnStartup lg = do
-  let port = 4242
+  port <- randomPortNumber
   mbException <-
     liftIO $
       everDelayingTCPServer port $
@@ -44,7 +48,7 @@ testSendMailTimeoutOnStartup lg = do
 
 testSendMailTimeout :: Logger.Logger -> Bilge.Http ()
 testSendMailTimeout lg = do
-  let port = 4243
+  port <- randomPortNumber
   mbException <-
     liftIO $
       withMailServer port (delayingApp (3 :: Second)) $
@@ -58,7 +62,7 @@ testSendMailTimeout lg = do
 
 testSendMailFailingConnectionOnSend :: Logger.Logger -> Bilge.Http ()
 testSendMailFailingConnectionOnSend lg = do
-  let port = 4244
+  port <- randomPortNumber
   receivedMailRef <- liftIO $ newIORef Nothing
   conPool <-
     liftIO $
@@ -77,7 +81,7 @@ testSendMailFailingConnectionOnSend lg = do
 
 testSendMailFailingConnectionOnStartup :: Logger.Logger -> Bilge.Http ()
 testSendMailFailingConnectionOnStartup lg = do
-  let port = 4245
+  port <- randomPortNumber
   caughtError <-
     liftIO $
       handle @ErrorCall
@@ -87,7 +91,7 @@ testSendMailFailingConnectionOnStartup lg = do
 
 testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
 testSendMailNoReceiver lg = do
-  let port = 4246
+  port <- randomPortNumber
   receivedMailRef <- liftIO $ newIORef Nothing
   liftIO
     . withMailServer port (mailStoringApp receivedMailRef)
@@ -101,7 +105,7 @@ testSendMailNoReceiver lg = do
 
 testSendMail :: Logger.Logger -> Bilge.Http ()
 testSendMail lg = do
-  let port = 4247
+  port <- randomPortNumber
   receivedMailRef <- liftIO $ newIORef Nothing
   liftIO
     . withMailServer port (mailStoringApp receivedMailRef)
@@ -155,7 +159,7 @@ toString bs = C.foldr (:) [] bs
 
 testSendMailTransactionFailed :: Logger.Logger -> Bilge.Http ()
 testSendMailTransactionFailed lg = do
-  let port = 4248
+  port <- randomPortNumber
   liftIO
     . withMailServer port mailRejectingApp
     $ do

From efa220e9a612847f84e24c2111eafdeea81c1dbc Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 4 Nov 2022 11:41:11 +0100
Subject: [PATCH 25/38] Reduce test setup duplication

---
 services/brig/test/integration/SMTP.hs | 13 +------------
 1 file changed, 1 insertion(+), 12 deletions(-)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 6021d27b38..47ce406099 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -167,19 +167,8 @@ testSendMailTransactionFailed lg = do
       caughtException <-
         handle @SomeException
           (const (pure True))
-          (sendMail lg conPool mail >> pure False)
+          (sendMail lg conPool someTestMail >> pure False)
       caughtException @? "Expected exception due to missing mail receiver."
-  where
-    receiver = Address Nothing "foo@example.com"
-    sender = Address Nothing "bar@example.com"
-    subject = "Some Subject"
-    body = "Some body"
-    mail =
-      simpleMail'
-        receiver
-        sender
-        subject
-        body
 
 withMailServer :: PortNumber -> Postie.Application -> IO a -> IO a
 withMailServer port app action = do

From 7e43aa2901e2cdb1eb6bbd871db2f72db962b3f6 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 4 Nov 2022 11:48:27 +0100
Subject: [PATCH 26/38] Re-order functions

---
 services/brig/test/integration/SMTP.hs | 168 ++++++++++++-------------
 1 file changed, 84 insertions(+), 84 deletions(-)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 47ce406099..942d7b498c 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -32,77 +32,6 @@ tests m lg =
       test m "should throw an error the initiation times out" $ testSendMailTimeoutOnStartup lg
     ]
 
-randomPortNumber :: MonadIO m => m PortNumber
-randomPortNumber = liftIO $ generate arbitrary
-
-testSendMailTimeoutOnStartup :: Logger.Logger -> Bilge.Http ()
-testSendMailTimeoutOnStartup lg = do
-  port <- randomPortNumber
-  mbException <-
-    liftIO $
-      everDelayingTCPServer port $
-        handle @ErrorCall
-          (\e -> pure (Just e))
-          (initSMTP' (500 :: Millisecond) lg "localhost" (Just port) Nothing Plain >> pure Nothing)
-  liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)"
-
-testSendMailTimeout :: Logger.Logger -> Bilge.Http ()
-testSendMailTimeout lg = do
-  port <- randomPortNumber
-  mbException <-
-    liftIO $
-      withMailServer port (delayingApp (3 :: Second)) $
-        do
-          conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
-          handle @SMTPPoolException
-            (\e -> pure (Just e))
-            (sendMail' (500 :: Millisecond) lg conPool someTestMail >> pure Nothing)
-  liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)"
-  liftIO $ mbException @?= Just SMTPConnectionTimeout
-
-testSendMailFailingConnectionOnSend :: Logger.Logger -> Bilge.Http ()
-testSendMailFailingConnectionOnSend lg = do
-  port <- randomPortNumber
-  receivedMailRef <- liftIO $ newIORef Nothing
-  conPool <-
-    liftIO $
-      withMailServer
-        port
-        (mailStoringApp receivedMailRef)
-        (initSMTP lg "localhost" (Just port) Nothing Plain)
-  caughtException <-
-    liftIO $
-      handle @SomeException
-        (const (pure True))
-        (sendMail lg conPool someTestMail >> pure False)
-  liftIO $ caughtException @? "Expected exception (SMTP server unreachable.)"
-  mbMail <- liftIO $ readIORef receivedMailRef
-  liftIO $ isNothing mbMail @? "No mail expected (if there is one, the test setup is broken.)"
-
-testSendMailFailingConnectionOnStartup :: Logger.Logger -> Bilge.Http ()
-testSendMailFailingConnectionOnStartup lg = do
-  port <- randomPortNumber
-  caughtError <-
-    liftIO $
-      handle @ErrorCall
-        (const (pure True))
-        (initSMTP lg "localhost" (Just port) Nothing Plain >> pure False)
-  liftIO $ caughtError @? "Expected error (SMTP server unreachable.)"
-
-testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
-testSendMailNoReceiver lg = do
-  port <- randomPortNumber
-  receivedMailRef <- liftIO $ newIORef Nothing
-  liftIO
-    . withMailServer port (mailStoringApp receivedMailRef)
-    $ do
-      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
-      caughtException <-
-        handle @SomeException
-          (const (pure True))
-          (sendMail lg conPool (emptyMail (Address Nothing "foo@example.com")) >> pure False)
-      caughtException @? "Expected exception due to missing mail receiver."
-
 testSendMail :: Logger.Logger -> Bilge.Http ()
 testSendMail lg = do
   port <- randomPortNumber
@@ -134,6 +63,87 @@ testSendMail lg = do
             ]
         )
 
+testSendMailNoReceiver :: Logger.Logger -> Bilge.Http ()
+testSendMailNoReceiver lg = do
+  port <- randomPortNumber
+  receivedMailRef <- liftIO $ newIORef Nothing
+  liftIO
+    . withMailServer port (mailStoringApp receivedMailRef)
+    $ do
+      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
+      caughtException <-
+        handle @SomeException
+          (const (pure True))
+          (sendMail lg conPool (emptyMail (Address Nothing "foo@example.com")) >> pure False)
+      caughtException @? "Expected exception due to missing mail receiver."
+
+testSendMailTransactionFailed :: Logger.Logger -> Bilge.Http ()
+testSendMailTransactionFailed lg = do
+  port <- randomPortNumber
+  liftIO
+    . withMailServer port mailRejectingApp
+    $ do
+      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
+      caughtException <-
+        handle @SomeException
+          (const (pure True))
+          (sendMail lg conPool someTestMail >> pure False)
+      caughtException @? "Expected exception due to missing mail receiver."
+
+testSendMailFailingConnectionOnStartup :: Logger.Logger -> Bilge.Http ()
+testSendMailFailingConnectionOnStartup lg = do
+  port <- randomPortNumber
+  caughtError <-
+    liftIO $
+      handle @ErrorCall
+        (const (pure True))
+        (initSMTP lg "localhost" (Just port) Nothing Plain >> pure False)
+  liftIO $ caughtError @? "Expected error (SMTP server unreachable.)"
+
+testSendMailFailingConnectionOnSend :: Logger.Logger -> Bilge.Http ()
+testSendMailFailingConnectionOnSend lg = do
+  port <- randomPortNumber
+  receivedMailRef <- liftIO $ newIORef Nothing
+  conPool <-
+    liftIO $
+      withMailServer
+        port
+        (mailStoringApp receivedMailRef)
+        (initSMTP lg "localhost" (Just port) Nothing Plain)
+  caughtException <-
+    liftIO $
+      handle @SomeException
+        (const (pure True))
+        (sendMail lg conPool someTestMail >> pure False)
+  liftIO $ caughtException @? "Expected exception (SMTP server unreachable.)"
+  mbMail <- liftIO $ readIORef receivedMailRef
+  liftIO $ isNothing mbMail @? "No mail expected (if there is one, the test setup is broken.)"
+
+testSendMailTimeout :: Logger.Logger -> Bilge.Http ()
+testSendMailTimeout lg = do
+  port <- randomPortNumber
+  mbException <-
+    liftIO $
+      withMailServer port (delayingApp (3 :: Second)) $
+        do
+          conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
+          handle @SMTPPoolException
+            (\e -> pure (Just e))
+            (sendMail' (500 :: Millisecond) lg conPool someTestMail >> pure Nothing)
+  liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)"
+  liftIO $ mbException @?= Just SMTPConnectionTimeout
+
+testSendMailTimeoutOnStartup :: Logger.Logger -> Bilge.Http ()
+testSendMailTimeoutOnStartup lg = do
+  port <- randomPortNumber
+  mbException <-
+    liftIO $
+      everDelayingTCPServer port $
+        handle @ErrorCall
+          (\e -> pure (Just e))
+          (initSMTP' (500 :: Millisecond) lg "localhost" (Just port) Nothing Plain >> pure Nothing)
+  liftIO $ isJust mbException @? "Expected exception (SMTP server action timed out.)"
+
 someTestReceiver :: Address
 someTestReceiver = Address Nothing "foo@example.com"
 
@@ -157,19 +167,6 @@ someTestMail =
 toString :: B.ByteString -> String
 toString bs = C.foldr (:) [] bs
 
-testSendMailTransactionFailed :: Logger.Logger -> Bilge.Http ()
-testSendMailTransactionFailed lg = do
-  port <- randomPortNumber
-  liftIO
-    . withMailServer port mailRejectingApp
-    $ do
-      conPool <- initSMTP lg "localhost" (Just port) Nothing Plain
-      caughtException <-
-        handle @SomeException
-          (const (pure True))
-          (sendMail lg conPool someTestMail >> pure False)
-      caughtException @? "Expected exception due to missing mail receiver."
-
 withMailServer :: PortNumber -> Postie.Application -> IO a -> IO a
 withMailServer port app action = do
   bracket
@@ -234,3 +231,6 @@ everDelayingTCPServer port action = withSocketsDo $ do
       bind sock $ addrAddress addr
       listen sock 1024
       pure sock
+
+randomPortNumber :: MonadIO m => m PortNumber
+randomPortNumber = liftIO $ generate arbitrary

From 413911cc44078ef9c0e4240b9f6295115bab3c6b Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 4 Nov 2022 12:56:13 +0100
Subject: [PATCH 27/38] Ensure that test mail server ports aren't priviledged
 and not already in use

---
 services/brig/test/integration/SMTP.hs | 22 +++++++++++++++++++++-
 1 file changed, 21 insertions(+), 1 deletion(-)

diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs
index 942d7b498c..f565b3078e 100644
--- a/services/brig/test/integration/SMTP.hs
+++ b/services/brig/test/integration/SMTP.hs
@@ -8,6 +8,8 @@ import qualified Data.ByteString.Char8 as C
 import Data.Text (unpack)
 import Data.Text.Lazy (fromStrict)
 import Data.Time.Units
+import Foreign.C.Error (Errno (..), eCONNREFUSED)
+import GHC.IO.Exception (ioe_errno)
 import Imports
 import Network.Mail.Mime
 import qualified Network.Mail.Postie as Postie
@@ -233,4 +235,22 @@ everDelayingTCPServer port action = withSocketsDo $ do
       pure sock
 
 randomPortNumber :: MonadIO m => m PortNumber
-randomPortNumber = liftIO $ generate arbitrary
+randomPortNumber = do
+  candidate <- liftIO $ generate (arbitrary `suchThat` (> 1024))
+  portOpen <- liftIO $ isPortOpen candidate
+  if portOpen
+    then randomPortNumber
+    else pure candidate
+
+isPortOpen :: PortNumber -> IO Bool
+isPortOpen port = do
+  let sockAddr = SockAddrInet port (tupleToHostAddress (127, 0, 0, 1))
+      tcpProtocolNumber = 6
+  bracket (socket AF_INET Stream tcpProtocolNumber) close' $ \sock -> do
+    res <- try $ connect sock sockAddr
+    case res of
+      Right () -> pure True
+      Left e ->
+        if (Errno <$> ioe_errno e) == Just eCONNREFUSED
+          then pure False
+          else throwIO e

From 64a2d7e4c716207fc4408529302a9e49bf009a9d Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 4 Nov 2022 13:00:01 +0100
Subject: [PATCH 28/38] Final touches to log/error messages

---
 services/brig/src/Brig/SMTP.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 649e513f09..3b5514b7c3 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -116,7 +116,7 @@ initSMTP' timeoutDuration lg host port credentials connType = do
       error $ "Failed to establish test connection with SMTP server: " ++ show e
     Right con ->
       either
-        (error "Failed to establish test connection with SMTP server.")
+        (error "Failed to close test connection with SMTP server.")
         (const (SMTP <$> createPool create destroy 1 5 5))
         =<< do
           r <- ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
@@ -151,7 +151,7 @@ initSMTP' timeoutDuration lg host port credentials connType = do
     create :: IO SMTP.SMTPConnection
     create = do
       res <- runExceptT establishConnection
-      logResult lg "Creating pooled SMTP connection" res
+      logResult lg ("Creating pooled SMTP connection to " ++ unpack host) res
       throwOnLeft res
 
     destroy :: SMTP.SMTPConnection -> IO ()
@@ -173,7 +173,7 @@ logResult lg actionString res =
       Logger.log
         lg
         Logger.Warn
-        (msg $ concatToVal actionString "Failed to established connection, check your credentials.")
+        (msg $ concatToVal actionString "Failed to establish connection, check your credentials.")
     Left ConnectionTimeout -> do
       Logger.log lg Logger.Warn (msg $ concatToVal actionString "Connection timeout.")
     Left (CaughtException e) -> do

From 6b2e1c0012ce3096f4255bbff87a570ea307ce80 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Fri, 11 Nov 2022 07:37:57 +0100
Subject: [PATCH 29/38] Add missing Nix dependencies

---
 libs/types-common/default.nix |  2 ++
 services/brig/default.nix     | 10 ++++++++++
 2 files changed, 12 insertions(+)

diff --git a/libs/types-common/default.nix b/libs/types-common/default.nix
index b1f22221ba..6c9d92ccb2 100644
--- a/libs/types-common/default.nix
+++ b/libs/types-common/default.nix
@@ -32,6 +32,7 @@
 , lens-datetime
 , lib
 , mime
+, network
 , optparse-applicative
 , pem
 , protobuf
@@ -91,6 +92,7 @@ mkDerivation {
     lens
     lens-datetime
     mime
+    network
     optparse-applicative
     pem
     protobuf
diff --git a/services/brig/default.nix b/services/brig/default.nix
index cb9aa3523d..3a76f885ea 100644
--- a/services/brig/default.nix
+++ b/services/brig/default.nix
@@ -85,9 +85,11 @@
 , network-conduit-tls
 , optparse-applicative
 , pem
+, pipes
 , polysemy
 , polysemy-plugin
 , polysemy-wire-zoo
+, postie
 , process
 , proto-lens
 , QuickCheck
@@ -130,6 +132,8 @@
 , text
 , text-icu-translit
 , time
+, time-out
+, time-units
 , tinylog
 , transformers
 , types-common
@@ -267,6 +271,8 @@ mkDerivation {
     text
     text-icu-translit
     time
+    time-out
+    time-units
     tinylog
     transformers
     types-common
@@ -329,13 +335,16 @@ mkDerivation {
     lens-aeson
     metrics-wai
     mime
+    mime-mail
     MonadRandom
     mtl
     network
     optparse-applicative
     pem
+    pipes
     polysemy
     polysemy-wire-zoo
+    postie
     process
     proto-lens
     QuickCheck
@@ -356,6 +365,7 @@ mkDerivation {
     temporary
     text
     time
+    time-units
     tinylog
     transformers
     types-common

From adf599d6b8d04da1bcba2eabf8d2972986e293cd Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Mon, 21 Nov 2022 10:27:33 +0100
Subject: [PATCH 30/38] Stricter version definition for postie

Cabal won't accept a smaller version as it's not compatible with our
current version of base (GHC).
---
 services/brig/brig.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/services/brig/brig.cabal b/services/brig/brig.cabal
index d8fa66a5f4..9c554f38c9 100644
--- a/services/brig/brig.cabal
+++ b/services/brig/brig.cabal
@@ -564,7 +564,7 @@ executable brig-integration
     , pipes
     , polysemy
     , polysemy-wire-zoo
-    , postie                 >=0.6
+    , postie                 >=0.6.0.3
     , process
     , proto-lens
     , QuickCheck

From 9ddd32b6e0209ed7044fc971f1706d5e8c4414e4 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Mon, 21 Nov 2022 14:45:50 +0100
Subject: [PATCH 31/38] Use Log.field to combine log items

---
 services/brig/src/Brig/SMTP.hs | 49 +++++++++++++++++++++++-----------
 1 file changed, 34 insertions(+), 15 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 3b5514b7c3..c73dfaf4c4 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -168,21 +168,40 @@ throwOnLeft = \case
 
 logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
 logResult lg actionString res =
-  case res of
-    Left Unauthorized -> do
-      Logger.log
-        lg
-        Logger.Warn
-        (msg $ concatToVal actionString "Failed to establish connection, check your credentials.")
-    Left ConnectionTimeout -> do
-      Logger.log lg Logger.Warn (msg $ concatToVal actionString "Connection timeout.")
-    Left (CaughtException e) -> do
-      Logger.log lg Logger.Warn (msg $ concatToVal actionString ("Caught exception : " ++ show e))
-    Right _ -> do
-      Logger.log lg Logger.Debug (msg $ concatToVal actionString "Succeeded.")
-  where
-    concatToVal :: ToBytes s1 => s1 -> String -> Builder
-    concatToVal a b = a +++ (" : " :: String) +++ b
+  let msg' = msg ("SMTP connection result" :: String)
+   in case res of
+        Left Unauthorized -> do
+          Logger.log
+            lg
+            Logger.Warn
+            ( msg'
+                . field "action" actionString
+                . field "result" ("Failed to establish connection, check your credentials." :: String)
+            )
+        Left ConnectionTimeout -> do
+          Logger.log
+            lg
+            Logger.Warn
+            ( msg'
+                . field "action" actionString
+                . field "result" ("Connection timeout." :: String)
+            )
+        Left (CaughtException e) -> do
+          Logger.log
+            lg
+            Logger.Warn
+            ( msg'
+                . field "action" actionString
+                . field "result" ("Caught exception : " ++ show e)
+            )
+        Right _ -> do
+          Logger.log
+            lg
+            Logger.Debug
+            ( msg'
+                . field "action" actionString
+                . field "result" ("Succeeded." :: String)
+            )
 
 -- | Default timeout for all actions
 --

From 33af67511af9fb9e183f42bb4125ddd7b9d90adb Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Mon, 21 Nov 2022 14:59:04 +0100
Subject: [PATCH 32/38] Add haddock

---
 services/brig/src/Brig/SMTP.hs | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index c73dfaf4c4..f2ed64eb66 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -212,6 +212,14 @@ logResult lg actionString res =
 defaultTimeoutDuration :: Second
 defaultTimeoutDuration = 15 :: Second
 
+-- | Wrapper function for `SMTP` network actions
+--
+-- This function ensures that @action@ finishes in a given period of time.
+-- Additionally, all exceptions are caught and transformed into @Left
+-- (CaughtException e)@. Staying in @Either SMTPFailure a@ makes error handling
+-- in this module a lot easier compared to having to deal with both, failure
+-- values and exceptions. (We cannot be sure which exceptions may arise as this
+-- depends on a stack of libraries...)
 ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m (Either SMTPFailure a)
 ensureSMTPConnectionTimeout timeoutDuration action =
   catch

From b37f3fa0841363301ab756f95fdbb030ba97367b Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Tue, 22 Nov 2022 17:20:09 +0100
Subject: [PATCH 33/38] Simplify: Get rid of Either

---
 services/brig/src/Brig/SMTP.hs | 160 ++++++++++++++++-----------------
 1 file changed, 76 insertions(+), 84 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index f2ed64eb66..71f3eedabd 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -33,11 +33,9 @@ where
 import qualified Control.Exception as CE (throw)
 import Control.Lens
 import Control.Monad.Catch
-import Control.Monad.Trans.Except
 import Control.Timeout (timeout)
 import Data.Aeson
 import Data.Aeson.TH
-import Data.Either.Extra
 import Data.Pool
 import Data.Text (unpack)
 import Data.Time.Units
@@ -67,9 +65,6 @@ deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType
 
 makeLenses ''SMTP
 
-data SMTPFailure = Unauthorized | ConnectionTimeout | CaughtException SomeException
-  deriving (Show)
-
 data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
   deriving (Eq, Show)
 
@@ -106,27 +101,29 @@ initSMTP' ::
 initSMTP' timeoutDuration lg host port credentials connType = do
   -- Try to initiate a connection and fail badly right away in case of bad auth
   -- otherwise config errors will be detected "too late"
-  res <- runExceptT establishConnection
-  logResult lg ("Checking test connection to " ++ unpack host ++ " on startup") res
-  -- Ensure that the logs are written: In case of failure, the errors thrown
-  -- below will kill the app (which could otherwise leave the logs unwritten).
-  flush lg
-  case res of
-    Left e ->
-      error $ "Failed to establish test connection with SMTP server: " ++ show e
-    Right con ->
-      either
-        (error "Failed to close test connection with SMTP server.")
-        (const (SMTP <$> createPool create destroy 1 5 5))
-        =<< do
-          r <- ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
-          logResult lg "Closing test connection on startup" r
-          pure r
+  con <-
+    catch
+      (logExceptionOrResult lg ("Checking test connection to " ++ unpack host ++ " on startup") establishConnection)
+      ( \(e :: SomeException) -> do
+          -- Ensure that the logs are written: In case of failure, the errors thrown
+          -- below will kill the app (which could otherwise leave the logs unwritten).
+          flush lg
+          error $ "Failed to establish test connection with SMTP server: " ++ show e
+      )
+  catch
+    ( logExceptionOrResult lg "Closing test connection on startup" $
+        ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
+    )
+    ( \(e :: SomeException) -> do
+        flush lg
+        error $ "Failed to close test connection with SMTP server: " ++ show e
+    )
+  SMTP <$> createPool create destroy 1 5 5
   where
-    liftSMTP :: IO a -> ExceptT SMTPFailure IO a
-    liftSMTP action = ExceptT $ ensureSMTPConnectionTimeout timeoutDuration action
+    liftSMTP :: IO a -> IO a
+    liftSMTP action = ensureSMTPConnectionTimeout timeoutDuration action
 
-    establishConnection :: ExceptT SMTPFailure IO SMTP.SMTPConnection
+    establishConnection :: IO SMTP.SMTPConnection
     establishConnection = do
       conn <- liftSMTP $ case (connType, port) of
         (Plain, Nothing) -> SMTP.connectSMTP (unpack host)
@@ -146,62 +143,60 @@ initSMTP' timeoutDuration lg host port credentials connType = do
         _ -> pure True
       if ok
         then pure conn
-        else throwE Unauthorized
+        else CE.throw SMTPUnauthorized
 
     create :: IO SMTP.SMTPConnection
-    create = do
-      res <- runExceptT establishConnection
-      logResult lg ("Creating pooled SMTP connection to " ++ unpack host) res
-      throwOnLeft res
+    create =
+      logExceptionOrResult
+        lg
+        ("Creating pooled SMTP connection to " ++ unpack host)
+        establishConnection
 
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
-      (ensureSMTPConnectionTimeout timeoutDuration . SMTP.gracefullyCloseSMTP) c
-        >>= void . logResult lg ("Closing pooled SMTP connection to " ++ unpack host)
-
-throwOnLeft :: MonadIO m => Either SMTPFailure a -> m a
-throwOnLeft = \case
-  Left Unauthorized -> CE.throw SMTPUnauthorized
-  Left ConnectionTimeout -> CE.throw SMTPConnectionTimeout
-  Left (CaughtException e) -> CE.throw e
-  Right a -> pure a
-
-logResult :: MonadIO m => Logger -> String -> Either SMTPFailure c -> m ()
-logResult lg actionString res =
+      logExceptionOrResult lg ("Closing pooled SMTP connection to " ++ unpack host) $ (ensureSMTPConnectionTimeout timeoutDuration . SMTP.gracefullyCloseSMTP) c
+
+logExceptionOrResult :: (MonadIO m, MonadCatch m) => Logger -> String -> m a -> m a
+logExceptionOrResult lg actionString action = do
   let msg' = msg ("SMTP connection result" :: String)
-   in case res of
-        Left Unauthorized -> do
-          Logger.log
-            lg
-            Logger.Warn
-            ( msg'
-                . field "action" actionString
-                . field "result" ("Failed to establish connection, check your credentials." :: String)
-            )
-        Left ConnectionTimeout -> do
-          Logger.log
-            lg
-            Logger.Warn
-            ( msg'
-                . field "action" actionString
-                . field "result" ("Connection timeout." :: String)
-            )
-        Left (CaughtException e) -> do
-          Logger.log
-            lg
-            Logger.Warn
-            ( msg'
-                . field "action" actionString
-                . field "result" ("Caught exception : " ++ show e)
-            )
-        Right _ -> do
-          Logger.log
-            lg
-            Logger.Debug
-            ( msg'
-                . field "action" actionString
-                . field "result" ("Succeeded." :: String)
-            )
+  res <-
+    catches
+      action
+      [ Handler
+          ( \(e :: SMTPPoolException) ->
+              let resultLog = case e of
+                    SMTPUnauthorized -> ("Failed to establish connection, check your credentials." :: String)
+                    SMTPConnectionTimeout -> ("Connection timeout." :: String)
+               in ( Logger.log
+                      lg
+                      Logger.Warn
+                      ( msg'
+                          . field "action" actionString
+                          . field "result" resultLog
+                      )
+                      >> CE.throw e
+                  )
+          ),
+        Handler
+          ( \(e :: SomeException) -> do
+              Logger.log
+                lg
+                Logger.Warn
+                ( msg'
+                    . field "action" actionString
+                    . field "result" ("Caught exception : " ++ show e)
+                )
+              CE.throw e
+          )
+      ]
+  Logger.log
+    lg
+    Logger.Debug
+    ( msg'
+        . field "action" actionString
+        . field "result" ("Succeeded." :: String)
+    )
+  pure res
 
 -- | Default timeout for all actions
 --
@@ -220,11 +215,13 @@ defaultTimeoutDuration = 15 :: Second
 -- in this module a lot easier compared to having to deal with both, failure
 -- values and exceptions. (We cannot be sure which exceptions may arise as this
 -- depends on a stack of libraries...)
-ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m (Either SMTPFailure a)
+ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m a
 ensureSMTPConnectionTimeout timeoutDuration action =
-  catch
-    (maybe (Left ConnectionTimeout) Right <$> timeout timeoutDuration action)
-    (\(e :: SomeException) -> pure (Left (CaughtException e)))
+  timeout timeoutDuration action >>= \mbA ->
+    ( case mbA of
+        Just a -> pure a
+        Nothing -> CE.throw SMTPConnectionTimeout
+    )
 
 -- | Send a `Mail` via an existing `SMTP` connection pool
 --
@@ -243,9 +240,4 @@ sendMail' :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> Logger -> SMTP -> Mai
 sendMail' timeoutDuration lg s m = liftIO $ withResource (s ^. pool) sendMail''
   where
     sendMail'' :: SMTP.SMTPConnection -> IO ()
-    sendMail'' c = ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c) >>= handleError
-
-    handleError :: MonadIO m => Either SMTPFailure a -> m ()
-    handleError r =
-      logResult lg "Sending mail via SMTP" r
-        >> (void . throwOnLeft) r
+    sendMail'' c = logExceptionOrResult lg "Sending mail via SMTP" $ ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c)

From 6842b15f2657f739d126c6fa92028fd4f75f213d Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Tue, 22 Nov 2022 17:42:38 +0100
Subject: [PATCH 34/38] Cleanup

---
 services/brig/src/Brig/SMTP.hs | 55 ++++++++++++++++++----------------
 1 file changed, 30 insertions(+), 25 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index 71f3eedabd..e341e599a6 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -99,11 +99,15 @@ initSMTP' ::
   SMTPConnType ->
   IO SMTP
 initSMTP' timeoutDuration lg host port credentials connType = do
-  -- Try to initiate a connection and fail badly right away in case of bad auth
-  -- otherwise config errors will be detected "too late"
+  -- Try to initiate a connection and fail badly right away in case of bad auth.
+  -- Otherwise, config errors will be detected "too late".
   con <-
     catch
-      (logExceptionOrResult lg ("Checking test connection to " ++ unpack host ++ " on startup") establishConnection)
+      ( logExceptionOrResult
+          lg
+          ("Checking test connection to " ++ unpack host ++ " on startup")
+          establishConnection
+      )
       ( \(e :: SomeException) -> do
           -- Ensure that the logs are written: In case of failure, the errors thrown
           -- below will kill the app (which could otherwise leave the logs unwritten).
@@ -115,17 +119,19 @@ initSMTP' timeoutDuration lg host port credentials connType = do
         ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
     )
     ( \(e :: SomeException) -> do
+        -- Ensure that the logs are written: In case of failure, the errors thrown
+        -- below will kill the app (which could otherwise leave the logs unwritten).
         flush lg
         error $ "Failed to close test connection with SMTP server: " ++ show e
     )
   SMTP <$> createPool create destroy 1 5 5
   where
-    liftSMTP :: IO a -> IO a
-    liftSMTP action = ensureSMTPConnectionTimeout timeoutDuration action
+    ensureTimeout :: IO a -> IO a
+    ensureTimeout = ensureSMTPConnectionTimeout timeoutDuration
 
     establishConnection :: IO SMTP.SMTPConnection
     establishConnection = do
-      conn <- liftSMTP $ case (connType, port) of
+      conn <- ensureTimeout $ case (connType, port) of
         (Plain, Nothing) -> SMTP.connectSMTP (unpack host)
         (Plain, Just p) -> SMTP.connectSMTPPort (unpack host) p
         (TLS, Nothing) -> SMTP.connectSMTPSTARTTLS (unpack host)
@@ -138,7 +144,7 @@ initSMTP' timeoutDuration lg host port credentials connType = do
             SMTP.defaultSettingsSMTPSSL {SMTP.sslPort = p}
       ok <- case credentials of
         (Just (Username u, Password p)) ->
-          liftSMTP $
+          ensureTimeout $
             SMTP.authenticate SMTP.LOGIN (unpack u) (unpack p) conn
         _ -> pure True
       if ok
@@ -154,7 +160,8 @@ initSMTP' timeoutDuration lg host port credentials connType = do
 
     destroy :: SMTP.SMTPConnection -> IO ()
     destroy c =
-      logExceptionOrResult lg ("Closing pooled SMTP connection to " ++ unpack host) $ (ensureSMTPConnectionTimeout timeoutDuration . SMTP.gracefullyCloseSMTP) c
+      logExceptionOrResult lg ("Closing pooled SMTP connection to " ++ unpack host) $
+        (ensureTimeout . SMTP.gracefullyCloseSMTP) c
 
 logExceptionOrResult :: (MonadIO m, MonadCatch m) => Logger -> String -> m a -> m a
 logExceptionOrResult lg actionString action = do
@@ -163,19 +170,19 @@ logExceptionOrResult lg actionString action = do
     catches
       action
       [ Handler
-          ( \(e :: SMTPPoolException) ->
+          ( \(e :: SMTPPoolException) -> do
               let resultLog = case e of
-                    SMTPUnauthorized -> ("Failed to establish connection, check your credentials." :: String)
+                    SMTPUnauthorized ->
+                      ("Failed to establish connection, check your credentials." :: String)
                     SMTPConnectionTimeout -> ("Connection timeout." :: String)
-               in ( Logger.log
-                      lg
-                      Logger.Warn
-                      ( msg'
-                          . field "action" actionString
-                          . field "result" resultLog
-                      )
-                      >> CE.throw e
-                  )
+              Logger.log
+                lg
+                Logger.Warn
+                ( msg'
+                    . field "action" actionString
+                    . field "result" resultLog
+                )
+              CE.throw e
           ),
         Handler
           ( \(e :: SomeException) -> do
@@ -210,11 +217,7 @@ defaultTimeoutDuration = 15 :: Second
 -- | Wrapper function for `SMTP` network actions
 --
 -- This function ensures that @action@ finishes in a given period of time.
--- Additionally, all exceptions are caught and transformed into @Left
--- (CaughtException e)@. Staying in @Either SMTPFailure a@ makes error handling
--- in this module a lot easier compared to having to deal with both, failure
--- values and exceptions. (We cannot be sure which exceptions may arise as this
--- depends on a stack of libraries...)
+-- Throws on a timeout. Exceptions of @action@ are propagated (re-thrown).
 ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m a
 ensureSMTPConnectionTimeout timeoutDuration action =
   timeout timeoutDuration action >>= \mbA ->
@@ -240,4 +243,6 @@ sendMail' :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> Logger -> SMTP -> Mai
 sendMail' timeoutDuration lg s m = liftIO $ withResource (s ^. pool) sendMail''
   where
     sendMail'' :: SMTP.SMTPConnection -> IO ()
-    sendMail'' c = logExceptionOrResult lg "Sending mail via SMTP" $ ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c)
+    sendMail'' c =
+      logExceptionOrResult lg "Sending mail via SMTP" $
+        ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c)

From f509136e18c05890281b7757c809d1f2ebc58bcc Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Tue, 22 Nov 2022 18:21:57 +0100
Subject: [PATCH 35/38] Fix typo

---
 services/brig/src/Brig/SMTP.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index e341e599a6..f5661b11ef 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -109,7 +109,7 @@ initSMTP' timeoutDuration lg host port credentials connType = do
           establishConnection
       )
       ( \(e :: SomeException) -> do
-          -- Ensure that the logs are written: In case of failure, the errors thrown
+          -- Ensure that the logs are written: In case of failure, the error thrown
           -- below will kill the app (which could otherwise leave the logs unwritten).
           flush lg
           error $ "Failed to establish test connection with SMTP server: " ++ show e
@@ -119,7 +119,7 @@ initSMTP' timeoutDuration lg host port credentials connType = do
         ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
     )
     ( \(e :: SomeException) -> do
-        -- Ensure that the logs are written: In case of failure, the errors thrown
+        -- Ensure that the logs are written: In case of failure, the error thrown
         -- below will kill the app (which could otherwise leave the logs unwritten).
         flush lg
         error $ "Failed to close test connection with SMTP server: " ++ show e

From 40864e50c7fb3047c2e8bd6d60d1a710dcd6dff7 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 23 Nov 2022 10:41:59 +0100
Subject: [PATCH 36/38] Update services/brig/src/Brig/SMTP.hs

Co-authored-by: fisx <mf@zerobuzz.net>
---
 services/brig/src/Brig/SMTP.hs | 6 +-----
 1 file changed, 1 insertion(+), 5 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index f5661b11ef..d27b173e71 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -220,11 +220,7 @@ defaultTimeoutDuration = 15 :: Second
 -- Throws on a timeout. Exceptions of @action@ are propagated (re-thrown).
 ensureSMTPConnectionTimeout :: (MonadIO m, MonadCatch m, TimeUnit t) => t -> m a -> m a
 ensureSMTPConnectionTimeout timeoutDuration action =
-  timeout timeoutDuration action >>= \mbA ->
-    ( case mbA of
-        Just a -> pure a
-        Nothing -> CE.throw SMTPConnectionTimeout
-    )
+  timeout timeoutDuration action >>= maybe (CE.throw SMTPConnectionTimeout) pure
 
 -- | Send a `Mail` via an existing `SMTP` connection pool
 --

From d5d095acf447d7130898e52b4f13ea31f0c35f24 Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 23 Nov 2022 10:42:13 +0100
Subject: [PATCH 37/38] Update services/brig/src/Brig/SMTP.hs

Co-authored-by: fisx <mf@zerobuzz.net>
---
 services/brig/src/Brig/SMTP.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index d27b173e71..dbc60e3cec 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -212,7 +212,7 @@ logExceptionOrResult lg actionString action = do
 -- servers / network components aren't playing tricks to us. Other cases should
 -- be handled by the network libraries themselves.
 defaultTimeoutDuration :: Second
-defaultTimeoutDuration = 15 :: Second
+defaultTimeoutDuration = 15
 
 -- | Wrapper function for `SMTP` network actions
 --

From 869a934a30da7573328f436a695c71e1d127ca0e Mon Sep 17 00:00:00 2001
From: Sven Tennie <sven.tennie@wire.com>
Date: Wed, 23 Nov 2022 11:07:18 +0100
Subject: [PATCH 38/38] Reduce duplication in logging

---
 services/brig/src/Brig/SMTP.hs | 30 ++++++++----------------------
 1 file changed, 8 insertions(+), 22 deletions(-)

diff --git a/services/brig/src/Brig/SMTP.hs b/services/brig/src/Brig/SMTP.hs
index dbc60e3cec..86bc1a88dc 100644
--- a/services/brig/src/Brig/SMTP.hs
+++ b/services/brig/src/Brig/SMTP.hs
@@ -165,7 +165,6 @@ initSMTP' timeoutDuration lg host port credentials connType = do
 
 logExceptionOrResult :: (MonadIO m, MonadCatch m) => Logger -> String -> m a -> m a
 logExceptionOrResult lg actionString action = do
-  let msg' = msg ("SMTP connection result" :: String)
   res <-
     catches
       action
@@ -175,35 +174,22 @@ logExceptionOrResult lg actionString action = do
                     SMTPUnauthorized ->
                       ("Failed to establish connection, check your credentials." :: String)
                     SMTPConnectionTimeout -> ("Connection timeout." :: String)
-              Logger.log
-                lg
-                Logger.Warn
-                ( msg'
-                    . field "action" actionString
-                    . field "result" resultLog
-                )
+              doLog Logger.Warn resultLog
               CE.throw e
           ),
         Handler
           ( \(e :: SomeException) -> do
-              Logger.log
-                lg
-                Logger.Warn
-                ( msg'
-                    . field "action" actionString
-                    . field "result" ("Caught exception : " ++ show e)
-                )
+              doLog Logger.Warn ("Caught exception : " ++ show e)
               CE.throw e
           )
       ]
-  Logger.log
-    lg
-    Logger.Debug
-    ( msg'
-        . field "action" actionString
-        . field "result" ("Succeeded." :: String)
-    )
+  doLog Logger.Debug ("Succeeded." :: String)
   pure res
+  where
+    doLog :: MonadIO m => Logger.Level -> String -> m ()
+    doLog lvl result =
+      let msg' = msg ("SMTP connection result" :: String)
+       in Logger.log lg lvl (msg' . field "action" actionString . field "result" result)
 
 -- | Default timeout for all actions
 --