From 8dcdcae086e4701055a170806d8f62722c3172db Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Fri, 5 Oct 2018 12:30:39 +0200
Subject: [PATCH] More aggressive transaction commits & Cleanup

Fixes #198
---
 src/Foundation.hs |  1 +
 src/Jobs.hs       | 37 +++++++++++++++++++------------------
 src/Mail.hs       |  4 ++++
 3 files changed, 24 insertions(+), 18 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index dd304590b..4a9cbec87 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -1326,6 +1326,7 @@ instance YesodMail UniWorX where
   mailT ls mail = defMailT ls $ do 
     setMailObjectId
     setDateCurrent
+    replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
   
     ret <- mail
   
diff --git a/src/Jobs.hs b/src/Jobs.hs
index c3216513b..8ecbfde31 100644
--- a/src/Jobs.hs
+++ b/src/Jobs.hs
@@ -28,7 +28,7 @@ import qualified Data.Text.Lazy as LT
 
 import Data.Aeson (fromJSON, toJSON)
 import qualified Data.Aeson as Aeson
-import Database.Persist.Sql (executeQQ, fromSqlKey)
+import Database.Persist.Sql (executeQQ, fromSqlKey, transactionSave)
 
 import Data.Monoid (Last(..))
 import Control.Monad.Trans.Writer (WriterT(..), execWriterT)
@@ -78,8 +78,7 @@ handleJobs' = C.mapM_ $ void . handleAny ($logErrorS "Jobs" . tshow) . handleCmd
 jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
 jLocked jId act = do
   hasLock <- liftIO $ newTVarIO False
-  val <- runDB $ do
-    setSerializable
+  val <- runDB . setSerializable $ do
     j@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
     maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime
     case fromJSON queuedJobContent :: Aeson.Result Job of
@@ -97,8 +96,7 @@ jLocked jId act = do
   act val `finally` whenM (liftIO . atomically $ readTVar hasLock) jUnlock
   where
     jUnlock :: Handler ()
-    jUnlock = runDB $ do
-      setSerializable
+    jUnlock = runDB . setSerializable $
       update jId [ QueuedJobLockInstance =. Nothing
                  , QueuedJobLockTime =. Nothing
                  ]
@@ -110,25 +108,28 @@ writeJobCtl cmd = do
 
 queueJob :: Job -> YesodDB UniWorX QueuedJobId
 queueJob job = do
-  setSerializable
-  now <- liftIO getCurrentTime
-  self <- getsYesod appInstanceID
-  jId <- insert QueuedJob
-    { queuedJobContent = toJSON job
-    , queuedJobCreationInstance = self
-    , queuedJobCreationTime = now
-    , queuedJobLockInstance = Nothing
-    , queuedJobLockTime = Nothing
-    }
+  jId <- setSerializable $ do
+    now <- liftIO getCurrentTime
+    self <- getsYesod appInstanceID
+    insert QueuedJob
+      { queuedJobContent = toJSON job
+      , queuedJobCreationInstance = self
+      , queuedJobCreationTime = now
+      , queuedJobLockInstance = Nothing
+      , queuedJobLockTime = Nothing
+      }
   writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
   return jId
 
-setSerializable :: DB ()
-setSerializable = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
-
+setSerializable :: DB a -> DB a
+setSerializable act = do
+  transactionSave
+  [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|]
+  act <* transactionSave
 
 performJob :: Job -> WriterT (Last Bool) (HandlerT UniWorX IO) ()
 performJob JobSendNotification{ jNotification = NotificationSubmissionRated{..}, .. } = do
+  $logDebugS "Jobs" "NotificationSubmissionRated"
   fail "NotificationSubmissionRated not implemented yet" -- TODO
 performJob JobSendTestEmail{..} = do
   $logInfoS "Jobs" $ "Sending test-email to " <> jEmail
diff --git a/src/Mail.hs b/src/Mail.hs
index 2632bef80..08a121600 100644
--- a/src/Mail.hs
+++ b/src/Mail.hs
@@ -190,12 +190,14 @@ class YesodMail site where
   mailT :: ( MonadHandler m
            , HandlerSite m ~ site
            , MonadBaseControl IO m
+           , MonadLogger m
            ) => MailLanguages -> MailT m a -> m a
   mailT = defMailT
 
 defMailT :: ( MonadHandler m
             , YesodMail (HandlerSite m)
             , MonadBaseControl IO m
+            , MonadLogger m
             ) => MailLanguages -- ^ Languages in priority order
               -> MailT m a
               -> m a
@@ -203,6 +205,8 @@ defMailT ls (MailT mail) = do
   fromAddress <- defaultFromAddress
   (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
   mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
+  $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
+  $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
   ret <$ case smtpData of
     MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
     MailSmtpData{ smtpRecipients }