-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.MailCenter
  ( getMailCenterR, postMailCenterR
  , getMailHtmlR
  , getMailPlainR
  , getMailAttachmentR
  ) where

import Import

import qualified Data.Set as Set
import qualified Data.Map as Map
-- import qualified Data.Aeson  as Aeson
-- import qualified Data.Text as Text

-- import Database.Persist.Sql (updateWhereCount)
import           Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy
import qualified Database.Esqueleto.Experimental as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH

import qualified Data.Aeson as Aeson

import Text.Blaze.Html (preEscapedToHtml)
-- import Text.Blaze.Html5 as H (html, body, pre, p, h1)
-- import Text.Blaze.Html.Renderer.String (renderHtml)

import Numeric (readHex)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.ByteString as S
import qualified Data.ByteString.Lazy as LB


import Handler.Utils


data MCTableAction = MCActResendEmail
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe MCTableAction
instance Finite MCTableAction
nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''MCTableAction id

newtype MCTableActionData  = MCActResendEmailData UserEmail
  deriving (Eq, Ord, Read, Show, Generic)


resendMailTo :: (MonoFoldable mono, Element mono ~ SentMailId) => UserEmail -> mono -> Handler ()
resendMailTo recv smids = do
  (recvName, mails) <- runDBRead $ (,)
    <$> (userDisplayName . entityVal <<$>> getByFilter ([UserEmail ==. recv] ||. [UserDisplayEmail ==. recv]))
    <*> E.select (do
          (sm :& smc) <- E.from $ E.table @SentMail `E.innerJoin` E.table @SentMailContent `E.on` (\(sm :& smc) -> sm E.^. SentMailContentRef E.==. smc E.^. SentMailContentId)
          E.where_ $ sm E.^. SentMailId `E.in_` E.vals smids
          return (sm, smc)
        )
  forM_ mails $ \(Entity {entityVal=SentMail{..}}, Entity{entityVal=SentMailContent{sentMailContentContent=content}}) -> do
    let mailParts = getMailContent content
        mailTo    = []
        mailCc    = []
        mailBcc   = [Address{addressName = recvName, addressEmail = ciOriginal recv}]
        mailFrom  = error "Handler.MailCenter.resenMailTo: mailFrom not replaced by sendSimpleMail"  -- :: Address -- will be filled in later by sendSimpleMail
        mailHeaders = toHeaders sentMailHeaders -- :: Headers -- keep as it was? Includes To/Cc/Bcc
    sendSimpleMail Mail{..}


