module Handler.SystemMessage
  ( getMessageR, postMessageR
  , getMessageListR, postMessageListR
  , ButtonSystemMessageHide(..)
  , postMessageHideR
  ) where

import Import

import qualified Data.Map.Lazy as Map

import qualified Data.Set as Set
import qualified Data.HashMap.Strict as HashMap

import qualified Data.List.NonEmpty as NonEmpty

import Handler.Utils
import Handler.Utils.News

import qualified Database.Esqueleto as E

-- htmlField' moved to Handler.Utils.Form/Fields

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)
          <*> 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
      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 "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 DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
      smT <- (>>= view _2) <$> getSystemMessage smId
      return DBRow
        { dbrOutput = (smE, smT)
        , ..
        }
    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
        )
      , ( "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 $ deleteCascadeWhere [ SystemMessageId <-. selection' ]
          $(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 ]
          $(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 ]
          $(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)
    <*> 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, Typeable)
  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
