From 4e8a1d11e931e8a09871f357c3df725971fbefc3 Mon Sep 17 00:00:00 2001
From: nek0 <nek0@nek0.eu>
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