fradrive/src/Handler/Utils/Mail.hs

-- 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, userMailTdirect
  , 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 Handler.Utils.Profile 

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)

-- import qualified Text.Blaze.Html5 as H

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, userDisplayEmail, userDisplayName}) = do
      let addr = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail
      _mailTo %= flip snoc addr

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

userAddress :: User -> Address
-- ^ Format an e-mail address suitable for usage as a recipient
--
-- Like userAddressFrom, but prefers `userDisplayEmail` (if valid) and otherwise uses `userEmail`. Unlike Uni2work, userEmail from LDAP is untrustworthy.
userAddress User{userEmail, userDisplayEmail, userDisplayName}
  = Address (Just userDisplayName) $ CI.original $ pickValidEmail userDisplayEmail userEmail

-- | Send an email to the given UserId or to all registered Supervisor with rerouteNotifications == True
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 $ pickValidEmail (underling ^. _userDisplayEmail) (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</a>. #
              $if undercopy
                _{MsgMailSupervisorCopy undermail}
              $else
                _{MsgMailSupervisorNoCopy}
          |]
        mailtoAddr = userAddress supervisor
    if validEmail $ addressEmail mailtoAddr
      then 
        mailT ctx $ do
          -- TODO: ensure that the Email is VALID HERE!
          _mailTo .= pure mailtoAddr 
          mAct
          if uid==svr
            then when (length receivers > 1) $ addHtmlMarkdownAlternatives' "InfoSupervised" infoSupervised -- notify about supervisors
            else do
              mapSubject ("[SUPERVISOR] " <>)
              addHtmlMarkdownAlternatives' "InfoSupervisor" infoSupervisor -- adding explanation why the supervisor received this email
      else -- do
        -- failedSubject <- lookupMailHeader "Subject"
        $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr -- <> " with subject " <> tshow failedSubject

-- | like userMailT, but always sends a single mail to the given UserId, ignoring supervisors
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
      }
    mailtoAddr = userAddress user 
  mailT ctx $ do
    failedSubject <- lookupMailHeader "Subject"
    unless (validEmail $ addressEmail mailtoAddr) ($logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAddr <> " with subject " <> tshow failedSubject)
    _mailTo .= pure mailtoAddr
    mAct  
{- Problematic due to return type a      
  if validEmail $ addressEmail mailtoAddr
    then mailT ctx $ do
      _mailTo .= pure mailtoAddr
      mAct
    else 
      -- failedSubject <- lookupMailHeader "Subject"        
      $logErrorS "Mail" $ "Attempt to email invalid address: " <> tshow mailtoAdd -- <> " with subject " <> tshow failedSubject
-}      



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
      , P.writerPreferAscii    = False
      }

-- | 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
    --let html_meta = H.head $ H.preEscapedText "<meta charset=\"utf-8\">" -- this is probably not the correct way to do this
    let html_meta = [shamlet|
            $doctype 5
            <html> 
              <head>
                <meta charset="utf-8">
                <title>
                  #{fn}
              <body> 
                ^{html}
          |]
    providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition $ fn <> ".html", namedPart = html_meta  }
    whenIsJust markdown $ provideAlternative . NamedMailPart (InlineDisposition (fn <> ".txt"))
  where
    writerOptions = markdownWriterOptions
      { P.writerReferenceLinks = True
      , P.writerPreferAscii    = False
      }