queue outgoing mails and send them asynchronously

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)

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

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
+  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 [] mail
+    renderSendMailCustom sendmailPath [] email
   else
-      print ("Warning: sending notification failed: Sendmail not present!"
-        :: String)
+    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