-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@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.SystemMessage
  ( getMessageR, postMessageR
  , getMessageListR, postMessageListR
  , ButtonSystemMessageHide(..)
  , postMessageHideR
  ) where

import Import

import Handler.Utils
import Handler.Utils.News

import qualified Data.HashMap.Strict as HashMap
import Data.Map ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Set as Set
import qualified Data.Text as Text (intercalate)

import qualified Database.Esqueleto.Legacy as E


invalidateVisibleSystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
invalidateVisibleSystemMessages = memcachedByInvalidate AuthCacheVisibleSystemMessages $ Proxy @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime))


systemMessageVolatileClusterSettingsForm :: Maybe SystemMessageVolatileClusterSettings -> AForm Handler SystemMessageVolatileClusterSettings
systemMessageVolatileClusterSettingsForm (fmap Set.toList -> mPrev) = wFormToAForm $ do
  currentRoute <- fromMaybe (error "systemMessageVolatileClusterSettingsForm called from 404-handler") <$> getCurrentRoute
  let
    volatileClusterSettingForm :: (Text -> Text) -> Maybe (VolatileClusterSettingsKey, Value) -> Form (VolatileClusterSettingsKey, Value)
    volatileClusterSettingForm nudge mTemplate csrf = do
      (keyRes, keyView) <- mpreq (selectField optionsFinite) ("" & addName (nudge "key"  )) (view _1 <$> mTemplate)
      (valRes, valView) <- mpreq (jsonField JsonFieldNormal) ("" & addName (nudge "value")) (view _2 <$> mTemplate)
      return ((,) <$> keyRes <*> valRes, $(widgetFile "widgets/massinput/systemMessage/volatileClusterSettings/form"))

    miAdd nudge submitView csrf = do
      (formRes, formView) <- volatileClusterSettingForm nudge Nothing csrf
      MsgRenderer mr <- getMsgRenderer
      let res = formRes <&> \newDat@(newKey, _) oldDat -> if
            | any (\(oldKey, _) -> newKey == oldKey) oldDat -> FormFailure [mr MsgSystemMessageOnVolatileClusterSettingKeyExists]
            | otherwise -> FormSuccess $ pure newDat
      return (res, $(widgetFile "widgets/massinput/systemMessage/volatileClusterSettings/add"))
    miEdit nudge = volatileClusterSettingForm nudge . Just

    miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
    miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag

    miLayout :: MassInputLayout ListLength (VolatileClusterSettingsKey, Value) (VolatileClusterSettingsKey, Value)
    miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/systemMessage/volatileClusterSettings/layout")
  fmap Set.fromList <$> massInputAccumEditW miAdd miEdit miButtonAction miLayout ("system-message-volatile-cluster-settings" :: Text) (fslI MsgSystemMessageOnVolatileClusterSettings) False mPrev

getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
getMessageR = postMessageR
postMessageR cID = do
  smId <- decrypt cID
  (SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage smId
  let (summary, content) = case translation of
        Nothing -> (systemMessageSummary, systemMessageContent)
        Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)

  MsgRenderer mr <- getMsgRenderer
  now <- liftIO getCurrentTime
  let
    mkForm = do
      ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm FIDSystemMessageModify . renderAForm FormStandard
        $ SystemMessage
          <$> aopt  utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
          <*> aopt  utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
          <*> systemMessageVolatileClusterSettingsForm (Just systemMessageOnVolatileClusterSettings)
          <*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just systemMessageNewsOnly)
          <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
          <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
          <*> aopt (natFieldI MsgSystemMessagePriorityNegative) (fslI MsgSystemMessagePriority) (Just systemMessageManualPriority)
          <*> pure systemMessageCreated
          <*> (bool systemMessageLastChanged now <$> apopt checkBoxField (fslI MsgSystemMessageRecordChanged & setTooltip MsgSystemMessageRecordChangedTip) (Just True))
          <*> (bool systemMessageLastUnhide now <$> apopt checkBoxField (fslI MsgSystemMessageUnhide & setTooltip MsgSystemMessageUnhideTip) (Just False))
          <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageDefaultLanguage)
          <*> areq  htmlField (fslI MsgSystemMessageContent) (Just systemMessageContent)
          <*> aopt  htmlField (fslI MsgSystemMessageSummary) (Just systemMessageSummary)

      ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
      let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts

      modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
        cID' <- encrypt tId
        runFormPost . identifyForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
          $ (,)
          <$> fmap (Entity tId)
              ( SystemMessageTranslation systemMessageTranslationMessage
                  <$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just systemMessageTranslationLanguage)
                  <*> areq htmlField (fslI MsgSystemMessageContent) (Just systemMessageTranslationContent)
                  <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just systemMessageTranslationSummary)
              )
          <*> combinedButtonFieldF ""

      let modifyTranss = Map.map (view $ _1._1) modifyTranss'
          nextLang = toList appLanguages
            & filter (not . langMatches systemMessageDefaultLanguage)
            & filter (\l -> none (`langMatches` l) $ Map.keys ts')

      ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identifyForm FIDSystemMessageAddTranslation . renderAForm FormStandard
        $ SystemMessageTranslation smId
          <$> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (listToMaybe nextLang)
          <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
          <*> aopt htmlField (fslI MsgSystemMessageSummary) Nothing

      formResult modifyRes $ modifySystemMessage smId

      formResult addTransRes addTranslation

      forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, catMaybes -> acts) -> case acts of
        [BtnDelete'] -> do
          runDB $ delete tId
          addMessageI Success MsgSystemMessageDeleteTranslationSuccess
          redirect $ MessageR cID
        _other -> do
          runDB $ update tId
            [ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage
            , SystemMessageTranslationContent =. systemMessageTranslationContent
            , SystemMessageTranslationSummary =. systemMessageTranslationSummary
            ]
          addMessageI Success MsgSystemMessageEditTranslationSuccess
          redirect $ MessageR cID

      let
        messageEditModal = modal [whamlet|_{MsgSystemMessageEdit}|] . Right $
          wrapForm modifyView FormSettings
            { formMethod   = POST
            , formAction   = Just . SomeRoute $ MessageR cID
            , formEncoding = modifyEnctype
            , formAttrs    = []
            , formSubmit   = FormSubmit
            , formAnchor   = Nothing :: Maybe Text
            }
        translationAddModal = modal [whamlet|_{MsgSystemMessageAddTranslation}|] . Right $
          wrapForm addTransView FormSettings
            { formMethod   = POST
            , formAction   = Just . SomeRoute $ MessageR cID
            , formEncoding = addTransEnctype
            , formAttrs    = []
            , formSubmit   = FormSubmit
            , formAnchor   = Nothing :: Maybe Text
            }
        translationsEditModal
          | not $ null modifyTranss' = modal [whamlet|_{MsgSystemMessageEditTranslations}|] . Right $ do
              let modifyTranss'' = flip map modifyTranss' $ \((_, transView), transEnctype) -> wrapForm transView FormSettings
                    { formMethod   = POST
                    , formAction   = Just . SomeRoute $ MessageR cID
                    , formEncoding = transEnctype
                    , formAttrs    = []
                    , formSubmit   = FormNoSubmit
                    , formAnchor   = Nothing :: Maybe Text
                    }
              [whamlet|
                $forall transView <- modifyTranss''
                  <section>
                    ^{transView}
              |]
          | otherwise = mempty
      return (messageEditModal, translationAddModal, translationsEditModal)

  maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
  forms <- traverse (const mkForm) $ () <$ guard maySubmit

  siteLayout' (toWidget <$> summary)
    $(widgetFile "system-message")
  where
    modifySystemMessage smId sm = do
      runDB $ replace smId sm
      invalidateVisibleSystemMessages
      addMessageI Success MsgSystemMessageEditSuccess
      redirect $ MessageR cID

    addTranslation translation = do
      runDB . void $ insert translation
      addMessageI Success MsgSystemMessageAddTranslationSuccess
      redirect $ MessageR cID

type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation)

data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate
  deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe ActionSystemMessage
instance Finite ActionSystemMessage

