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

View file

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

View file

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