type MCTableExpr =
  (                   E.SqlExpr (Entity SentMail)
    `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
  )

queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail)
queryMail = $(sqlLOJproj 2 1)


queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User))
queryRecipient = $(sqlLOJproj 2 2)


type MCTableData = DBRow (Entity SentMail, Maybe (Entity User))

resultMail :: Lens' MCTableData (Entity SentMail)
resultMail = _dbrOutput . _1

resultRecipient :: Traversal' MCTableData (Entity User)
resultRecipient = _dbrOutput . _2 . _Just


mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget)
mkMCTable = do
  let
    dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User)))
    dbtSQLQuery  (mail `E.LeftOuterJoin` recipient) = do
      EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId
      return (mail, recipient)
    dbtRowKey = queryMail >>> (E.^. SentMailId)
    dbtProj = dbtProjId
    dbtColonnade = mconcat
      [ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey))
        sortable (Just "sent")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t
      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
      , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
          let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
              linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
          in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
      -- , sortable Nothing (i18nCell MsgCommContent)    $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
      -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
      ]
    dbtSorting = Map.fromList
      [ ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
      , ("recipient" , sortUserNameBareM queryRecipient)
      ]
    dbtFilter = Map.fromList
      [ ("sentTo"    , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
      , ("sentFrom"  , FilterColumn . E.mkDayFilterFrom                      $ views (to queryMail)        (E.^. SentMailSentAt))
      , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
      , ("subject"   , FilterColumn . E.mkContainsFilterWithCommaPlus id     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
      -- , ("regex"     , FilterColumn . E.mkRegExFilterWith id                 $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
      , ("content"   , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
          body <- E.from $ E.table @SentMailContent
          E.where_ $ body E.^. SentMailContentId E.==. queryMail row E.^. SentMailContentRef
                E.&&. E.mailContentContains (body E.^. SentMailContentContent) (E.val criterion)
        )
      ]
    dbtFilterUI mPrev = mconcat
      [ prismAForm (singletonFilter "sentTo"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgTableFilterSentBefore)
      , prismAForm (singletonFilter "sentFrom"  . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgTableFilterSentAfter)
      , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus)
      , prismAForm (singletonFilter "subject"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    & setTooltip MsgTableFilterCommaPlusShort)
      -- , prismAForm (singletonFilter "regex"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommSubject    )
      , prismAForm (singletonFilter "content"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)  (fslI MsgCommContent) --    & setTooltip MsgCommContentSearch)
      ]
    dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
    dbtIdent :: Text
    dbtIdent = "sent-mail"
    dbtCsvEncode = noCsvEncode
    dbtCsvDecode = Nothing
    dbtExtraReps = []
    dbtParams = DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
      , dbParamsFormAttrs  = []
      , dbParamsFormSubmit = FormSubmit
      , dbParamsFormAdditional
          = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
                acts = mconcat
                  [ singletonMap MCActResendEmail $ MCActResendEmailData
                      <$> areq (emailField & cfStrip & cfCI) (fslI MsgMCActResendEmail & setTooltip MsgMCActResendEmailTooltip) Nothing
                  ]
             in renderAForm FormStandard
               $  (, mempty) . First . Just
              <$> multiActionA acts (fslI MsgTableAction) Nothing
      , dbParamsFormEvaluate = liftHandler . runFormPost
      , dbParamsFormResult   = id
      , dbParamsFormIdent    = def
      }
    postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData)
                -> FormResult (      MCTableActionData, Set SentMailId)
    postprocess inp = do
        (First (Just act), jobMap) <- inp
        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
        return (act, jobSet)
    psValidator = def & defaultSorting [SortDescBy "sent"]
  over _1 postprocess <$> dbTable psValidator DBTable{..}

getMailCenterR,  postMailCenterR :: Handler Html
getMailCenterR = postMailCenterR
postMailCenterR = do
  (mcRes, mcTable) <- runDB mkMCTable
  formResult mcRes $ \case
    (MCActResendEmailData recv, smIds) -> do
      resendMailTo recv smIds
      addMessageI (bool Success Error $ null smIds) $ MsgMCActResendEmailInfo (Set.size smIds) (ciOriginal recv)
      reloadKeepGetParams MailCenterR
  siteLayoutMsg MsgMenuMailCenter $ do
    setTitleI MsgMenuMailCenter
    $(widgetFile "mail-center")


typePDF :: ContentType
typePDF = "application/pdf"

getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent
getMailAttachmentR cusm attdisp = do
  smid <- decrypt cusm
  (sm,cn) <- runDBRead $ do
    sm <- get404 smid
    cn <- get404 $ sm ^. _sentMailContentRef
    return (sm,cn)
  let mcontent = getMailContent (sentMailContentContent cn)
      getAttm alts = case selectAlternative [typePDF] alts of
        (Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt,
          | t == attdisp
            -> Just pc
        _ -> Nothing
      attm = firstJust getAttm mcontent
  case attm of
    (Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt
    _              -> notFound

getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
getMailHtmlR  = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]

getMailPlainR :: CryptoUUIDSentMail -> Handler Html
getMailPlainR = handleMailShow (SomeMsgs [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]

handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
handleMailShow hdr prefTypes cusm = do
  smid <- decrypt cusm
  (sm,cn) <- runDBRead $ do
    sm <- get404 smid
    cn <- get404 $ sm ^. _sentMailContentRef
    return (sm,cn)
  siteLayout' Nothing $ do
    setTitleI hdr
    let mcontent = getMailContent (sentMailContentContent cn)
        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
        mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent
    [whamlet|
      <section>
        <dl .deflist>
          <dt .deflist__dt>
            _{MsgPrintJobCreated}
          <dd .deflist__dd>
            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
          $maybe usr <- sm ^. _sentMailRecipient
            <dt .deflist__dt>
              _{MsgPrintRecipient}
            <dd .deflist__dd>
              ^{userIdWidget usr}
          $maybe r <- getHeader "To"
            <dt .deflist__dt>
              To
            <dd .deflist__dd>
              #{decodeEncodedWord r}
          $maybe r <- getHeader "Cc"
            <dt .deflist__dt>
              Cc
            <dd .deflist__dd>
              #{decodeEncodedWord r}
          $maybe r <- getHeader "From"
            <dt .deflist__dt>
              From
            <dd .deflist__dd>
              #{decodeEncodedWord r}
          $maybe r <- getHeader "Subject"
            <dt .deflist__dt>
              _{MsgCommSubject}
            <dd .deflist__dd>
              #{decodeEncodedWord r}

      <section>
        $forall pt <- mparts
          ^{part2widget cusm pt}
    |]
      -- Include for Debugging:
      -- <section>
      --   <h2>Debugging
      --   <p>
      --     ^{jsonWidget (sm ^. _sentMailHeaders)}
      --   <p>
      --     ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here

selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
  where
    aux ts@(ct:_) (pt:ps)
      | ct == partType pt = Just pt
      | otherwise         = aux ts ps
    aux (_:ts) []         = aux ts allAlts
    aux []     (pt:_)     = Just pt
    aux _      []         = Nothing

reorderParts :: [Part] -> [Part]
reorderParts = sortBy pOrder
  where
    pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2

    dispoOrder DefaultDisposition DefaultDisposition                 = EQ
    dispoOrder DefaultDisposition _                                  = LT
    dispoOrder _ DefaultDisposition                                  = GT
    dispoOrder (InlineDisposition t1) (InlineDisposition t2)         = compare t1 t2
    dispoOrder (InlineDisposition _) _                               = LT
    dispoOrder _ (InlineDisposition _)                               = GT
    dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2

disposition2widget :: Disposition -> Widget
disposition2widget (AttachmentDisposition _) = [whamlet|<h3>_{MsgMailFileAttachment}|]
disposition2widget (InlineDisposition     n) = [whamlet|<h3>_{MsgMenuMailAttachment} #{n}|]
disposition2widget  DefaultDisposition       = mempty

part2widget :: CryptoUUIDSentMail -> Part -> Widget
part2widget cusm Part{partContent=NestedParts ps} =
  [whamlet|
      $forall p <- ps
        ^{part2widget cusm p}
  |]
part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
    [whamlet|
      <section>
        ^{disposition2widget dispo}
        ^{showBody}
      ^{showPass}
    |]
  where
    showBody
      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc
      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
      | pt == decodeUtf8 typeJson  =
          let jw :: Aeson.Value -> Widget = jsonWidget
          in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
      | pt == decodeUtf8 typePDF
      , AttachmentDisposition t <- dispo
        = [whamlet|<a href=@{MailAttachmentR cusm t}>#{t}|]
      | otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|]
    showPass
      | pt == decodeUtf8 typePlain
      , let cw = T.words $ decodeUtf8 pc
      , Just name <- listBracket ("Inhaber","Gültig") cw                               -- heursitic for dirving licence renewal letters only; improve
                <|>  listBracket ("Licensee","Valid") cw
      = let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in
        liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case
          Nothing -> mempty -- DEBUG: [whamlet|<h2>Not found: #{sdn}|]
          Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
            [whamlet|
              <section>
                $maybe pw <- mbpw
                  <details>
                    <summary>
                      _{MsgAdminUserPinPassword}
                    <p>
                      <dl .deflist>
                        <dt .deflist__dt>
                          ^{userWidget u}
                        <dd .deflist__dd>
                          <b>
                            #{pw}
                    <p>
                      _{MsgAdminUserPinPassNotIncluded}
                $nothing
                  _{MsgAdminUserNoPassword}
            |]
      | otherwise = mempty

------------------------------
-- Decode MIME Encoded Word

-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
decodeEncodedWord :: Text -> Text
decodeEncodedWord tinp
  | (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp
  , (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf
  , notNull cw
    = pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm
  | otherwise
    = tinp

decodeEncodedWordHeader :: Text -> Text
decodeEncodedWordHeader tinp
  | [enc, bin, cw] <- T.splitOn "?" tinp
  , "utf-8" == T.toLower enc
  , "Q"     == T.toUpper bin      -- Quoted Printable Text
    = decEncWrdUtf8Q cw
  -- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment
  | otherwise
    = tinp

decEncWrdUtf8Q :: Text -> Text
decEncWrdUtf8Q tinp
  | Right ok <- TE.decodeUtf8' $ decWds tinp
    = ok
  | otherwise
    = tinp
  where
    decWds :: Text -> S.ByteString
    decWds t
      | (h:tl) <- T.splitOn "=" t
        = mconcat $ TE.encodeUtf8 h : map deco tl
      | otherwise
        = TE.encodeUtf8 t

    deco :: Text -> S.ByteString
    deco w
      | (c,r) <- T.splitAt 2 w
      , [(v,"")] <- readHex $ T.unpack c
        = S.cons v $ TE.encodeUtf8 r
      | otherwise
        = TE.encodeUtf8 w
