fradrive-old/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
  , addFileDB
  , addHtmlMarkdownAlternatives
  , addHtmlMarkdownAlternatives'
  , addHtmlMarkdownAlternatives''
  ) where

import Import
import Handler.Utils.Pandoc
import Handler.Utils.Files

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 (Translate)
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
  -- now <- liftIO getCurrentTime
  superVs <- liftHandler . runDB $ selectList [UserSupervisorUser ==. uid, UserSupervisorRerouteNotifications ==. True] []
  let receivers = if null superVs
                    then [uid]
                    else userSupervisorSupervisor . entityVal <$> superVs
  -- underling <- liftHandler . runDB $ getJust uid
  forM_ receivers $ \svr -> do 
    supervisor@User
      { userLanguages
      , userDateTimeFormat
      , userDateFormat
      , userTimeFormat
      , userCsvOptions
      } <- liftHandler . runDB $ getJust svr
    let ctx = MailContext
                { mcLanguages = fromMaybe def userLanguages
                , mcDateTimeFormat = \case
                    SelFormatDateTime -> userDateTimeFormat
                    SelFormatDate -> userDateFormat
                    SelFormatTime -> userTimeFormat
                , mcCsvOptions = userCsvOptions
                }
        --bsExplainSupervisor   = $(ihamletFile "templates/mail/supervisorPrefix.hamlet") -- TODO
        --explanationSupervisor = File { fileTitle = "SupervisorInfo.txt"
        --                             , fileModified = no
        --                             , fileContent = Just $ yield bsExplainSupervisor
        --                             }
    mailT ctx $ do
      _mailTo .= pure (userAddress supervisor)
      mAct
      unless (uid==svr) $ -- do 
        mapSubject ("[SUPERVISOR]"<>)  -- changing subject is easy 
        --addPart explanationSupervisor  -- adding an attachment is also easy


_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


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
      }

-- | provide a name for the part 
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 { namedPart = html, disposition = AttachmentDisposition fn } 
    whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
  where
    writerOptions = markdownWriterOptions
      { P.writerReferenceLinks = True
      }


-- | provide a name for the part 
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, namedPart = html } 
    whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
  where
    writerOptions = markdownWriterOptions
      { P.writerReferenceLinks = True
      }