module Handler.SystemMessage where

import Import

import qualified Data.Map.Lazy as Map
import qualified Data.Text as Text

import qualified Data.Set as Set

import qualified Data.List.NonEmpty as NonEmpty

import Handler.Utils
import Handler.Utils.Table.Cells

import Utils.Lens

import qualified Database.Esqueleto as E


htmlField' :: Field (HandlerT UniWorX IO) Html
htmlField' = htmlField
  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
  }



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

  let
    mkForm = do
      ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
        $ SystemMessage
          <$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
          <*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
          <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
          <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary)
          <* submitButton

      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 . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
          $ (,)
          <$> fmap (Entity tId)
              ( SystemMessageTranslation
                  <$> pure systemMessageTranslationMessage
                  <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
                  <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
                  <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
              )
          <*> combinedButtonFieldF ""

      let modifyTranss = Map.map (view $ _1._1) modifyTranss'

      ((addTransRes, addTransView), addTransEnctype) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
        $ SystemMessageTranslation
          <$> pure smId
          <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
          <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
          <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
          <* submitButton

      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
          [whamlet|
            <form method=post action=@{MessageR cID} enctype=#{modifyEnctype}>
              ^{modifyView}
          |]
        translationAddModal = modal [whamlet|_{MsgSystemMessageAddTranslation}|] $ Right
          [whamlet|
            <form method=post action=@{MessageR cID} enctype=#{addTransEnctype}>
              ^{addTransView}
          |]
        translationsEditModal
          | not $ null modifyTranss' = modal [whamlet|_{MsgSystemMessageEditTranslations}|] $ Right
            [whamlet|
              $forall ((_, transView), transEnctype) <- modifyTranss'
                <section>
                  <form method=post action=@{MessageR cID} enctype=#{transEnctype}>
                    ^{transView}
            |]
          | otherwise = mempty
      return (messageEditModal, translationAddModal, translationsEditModal)

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

  defaultLayout
    $(widgetFile "system-message")
  where
    modifySystemMessage smId SystemMessage{..} = do
      runDB $ update smId
        [ SystemMessageFrom =. systemMessageFrom
        , SystemMessageTo =. systemMessageTo
        , SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
        , SystemMessageSeverity =. systemMessageSeverity
        , SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
        , SystemMessageContent =. systemMessageContent
        , SystemMessageSummary =. systemMessageSummary
        ]
      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
      , dbRow
      , sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) MessageR (toWidget . tshow . 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 "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
      , sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
      , 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
      Just (_, smT) <- lift $ getSystemMessage appLanguages smId
      return DBRow
        { dbrOutput = (smE, smT)
        , ..
        }
    psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (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
        )
      , ( "authenticated"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageAuthenticatedOnly
        )
      , ( "severity"
        , SortColumn $ \systemMessage -> systemMessage E.^. SystemMessageSeverity
        )
      ]
    , dbtFilter = mempty
    , dbtFilterUI = mempty
    , dbtStyle = def
    , dbtParams = DBParamsForm
      { dbParamsFormMethod = POST
      , dbParamsFormAction = Just $ SomeRoute MessageListR
      , dbParamsFormAttrs = []
      , dbParamsFormAddSubmit = True
      , 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) <- multiAction actions (Just SMActivate)
          return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
      , dbParamsFormEvaluate = liftHandlerT . runFormPost
      , dbParamsFormResult = id
      }
    , dbtIdent = "messages" :: Text
    }

  let tableRes = tableRes' & mapped._2 %~ Map.keysSet . Map.filter id . getDBFormResult (const False)
                           & mapped._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

  ((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
    <$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
    <*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
    <*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
    <*> areq (selectField optionsFinite) (fslI MsgSystemMessageSeverity) Nothing
    <*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
    <*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
    <*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
    <* submitButton

  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

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