fix(email): instead of sender set reply-to only

src/Jobs/Handler/SendCourseCommunication.hs

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

src/Mail.hs

@@ -32,7 +32,7 @@ module Mail
   , setDate, setDateCurrent
   , getMailSmtpData
   , _addressName, _addressEmail
-  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailHeaders, _mailHeader, _mailParts
   , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
   ) where
 
@@ -71,7 +71,7 @@ import qualified Data.Text.Lazy.Builder as LTB
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString as BS
 
-import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue)
+import Utils (MsgRendererS(..), MonadSecretBox(..), YamlValue, maybeMonoid, insertAssoc)
 import Utils.Lens.TH
 
 import Control.Lens hiding (from)
@@ -139,6 +139,24 @@ _partFilename = _partDisposition . dispositionFilename
 _mailHeader :: CI ByteString -> Traversal' Mail Text
 _mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
 
+_mailReplyTo :: Lens' Mail Text 
+_mailReplyTo = _mailHeaders . _headerReplyTo
+
+_headerReplyTo :: Lens' Headers Text 
+--                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)]
+_headerReplyTo' f hdrs = (\x -> insertAssoc (replyto,renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
+  where 
+    replyto = "Reply-To"        
+
 
 newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
   deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus

src/Utils.hs

@@ -522,7 +522,6 @@ lastMaybe' l = fmap snd $ l ^? _Snoc
 
 -- | Merge/Add any attribute-value pair to an existing list of such pairs.
 --   If the attribute exists, the new valu will be prepended, separated by a single empty space
---   Also see `Utils.mergeAttrs`
 insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
 insertAttr attr valu = aux
   where
@@ -531,7 +530,34 @@ insertAttr attr valu = aux
     aux (p@(a,v) : t)
       | attr==a   = (a, Text.append valu $ Text.cons ' ' v) : t
       | otherwise = p : aux t
+--  Could be implemented using updateAssoc like so, but would add superfluous space at the end:
+--  insertAttr attr valu = updateAssoc (Text.append valu . Text.cons ' ') attr 
 
+-- | Insert key-value pair into association list.
+--   If the key is already present, then the old associated values is replaced by the new one.
+--   Note: better use Data.Map instead of association lists, but 
+--   some libraries use association lists efficiently for a small number of keys.
+--   Use in conjunction with Prelude.lookup
+insertAssoc :: Eq k => (k,v) -> [(k,v)] -> [(k,v)]
+insertAssoc kv@(key,_) = aux 
+  where 
+    aux [] = [kv]    
+    aux (p@(k,_) : t)
+      | key==k    = kv :     t
+      | otherwise =  p : aux t
+
+-- | Update a value within an association list.
+--   If the key is not present, the update function is applied to mempty.
+--   Note: better use Data.Map instead of association lists, but 
+--   some libraries use association lists efficiently for a small number of keys.
+--   Use in conjunction with Prelude.lookup
+updateAssoc :: (Eq k, Monoid v) => (v -> v) -> k -> [(k,v)] -> [(k,v)]
+updateAssoc upd key = aux 
+  where 
+    aux [] = [(key, upd mempty)]
+    aux (p@(k,v) : t)
+      | key == k  = (k, upd v) :     t
+      | otherwise =   p        : aux t
 
 -- | Copied form Util from package ghc
 partitionWith :: (a -> Either b c) -> [a] -> ([b], [c])