fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(mails): prevent emails being resent to due archiving errors

Browse Source
This commit is contained in:
Gregor Kleen 2020-11-05 11:05:36 +01:00
parent 9ef9a7fcbb
commit 8cf39dcbe6
1 changed files with 8 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
src/Foundation/Instances.hs
View File

@ -255,7 +255,7 @@ instance YesodMail UniWorX where
return mRes return mRes
(smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord (smtpRecipients, sentMailContentContent, sentMail) <- atomically $ takeTMVar mailRecord
liftHandler . runDB . setSerializable $ do void . tryAny . liftHandler . runDB . setSerializable $ do -- Ignore exceptions that occur during logging
sentMailRecipient <- if sentMailRecipient <- if
| [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do | [Address _ (CI.mk -> recipAddr)] <- smtpRecipients -> do
recipUsers <- E.select . E.from $ \user -> do recipUsers <- E.select . E.from $ \user -> do
@ -275,11 +275,14 @@ instance YesodMail UniWorX where
| otherwise -> Nothing | otherwise -> Nothing
| otherwise -> return Nothing | otherwise -> return Nothing
void $ insertUnique SentMailContent{ sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail -- @insertUnique@ _does not_ work here
, sentMailContentContent unlessM (exists [ SentMailContentHash ==. unSentMailContentKey (sentMailContentRef sentMail) ]) $
} insert_ SentMailContent { sentMailContentHash = unSentMailContentKey $ sentMailContentRef sentMail
, sentMailContentContent
}
insert_ sentMail{ sentMailRecipient } 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 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
type MonadCryptoKey m = CryptoIDKey type MonadCryptoKey m = CryptoIDKey