-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE GeneralizedNewtypeDeriving
           , UndecidableInstances
  #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module Mail
  ( -- * Structured MIME emails
    module Network.Mail.Mime
    -- * MailT
  , MailT, defMailT
  , MailSmtpData(..), _smtpEnvelopeFrom, _smtpRecipients
  , _MailSmtpDataSet
  , MailContext(..)
  , MonadMail(..)
  , getMailMessageRender, getMailMsgRenderer
    -- * YesodMail
  , YesodMail(..)
  , MailException(..)
    -- * Monadically constructing Mail
  , PrioritisedAlternatives
  , ToMailPart(..)
  , NamedMailPart(..)
  , addAlternatives, provideAlternative, providePreferredAlternative
  , addPart, addPart', modifyPart, partIsAttachment
  , MonadHeader(..)
  , MailHeader
  , MailObjectId
  , replaceMailHeader, addMailHeader, removeMailHeader, getMailHeaders, lookupMailHeader, mapMailHeader
  , replaceMailHeaderI, addMailHeaderI
  , setSubjectI, mapSubject
  , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
  , getMailObjectId
  , setDate, setDateCurrent
  , getMailSmtpData
  , _addressName, _addressEmail
  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
  , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
  ) where

import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)

import Data.Kind (Type)

import Model.Types.Languages
import Model.Types.Csv
import Model.Types.File

import Network.Mail.Mime hiding (addPart, addAttachment)
import qualified Network.Mail.Mime as Mime (addPart)

import Settings.Mime

import Data.Monoid (Last(..))
-- import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.RWS (RWST(..))
import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
import Control.Monad.Trans.Writer (execWriter, execWriterT, Writer)
import Control.Monad.RWS.Class (MonadWriter(..), MonadState(..), modify)
import Control.Monad.Fail
import Control.Monad.Base
import Control.Monad.Catch

import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import qualified Data.Sequence as Seq

import qualified Data.Set as Set

import qualified Data.Foldable as Foldable

import qualified Data.Text as Text
import qualified Data.Text.Lazy as LT
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, maybeMonoid, insertAssoc, maybeT, guardM, adjustAssoc)
import Utils.Lens.TH

import Control.Lens hiding (from)
import Control.Lens.Extras (is)

import Text.Blaze.Renderer.Utf8

import Data.UUID (UUID)
import qualified Data.UUID as UUID
import Data.UUID.Cryptographic.ImplicitNamespace

import Data.Binary (Binary)
import qualified Data.Binary as Binary

import "network-bsd" Network.BSD (getHostName)

import Data.Time.Zones (utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
import Data.Time.LocalTime (ZonedTime(..), TimeZone(..), utcToZonedTime, utc)
import Data.Time.Format (rfc822DateFormat)

import Network.HaskellNet.SMTP (SMTPConnection)
import qualified Network.HaskellNet.SMTP as SMTP

import qualified Text.Hamlet as Hamlet (Translate)
import qualified Text.Shakespeare as Shakespeare (RenderUrl)

import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Yaml as Yaml
import Data.Aeson.TH
import Utils.PathPiece (splitCamel)
import Utils.DateTime

import Data.Universe.Instances.Reverse ()
import Data.Universe.Instances.Reverse.JSON ()
import Data.Universe.Instances.Reverse.Hashable ()

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI

import Control.Monad.Random (MonadRandom(..))
import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
import qualified Data.ByteArray as ByteArray (convert)
import Crypto.MAC.KMAC (KMAC)
import qualified Crypto.MAC.KMAC as KMAC
import Crypto.Hash.Algorithms (SHAKE128)

import Language.Haskell.TH (nameBase)

import Network.Mail.Mime.Instances()

import Data.Char (isLatin1)
import Data.Text.Lazy.Encoding (decodeUtf8')
import System.FilePath (takeFileName)
import Network.HTTP.Types.Header (hETag)
import Web.HttpApiData (ToHttpApiData(toHeader))


makeLenses_ ''Address
makeLenses_ ''Mail
makeLenses_ ''Part

_partFilename :: Traversal' Part Text
_partFilename = _partDisposition . dispositionFilename
  where
    dispositionFilename :: Traversal' Disposition Text
    dispositionFilename f (AttachmentDisposition t) = AttachmentDisposition <$> f t
    dispositionFilename f (InlineDisposition     t) = InlineDisposition     <$> f t
    dispositionFilename _  DefaultDisposition       = pure DefaultDisposition

_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 
--  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

_headerReplyTo :: Lens' Headers 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"        
    -- _addressEmail :: Lens' Address Text might help to simplify this code?

newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
  deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
                   , MonadIO, MonadLogger, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
                   , MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
                   )

instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
  type MonadCryptoKey (MailT m) = CryptoIDKey
  cryptoIDKey f = lift (cryptoIDKey return) >>= f

data MailSmtpData = MailSmtpData
  { smtpEnvelopeFrom :: Last Text
  , smtpRecipients :: Set Address
  } deriving (Eq, Ord, Show, Read, Generic)

instance Semigroup MailSmtpData where
  (<>) = mappenddefault

instance Monoid MailSmtpData where
  mempty = memptydefault
  mappend = (<>)

_MailSmtpDataSet :: Getter MailSmtpData Bool
_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
  [ is (_Wrapped . _Nothing) smtpEnvelopeFrom
  , Set.null smtpRecipients
  ]


data MailContext = MailContext
  { mcLanguages :: Languages
  , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
  , mcCsvOptions :: CsvOptions
  } deriving (Eq, Ord, Read, Show, Generic)

deriveJSON defaultOptions
  { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
  } ''MailContext

instance Hashable MailContext
instance NFData MailContext
instance Default MailContext where
  def = MailContext
    { mcLanguages = def
    , mcDateTimeFormat = def
    , mcCsvOptions = def
    }

makeLenses_ ''MailContext

makeLenses_ ''MailSmtpData

class (MonadHandler m, MonadState Mail m) => MonadMail m where
  askMailLanguages :: m Languages
  askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
  askMailCsvOptions :: m CsvOptions
  tellMailSmtpData :: MailSmtpData -> m ()

instance MonadHandler m => MonadMail (MailT m) where
  askMailLanguages = view _mcLanguages
  askMailDateTimeFormat = (view _mcDateTimeFormat ??)
  askMailCsvOptions = view _mcCsvOptions
  tellMailSmtpData = tell

getMailMessageRender :: ( MonadMail m
                        , HandlerSite m ~ site
                        , RenderMessage site msg
                        ) => m (msg -> Text)
getMailMessageRender = renderMessage <$> getYesod <*> (view _Wrapped <$> askMailLanguages)

getMailMsgRenderer :: forall site m.
                      ( MonadMail m
                      , HandlerSite m ~ site
                      ) => m (MsgRendererS site)
getMailMsgRenderer = do
  mr <- getMailMessageRender
  return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)


data MailException = MailNotAvailable
                   | MailNoSenderSpecified
                   | MailNoRecipientsSpecified
  deriving (Eq, Ord, Read, Show, Generic)

instance Exception MailException


class Yesod site => YesodMail site where
  defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
  defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
  
  envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
  envelopeFromAddress = addressEmail <$> defaultFromAddress

  mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
  mailObjectIdDomain = pack <$> liftIO getHostName

  -- | Use replyTo instead for all senders within mailObjectIdDomain
  useReplyToInstead :: (MonadHandler m, HandlerSite m ~ site) => m Bool
  useReplyToInstead = return True -- not changeing the sender is the save choice

  mailRerouteTo :: (MonadHandler m, HandlerSite m ~ site) => m (Maybe Address)
  mailRerouteTo = return Nothing -- all mail will be sent to this address instead, if set (for test-instances)

  mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
  mailDateTZ = return utcTZ

  mailSmtp :: ( MonadHandler m
              , HandlerSite m ~ site
              , MonadUnliftIO m
              , MonadThrow m
              ) => (SMTPConnection -> m a) -> m a
  mailSmtp _ = throwM MailNotAvailable

  mailT :: ( MonadHandler m
           , HandlerSite m ~ site
           , MonadUnliftIO m
           , MonadLogger m
           , MonadThrow m
           ) => MailContext -> MailT m a -> m a

  default mailT :: ( MonadHandler m
                   , HandlerSite m ~ site
                   , MonadUnliftIO m
                   , MonadThrow m
                   ) => MailContext -> MailT m a -> m a
  mailT = defMailT

  defaultMailLayout :: ( MonadHandler m
                       , HandlerSite m ~ site
                       )
                    => WidgetFor site () -> m Html
  defaultMailLayout wgt = do
    PageContent{..} <- liftHandler $ widgetToPageContent wgt
    msgs <- getMessages
    withUrlRenderer [hamlet|
      $newline never
      $doctype 5
      <html>
        <head>
          <title>#{pageTitle}
          ^{pageHead}
        <body>
          $forall (status, msg) <- msgs
            <p class="message #{status}">#{msg}
        ^{pageBody}
    |]

