{-# LANGUAGE GeneralizedNewtypeDeriving
           , UndecidableInstances
  #-}

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

import ClassyPrelude.Yesod hiding (snoc, (.=), 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(..))
import Control.Monad.Trans.State (StateT(..), execStateT, 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.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS

import Utils (MsgRendererS(..))
import Utils.Lens.TH
import Control.Lens hiding (from)

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 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 Data.Aeson (Options(..))
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 GHC.Exts (IsList)

makeLenses_ ''Mail
makeLenses_ ''Part


newtype MailT m a = MailT { _unMailT :: RWST MailContext 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 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 Monoid (MailSmtpData) where
  mempty = memptydefault
  mappend = mappenddefault

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

instance Default MailLanguages where
  def = MailLanguages []

instance Hashable MailLanguages

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

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

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

makeLenses_ ''MailContext

class (MonadHandler m, MonadState Mail m) => MonadMail m where
  askMailLanguages :: m MailLanguages
  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 <*> (mailLanguages <$> 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
              , 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
           ) => MailContext -> MailT m a -> m a
  mailT = defMailT

  defaultMailLayout :: ( MonadHandler m
                       , HandlerSite m ~ site
                       ) => WidgetT site IO () -> m Html
  defaultMailLayout wgt = do
    PageContent{..} <- liftHandlerT $ 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)
            , MonadBaseControl IO m
            , MonadLogger 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 Monoid (PrioritisedAlternatives m) where
  mempty = memptydefault
  mappend = mappenddefault

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

instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where
  type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
  toMailPart = mapStateT liftHandlerT

instance YesodMail site => ToMailPart site LT.Text where
  toMailPart text = do
    _partType .= "text/plain; charset=utf-8"
    _partEncoding .= QuotedPrintableText
    _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 .= "text/html; charset=utf-8"
    _partEncoding .= QuotedPrintableText
    _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 .= "application/json; charset=utf-8"
    _partEncoding .= QuotedPrintableText
    _partContent .= Aeson.encodePretty 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 part = do
  (ret, part') <- runStateT (toMailPart part) initialPart
  modify . Mime.addPart $ pure part'
  return ret

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

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

setMailObjectId' :: ( MonadHeader m
                    , YesodMail (HandlerSite m)
                    , MonadCrypto m
                    , HasCryptoUUID plain m
                    , MonadCryptoKey m ~ CryptoIDKey
                    , KnownSymbol (CryptoIDNamespace UUID plain)
                    , Binary plain
                    ) => plain -> m MailObjectId
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid


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 "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time)
  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 (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 }