Dates in emails

src/Foundation.hs

@@ -1292,6 +1292,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 instance YesodMail UniWorX where
   defaultFromAddress = getsYesod $ appMailFrom . appSettings
   mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
+  mailDateTZ = return appTZ
 
 
 instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where

src/Mail.hs

@@ -31,6 +31,7 @@ module Mail
   , replaceMailHeader, addMailHeader, removeMailHeader
   , replaceMailHeaderI, addMailHeaderI
   , setSubjectI, setMailObjectId, setMailObjectId'
+  , setDateCurrent
   , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
   , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
   ) where
@@ -73,6 +74,10 @@ import GHC.TypeLits (KnownSymbol)
 
 import Network.BSD (getHostName)
 
+import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
+import Data.Time.LocalTime (ZonedTime(..))
+import Data.Time.Format
+
 
 makeLenses_ ''Mail
 makeLenses_ ''Part
@@ -108,6 +113,9 @@ class YesodMail site where
   mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
   mailObjectIdDomain = pack <$> liftIO getHostName
 
+  mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
+  mailDateTZ = return utcTZ
+
 mailT :: ( MonadHandler m
          , YesodMail (HandlerSite m)
          ) => [Text] -- ^ Languages in priority order
@@ -241,3 +249,11 @@ setMailObjectId' :: ( MonadHandler m
                     , Binary plain
                     ) => plain -> MailT m MailObjectId
 setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
+
+
+setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
+setDateCurrent = do
+  now <- liftIO getCurrentTime
+  tz <- mailDateTZ
+  let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz now) (timeZoneForUTCTime tz now)
+  replaceMailHeader "Date" . Just $ pack timeStr