From 9ba7a82449c72009124625b513574be53322b513 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Mon, 10 Mar 2025 11:41:48 +0100 Subject: [PATCH] fix(mail): fix #2979 by completing simple mail resent function --- .../uniworx/categories/print/de-de-formal.msg | 5 +- messages/uniworx/categories/print/en-eu.msg | 5 +- src/Handler/MailCenter.hs | 51 ++++++++++--------- src/Mail.hs | 1 + 4 files changed, 35 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 0a6f96a23..df4a729fb 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -28,5 +28,8 @@ PrintLmsUser: E‑Learning Id PrintJobs: Druckaufräge PrintLetterType: Brieftypkürzel -MCActDummy: Platzhalter +MCActResendEmail: E‑Mail Kopie versenden +MCActResendEmailTooltip: Eine unveränderte Kopie der E‑Mail erneut versenden. Nur die vorherigen Empfänger werden offiziell aufgeführt, sie erhalten jedoch keine neue Kopie. +MCActResendEmailInfo n@Int recv@Text: #{pluralDEnN n "E‑Mail Kopie"} wurden an #{recv} versandt. + CCActDummy: Platzhalter \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index b722f9d32..11b58c159 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -28,5 +28,8 @@ PrintLmsUser: E‑learning id PrintJobs: Print jobs PrintLetterType: Letter type shorthand -MCActDummy: Placeholder +MCActResendEmail: Resend email copy +MCActResendEmailTooltip: Resend an unchanged copy of the email. Only previous recipients will officially be listed, but they will not receive another copy. +MCActResendEmailInfo n recv: #{n} #{noneOneMoreEN n "email copy" "email copy" "email copies"} were sent to #{recv} only. + CCActDummy: Placeholder \ No newline at end of file diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 70792a07d..d7d489c20 100644 --- a/src/Handler/MailCenter.hs +++ b/src/Handler/MailCenter.hs @@ -41,7 +41,7 @@ import qualified Data.ByteString.Lazy as LB import Handler.Utils -data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing +data MCTableAction = MCActResendEmail deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe MCTableAction @@ -49,25 +49,26 @@ instance Finite MCTableAction nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''MCTableAction id -data MCTableActionData = MCActDummyData +newtype MCTableActionData = MCActResendEmailData UserEmail deriving (Eq, Ord, Read, Show, Generic) resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler () resendMailTo recv smids = do - mails <- runDBRead $ E.select $ do - (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId) - E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids - return (sm, smc) - -- recvName <- fmap userDisplayName $ getByFilter $ [UserEmail ==. recv] ||. [UserDisplayEmail ==. rev] + (recvName, mails) <- runDBRead $ (,) + <$> (userDisplayName . entityVal <<$>> getByFilter ([UserEmail ==. recv] ||. [UserDisplayEmail ==. recv])) + <*> E.select (do + (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId) + E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids + return (sm, smc) + ) forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do let mailParts = getMailContent content - mailTo = [Address{addressName = Nothing, addressEmail = ciOriginal recv}] + mailTo = [] mailCc = [] - mailBcc = [] - mailFrom = error "not used" -- :: Address - -- continue here: delete some weird outdated headers - mailHeaders = toHeaders sentMailHeaders -- :: Headers + mailBcc = [Address{addressName = recvName, addressEmail = ciOriginal recv}] + mailFrom = error "Handler.MailCenter.resenMailTo: mailFrom not replaced by sendSimpleMail" -- :: Address -- will be filled in later by sendSimpleMail + mailHeaders = toHeaders sentMailHeaders -- :: Headers -- keep as it was? Includes To/Cc/Bcc sendSimpleMail Mail{..} @@ -145,17 +146,16 @@ mkMCTable = do { dbParamsFormMethod = POST , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] - , dbParamsFormSubmit = FormNoSubmit - , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) - -- , dbParamsFormSubmit = FormSubmit - -- , dbParamsFormAdditional - -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) - -- acts = mconcat - -- [ singletonMap MCActDummy $ pure MCActDummyData - -- ] - -- in renderAForm FormStandard - -- $ (, mempty) . First . Just - -- <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormSubmit = FormSubmit + , dbParamsFormAdditional + = let acts :: Map MCTableAction (AForm Handler MCTableActionData) + acts = mconcat + [ singletonMap MCActResendEmail $ MCActResendEmailData + <$> areq (emailField & cfStrip & cfCI) (fslI MsgMCActResendEmail & setTooltip MsgMCActResendEmailTooltip) Nothing + ] + in renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def @@ -174,8 +174,9 @@ getMailCenterR = postMailCenterR postMailCenterR = do (mcRes, mcTable) <- runDB mkMCTable formResult mcRes $ \case - (MCActDummyData, Set.toList -> _smIds) -> do - addMessageI Success MsgBoolIrrelevant + (MCActResendEmailData recv, smIds) -> do + resendMailTo recv smIds + addMessageI (bool Success Error $ null smIds) $ MsgMCActResendEmailInfo (Set.size smIds) (ciOriginal recv) reloadKeepGetParams MailCenterR siteLayoutMsg MsgMenuMailCenter $ do setTitleI MsgMenuMailCenter diff --git a/src/Mail.hs b/src/Mail.hs index 61eeab90c..90b2591a7 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -375,6 +375,7 @@ defMailT ls (MailT mailC) = do mail3 conn +-- | sends an email as it is, no changes except mailFrom sendSimpleMail :: ( MonadHandler m , YesodMail (HandlerSite m) , MonadUnliftIO m