module Handler.SystemMessage where

import Import

import qualified Data.Map.Lazy as Map

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' 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 appLanguages smId
  let (summary, content) = case translation of
        Nothing -> (systemMessageSummary, systemMessageContent)
        Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)

  let
    mkForm = do
      ((modifyRes, modifyView), modifyEnctype) <- runFormPost . identifyForm 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)

      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
                  <$> 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 . identifyForm 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

      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 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 = []
      , 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 = liftHandlerT . runFormPost
      , dbParamsFormResult = id
      , dbParamsFormIdent = def
      }
    , dbtIdent = "messages" :: Text
    , dbtCsvEncode = noCsvEncode
    , dbtCsvDecode = Nothing
    }

  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 . identifyForm 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

  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")