defMailT :: ( MonadHandler m
            , YesodMail (HandlerSite m)
            , MonadUnliftIO m
            , MonadThrow m
            ) => MailContext
              -> MailT m a
              -> m a
defMailT ls (MailT mailC) = do
  fromAddress <- defaultFromAddress  
  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)  
  mail1 <- maybeT (return mail0) $ do
    guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
    domain <- mailObjectIdDomain
    let sender = mail0 ^. _mailFrom 
        isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
    $logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
    guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
    return $ mail0
      & _mailFrom     .~ fromAddress
      & _mailReplyTo  .~ sender
  mailRerouteTo' <- mailRerouteTo
  let (mail2, smtpData1) = maybe (mail1,smtpData0) switchRecipient mailRerouteTo'   -- switch receiver on enveloper, if rerouting is active
      switchRecipient rerouteTo = (Mime.addPart switchInfo mail1, smtpData0 { smtpRecipients = Set.singleton rerouteTo } )
      switchInfo = [plainPart $ LT.fromStrict $ "Due to setting 'mail-reroute-to', this mail was diverted; it was intended to be sent to: " <> tshow (smtpRecipients smtpData0)]
  mail3 <- liftIO $ LBS.toStrict <$> renderMail' mail2
  $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail3
  ret <$ case smtpData1 of
    MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
    MailSmtpData{ smtpRecipients }
      | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
    MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
                , smtpRecipients = (map (unpack . addressEmail) . toList -> recipients)
                } -> mailSmtp $ \conn -> do
      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData1
      liftIO $ SMTP.sendMail
        returnPath
        recipients
        mail3
        conn


data PrioritisedAlternatives m = PrioritisedAlternatives
  { preferredAlternative :: Last (m Part)
  , otherAlternatives :: Seq (m Part)
  } deriving (Generic)

instance Semigroup (PrioritisedAlternatives m) where
  (<>) = mappenddefault

instance Monoid (PrioritisedAlternatives m) where
  mempty = memptydefault  

class YesodMail site => ToMailPart site a where
  type MailPartReturn site a :: Type
  type MailPartReturn site a = ()
  toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)

instance YesodMail site => ToMailPart site (StateT Part (HandlerFor site) a) where
  type MailPartReturn site (StateT Part (HandlerFor site) a) = a
  toMailPart = mapStateT liftHandler

instance YesodMail site => ToMailPart site LT.Text where
  toMailPart text = do
    _partType .= decodeUtf8 typePlain
    _partEncoding .= QuotedPrintableText
    _partContent .= PartContent (encodeUtf8 text)

instance YesodMail site => ToMailPart site Text where
  toMailPart = toMailPart . LT.fromStrict

instance YesodMail site => ToMailPart site LTB.Builder where
  toMailPart = toMailPart . LTB.toLazyText

instance YesodMail site => ToMailPart site Html where
  toMailPart html = do
    _partType .= decodeUtf8 typeHtml
    _partEncoding .= QuotedPrintableText
    _partContent .= PartContent (renderMarkup html)

