-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@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

module Handler.Utils.Mail
  ( addRecipientsDB
  , userAddress, userAddressFrom
  , userMailT
  , addFileDB
  , addHtmlMarkdownAlternatives
  , addHtmlMarkdownAlternatives'
  ) where

import Import
import Handler.Utils.Pandoc
import Handler.Utils.Files
import Handler.Utils.Widgets (nameHtml') -- TODO: how to use name widget here?
import Handler.Utils.Users (getReceivers)

import qualified Data.CaseInsensitive as CI

import qualified Data.Conduit.Combinators as C

import qualified Text.Pandoc as P

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


addRecipientsDB :: ( MonadMail m
                   , HandlerSite m ~ UniWorX
                   ) => [Filter User] -> m ()
-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
addRecipientsDB uFilter = runConduit $ transPipe (liftHandler . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
  where
    addRecipient (Entity _ User{userEmail, userDisplayName}) = do
      let addr = Address (Just userDisplayName) $ CI.original userEmail
      _mailTo %= flip snoc addr

userAddressFrom :: User -> Address
-- ^ Format an e-mail address suitable for usage in a @From@-header
--
-- Uses `userDisplayEmail`
userAddressFrom User{userDisplayEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userDisplayEmail

userAddress :: User -> Address
-- ^ Format an e-mail address suitable for usage as a recipient
--
-- Uses `userEmail`
userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail


userMailT :: ( MonadHandler m
             , HandlerSite m ~ UniWorX
             , MonadThrow m
             , MonadUnliftIO m
             ) => UserId -> MailT m () -> m ()
userMailT uid mAct = do
  (underling, receivers, undercopy) <- liftHandler . runDB $ getReceivers uid
  let undername = underling ^. _userDisplayName -- nameHtml' underling
      undermail = CI.original $ underling ^. _userEmail
      infoSupervised :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
            <h2>_{MsgMailSupervisedNote}
            <p>
              _{MsgMailSupervisedBody}
              <ul>
                $forall svr <- receivers
                  <li>
                    #{nameHtml' svr}
          |]
  forM_ receivers $ \Entity
      { entityKey = svr
      , entityVal = supervisor@User{ userLanguages
                                 , userDateTimeFormat
                                 , userDateFormat
                                 , userTimeFormat
                                 , userCsvOptions
                                 } 
      } -> do
    let ctx = MailContext
                { mcLanguages = fromMaybe def userLanguages
                , mcDateTimeFormat = \case
                    SelFormatDateTime -> userDateTimeFormat
                    SelFormatDate     -> userDateFormat
                    SelFormatTime     -> userTimeFormat
                , mcCsvOptions = userCsvOptions
                }
        supername = supervisor ^. _userDisplayName -- nameHtml' supervisor
        infoSupervisor :: Hamlet.HtmlUrlI18n UniWorXSendMessage (Route UniWorX) = [ihamlet|
            <h2>_{MsgMailSupervisorNote}
            <p>
              _{MsgMailSupervisorBody undername supername} #
              <a href=@{NewsR}>
                FRADrive
              .
              $if undercopy
                _{MsgMailSupervisorCopy undermail}
              $else
                _{MsgMailSupervisorNoCopy}
          |]
    mailT ctx $ do
      _mailTo .= pure (userAddress supervisor)
      mAct
      if uid==svr
        then when (2 <= length receivers) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
        else do
          mapSubject ("[SUPERVISOR]" <>)
          addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email



_userMailTdirect :: ( MonadHandler m
             , HandlerSite m ~ UniWorX
             , MonadThrow m
             , MonadUnliftIO m
             ) => UserId -> MailT m a -> m a
_userMailTdirect uid mAct = do
  user@User
    { userLanguages
    , userDateTimeFormat
    , userDateFormat
    , userTimeFormat
    , userCsvOptions
    } <- liftHandler . runDB $ getJust uid
  let
    ctx = MailContext
      { mcLanguages = fromMaybe def userLanguages
      , mcDateTimeFormat = \case
          SelFormatDateTime -> userDateTimeFormat
          SelFormatDate -> userDateFormat
          SelFormatTime -> userTimeFormat
      , mcCsvOptions = userCsvOptions
      }
  mailT ctx $ do
    _mailTo .= pure (userAddress user)
    mAct


addFileDB :: ( MonadMail m
             , HandlerSite m ~ UniWorX
             ) => FileReference -> m (Maybe MailObjectId)
addFileDB fRef = runMaybeT $ do
  File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent'} <- return $ sourceFile fRef
  fileContent <- liftHandler . runDB . runConduit $ fileContent' .| C.sinkLazy
  lift . addPart $ do
    _partType .= decodeUtf8 (mimeLookup fileName)
    _partEncoding .= Base64
    _partDisposition .= AttachmentDisposition fileName
    _partContent .= PartContent fileContent
    setMailObjectIdPseudorandom (fileName, fileContent) :: StateT Part (HandlerFor UniWorX) MailObjectId


class YesodMail site => ToMailHtml site a where
  toMailHtml :: (MonadMail m, HandlerSite m ~ site) => a -> m Html

instance YesodMail site => ToMailHtml site Html where
  toMailHtml = return

instance (ToMailHtml site a, RenderMessage site msg) => ToMailHtml site (Hamlet.Translate msg -> a) where
  toMailHtml act = do
    mr <- getMailMessageRender
    toMailHtml $ act (toHtml . mr)

instance (ToMailHtml site a, site ~ site') => ToMailHtml site (MsgRendererS site' -> a) where
  toMailHtml act = do
    mr <- getMailMsgRenderer
    toMailHtml $ act mr

instance ToMailHtml site a => ToMailHtml site (Shakespeare.RenderUrl (Route site) -> a) where
  toMailHtml act = do
    ur <- getUrlRenderParams
    toMailHtml $ act ur

-- | Adds another Text part as Html AND Markdown (receiver's choice) to an email. Subsequently added parts create attachments named "Att#####.html" and "Att#####.txt"
addHtmlMarkdownAlternatives :: ( MonadMail m
                               , ToMailPart (HandlerSite m) Html
                               , ToMailHtml (HandlerSite m) a
                               )
                            => a -> m ()
addHtmlMarkdownAlternatives html' = do
  html <- toMailHtml html'
  markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html

  addAlternatives $ do
    providePreferredAlternative html
    whenIsJust markdown provideAlternative
  where
    writerOptions = markdownWriterOptions
      { P.writerReferenceLinks = True
      }

-- | Like @addHtmlMarkdownAlternatives, but adds subseqeunt parts with "content-disposition: inline" and the provided filename, if inline display is not permitted (receiver's choice)
addHtmlMarkdownAlternatives' :: ( MonadMail m
                                , ToMailPart (HandlerSite m) (NamedMailPart Html)
                                , ToMailHtml (HandlerSite m) a
                                ) => Text -> a -> m ()
addHtmlMarkdownAlternatives' fn html' = do
  html <- toMailHtml html'
  markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html

  addAlternatives $ do
    providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition $ fn <> ".html", namedPart = html }
    whenIsJust markdown $ provideAlternative . NamedMailPart (InlineDisposition (fn <> ".txt"))
  where
    writerOptions = markdownWriterOptions
      { P.writerReferenceLinks = True
      }