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

module Mail
  ( -- * Structured MIME emails
    module Network.Mail.Mime
    -- * MailT
  , MailT, defMailT
  , MailSmtpData(..)
  , _MailSmtpDataSet
  , MailContext(..)
  , MonadMail(..)
  , getMailMessageRender, getMailMsgRenderer
    -- * YesodMail
  , VerpMode(..)
  , YesodMail(..)
  , MailException(..)
    -- * Monadically constructing Mail
  , PrioritisedAlternatives
  , ToMailPart(..)
  , addAlternatives, provideAlternative, providePreferredAlternative
  , addPart, addPart', modifyPart, partIsAttachment
  , MonadHeader(..)
  , MailHeader
  , MailObjectId
  , replaceMailHeader, addMailHeader, removeMailHeader
  , replaceMailHeaderI, addMailHeaderI
  , setSubjectI
  , setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
  , setDate, setDateCurrent
  , setMailSmtpData
  , _addressName, _addressEmail
  , _mailFrom, _mailTo, _mailCc, _mailBcc, _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 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.RWS (RWST(..))
import Control.Monad.Trans.State (StateT(..), execStateT, mapStateT)
import Control.Monad.Trans.Writer (execWriter, 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.Text as Text

import qualified Data.Foldable as Foldable

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(..), maybeT, YamlValue)
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(..))
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 Control.Monad.Trans.Maybe (MaybeT(..))

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)


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


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 Text
  } 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
  } deriving (Eq, Ord, Read, Show, Generic, Typeable)

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
    }

makeLenses_ ''MailContext

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

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

data VerpMode = VerpNone
              | Verp { verpSeparator, verpAtReplacement :: Char }
  deriving (Eq, Show, Read, Generic)

deriveJSON defaultOptions
  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
  , sumEncoding = UntaggedValue
  } ''VerpMode

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, Typeable)

instance Exception MailException


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

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

  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

  mailVerp :: ( MonadHandler m
              , HandlerSite m ~ site
              ) => m VerpMode
  mailVerp = return VerpNone

  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, mail, smtpData) <- runRWST mailC ls (emptyMail fromAddress)
  mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
  -- logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
  ret <$ case smtpData of
    MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
    MailSmtpData{ smtpRecipients }
      | Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
    MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
                , smtpRecipients = (map unpack . toList -> recipients)
                } -> mailSmtp $ \conn -> do
      $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
      liftIO $ SMTP.sendMail
        returnPath
        recipients
        mail'
        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
  mappend = (<>)

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 (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)


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
  modifyHeaders :: (Headers -> Headers) -> m ()
  objectIdHeader :: m MailHeader

instance MonadHandler m => MonadHeader (MailT m) where
  modifyHeaders f = MailT . modify $ over _mailHeaders f
  objectIdHeader = return "Message-ID"

instance MonadHandler m => MonadHeader (StateT Part m) where
  modifyHeaders f = _partHeaders %= f
  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


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"

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)


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"
      ]


setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m), MonadThrow m) => MailT m ()
setMailSmtpData = do
  Address _ from <- maybeT (throwM MailNoSenderSpecified) $ asum
    [ MaybeT . preuses (_mailHeader "Sender") $ fromString . unpack
    , use _mailFrom
    ]
  recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use

  tell $ mempty { smtpRecipients = recps }

  verpMode <- mailVerp
  if
    | Verp{..} <- verpMode
    , [recp] <- Set.toList recps
    -> let (user, domain) = Text.breakOn "@" from
           verp = mconcat
             [ user
             , Text.singleton verpSeparator
             , Text.replace "@" (Text.singleton verpAtReplacement) recp
             , domain
             ]
        in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
    | otherwise
    -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }