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

{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
-- TODO: remove these above
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Handler.MailCenter
  ( getMailCenterR, postMailCenterR
  , getMailHtmlR
  , getMailPlainR
  ) 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 Utils.Print

import Handler.Utils
-- import Handler.Utils.Csv
-- import qualified Data.Csv as Csv
-- import qualified Data.CaseInsensitive as CI

-- import Jobs.Queue
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 Data.Text (Text)


-- import qualified Data.Text.Lazy as LT
-- import qualified Data.Text.Lazy.Encoding as LT
import qualified Data.ByteString.Lazy as LB

import Data.Char as C

import qualified Data.Text as T
-- import qualified Data.Text.Encoding as TE
-- import qualified Data.ByteString.Char8 as BS

import Data.Bits
-- import Data.Word

-- avoids repetition of local definitions
single :: (k,a) -> Map k a
single = uncurry Map.singleton


data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

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

data MCTableActionData  = MCActDummyData
  deriving (Eq, Ord, Read, Show, Generic)


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 MsgMenuMailHtml)   $ \(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 = mconcat
      [ single ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
      , single ("recipient" , sortUserNameBareM queryRecipient)
      ]
    dbtFilter = mconcat
      [ single ("sent"      , FilterColumn . E.mkDayFilter                          $ views (to queryMail)        (E.^. SentMailSentAt))
      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
      , single ("subject"   , FilterColumn . E.mkContainsFilter                     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
      ]
    dbtFilterUI mPrev = mconcat
      [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
      , 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)
      ]
    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 MCActDummy $ pure MCActDummyData
                  ]
             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
    (MCActDummyData, Set.toList -> _smIds) -> do
      addMessageI Success MsgBoolIrrelevant
      reloadKeepGetParams MailCenterR
  siteLayoutMsg MsgMenuMailCenter $ do
    setTitleI MsgMenuMailCenter
    $(widgetFile "mail-center")


getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
getMailHtmlR  = handleMailShow [typeHtml,typePlain]

getMailPlainR :: CryptoUUIDSentMail -> Handler Html
getMailPlainR = handleMailShow [typePlain,typeHtml]

handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html
handleMailShow prefTypes cusm = do
  smid <- decrypt cusm
  (sm,cn) <- runDB $ do
    sm <- get404 smid
    cn <- get404 $ sm ^. _sentMailContentRef
    return (sm,cn)
  siteLayoutMsg MsgMenuMailCenter $ do
    setTitleI MsgMenuMailCenter
    let mcontent = getMailContent (sentMailContentContent cn)
        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
    [whamlet|
      <section>
        <dl .deflist>
          <dt .deflist__dt>
            _{MsgPrintJobCreated}
          <dd .deflist__dd>
            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
          $maybe r <- getHeader "From"
            <dt .deflist__dt>
              _{MsgPrintSender}
            <dd .deflist__dd>
              #{decodeMime r}
          $maybe r <- getHeader "To"
            <dt .deflist__dt>
              _{MsgPrintRecipient}
            <dd .deflist__dd>
              #{decodeMime r}
          $maybe r <- getHeader "Subject"
            <dt .deflist__dt>
              _{MsgCommSubject}
            <dd .deflist__dd>
              #{decodeMime r}

      <section>
        $forall mc <- mcontent
          $maybe pt <- selectAlternative prefTypes mc
            <p>
              ^{part2widget pt}
    |]
    -- ^{jsonWidget (sm ^. _sentMailHeaders)}
    -- ^{jsonWidget (sentMailContentContent cn)}


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

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

part2widget :: Part -> Widget
part2widget Part{partContent=NestedParts ps} =
  [whamlet|
    <section>
      $forall p <- ps
        ^{part2widget p}
        <hr>
    <hr>
  |]
part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
    [whamlet|
      <section>
        ^{disposition2widget dispo}
        ^{showBody}
      <hr>
    |]
  where
    showBody
      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
      | pt == decodeUtf8 typeJson  =
          let jw :: Aeson.Value -> Widget = jsonWidget
          in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]


-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
decodeMime :: Text -> Text
decodeMime = id -- TODO