From 8cf39dcbe68cefcc50691ae8a7194315d18420d6 Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 5 Nov 2020 11:05:36 +0100
Subject: [PATCH] fix(mails): prevent emails being resent to due archiving
 errors

---
 src/Foundation/Instances.hs | 13 ++++++++-----
 1 file changed, 8 insertions(+), 5 deletions(-)

diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs
index cf56e7b5e..362af9d60 100644
--- a/src/Foundation/Instances.hs
+++ b/src/Foundation/Instances.hs
@@ -255,7 +255,7 @@ instance YesodMail UniWorX where
         return mRes
 
     (smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
-    liftHandler . runDB . setSerializable $ do
+    void . tryAny . liftHandler . runDB . setSerializable $ do -- Ignore exceptions that occur during logging
       sentMailRecipient <- if
         | [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
             recipUsers <- E.select . E.from $ \user -> do
@@ -275,11 +275,14 @@ instance YesodMail UniWorX where
               | otherwise -> Nothing
         | otherwise -> return Nothing
 
-      void $ insertUnique SentMailContent{ sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
-                                         , sentMailContentContent
-                                         }
+      -- @insertUnique@ _does not_ work here
+      unlessM (exists [ SentMailContentHash ==. unSentMailContentKey (sentMailContentRef sentMail) ]) $
+        insert_ SentMailContent { sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
+                                , sentMailContentContent
+                                }
       insert_ sentMail{ sentMailRecipient }
-      wait mailProcess
+      wait mailProcess -- Abort transaction if sending failed
+    wait mailProcess -- Rethrow exceptions for mailprocess; technically unnecessary due to linkage, doesn't hurt, though
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
   type MonadCryptoKey m = CryptoIDKey