instance YesodMail site => ToMailPart site PureFile where
  toMailPart file@File{fileTitle, fileModified} = do
    _partDisposition .= AttachmentDisposition (pack $ takeFileName fileTitle)
    _partType .= decodeUtf8 (mimeLookup $ pack fileTitle)
    let
      content :: LBS.ByteString
      content = file ^. _pureFileContent . _Just
      isLatin = either (const False) (all isLatin1) $ decodeUtf8' content
    _partEncoding .= bool Base64 QuotedPrintableText isLatin
    _partContent .= PartContent content
    forM_ (file ^. _FileReference . _1 . _fileReferenceContent) $ \fRefContent ->
      replaceMailHeader (CI.original hETag) . Just . decodeUtf8 . toHeader $ etagFileReference # fRefContent
    replaceMailHeader (CI.original hLastModified) . Just . pack . formatTime defaultTimeLocale rfc822DateFormat $ utcToZonedTime utc fileModified

instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
  type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
  toMailPart act = do
    mr <- lift getMailMessageRender
    toMailPart $ act (toHtml . mr)

instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
  type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
  toMailPart act = do
    mr <- lift getMailMsgRenderer
    toMailPart $ act mr

instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
  type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
  toMailPart act = do
    ur <- getUrlRenderParams
    toMailPart $ act ur

instance YesodMail site => ToMailPart site Aeson.Value where
  toMailPart val = do
    _partType .= decodeUtf8 typeJson
    _partEncoding .= QuotedPrintableText
    _partContent .= PartContent (Aeson.encodePretty val)

instance YesodMail site => ToMailPart site YamlValue where
  toMailPart val = do
    _partType .= "text/vnd.yaml"
    _partEncoding .= QuotedPrintableText
    _partContent .= PartContent (fromStrict $ Yaml.encode val)


data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a } 

instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
  type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
  toMailPart nmp = do 
    r <- toMailPart $ namedPart nmp 
    _partDisposition .= disposition nmp
    return r    


addAlternatives :: (MonadMail m)
                => Writer (PrioritisedAlternatives m) ()
                -> m ()
addAlternatives provided = do
  let PrioritisedAlternatives{..} = execWriter provided
  alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
  modify $ Mime.addPart alternatives

provideAlternative, providePreferredAlternative
  :: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
  => a
  -> Writer (PrioritisedAlternatives m) ()
provideAlternative          part = tell $ mempty { otherAlternatives  = Seq.singleton $ execStateT (toMailPart part) initialPart }
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }

addPart :: ( MonadMail m
           , HandlerSite m ~ site
           , ToMailPart site a
           ) => a -> m (MailPartReturn site a)
addPart = addPart' . toMailPart

addPart' :: MonadMail m
         => StateT Part m a
         -> m a
addPart' part = do
  (ret, part') <- runStateT part initialPart
  modify . Mime.addPart $ pure part'
  return ret

initialPart :: Part
initialPart = Part
  { partType = decodeUtf8 defaultMimeType
  , partEncoding = Base64
  , partDisposition = DefaultDisposition
  , partHeaders = []
  , partContent = PartContent mempty
  }

modifyPart :: (MonadMail m, HandlerSite m ~ site, YesodMail site)
           => StateT Part (HandlerFor site) a
           -> StateT Part m a
modifyPart = toMailPart

partIsAttachment :: (Textual t, MonadMail m, HandlerSite m ~ site, YesodMail site)
                 => t
                 -> StateT Part m ()
partIsAttachment (repack -> fName) = modifyPart $ _partDisposition .= AttachmentDisposition fName


class MonadHandler m => MonadHeader m where
  stateHeaders :: forall a. (Headers -> (a, Headers)) -> m a
  modifyHeaders :: (Headers -> Headers) -> m ()
  modifyHeaders f = stateHeaders $ ((), ) . f
  objectIdHeader :: m MailHeader

instance MonadHandler m => MonadHeader (MailT m) where
  stateHeaders = MailT . zoom _mailHeaders . state
  objectIdHeader = return "Message-ID"

instance MonadHandler m => MonadHeader (StateT Part m) where
  stateHeaders = zoom _partHeaders . state
  objectIdHeader = return "Content-ID"


type MailHeader = ByteString
type MailObjectId = Text


replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC

addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)

removeMailHeader :: MonadHeader m => MailHeader -> m ()
removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders

getMailHeaders :: MonadHeader m => MailHeader -> m [Text]
getMailHeaders header = stateHeaders $ \hdrs -> (, hdrs) . map (view _2) $ filter (views _1 (== header)) hdrs

lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
lookupMailHeader = fmap listToMaybe . getMailHeaders

mapMailHeader ::  MonadHeader m => MailHeader -> (Text -> Text) -> m ()
mapMailHeader header f = modifyHeaders $ adjustAssoc f header 

replaceMailHeaderI :: ( RenderMessage site msg
                      , MonadMail m
                      , HandlerSite m ~ site
                      , MonadHeader m
                      ) => MailHeader -> msg -> m ()
replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg

addMailHeaderI :: ( RenderMessage site msg
                  , MonadMail m
                  , HandlerSite m ~ site
                  , MonadHeader m
                  ) => MailHeader -> msg -> m ()
addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)


setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
setSubjectI = replaceMailHeaderI "Subject"

mapSubject ::  MonadHeader m => (Text -> Text) -> m ()
mapSubject = mapMailHeader "Subject"

setMailObjectUUID :: ( MonadHeader m
                     , YesodMail (HandlerSite m)
                     ) => UUID -> m MailObjectId
setMailObjectUUID uuid = do
  domain <- mailObjectIdDomain
  oidHeader <- objectIdHeader
  let objectId = UUID.toText uuid <> "@" <> domain
  replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
  return objectId

setMailObjectIdRandom :: ( MonadHeader m
                         , YesodMail (HandlerSite m)
                         ) => m MailObjectId
setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom

setMailObjectIdCrypto :: ( MonadHeader m
                         , YesodMail (HandlerSite m)
                         , HasCryptoUUID plain m
                         ) => plain -> m MailObjectId
setMailObjectIdCrypto = setMailObjectUUID . ciphertext <=< encrypt

setMailObjectIdPseudorandom :: ( MonadHeader m
                               , YesodMail (HandlerSite m)
                               , Binary obj
                               , MonadSecretBox m
                               ) => obj -> m MailObjectId
-- | Designed to leak no information about the `secretBoxKey` or the given object
setMailObjectIdPseudorandom obj = do
  sbKey <- secretBoxKey
  let
    seed :: KMAC (SHAKE128 128)
    seed = KMAC.finalize . KMAC.updates (KMAC.initialize (BS.pack . encodeUtf8 $ nameBase 'setMailObjectIdPseudorandom) $ Saltine.encode sbKey) . LBS.toChunks $ Binary.encode obj
  setMailObjectUUID . fromMaybe (error "Could not convert hash to UUID") . UUID.fromByteString $ fromStrict (ByteArray.convert seed :: ByteString)

getMailObjectId :: ( MonadHeader m, YesodMail (HandlerSite m) ) => m (Maybe MailObjectId)
getMailObjectId = fmap (fmap stripBrackets) . lookupMailHeader =<< objectIdHeader
  where stripBrackets val = fromMaybe val $
          Text.stripSuffix ">" =<< Text.stripPrefix "<" val


setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setDateCurrent = setDate =<< liftIO getCurrentTime

setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m ()
setDate time = do
  tz <- mailDateTZ
  let timeStr = formatTime defaultTimeLocale rfc822DateFormat $ ZonedTime (utcToLocalTimeTZ tz time) (rfc822zone $ timeZoneForUTCTime tz time)
  replaceMailHeader "Date" . Just $ pack timeStr
  where
    rfc822zone tz'
      | tz' `elem` rfc822zones = tz'
      | otherwise              = tz' { timeZoneName = "" }
    rfc822zones =
      [ TimeZone 0         False "UT"
      , TimeZone 0         False "GMT"
      , TimeZone (-5 * 60) False "EST"
      , TimeZone (-4 * 60) True  "EDT"
      , TimeZone (-6 * 60) False "CST"
      , TimeZone (-5 * 60) True  "CDT"
      , TimeZone (-7 * 60) False "MST"
      , TimeZone (-6 * 60) True  "MDT"
      , TimeZone (-8 * 60) False "PST"
      , TimeZone (-7 * 60) True  "PDT"
      ]


getMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m MailSmtpData
getMailSmtpData = execWriterT $ do
  from <- envelopeFromAddress
  recps <- lift $ Set.fromList . concat <$> forM [_mailTo, _mailCc, _mailBcc] use

  tell $ mempty
    { smtpRecipients = recps
    , smtpEnvelopeFrom = Last $ Just from 
    }