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

fix(smtp): use full email with name in reply-to field

Browse Source
This commit is contained in:
Steffen Jost 2021-12-23 13:26:18 +01:00
parent 965d538dfb
commit 8cdc2b5267
2 changed files with 15 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/Jobs/Handler/SendCourseCommunication.hs
View File

@ -31,7 +31,7 @@ dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCours
MsgRenderer mr <- getMailMsgRenderer MsgRenderer mr <- getMailMsgRenderer
void $ setMailObjectUUID jMailObjectUUID void $ setMailObjectUUID jMailObjectUUID
_mailReplyTo .= (userAddressFrom sender ^. _addressEmail) _mailReplyTo .= userAddressFrom sender
addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|] addMailHeader "Cc" [st|#{mr MsgCommUndisclosedRecipients}:;|]
addMailHeader "Auto-Submitted" "no" addMailHeader "Auto-Submitted" "no"
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject

28
src/Mail.hs
View File

@ -32,7 +32,7 @@ module Mail
, setDate, setDateCurrent , setDate, setDateCurrent
, getMailSmtpData , getMailSmtpData
, _addressName, _addressEmail , _addressName, _addressEmail
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailHeaders, _mailHeader, _mailParts , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
, _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
) where ) where
@ -139,24 +139,24 @@ _partFilename = _partDisposition . dispositionFilename
_mailHeader :: CI ByteString -> Traversal' Mail Text _mailHeader :: CI ByteString -> Traversal' Mail Text
_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2 _mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
_mailReplyTo :: Lens' Mail Text _mailReplyTo' :: Lens' Mail Text
_mailReplyTo' = _mailHeaders . _headerReplyTo'
_headerReplyTo' :: Lens' Headers Text
-- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
_headerReplyTo' f hdrs = (\x -> insertAssoc (replyto,x) hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
where
replyto = "Reply-To"
_mailReplyTo :: Lens' Mail Address
_mailReplyTo = _mailHeaders . _headerReplyTo _mailReplyTo = _mailHeaders . _headerReplyTo
_headerReplyTo :: Lens' Headers Text _headerReplyTo :: Lens' Headers Address
-- Lens' [(ByteString, Text)] Text
-- Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
_headerReplyTo f hdrs = (\x -> insertAssoc (replyto,x) hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
where
replyto = "Reply-To"
-- _addressEmail :: Lens' Address Text
_headerReplyTo' :: Lens' Headers Address
-- Lens' [(ByteString, Text)] Address
-- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)] -- Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
_headerReplyTo' f hdrs = (\x -> insertAssoc (replyto,renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs) _headerReplyTo f hdrs = (\x -> insertAssoc (replyto,renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
where where
replyto = "Reply-To" replyto = "Reply-To"
-- _addressEmail :: Lens' Address Text might help to simplify this code?
newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a } newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus