queue outgoing mails and send them asynchronously

This commit is contained in:
nek0 2022-07-31 06:09:48 +02:00
parent fbd4ab48e8
commit 4e8a1d11e9
3 changed files with 42 additions and 14 deletions

View File

@ -10,6 +10,9 @@ module Main where
import Prelude as P import Prelude as P
import Control.Concurrent.STM (newTQueueIO)
import Control.Concurrent (forkIO)
import Servant import Servant
import Servant.Server.Experimental.Auth import Servant.Server.Experimental.Auth
import qualified Servant.OpenApi as OA import qualified Servant.OpenApi as OA
@ -50,7 +53,7 @@ import System.Exit
-- internal imports -- internal imports
import API import API
import Util (initDB) import Util (initDB, engageCourier)
import Model as M import Model as M
import AppTypes import AppTypes
@ -123,6 +126,8 @@ main = do
putStrLn "Migration validation success!" putStrLn "Migration validation success!"
putStrLn "starting up..." putStrLn "starting up..."
forkCleanProcess conn store forkCleanProcess conn store
mailQueue <- newTQueueIO
void $ forkIO $ engageCourier mailQueue sendmail_path
withStdoutLogger $ \ilog -> do withStdoutLogger $ \ilog -> do
let settings = setPort (fromIntegral lport) $ let settings = setPort (fromIntegral lport) $
setHost (fromString $ T.unpack lhost) $ setHost (fromString $ T.unpack lhost) $
@ -136,6 +141,7 @@ main = do
, rsCurrencyFraction = currency_fraction , rsCurrencyFraction = currency_fraction
, rsSoftwareVersion = T.pack (showVersion version) , rsSoftwareVersion = T.pack (showVersion version)
, rsSendmailPath = sendmail_path , rsSendmailPath = sendmail_path
, rsMailQueue = mailQueue
} }
expirationSpec = TimeSpec 5 0 -- five seconds expirationSpec = TimeSpec 5 0 -- five seconds
throt = (defaultThrottleSettings expirationSpec) throt = (defaultThrottleSettings expirationSpec)

View File

@ -4,10 +4,13 @@ import qualified Data.Text as T
import Servant (Handler) import Servant (Handler)
import Control.Concurrent.STM (TQueue)
import Control.Monad.Reader (ReaderT) import Control.Monad.Reader (ReaderT)
import Database.PostgreSQL.Simple (Connection) import Database.PostgreSQL.Simple (Connection)
import Network.Mail.Mime (Mail)
-- internal imports -- internal imports
import Types.Auth (TicketStore) import Types.Auth (TicketStore)
@ -19,6 +22,7 @@ data ReadState = ReadState
, rsCurrencyFraction :: Word , rsCurrencyFraction :: Word
, rsSoftwareVersion :: T.Text , rsSoftwareVersion :: T.Text
, rsSendmailPath :: FilePath , rsSendmailPath :: FilePath
, rsMailQueue :: TQueue Mail
} }
type MateHandler = ReaderT ReadState Handler type MateHandler = ReaderT ReadState Handler

View File

@ -3,12 +3,16 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
module Util where module Util where
import Control.Concurrent.STM (TQueue, tryReadTQueue, atomically, writeTQueue)
import Control.Concurrent (threadDelay)
import Control.Monad.Extra (whileM)
import Servant import Servant
import Opaleye import Opaleye
import qualified Data.ByteString as BS
import Data.ByteString.Lazy (fromStrict) import Data.ByteString.Lazy (fromStrict)
import Data.ByteString.Char8 (hPutStrLn)
import Data.Maybe (fromMaybe, fromJust) import Data.Maybe (fromMaybe, fromJust)
@ -22,15 +26,14 @@ import qualified Data.Text.Encoding as E
import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple
import Control.Monad (void, filterM) import Control.Monad (void, filterM, forever)
import Control.Monad.Reader (asks) import Control.Monad.Reader (asks)
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Network.Mail.Mime import Network.Mail.Mime
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import System.IO (stderr)
import System.Random.Stateful
-- internal imports -- internal imports
@ -146,15 +149,30 @@ sendAdminNotification subject message = do
sendNotification :: Mail -> MateHandler () sendNotification :: Mail -> MateHandler ()
sendNotification mail = do sendNotification mail = do
sendmailPath <- asks rsSendmailPath mailQueue <- asks rsMailQueue
liftIO $ do void $ liftIO $ atomically $ writeTQueue mailQueue mail
existence <- doesFileExist sendmailPath
if existence engageCourier :: TQueue Mail -> FilePath -> IO ()
then engageCourier mailQueue sendmailPath = forever $ do
renderSendMailCustom sendmailPath [] mail threadDelay (10 ^ (6 :: Int))
else whileM $ do
print ("Warning: sending notification failed: Sendmail not present!" mEmail <- atomically $ tryReadTQueue mailQueue
:: String) 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 -- | throws a HTTP 401 error in case no auth token was provided when needed
throwMissingAuth :: MateHandler a throwMissingAuth :: MateHandler a