{-# LANGUAGE NoImplicitPrelude
           , GeneralizedNewtypeDeriving
           , DerivingStrategies
           , FlexibleInstances
           , MultiParamTypeClasses
           , UndecidableInstances
           , DeriveGeneric
           , TemplateHaskell
           , OverloadedStrings
           , RecordWildCards
           , FlexibleContexts
           , TypeFamilies
           , ViewPatterns
           , NamedFieldPuns
           , MultiWayIf
  #-}

module Mail
  ( -- * Structured MIME emails
    module Network.Mail.Mime
    -- * MailT
  , MailT, defMailT
  , MailSmtpData(..), MailLanguages(..)
  , MonadMail(..)
    -- * YesodMail
  , VerpMode(..)
  , YesodMail(..)
  , MailException(..)
    -- * Monadically constructing Mail
  , PrioritisedAlternatives
  , ToMailPart(..)
  , addAlternatives, provideAlternative, providePreferredAlternative
  , addPart
  , MonadHeader(..)
  , MailHeader
  , MailObjectId
  , replaceMailHeader, addMailHeader, removeMailHeader
  , replaceMailHeaderI, addMailHeaderI
  , setSubjectI, setMailObjectId, setMailObjectId'
  , setDateCurrent
  , setMailSmtpData
  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
  , _partType, _partEncoding, _partFilename, _partHeaders, _partContent
  ) where

import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
import qualified ClassyPrelude.Yesod as Yesod (getMessageRender)

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

import Data.Monoid (Last(..))
import Control.Monad.Trans.RWS (RWST(..), execRWST)
import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT)
import Control.Monad.Trans.Writer (execWriter, Writer)
import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
import Control.Monad.Fail

import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)

import Data.Sequence (Seq)
import qualified Data.Sequence as Seq

import Data.Set (Set)
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.ByteString.Lazy as LBS

import Utils.Lens.TH
import Control.Lens

import Text.Blaze.Renderer.Utf8

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

import Data.Binary (Binary)

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

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

import qualified Text.Hamlet as Shakespeare (Translate, Render)

import Data.Aeson (Options(..))
import Data.Aeson.TH
import Utils (MsgRendererS, getMsgRenderer)
import Utils.PathPiece (splitCamel)


makeLenses_ ''Mail
makeLenses_ ''Part


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

instance (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 Monoid (MailSmtpData) where
  mempty = memptydefault
  mappend = mappenddefault

newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
  deriving (Eq, Ord, Show, Read)
  deriving newtype (FromJSON, ToJSON)

instance Default MailLanguages where
  def = MailLanguages []

class (MonadHandler m, MonadState Mail m) => MonadMail m where
  askMailLanguages :: m MailLanguages
  tellMailSmtpData :: MailSmtpData -> m ()

instance MonadHandler m => MonadMail (MailT m) where
  askMailLanguages = ask
  tellMailSmtpData = tell

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

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

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


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

instance Exception MailException
  

class 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
              , MonadBaseControl IO 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
           , MonadBaseControl IO m
           , MonadLogger m
           ) => MailLanguages -> MailT m a -> m a
  mailT = defMailT

defMailT :: ( MonadHandler m
            , YesodMail (HandlerSite m)
            , MonadBaseControl IO m
            , MonadLogger m
            ) => MailLanguages -- ^ Languages in priority order
              -> MailT m a
              -> m a
defMailT ls (MailT mail) = do
  fromAddress <- defaultFromAddress
  (ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
  mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
  $logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
  $logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
  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 $ liftIO . SMTP.sendMail
                       returnPath
                       recipients
                       mail'


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

instance Monoid (PrioritisedAlternatives m) where
  mempty = memptydefault
  mappend = mappenddefault

class ToMailPart site a where
  toMailPart :: (MonadHandler m, HandlerSite m ~ site) => a -> StateT Part m ()

instance ToMailPart site (StateT Part (HandlerT site IO) ()) where
  toMailPart = mapStateT liftHandlerT

instance ToMailPart site LT.Text where
  toMailPart text = do
    _partType .= "text/plain"
    _partEncoding .= QuotedPrintableText
    _partContent .= encodeUtf8 text

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

instance ToMailPart site Html where
  toMailPart html = do
    _partType .= "text/html"
    _partEncoding .= QuotedPrintableText
    _partContent .= renderMarkup html

instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Shakespeare.Translate msg -> a) where
  toMailPart act = do
    mr <- Yesod.getMessageRender
    toMailPart $ act (toHtml . mr)

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

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


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

provideAlternative, providePreferredAlternative
  :: (MonadHandler 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 :: (MonadHandler m, HandlerSite m ~ site, ToMailPart site a) => a -> MailT m ()
addPart part = MailT $ do
  part' <- lift $ execStateT (toMailPart part) initialPart
  modify . Mime.addPart $ pure part'

initialPart :: Part
initialPart = Part
  { partType = "text/plain"
  , partEncoding = None
  , partFilename = Nothing
  , partHeaders = []
  , partContent = mempty
  }


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 =<< (getMessageRender <*> pure msg)


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

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

setMailObjectId :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m MailObjectId
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom

setMailObjectId' :: ( MonadHandler m
                    , YesodMail (HandlerSite m)
                    , MonadCrypto m
                    , HasCryptoUUID plain m
                    , MonadCryptoKey m ~ CryptoIDKey
                    , KnownSymbol (CryptoIDNamespace UUID plain)
                    , 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


setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setMailSmtpData = do
  Address _ from <- 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 doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat
             [ user
             , Text.singleton verpSeparator
             , Text.replace "@" (Text.singleton verpAtReplacement) recp
             , domain
             ]
        in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp }
    | otherwise
    -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }