module Handler.Utils.Mail
  ( addRecipientsDB
  , userAddress, userAddressFrom
  , userMailT
  , addFileDB
  , 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 a -> m a
userMailT uid mAct = do
  user@User
    { userLanguages
    , userDateTimeFormat
    , userDateFormat
    , userTimeFormat
    } <- liftHandler . runDB $ getJust uid
  let
    ctx = MailContext
      { mcLanguages = fromMaybe def userLanguages
      , mcDateTimeFormat = \case
          SelFormatDateTime -> userDateTimeFormat
          SelFormatDate -> userDateFormat
          SelFormatTime -> userTimeFormat
      }
  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
      }