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 Utils.Lens

  
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 (id :: MessageClass -> MessageClass)) (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)
              )
          <*> combinedButtonField (universeF :: [BtnSubmitDelete])

      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
$(return [])
instance PathPiece ActionSystemMessage where
  toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ])
  fromPathPiece = finiteFromPathPiece

instance RenderMessage UniWorX ActionSystemMessage where
  renderMessage m ls = renderMessage m ls . \case
    SMDelete -> MsgSystemMessageDelete
    SMActivate -> MsgSystemMessageActivate
    SMDeactivate -> MsgSystemMessageDeactivate

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 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 (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
  tableForm <- dbTable psValidator DBTable
    { dbtSQLQuery
    , dbtColonnade
    , dbtProj
    , dbtSorting = Map.fromList
      [ -- TODO: from, to, authenticated, severity
      ]
    , dbtFilter = Map.fromList
      [
      ]
    , dbtStyle = def
    , dbtIdent = "messages" :: Text
    }
  ((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
    (fmap $ Map.keysSet . Map.filter id . getDBFormResult (const False) -> selectionRes, table) <- tableForm csrf
    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)
    $logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
    return ((,) <$> actionRes <*> selectionRes, table <> action)

  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 (id :: MessageClass -> MessageClass)) (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")