diff --git a/changelog.d/2-features/smtp-logging b/changelog.d/2-features/smtp-logging new file mode 100644 index 00000000000..496d0aebdd2 --- /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. diff --git a/nix/haskell-pins.nix b/nix/haskell-pins.nix index 87875e4e3ac..ce404aa2326 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 0cecced5165..1d5e8c8a448 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 3f3dd9b1d7b..1c508ba9929 100644 --- a/services/brig/brig.cabal +++ b/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,6 +579,7 @@ executable brig-integration , servant-client , servant-client-core , spar + , streaming-commons , string-conversions , tasty >=1.0 , tasty-cannon >=0.3.4 @@ -580,6 +587,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/default.nix b/services/brig/default.nix index cb9aa3523dc..b67ec42e530 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 @@ -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,6 +359,7 @@ mkDerivation { servant-client servant-client-core spar + streaming-commons string-conversions tasty tasty-cannon @@ -356,6 +367,7 @@ mkDerivation { temporary text time + time-units tinylog transformers types-common diff --git a/services/brig/src/Brig/Email.hs b/services/brig/src/Brig/Email.hs index 00ce2c1ce4f..26faabe6344 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 920752199b6..9267b827609 100644 --- a/services/brig/src/Brig/SMTP.hs +++ b/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 . -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, or 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 on 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) diff --git a/services/brig/src/Brig/User/Email.hs b/services/brig/src/Brig/User/Email.hs index 73063a10c94..5d200af829c 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 -> diff --git a/services/brig/test/integration/Main.hs b/services/brig/test/integration/Main.hs index 7fab864c0a8..dea31d0ff6d 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 @@ -151,9 +152,9 @@ runTests iConf brigOpts otherArgs = do includeFederationTests <- (== Just "1") <$> Blank.getEnv "INTEGRATION_FEDERATION_TESTS" internalApi <- API.Internal.tests brigOpts mg db b (brig iConf) gd g - 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 @@ -176,7 +177,8 @@ runTests iConf brigOpts otherArgs = do federationEndpoints, internalApi, versionApi, - mlsApi + mlsApi, + smtp ] <> [federationEnd2End | includeFederationTests] where diff --git a/services/brig/test/integration/SMTP.hs b/services/brig/test/integration/SMTP.hs new file mode 100644 index 00000000000..02a5108f1e7 --- /dev/null +++ b/services/brig/test/integration/SMTP.hs @@ -0,0 +1,234 @@ +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} + +module SMTP where + +import qualified Bilge +import Brig.SMTP +import Control.Exception +import Data.Bifunctor +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Streaming.Network (bindRandomPortTCP) +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 + +tests :: Bilge.Manager -> Logger.Logger -> TestTree +tests m 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, + test m "should throw when sending times out" $ testSendMailTimeout lg, + test m "should throw an error the initiation times out" $ testSendMailTimeoutOnStartup lg + ] + +testSendMail :: Logger.Logger -> Bilge.Http () +testSendMail lg = do + receivedMailRef <- liftIO $ newIORef Nothing + liftIO + . withRandomPortAndSocket + $ \(port, sock) -> + withMailServer sock (mailStoringApp receivedMailRef) $ + do + conPool <- initSMTP lg "localhost" (Just port) Nothing Plain + sendMail lg conPool someTestMail + mbMail <- + retryWhileN 3 isJust $ do + readIORef receivedMailRef + isJust mbMail @? "Expected to receive mail" + postieAddressAsString . rmSender <$> mbMail + @=? (Just . unpack . addressEmail) someTestSender + postieAddressAsString <$> (concat . maybeToList) (rmReceipients <$> mbMail) + @=? [(unpack . addressEmail) someTestReceiver] + let mailContent = (rmContent . fromJust) mbMail + 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 + postieAddressAsString :: Postie.Address -> String + postieAddressAsString addr = + toString + ( B.concat + [ Postie.addressLocalPart addr, + C.singleton '@', + Postie.addressDomain addr + ] + ) + +testSendMailNoReceiver :: Logger.Logger -> Bilge.Http () +testSendMailNoReceiver lg = do + receivedMailRef <- liftIO $ newIORef Nothing + liftIO + . withRandomPortAndSocket + $ \(port, sock) -> + withMailServer sock (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 + liftIO + . withRandomPortAndSocket + $ \(port, sock) -> + withMailServer sock 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, sock) <- liftIO $ openRandomPortAndSocket + liftIO $ gracefulClose sock 1000 + 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 + receivedMailRef <- liftIO $ newIORef Nothing + conPool <- + liftIO $ + withRandomPortAndSocket $ + \(port, sock) -> + withMailServer + sock + (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 + mbException <- + liftIO $ + withRandomPortAndSocket $ + \(port, sock) -> + withMailServer sock (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 + mbException <- + liftIO $ + withRandomPortAndSocket $ + \(port, sock) -> + everDelayingTCPServer sock $ + 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" + +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 + +withMailServer :: Socket -> Postie.Application -> IO a -> IO a +withMailServer s app action = do + bracket + (forkIO $ Postie.runSettingsSocket Postie.def s app) + killThread + (const 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 + 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 + +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 + $> Postie.Accepted + ) + +everDelayingTCPServer :: HasCallStack => Socket -> IO a -> IO a +everDelayingTCPServer sock action = listen sock 1024 >> action + +withRandomPortAndSocket :: MonadIO m => ((PortNumber, Socket) -> IO a) -> m a +withRandomPortAndSocket action = + liftIO $ + bracket + (liftIO $ openRandomPortAndSocket) + (\(_, s) -> liftIO $ close s) + (\(p, s) -> action (p, s)) + +openRandomPortAndSocket :: IO (PortNumber, Socket) +openRandomPortAndSocket = bindRandomPortTCP "*6" <&> \x -> first fromIntegral x