content: {-# LANGUAGE RankNTypes #-}
  module Matterhorn.State.MessageSelect
    (
    -- * Message selection mode
      beginMessageSelect
    , flagSelectedMessage
    , pinSelectedMessage
    , viewSelectedMessage
    , openSelectedMessageInEditor
    , fillSelectedGap
    , copyPostLink
    , yankSelectedMessageVerbatim
    , yankSelectedMessage
    , openSelectedMessageURLs
    , beginConfirmDeleteSelectedMessage
    , messageSelectUp
    , messageSelectUpBy
    , messageSelectDown
    , messageSelectDownBy
    , messageSelectFirst
    , messageSelectLast
    , deleteSelectedMessage
    , beginReplyCompose
    , beginEditMessage
    , flagMessage
    , getSelectedMessage
    , openThreadWindow
    , exitMessageSelect
    )
  where
  
  import           Prelude ()
  import           Matterhorn.Prelude
  
  import           Brick ( invalidateCache )
  import           Brick.Widgets.Edit ( applyEdit )
  import           Control.Monad ( replicateM_ )
  import qualified Data.Text as T
  import           Data.Text.Zipper ( clearZipper, insertMany )
  import           Data.Maybe ( fromJust )
  import           Lens.Micro.Platform
  import qualified System.Environment as Sys
  import           System.IO (hClose, hPutStr)
  import qualified System.IO.Temp as Sys
  import qualified System.Process as Sys
  
  import qualified Network.Mattermost.Endpoints as MM
  import           Network.Mattermost.Types
  
  import           Matterhorn.Clipboard ( copyToClipboard )
  import           Matterhorn.State.Common
  import           Matterhorn.State.Links
  import {-# SOURCE #-} Matterhorn.State.Messages ( asyncFetchMessagesForGap )
  import           Matterhorn.Types
  import           Matterhorn.Types.RichText ( findVerbatimChunk, makePermalink )
  import           Matterhorn.Types.Common
  import           Matterhorn.Windows.ViewMessage
  import qualified Matterhorn.State.ThreadWindow as TW
  
  
  getSelectedMessage :: Lens' ChatState (MessageInterface n i)
                     -> ChatState
                     -> Maybe Message
  getSelectedMessage which st = do
      selMsgId <- selectMessageId $ st^.which.miMessageSelect
      let chanMsgs = st^.which.miMessages
      findMessage selMsgId chanMsgs
  
  withSelectedMessage :: Lens' ChatState (MessageInterface n i)
                      -> (Message -> MH ())
                      -> MH ()
  withSelectedMessage which act = do
      selectedMessage <- use (to (getSelectedMessage which))
      case selectedMessage of
          Nothing -> return ()
          Just m -> act m
  
  beginMessageSelect :: Lens' ChatState (MessageInterface n i)
                     -> MH ()
  beginMessageSelect which = do
      -- Invalidate the rendering cache since we cache messages to speed
      -- up the selection UI responsiveness. (See Draw.Messages for
      -- caching behavior.)
      mh invalidateCache
  
      -- Get the number of messages in the listing and set the currently
      -- selected message index to be the most recently received message
      -- that corresponds to a Post (i.e. exclude informative messages).
      --
      -- If we can't find one at all, we ignore the mode switch request
      -- and just return.
      msgs <- use (which.miMessages)
      let recentMsg = getLatestSelectableMessage msgs
  
      when (isJust recentMsg) $ do
          which.miMode .= MessageSelect
          which.miMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId)
  
  exitMessageSelect :: Lens' ChatState (MessageInterface n i) -> MH ()
  exitMessageSelect which = do
      m <- use (which.miMode)
      when (m == MessageSelect) $
          which.miMode .= Compose
  
  -- | Tell the server that the message we currently have selected
  -- should have its flagged state toggled.
  flagSelectedMessage :: Lens' ChatState (MessageInterface n i)
                      -> MH ()
  flagSelectedMessage which =
      withSelectedMessage which $ \msg ->
          when (isFlaggable msg) $ do
              case messagePostId msg of
                  Just pId -> flagMessage pId (not (msg^.mFlagged))
                  Nothing -> return ()
  
  -- | Tell the server that the message we currently have selected
  -- should have its pinned state toggled.
  pinSelectedMessage :: Lens' ChatState (MessageInterface n i)
                     -> MH ()
  pinSelectedMessage which =
      withSelectedMessage which $ \msg -> do
          when (isPinnable msg) $ do
              case messagePostId msg of
                  Just pId -> pinMessage pId (not (msg^.mPinned))
                  Nothing -> return ()
  
  viewSelectedMessage :: TeamId
                      -> Lens' ChatState (MessageInterface n i)
                      -> MH ()
  viewSelectedMessage tId which =
      withSelectedMessage which $ \msg ->
          when (not (isGap msg)) $ viewMessage tId msg
  
  openSelectedMessageInEditor :: Lens' ChatState (MessageInterface n i)
                              -> MH ()
  openSelectedMessageInEditor which =
      withSelectedMessage which $ \msg ->
          when (not (isGap msg)) $ openMessageInEditor msg which
  
  -- This will only work for channel message selection, not thread message
  -- selection, since there will never be gap entries in the thread view.
  -- But this is generalized enough that it looks like it should work for
  -- thread views, but it won't because asyncFetchMessagesForGap only
  -- works for channel message selection (and should).
  fillSelectedGap :: Lens' ChatState (MessageInterface n i)
                  -> MH ()
  fillSelectedGap which = do
      cId <- use (which.miChannelId)
      withSelectedMessage which $ \msg ->
          when (isGap msg) $ asyncFetchMessagesForGap cId msg
  
  copyPostLink :: TeamId
               -> Lens' ChatState (MessageInterface n i)
               -> MH ()
  copyPostLink tId which =
      withSelectedMessage which $ \msg ->
          when (isPostMessage msg) $ do
              baseUrl <- getServerBaseUrl tId
              let pId = fromJust (messageIdPostId =<< _mMessageId msg)
              copyToClipboard $ makePermalink baseUrl pId
              exitMessageSelect which
  
  viewMessage :: TeamId -> Message -> MH ()
  viewMessage tId m = do
      let w = tabbedWindow VMTabMessage (viewMessageWindowTemplate tId) (78, 25)
      csTeam(tId).tsViewedMessage .= Just (m, w)
      runTabShowHandlerFor (twValue w) w
      pushMode tId ViewMessage
  
  openMessageInEditor :: Message -> Lens' ChatState (MessageInterface n i) -> MH ()
  openMessageInEditor m which = do
      -- If EDITOR is in the environment, write the current message to a
      -- temp file, invoke EDITOR on it, read the result, remove the temp
      -- file, and update the program state.
      --
      -- If EDITOR is not present, fall back to 'vi'.
      mEnv <- liftIO $ Sys.lookupEnv "EDITOR"
      let editorProgram = maybe "vi" id mEnv
  
      case m^.mOriginalPost of
          Nothing -> return ()
          Just p -> do
              mhSuspendAndResume $ \s -> do
                  Sys.withSystemTempFile "matterhorn_editor.md" $ \tmpFileName tmpFileHandle -> do
                      hPutStr tmpFileHandle $ T.unpack $ unsafeUserText $ postMessage p
                      hClose tmpFileHandle
                      void $ Sys.system (editorProgram <> " " <> tmpFileName)
                      return s
  
      exitMessageSelect which
  
  yankSelectedMessageVerbatim :: Lens' ChatState (MessageInterface n i)
                              -> MH ()
  yankSelectedMessageVerbatim which =
      withSelectedMessage which $ \msg -> do
          exitMessageSelect which
          case findVerbatimChunk (msg^.mText) of
              Just txt -> copyToClipboard txt
              Nothing  -> return ()
  
  openThreadWindow :: TeamId
                   -> Lens' ChatState (MessageInterface n i)
                   -> MH ()
  openThreadWindow tId which =
      withSelectedMessage which $ \msg -> do
          when (isPostMessage msg) $ do
              rootMsg <- getReplyRootMessage msg
              let p = fromJust $ rootMsg^.mOriginalPost
              case msg^.mChannelId of
                  Nothing -> return ()
                  Just cId -> do
                      -- Leave message selection mode
                      exitMessageSelect which
                      TW.openThreadWindow tId cId (postId p)
  
  yankSelectedMessage :: Lens' ChatState (MessageInterface n i)
                      -> MH ()
  yankSelectedMessage which =
      withSelectedMessage which $ \msg -> do
          exitMessageSelect which
          copyToClipboard $ msg^.mMarkdownSource
  
  openSelectedMessageURLs :: Lens' ChatState (MessageInterface n i)
                          -> MH ()
  openSelectedMessageURLs which =
      withSelectedMessage which $ \msg -> do
          let urls = msgURLs msg
          when (not (null urls)) $ do
              mapM_ (openLinkTarget . _linkTarget) urls
  
  beginConfirmDeleteSelectedMessage :: TeamId
                                    -> Lens' ChatState (MessageInterface n i)
                                    -> MH ()
  beginConfirmDeleteSelectedMessage tId which = do
      st <- use id
      target <- use (which.miTarget)
      withSelectedMessage which $ \msg ->
          when (isDeletable msg && isMine st msg) $
              pushMode tId $ MessageSelectDeleteConfirm target
  
  messageSelectUp :: Lens' ChatState (MessageInterface n i)
                  -> MH ()
  messageSelectUp which =
      withSelectedMessage which $ \msg -> do
          let selected = _mMessageId msg
          msgs <- use (which.miMessages)
          let nextMsgId = getPrevMessageId selected msgs
          which.miMessageSelect .= MessageSelectState (nextMsgId <|> selected)
  
  messageSelectDown :: Lens' ChatState (MessageInterface n i)
                    -> MH ()
  messageSelectDown which =
      withSelectedMessage which $ \msg -> do
          let selected = _mMessageId msg
          msgs <- use (which.miMessages)
          let nextMsgId = getNextMessageId selected msgs
          which.miMessageSelect .= MessageSelectState (nextMsgId <|> selected)
  
  messageSelectDownBy :: Lens' ChatState (MessageInterface n i)
                      -> Int
                      -> MH ()
  messageSelectDownBy which amt =
      replicateM_ amt $ messageSelectDown which
  
  messageSelectUpBy :: Lens' ChatState (MessageInterface n i)
                    -> Int
                    -> MH ()
  messageSelectUpBy which amt =
      replicateM_ amt $ messageSelectUp which
  
  messageSelectFirst :: Lens' ChatState (MessageInterface n i)
                     -> MH ()
  messageSelectFirst which =
      withSelectedMessage which $ \msg -> do
          let selected = _mMessageId msg
          msgs <- use (which.miMessages)
          case getEarliestSelectableMessage msgs of
            Just firstMsg ->
              which.miMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)
            Nothing -> mhLog LogError "No first message found from current message?!"
  
  messageSelectLast :: Lens' ChatState (MessageInterface n i)
                    -> MH ()
  messageSelectLast which =
      withSelectedMessage which $ \msg -> do
          let selected = _mMessageId msg
          msgs <- use (which.miMessages)
          case getLatestSelectableMessage msgs of
            Just lastSelMsg ->
              which.miMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)
            Nothing -> mhLog LogError "No last message found from current message?!"
  
  deleteSelectedMessage :: Lens' ChatState (MessageInterface n i)
                        -> MH ()
  deleteSelectedMessage which = do
      st <- use id
      withSelectedMessage which $ \msg ->
          when (isMine st msg && isDeletable msg) $ do
              exitMessageSelect which
              case msg^.mOriginalPost of
                  Just p ->
                      doAsyncMM Preempt
                          (\s -> MM.mmDeletePost (postId p) s)
                          (const Nothing)
                  Nothing -> return ()
  
  beginReplyCompose :: Lens' ChatState (MessageInterface n i)
                    -> MH ()
  beginReplyCompose which = do
      withSelectedMessage which $ \msg ->
          when (isReplyable msg) $ do
              rootMsg <- getReplyRootMessage msg
              let p = fromJust $ rootMsg^.mOriginalPost
              exitMessageSelect which
              which.miEditor.esEditMode .= Replying rootMsg p
  
  beginEditMessage :: Lens' ChatState (MessageInterface n i)
                   -> MH ()
  beginEditMessage which = do
      st <- use id
      withSelectedMessage which $ \msg ->
          when (isMine st msg && isEditable msg) $ do
              let p = fromJust $ msg^.mOriginalPost
              exitMessageSelect which
              which.miEditor.esEditMode .= Editing p (msg^.mType)
              -- If the post that we're editing is an emote, we need
              -- to strip the formatting because that's only there to
              -- indicate that the post is an emote. This is annoying and
              -- can go away one day when there is an actual post type
              -- value of "emote" that we can look at. Note that the
              -- removed formatting needs to be reinstated just prior to
              -- issuing the API call to update the post.
              let sanitized = sanitizeUserText $ postMessage p
              let toEdit = if isEmote msg
                           then removeEmoteFormatting sanitized
                           else sanitized
              which.miEditor.esEditor %= applyEdit (insertMany toEdit . clearZipper)
  
  -- | Tell the server that we have flagged or unflagged a message.
  flagMessage :: PostId -> Bool -> MH ()
  flagMessage pId f = do
      session <- getSession
      myId <- gets myUserId
      doAsyncWith Normal $ do
          let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost
          doFlag myId pId session
          return Nothing
  
  -- | Tell the server that we have pinned or unpinned a message.
  pinMessage :: PostId -> Bool -> MH ()
  pinMessage pId f = do
      session <- getSession
      doAsyncWith Normal $ do
          let doPin = if f then MM.mmPinPostToChannel else MM.mmUnpinPostToChannel
          void $ doPin pId session
          return Nothing
  