bullet proof smtp (fix flaky test)

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.

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 = {

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);
 }

services/brig/brig.cabal

@@ -288,6 +288,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
@@ -464,6 +466,7 @@ executable brig-integration
     Federation.Util
     Index.Create
     Main
+    SMTP
     Util
     Util.AWS
 
@@ -553,13 +556,16 @@ executable brig-integration
     , lens-aeson
     , metrics-wai
     , mime                   >=0.4
+    , mime-mail
     , MonadRandom            >=0.5
     , mtl
     , network
     , optparse-applicative
     , pem
+    , pipes
     , polysemy
     , polysemy-wire-zoo
+    , postie                 >=0.6.0.3
     , process
     , proto-lens
     , QuickCheck
@@ -573,13 +579,15 @@ executable brig-integration
     , servant-client
     , servant-client-core
     , spar
+    , streaming-commons
     , string-conversions
     , tasty                  >=1.0
     , tasty-cannon           >=0.3.4
     , tasty-hunit            >=0.2
     , temporary              >=1.2.1
     , text
     , time                   >=1.5
+    , time-units
     , tinylog
     , transformers
     , types-common           >=0.3

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
@@ -116,6 +118,7 @@
 , ssl-util
 , statistics
 , stomp-queue
+, streaming-commons
 , string-conversions
 , swagger
 , swagger2
@@ -130,6 +133,8 @@
 , text
 , text-icu-translit
 , time
+, time-out
+, time-units
 , tinylog
 , transformers
 , types-common
@@ -267,6 +272,8 @@ mkDerivation {
     text
     text-icu-translit
     time
+    time-out
+    time-units
     tinylog
     transformers
     types-common
@@ -329,13 +336,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
@@ -349,13 +359,15 @@ mkDerivation {
     servant-client
     servant-client-core
     spar
+    streaming-commons
     string-conversions
     tasty
     tasty-cannon
     tasty-hunit
     temporary
     text
     time
+    time-units
     tinylog
     transformers
     types-common

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
 
 -------------------------------------------------------------------------------

services/brig/src/Brig/SMTP.hs

@@ -17,13 +17,28 @@
 -- 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,
+    sendMail',
+    initSMTP',
+    SMTPConnType (..),
+    SMTP (..),
+    Username (..),
+    Password (..),
+    SMTPPoolException (..),
+  )
+where
 
+import qualified Control.Exception as CE (throw)
 import Control.Lens
+import Control.Monad.Catch
+import Control.Timeout (timeout)
 import Data.Aeson
 import Data.Aeson.TH
 import Data.Pool
 import Data.Text (unpack)
+import Data.Time.Units
 import Imports
 import qualified Network.HaskellNet.SMTP as SMTP
 import qualified Network.HaskellNet.SMTP.SSL as SMTP
@@ -50,17 +65,73 @@ deriveJSON defaultOptions {constructorTagModifier = map toLower} ''SMTPConnType
 
 makeLenses ''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"
-  (success, _) <- connect
-  unless success $
-    error "Failed to authenticate against the SMTP server"
+data SMTPPoolException = SMTPUnauthorized | SMTPConnectionTimeout
+  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 ->
+  Maybe PortNumber ->
+  Maybe (Username, Password) ->
+  SMTPConnType ->
+  IO SMTP
+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".
+  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 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
+      )
+  catch
+    ( logExceptionOrResult lg "Closing test connection on startup" $
+        ensureSMTPConnectionTimeout timeoutDuration (SMTP.gracefullyCloseSMTP con)
+    )
+    ( \(e :: SomeException) -> do
+        -- 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
+    )
   SMTP <$> createPool create destroy 1 5 5
   where
-    connect = do
-      conn <- case (connType, port) of
+    ensureTimeout :: IO a -> IO a
+    ensureTimeout = ensureSMTPConnectionTimeout timeoutDuration
+
+    establishConnection :: IO SMTP.SMTPConnection
+    establishConnection = do
+      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)
@@ -72,18 +143,88 @@ 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)) ->
+          ensureTimeout $
+            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
-    destroy c = do
-      SMTP.closeSMTP c
-      Logger.log lg Logger.Debug (msg $ val "Closing connection to: " +++ host)
-
-sendMail :: MonadIO m => SMTP -> Mail -> m ()
-sendMail s m = liftIO $ withResource (s ^. pool) $ SMTP.sendMail m
+        then pure conn
+        else CE.throw SMTPUnauthorized
+
+    create :: IO SMTP.SMTPConnection
+    create =
+      logExceptionOrResult
+        lg
+        ("Creating pooled SMTP connection to " ++ unpack host)
+        establishConnection
+
+    destroy :: SMTP.SMTPConnection -> IO ()
+    destroy 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
+  res <-
+    catches
+      action
+      [ Handler
+          ( \(e :: SMTPPoolException) -> do
+              let resultLog = case e of
+                    SMTPUnauthorized ->
+                      ("Failed to establish connection, check your credentials." :: String)
+                    SMTPConnectionTimeout -> ("Connection timeout." :: String)
+              doLog Logger.Warn resultLog
+              CE.throw e
+          ),
+        Handler
+          ( \(e :: SomeException) -> do
+              doLog Logger.Warn ("Caught exception : " ++ show e)
+              CE.throw e
+          )
+      ]
+  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
+--
+-- 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
+
+-- | Wrapper function for `SMTP` network actions
+--
+-- This function ensures that @action@ finishes in a given period of time.
+-- 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 >>= maybe (CE.throw SMTPConnectionTimeout) pure
+
+-- | 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 = 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 =
+      logExceptionOrResult lg "Sending mail via SMTP" $
+        ensureSMTPConnectionTimeout timeoutDuration (SMTP.sendMail m c)