Added mandatory Date: header to E-Mail (why doesn't the library do that?)

This commit is contained in:
Dennis Frieberg 2025-06-06 20:39:28 +02:00
parent 72e53eea4f
commit 4c54800b98
Signed by: nerf
GPG key ID: 7C58AFED036072C5

View file

@ -1,19 +1,32 @@
{-# LANGUAGE OverloadedStrings #-}
module Sender where
module Sender
(generateMail
,send
) where
import Network.Mail.Mime
import Network.Mail.SMTP
import qualified Data.Text as ST
import qualified Data.Text.Lazy as LT
import Monad
import Control.Monad.IO.Class
import Data.Time.LocalTime (getZonedTime)
import Data.Time.Format (TimeLocale, formatTime, defaultTimeLocale)
rfc5322Format :: String
rfc5322Format = "%a, %d %b %0Y %T %z"
generateMail :: ST.Text -> ST.Text -> ST.Text -> LT.Text -> Mail
generateMail to from subj = simpleMail' (Address Nothing to) (Address Nothing from) subj
generateMail :: (MonadIO m) => ST.Text -> ST.Text -> ST.Text -> LT.Text -> m Mail
generateMail to from subj body = do
time <- liftIO getZonedTime
let timeString = ST.pack $ formatTime defaultTimeLocale rfc5322Format time
mailWithoutDate = simpleMail' (Address Nothing to) (Address Nothing from) subj body
mailWithDate = mailWithoutDate {mailHeaders = ("Date",timeString) : mailHeaders mailWithoutDate}
return mailWithDate
-- domain -> Username -> password -> To -> From -> Subject -> Body
send :: (MonadIO m) => String -> String -> String -> ST.Text -> ST.Text -> ST.Text -> LT.Text -> m ()
send domain user pass to from subj body = liftIO $ sendMailWithLoginTLS domain user pass mail
where
mail = generateMail to from subj body
send domain user pass to from subj body = do
mail <- liftIO $ generateMail to from subj body
liftIO $ sendMailWithLoginTLS domain user pass mail