From 4e8a1d11e931e8a09871f357c3df725971fbefc3 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 31 Jul 2022 06:09:48 +0200 Subject: [PATCH] queue outgoing mails and send them asynchronously --- app/Main.hs | 8 +++++++- src/Types/Reader.hs | 4 ++++ src/Util.hs | 44 +++++++++++++++++++++++++++++++------------- 3 files changed, 42 insertions(+), 14 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 09f642d..63871e3 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -10,6 +10,9 @@ module Main where import Prelude as P +import Control.Concurrent.STM (newTQueueIO) +import Control.Concurrent (forkIO) + import Servant import Servant.Server.Experimental.Auth import qualified Servant.OpenApi as OA @@ -50,7 +53,7 @@ import System.Exit -- internal imports import API -import Util (initDB) +import Util (initDB, engageCourier) import Model as M import AppTypes @@ -123,6 +126,8 @@ main = do putStrLn "Migration validation success!" putStrLn "starting up..." forkCleanProcess conn store + mailQueue <- newTQueueIO + void $ forkIO $ engageCourier mailQueue sendmail_path withStdoutLogger $ \ilog -> do let settings = setPort (fromIntegral lport) $ setHost (fromString $ T.unpack lhost) $ @@ -136,6 +141,7 @@ main = do , rsCurrencyFraction = currency_fraction , rsSoftwareVersion = T.pack (showVersion version) , rsSendmailPath = sendmail_path + , rsMailQueue = mailQueue } expirationSpec = TimeSpec 5 0 -- five seconds throt = (defaultThrottleSettings expirationSpec) diff --git a/src/Types/Reader.hs b/src/Types/Reader.hs index 49d9d87..544de47 100644 --- a/src/Types/Reader.hs +++ b/src/Types/Reader.hs @@ -4,10 +4,13 @@ import qualified Data.Text as T import Servant (Handler) +import Control.Concurrent.STM (TQueue) import Control.Monad.Reader (ReaderT) import Database.PostgreSQL.Simple (Connection) +import Network.Mail.Mime (Mail) + -- internal imports import Types.Auth (TicketStore) @@ -19,6 +22,7 @@ data ReadState = ReadState , rsCurrencyFraction :: Word , rsSoftwareVersion :: T.Text , rsSendmailPath :: FilePath + , rsMailQueue :: TQueue Mail } type MateHandler = ReaderT ReadState Handler diff --git a/src/Util.hs b/src/Util.hs index bc37831..c5577e5 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -3,12 +3,16 @@ {-# LANGUAGE RecordWildCards #-} module Util where +import Control.Concurrent.STM (TQueue, tryReadTQueue, atomically, writeTQueue) +import Control.Concurrent (threadDelay) +import Control.Monad.Extra (whileM) + import Servant import Opaleye -import qualified Data.ByteString as BS import Data.ByteString.Lazy (fromStrict) +import Data.ByteString.Char8 (hPutStrLn) import Data.Maybe (fromMaybe, fromJust) @@ -22,15 +26,14 @@ import qualified Data.Text.Encoding as E import Database.PostgreSQL.Simple -import Control.Monad (void, filterM) +import Control.Monad (void, filterM, forever) import Control.Monad.Reader (asks) import Control.Monad.IO.Class (liftIO) import Network.Mail.Mime import System.Directory (doesFileExist) - -import System.Random.Stateful +import System.IO (stderr) -- internal imports @@ -146,15 +149,30 @@ sendAdminNotification subject message = do sendNotification :: Mail -> MateHandler () sendNotification mail = do - sendmailPath <- asks rsSendmailPath - liftIO $ do - existence <- doesFileExist sendmailPath - if existence - then - renderSendMailCustom sendmailPath [] mail - else - print ("Warning: sending notification failed: Sendmail not present!" - :: String) + mailQueue <- asks rsMailQueue + void $ liftIO $ atomically $ writeTQueue mailQueue mail + +engageCourier :: TQueue Mail -> FilePath -> IO () +engageCourier mailQueue sendmailPath = forever $ do + threadDelay (10 ^ (6 :: Int)) + whileM $ do + mEmail <- atomically $ tryReadTQueue mailQueue + case mEmail of + Just email -> do + sendEmail email sendmailPath + return True + Nothing -> + return False + +sendEmail :: Mail -> FilePath -> IO () +sendEmail email sendmailPath = do + existence <- doesFileExist sendmailPath + if existence + then + renderSendMailCustom sendmailPath [] email + else + hPutStrLn stderr "Error: sending notification failed: Sendmail not present!" + -- | throws a HTTP 401 error in case no auth token was provided when needed throwMissingAuth :: MateHandler a