nullaryPathPiece ''ActionSystemMessage (camelToPathPiece' 1)
embedRenderMessage ''UniWorX ''ActionSystemMessage (("SystemMessage" <>) . dropPrefix "SM")

data ActionSystemMessageData = SMDDelete
                             | SMDActivate (Maybe UTCTime)
                             | SMDDeactivate (Maybe UTCTime)
  deriving (Eq, Show, Read)

getMessageListR, postMessageListR :: Handler Html
getMessageListR = postMessageListR
postMessageListR = do
  let
    dbtSQLQuery = return
    dbtColonnade = mconcat
      [ dbSelect (applying _2) id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR ciphertext
      , sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
      , sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
      , sortable (Just "on-volatile-cluster-settings") (i18nCell MsgSystemMessageOnVolatileClusterSettings) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell . toWidget . unlines . fmap (\(k,v) -> Text.intercalate " = " [tshow k, tshow v]) $ Set.toList systemMessageOnVolatileClusterSettings
      , sortable (Just "news-only") (i18nCell MsgSystemMessageNewsOnly) $ \DBRow { dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageNewsOnly
      , sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
      , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
      , sortable (Just "priority") (i18nCell MsgSystemMessagePriority) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> maybe mempty numCell systemMessageManualPriority
      , sortable (Just "created") (i18nCell MsgSystemMessageCreated) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageCreated
      , sortable (Just "last-changed") (i18nCell MsgSystemMessageLastChanged) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastChanged
      , sortable (Just "last-unhide") (i18nCell MsgSystemMessageLastUnhide) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ formatTimeW SelFormatDateTime systemMessageLastUnhide
      , sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
          (summary, content) = case smT of
              Nothing -> (systemMessageSummary, systemMessageContent)
              Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
            in cell . toWidget $ fromMaybe content summary
      ]
    dbtProj = dbtProjSimple $ \smE@(Entity smId _) ->
      (smE, ) . (>>= view _2) <$> getSystemMessage smId
    psValidator = def :: PSValidator (MForm Handler) (FormResult (Last ActionSystemMessageData, DBFormResult CryptoUUIDSystemMessage Bool MessageListData))
  (tableRes', tableView) <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery
    , dbtRowKey = (E.^. SystemMessageId)
    , dbtColonnade
    , dbtProj
    , dbtSorting = Map.fromList
      [ ( "from"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageFrom
        )
      , ( "to"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageTo
        )
      , ( "on-volatile-cluster-settings"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageOnVolatileClusterSettings
        )
      , ( "news-only"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageNewsOnly
        )
      , ( "authenticated"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
        )
      , ( "severity"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
        )
      , ( "priority"
        , SortColumn (E.^. SystemMessageManualPriority)
        )
      , ( "created"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageCreated
        )
      , ( "last-changed"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastChanged
        )
      , ( "last-unhide"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageLastUnhide
        )
      ]
    , dbtFilter = mempty
    , dbtFilterUI = mempty
    , dbtStyle = def
    , dbtParams = DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Just $ SomeRoute MessageListR
      , dbParamsFormAttrs = []
      , dbParamsFormSubmit = FormSubmit
      , dbParamsFormAdditional = \frag -> do
          now <- liftIO getCurrentTime
          let actions = Map.fromList
                [ (SMDelete, pure SMDDelete)
                , (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
                , (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
                ]
          (actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
          return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
      , dbParamsFormEvaluate = liftHandler . runFormPost
      , dbParamsFormResult = id
      , dbParamsFormIdent = def
      }
    , dbtIdent = "messages" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    , dbtExtraReps = []
    }

  let tableRes = tableRes' <&> _2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
                           <&> _1 %~ fromMaybe (error "By construction the form should always return an action") . getLast

  case tableRes of
    FormMissing -> return ()
    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
    FormSuccess (SMDDelete, selection)
      | not $ null selection -> do
          selection' <- traverse decrypt $ Set.toList selection
          runDB $ deleteWhere [ SystemMessageId <-. selection' ]
          invalidateVisibleSystemMessages
          $(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
          redirect MessageListR
    FormSuccess (SMDActivate ts, selection)
      | not $ null selection -> do
          selection' <- traverse decrypt $ Set.toList selection
          runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
          invalidateVisibleSystemMessages
          $(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
          redirect MessageListR
    FormSuccess (SMDDeactivate ts, selection)
      | not $ null selection -> do
          selection' <- traverse decrypt $ Set.toList selection
          runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
          invalidateVisibleSystemMessages
          $(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
          redirect MessageListR
    FormSuccess (_, _selection) -- prop> null _selection
      -> addMessageI Error MsgSystemMessageEmptySelection

  MsgRenderer mr <- getMsgRenderer
  now <- liftIO getCurrentTime
  ((addRes, addView), addEncoding) <- runFormPost . identifyForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just Nothing)
    <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just Nothing)
    <*> systemMessageVolatileClusterSettingsForm Nothing
    <*> apopt checkBoxField (fslI MsgSystemMessageNewsOnly) (Just False)
    <*> apopt checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just False)
    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just Info)
    <*> aopt (natFieldI MsgSystemMessagePriorityNegative) (fslI MsgSystemMessagePriority) (Just Nothing)
    <*> pure now <*> pure now <*> pure now
    <*> areq (langField False) (fslpI MsgSystemMessageLanguage (mr MsgRFC1766)) (Just $ NonEmpty.head appLanguages)
    <*> areq htmlField (fslI MsgSystemMessageContent) Nothing
    <*> aopt htmlField (fslI MsgSystemMessageSummary) (Just Nothing)

  case addRes of
    FormMissing -> return ()
    FormFailure errs -> forM_ errs $ addMessage Error . toHtml
    FormSuccess sysMsg -> do
      sId <- runDB $ insert sysMsg
      cID <- encrypt sId :: Handler CryptoUUIDSystemMessage
      addMessageI Success $ MsgSystemMessageAdded cID
      redirect $ MessageR cID

  let addForm = wrapForm addView def
        { formAction   = Just $ SomeRoute MessageListR
        , formEncoding = addEncoding
        }

  defaultLayout
    $(widgetFile "system-message-list")


data ButtonSystemMessageHide
  = BtnSystemMessageHide
  | BtnSystemMessageUnhide
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)
nullaryPathPiece ''ButtonSystemMessageHide $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''ButtonSystemMessageHide id

instance Button UniWorX ButtonSystemMessageHide where
  btnClasses BtnSystemMessageHide = [BCLink]
  btnClasses BtnSystemMessageUnhide = [BCLink]


postMessageHideR :: CryptoUUIDSystemMessage -> Handler Void
postMessageHideR cID = do
  now <- liftIO getCurrentTime
  muid <- maybeAuthId
  smId <- decrypt cID

  ((btnRes, _), _) <- runFormPost buttonForm

  formResult btnRes $ \case
    BtnSystemMessageHide -> runDB $ do
      existsKey404 smId

      whenIsJust muid $ \uid -> void $
        upsert SystemMessageHidden
          { systemMessageHiddenMessage = smId
          , systemMessageHiddenUser    = uid
          , systemMessageHiddenTime    = now
          }
          [ SystemMessageHiddenTime =. now ]

      modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
        -> fmap MergeHashMap . assertM' (/= mempty) $
             HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageUnhidden = Nothing, userSystemMessageHidden = guardOn (is _Nothing muid) now }) cID hm

    BtnSystemMessageUnhide -> runDB $ do
      existsKey404 smId

      whenIsJust muid $ \uid ->
        deleteBy $ UniqueSystemMessageHidden uid smId

      modifyRegisteredCookieJson CookieSystemMessageState $ \(fold -> MergeHashMap hm)
        -> fmap MergeHashMap . assertM' (/= mempty) $
             HashMap.update (\smSt -> assertM' (/= mempty) $ smSt { userSystemMessageHidden = Nothing, userSystemMessageUnhidden = guardOn (is _Nothing muid) now }) cID hm

  redirect . (NewsR, ) . bool [] [(toPathPiece GetHidden, "")] $ btnRes == FormSuccess BtnSystemMessageUnhide