{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
module State where

import           Prelude ()
import           Prelude.Compat

import           Brick (invalidateCacheEntry)
import           Brick.Widgets.Edit (getEditContents, editContentsL)
import           Brick.Widgets.List (list, listMoveTo, listSelectedElement)
import           Control.Applicative
import           Control.Exception (SomeException, catch, try)
import           Control.Monad.IO.Class (liftIO)
import qualified Control.Concurrent.STM as STM
import           Data.Char (isAlphaNum)
import           Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy)
import           Brick.Widgets.Edit (applyEdit)
import           Control.Monad (when, void)
import qualified Data.ByteString as BS
import           Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL)
import qualified Data.HashMap.Strict as HM
import qualified Data.Sequence as Seq
import           Data.List (sort)
import           Data.Maybe (maybeToList, isJust, catMaybes, isNothing)
import           Data.Monoid ((<>))
import           Data.Time.Clock (UTCTime, getCurrentTime)
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Data.Foldable as F
import           Graphics.Vty (outputIface)
import           Graphics.Vty.Output.Interface (ringTerminalBell)
import           Lens.Micro.Platform
import           System.Exit (ExitCode(..))
import           System.Process (proc, std_in, std_out, std_err, StdStream(..),
                                 createProcess, waitForProcess)
import           System.IO (hGetContents)
import           System.Directory ( createDirectoryIfMissing )
import           System.Environment.XDG.BaseDir ( getUserCacheDir )
import           System.FilePath

import           Network.Mattermost
import           Network.Mattermost.Exceptions
import           Network.Mattermost.Lenses

import           Config
import           FilePaths
import           Types
import           Types.Posts
import           Types.Messages
import           InputHistory
import           Themes
import           Zipper (Zipper)
import qualified Zipper as Z
import           Markdown (blockGetURLs, findVerbatimChunk)

import           State.Common

-- * Hard-coded constants

-- | The number of posts to include per page
pageAmount :: Int
pageAmount = 15

-- * Refreshing Channel Data

-- | Get all the new messages for a given channel. In addition, load the
-- channel metadata and update that, too.
refreshChannel :: ChannelId -> MH ()
refreshChannel chan = do
  msgs <- use (csChannel(chan).ccContents.cdMessages)
  session <- use csSession
  myTeamId <- use (csMyTeam.teamIdL)
  doAsyncWith Normal $
    case getLatestPostId msgs of
    Just pId -> do
      -- Get the latest channel metadata.
      cwd <- mmGetChannel session myTeamId chan

      -- Load posts since the last post in this channel.  Note that
      -- postsOrder from mattermost-api is most recent first.
      posts <- mmGetPostsAfter session myTeamId chan pId 0 100
      return $ do
        mapM_ addMessageToState [ (posts^.postsPostsL) HM.! p
                                | p <- F.toList (posts^.postsOrderL)
                                ]
        let newChanInfo ci = channelInfoFromChannelWithData cwd ci
                               & cdCurrentState     .~ ChanLoaded

        csChannel(chan).ccInfo %= newChanInfo
    _ -> return (return ())

-- | Find all the loaded channels and refresh their state, setting the
-- state as dirty until we get a response
refreshLoadedChannels :: MH ()
refreshLoadedChannels = do
  msgs <- use msgMap
  sequence_
    [ refreshChannel cId
    | (cId, chan) <- HM.toList msgs
    , chan^.ccInfo.cdCurrentState == ChanLoaded
    ]
  let upd ChanLoaded = ChanRefreshing
      upd chanState  = chanState
  msgMap.each.ccInfo.cdCurrentState %= upd

-- * Message selection mode

beginMessageSelect :: MH ()
beginMessageSelect = do
    -- Get the number of messages in the current channel 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.
    chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)
    let recentPost = getLatestPostId chanMsgs

    when (isJust recentPost) $ do
        csMode .= MessageSelect
        csMessageSelect .= MessageSelectState recentPost

getSelectedMessage :: ChatState -> Maybe Message
getSelectedMessage st
    | st^.csMode /= MessageSelect && st^.csMode /= MessageSelectDeleteConfirm = Nothing
    | otherwise = do
        selPostId <- selectMessagePostId $ st^.csMessageSelect

        let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages
        findMessage selPostId chanMsgs

messageSelectUp :: MH ()
messageSelectUp = do
    mode <- use csMode
    selected <- use (csMessageSelect.to selectMessagePostId)
    case selected of
        Just _ | mode == MessageSelect -> do
            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
            let nextPostId = getPrevPostId selected chanMsgs
            csMessageSelect .= MessageSelectState (nextPostId <|> selected)
        _ -> return ()

messageSelectDown :: MH ()
messageSelectDown = do
    mode <- use csMode
    selected <- use (csMessageSelect.to selectMessagePostId)
    case selected of
        Just _ | mode == MessageSelect -> do
            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
            let nextPostId = getNextPostId selected chanMsgs
            csMessageSelect .= MessageSelectState (nextPostId <|> selected)
        _ -> return ()

isMine :: ChatState -> Message -> Bool
isMine st msg = (Just $ st^.csMe.userUsernameL) == msg^.mUserName

messageSelectDownBy :: Int -> MH ()
messageSelectDownBy amt
    | amt <= 0 = return ()
    | otherwise =
        messageSelectDown >> messageSelectDownBy (amt - 1)

messageSelectUpBy :: Int -> MH ()
messageSelectUpBy amt
    | amt <= 0 = return ()
    | otherwise =
      messageSelectUp >> messageSelectUpBy (amt - 1)

beginConfirmDeleteSelectedMessage :: MH ()
beginConfirmDeleteSelectedMessage =
    csMode .= MessageSelectDeleteConfirm

deleteSelectedMessage :: MH ()
deleteSelectedMessage = do
    selectedMessage <- use (to getSelectedMessage)
    st <- use id
    case selectedMessage of
        Just msg | isMine st msg && isDeletable msg -> do
            cId <- use csCurrentChannelId
            session <- use csSession
            myTeamId <- use (csMyTeam.teamIdL)
            doAsyncWith Preempt $ do
                let Just p = msg^.mOriginalPost
                mmDeletePost session myTeamId cId (postId p)
                return $ do
                    csEditState.cedEditMode .= NewPost
                    csMode .= Main
        _ -> return ()

beginCurrentChannelDeleteConfirm :: MH ()
beginCurrentChannelDeleteConfirm = do
    cId <- use csCurrentChannelId
    chType <- use (csChannel(cId).ccInfo.cdType)
    if chType /= Direct
       then csMode .= DeleteChannelConfirm
       else postErrorMessage "The /delete-channel command cannot be used with direct message channels."

deleteCurrentChannel :: MH ()
deleteCurrentChannel = do
    cId <- use csCurrentChannelId
    session <- use csSession
    myTeamId <- use (csMyTeam.teamIdL)
    doAsyncWith Preempt $ do
        mmDeleteChannel session myTeamId cId
        return $ do
            csMode .= Main
            leaveCurrentChannel

beginUpdateMessage :: MH ()
beginUpdateMessage = do
    selected <- use (to getSelectedMessage)
    st <- use id
    case selected of
        Just msg | isMine st msg && isEditable msg -> do
            let Just p = msg^.mOriginalPost
            csMode .= Main
            csEditState.cedEditMode .= Editing p
            csCmdLine %= applyEdit (clearZipper >> (insertMany $ postMessage p))
        _ -> return ()

replyToLatestMessage :: MH ()
replyToLatestMessage = do
  msgs <- use (csCurrentChannel . ccContents . cdMessages)
  case findLatestUserMessage isReplyable msgs of
    Just msg -> do let Just p = msg^.mOriginalPost
                   csMode .= Main
                   csEditState.cedEditMode .= Replying msg p
    _ -> return ()

beginReplyCompose :: MH ()
beginReplyCompose = do
    selected <- use (to getSelectedMessage)
    case selected of
        Nothing -> return ()
        Just msg -> do
            let Just p = msg^.mOriginalPost
            csMode .= Main
            csEditState.cedEditMode .= Replying msg p

cancelReplyOrEdit :: MH ()
cancelReplyOrEdit = do
    mode <- use (csEditState.cedEditMode)
    case mode of
        NewPost -> return ()
        _ -> do
            csEditState.cedEditMode .= NewPost
            csCmdLine %= applyEdit clearZipper

copyVerbatimToClipboard :: MH ()
copyVerbatimToClipboard = do
    selectedMessage <- use (to getSelectedMessage)
    case selectedMessage of
        Nothing -> return ()
        Just m -> case findVerbatimChunk (m^.mText) of
            Nothing -> return ()
            Just txt -> do
              copyToClipboard txt
              csMode .= Main

-- * Joining, Leaving, and Inviting

startJoinChannel :: MH ()
startJoinChannel = do
    session <- use csSession
    myTeamId <- use (csMyTeam.teamIdL)
    doAsyncWith Preempt $ do
        -- We don't get to just request all channels, so we request channels in
        -- chunks of 50.  A better UI might be to request an initial set and
        -- then wait for the user to demand more.
        let fetchCount     = 50
            loop acc start = do
              newChans <- mmGetMoreChannels session myTeamId start fetchCount
              let chans = acc <> newChans
              if length newChans < fetchCount
                then return chans
                else loop chans (start+fetchCount)
        chans <- loop mempty 0
        return $ do
            csJoinChannelList .= (Just $ list JoinChannelList (V.fromList $ F.toList chans) 1)

    csMode .= JoinChannel
    csJoinChannelList .= Nothing

joinChannel :: Channel -> MH ()
joinChannel chan = do
    let cId = getId chan
    session <- use csSession
    myTeamId <- use (csMyTeam.teamIdL)
    doAsyncWith Preempt $ do
        void $ mmJoinChannel session myTeamId cId
        return (return ())

    csMode .= Main

-- | When another user adds us to a channel, we need to fetch the
-- channel info for that channel.
handleChannelInvite :: ChannelId -> MH ()
handleChannelInvite cId = do
    st <- use id
    doAsyncWith Normal $ do
        tryMM (mmGetChannel (st^.csSession) (st^.csMyTeam.teamIdL) cId)
              (\(ChannelWithData chan _) -> do
                return $ do
                  handleNewChannel (preferredChannelName chan) False chan
                  asyncFetchScrollback Normal cId)

startLeaveCurrentChannel :: MH ()
startLeaveCurrentChannel = do
    cInfo <- use (csCurrentChannel.ccInfo)
    case canLeaveChannel cInfo of
        True -> csMode .= LeaveChannelConfirm
        False -> postErrorMessage "The /leave command cannot be used with this channel."

canLeaveChannel :: ChannelInfo -> Bool
canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct, Group]

leaveCurrentChannel :: MH ()
leaveCurrentChannel = do
    cId <- use csCurrentChannelId
    cInfo <- use (csCurrentChannel.ccInfo)
    session <- use csSession
    myTeamId <- use (csMyTeam.teamIdL)

    when (canLeaveChannel cInfo) $ doAsyncWith Preempt $ do
        mmLeaveChannel session myTeamId cId
        return (removeChannelFromState cId)

removeChannelFromState :: ChannelId -> MH ()
removeChannelFromState cId = do
    cName <- use (csChannel(cId).ccInfo.cdName)
    chType <- use (csChannel(cId).ccInfo.cdType)
    when (chType /= Direct) $ do
            csEditState.cedInputHistoryPosition .at cId .= Nothing
            csEditState.cedLastChannelInput     .at cId .= Nothing
            -- Update input history
            csEditState.cedInputHistory         %= removeChannelHistory cId
            -- Flush cnToChanId
            csNames.cnToChanId                  .at cName .= Nothing
            -- Flush cnChans
            csNames.cnChans                     %= filter (/= cName)
            -- Update msgMap
            msgMap                              .at cId .= Nothing
            -- Remove from focus zipper
            csFocus                             %= Z.filterZipper (/= cId)

fetchCurrentChannelMembers :: MH ()
fetchCurrentChannelMembers = do
    cId <- use csCurrentChannelId
    session <- use csSession
    myTeamId <- use (csMyTeam.teamIdL)
    doAsyncWith Preempt $ do
        chanUserMap <- mmGetChannelMembers session myTeamId cId 0 10000

        -- Construct a message listing them all and post it to the
        -- channel:
        let msgStr = "Channel members (" <> (T.pack $ show $ length chanUsers) <> "):\n" <>
                     T.intercalate ", " usernames
            chanUsers = snd <$> HM.toList chanUserMap
            usernames = sort $ userUsername <$> (F.toList chanUsers)

        return $ postInfoMessage msgStr

-- *  Channel Updates and Notifications

hasUnread :: ChatState -> ChannelId -> Bool
hasUnread st cId = maybe False id $ do
  chan <- st^.msgMap.at(cId)
  u <- chan^.ccInfo.cdViewed
  let v = chan^.ccInfo.cdUpdated
  return (v > u)

setLastViewedFor :: ChannelId -> MH ()
setLastViewedFor cId = do
  now <- getNow
  msgs <- use msgMap
  if cId `HM.member` msgs
    then csChannel(cId).ccInfo.cdViewed .= Just now
    else handleChannelInvite cId

updateViewed :: MH ()
updateViewed = do
  st <- use id
  liftIO (updateViewedIO st)

resetHistoryPosition :: MH ()
resetHistoryPosition = do
    cId <- use csCurrentChannelId
    csInputHistoryPosition.at cId .= Just Nothing

updateStatus :: UserId -> T.Text -> MH ()
updateStatus uId t =
  usrMap.ix(uId).uiStatus .= statusFromText t

clearEditor :: MH ()
clearEditor = csCmdLine %= applyEdit clearZipper

loadLastEdit :: MH ()
loadLastEdit = do
    cId <- use csCurrentChannelId
    lastInput <- use (csLastChannelInput.at cId)
    case lastInput of
        Nothing -> return ()
        Just (lastEdit, lastEditMode) -> do
            csCmdLine %= (applyEdit $ insertMany (lastEdit) . clearZipper)
            csEditState.cedEditMode .= lastEditMode

saveCurrentEdit :: MH ()
saveCurrentEdit = do
    cId <- use csCurrentChannelId
    cmdLine <- use csCmdLine
    mode <- use (csEditState.cedEditMode)
    csLastChannelInput.at cId .=
      Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode)

resetCurrentEdit :: MH ()
resetCurrentEdit = do
    cId <- use csCurrentChannelId
    csLastChannelInput.at cId .= Nothing

updateChannelListScroll :: MH ()
updateChannelListScroll = do
    mh $ vScrollToBeginning (viewportScroll ChannelList)

postChangeChannelCommon :: MH ()
postChangeChannelCommon = do
    resetHistoryPosition
    fetchCurrentScrollback
    resetEditorState
    updateChannelListScroll
    loadLastEdit
    resetCurrentEdit

resetEditorState :: MH ()
resetEditorState = do
    csEditState.cedEditMode .= NewPost
    clearEditor

preChangeChannelCommon :: MH ()
preChangeChannelCommon = do
    cId <- use csCurrentChannelId
    csRecentChannel .= Just cId
    saveCurrentEdit
    clearNewMessageCutoff cId

nextChannel :: MH ()
nextChannel = do
    st <- use id
    setFocusWith (getNextNonDMChannel st Z.right)

prevChannel :: MH ()
prevChannel = do
    st <- use id
    setFocusWith (getNextNonDMChannel st Z.left)

recentChannel :: MH ()
recentChannel = do
  recent <- use csRecentChannel
  case recent of
    Nothing  -> return ()
    Just cId -> setFocus cId

nextUnreadChannel :: MH ()
nextUnreadChannel = do
    st <- use id
    setFocusWith (getNextUnreadChannel st)

getNextNonDMChannel :: ChatState
                    -> (Zipper ChannelId -> Zipper ChannelId)
                    -> (Zipper ChannelId -> Zipper ChannelId)
getNextNonDMChannel st shift z =
    if (st^?msgMap.ix(Z.focus z).ccInfo.cdType) == Just Direct
    then z
    else go (shift z)
  where go z'
          | (st^?msgMap.ix(Z.focus z').ccInfo.cdType) /= Just Direct = z'
          | otherwise = go (shift z')

getNextUnreadChannel :: ChatState
                     -> (Zipper ChannelId -> Zipper ChannelId)
getNextUnreadChannel st = Z.findRight (hasUnread st)

listThemes :: MH ()
listThemes = do
    let mkThemeList _ = T.intercalate "\n\n" $
                        "Available built-in themes:" :
                        (("  " <>) <$> fst <$> themes)
    postInfoMessage (mkThemeList themes)

setTheme :: T.Text -> MH ()
setTheme name =
    case lookup name themes of
        Nothing -> listThemes
        Just t -> csResources.crTheme .= t

channelPageUp :: MH ()
channelPageUp = do
  cId <- use csCurrentChannelId
  mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1 * pageAmount)

channelPageDown :: MH ()
channelPageDown = do
  cId <- use csCurrentChannelId
  mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount

asyncFetchMoreMessages :: ChatState -> ChannelId -> IO ()
asyncFetchMoreMessages st cId =
    doAsyncWithIO Preempt st $ do
        let offset = length $ st^.csChannel(cId).ccContents.cdMessages
            numToFetch = 10
        posts <- mmGetPosts (st^.csSession) (st^.csMyTeam.teamIdL) cId (offset - 1) numToFetch
        return $ do
            cc <- fromPosts posts
            ccId <- use csCurrentChannelId
            mh $ invalidateCacheEntry (ChannelMessages ccId)
            mapM_ (\m ->
                   csChannel(ccId).ccContents.cdMessages %= (addMessage m))
                 (cc^.cdMessages)

loadMoreMessages :: MH ()
loadMoreMessages = do
    mode <- use csMode
    cId  <- use csCurrentChannelId
    st   <- use id
    case mode of
        ChannelScroll -> do
            liftIO $ asyncFetchMoreMessages st cId
        _ -> return ()

channelByName :: ChatState -> T.Text -> Maybe ChannelId
channelByName st n
    | (T.singleton normalChannelSigil) `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n)
    | (T.singleton userSigil) `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n)
    | otherwise            = st ^. csNames . cnToChanId . at n

-- | This switches to the named channel or creates it if it is a missing
-- but valid user channel.
changeChannel :: T.Text -> MH ()
changeChannel name = do
    st <- use id
    case channelByName st name of
      Just cId -> setFocus cId
      Nothing -> attemptCreateDMChannel name

setFocus :: ChannelId -> MH ()
setFocus cId = setFocusWith (Z.findRight (== cId))

setFocusWith :: (Zipper ChannelId -> Zipper ChannelId) -> MH ()
setFocusWith f = do
    oldZipper <- use csFocus
    let newZipper = f oldZipper
        newFocus = Z.focus newZipper
        oldFocus = Z.focus oldZipper

    -- If we aren't changing anything, skip all the book-keeping because
    -- we'll end up clobbering things like csRecentChannel.
    when (newFocus /= oldFocus) $ do
        preChangeChannelCommon
        csFocus .= newZipper
        updateViewed
        postChangeChannelCommon

attemptCreateDMChannel :: T.Text -> MH ()
attemptCreateDMChannel name = do
  users <- use (csNames.cnUsers)
  nameToChanId <- use (csNames.cnToChanId)
  if name `elem` users && not (name `HM.member` nameToChanId)
    then do
      -- We have a user of that name but no channel. Time to make one!
      tId <- use (csMyTeam.teamIdL)
      Just uId <- use (csNames.cnToUserId.at(name))
      session <- use csSession
      doAsyncWith Normal $ do
        -- create a new channel
        nc <- mmCreateDirect session tId uId
        return $ handleNewChannel name True nc
    else
      postErrorMessage ("No channel or user named " <> name)

createOrdinaryChannel :: T.Text -> MH ()
createOrdinaryChannel name  = do
  tId <- use (csMyTeam.teamIdL)
  session <- use csSession
  doAsyncWith Preempt $ do
    -- create a new chat channel
    let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)
        minChannel = MinChannel
          { minChannelName        = slug
          , minChannelDisplayName = name
          , minChannelPurpose     = Nothing
          , minChannelHeader      = Nothing
          , minChannelType        = Ordinary
          }
    tryMM (mmCreateChannel session tId minChannel)
          (return . handleNewChannel name True)

handleNewChannel :: T.Text -> Bool -> Channel -> MH ()
handleNewChannel name switch nc = do
  -- time to do a lot of state updating:
  -- create a new ClientChannel structure
  now <- getNow
  let cChannel = ClientChannel
        { _ccContents = emptyChannelContents
        , _ccInfo     = ChannelInfo
                          { _cdViewed           = Nothing
                          , _cdUpdated          = now
                          , _cdName             = preferredChannelName nc
                          , _cdHeader           = nc^.channelHeaderL
                          , _cdType             = nc^.channelTypeL
                          , _cdCurrentState     = ChanLoaded
                          , _cdNewMessageCutoff = Nothing
                          }
        }
  -- add it to the message map, and to the map so we can look it up by
  -- user name
  csNames.cnToChanId.at(name) .= Just (getId nc)
  let chType = nc^.channelTypeL
  -- For direct channels the username is already in the user list so
  -- do nothing
  when (chType /= Direct) $
      csNames.cnChans %= (sort . (name:))
  msgMap.at(getId nc) .= Just cChannel
  -- we should figure out how to do this better: this adds it to the
  -- channel zipper in such a way that we don't ever change our focus
  -- to something else, which is kind of silly
  names <- use csNames
  let newZip = Z.updateList (mkChannelZipperList names)
  csFocus %= newZip
    -- and we finally set our focus to the newly created channel
  when switch $ setFocus (getId nc)

editMessage :: Post -> MH ()
editMessage new = do
  now <- getNow
  st <- use id
  let chan = csChannel (postChannelId new)
      isEditedMessage m = m^.mPostId == Just (new^.postIdL)
      msg = clientPostToMessage st (toClientPost new (new^.postParentIdL))
  chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg
  chan . ccInfo . cdUpdated .= now
  csPostMap.ix(postId new) .= msg
  cId <- use csCurrentChannelId
  when (postChannelId new == cId) $
    updateViewed

deleteMessage :: Post -> MH ()
deleteMessage new = do
  now <- getNow
  let isDeletedMessage m = m^.mPostId == Just (new^.postIdL)
      chan = csChannel (postChannelId new)
  chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)
  chan.ccInfo.cdUpdated .= now
  cId <- use csCurrentChannelId
  when (postChannelId new == cId) $
    updateViewed

maybeRingBell :: MH ()
maybeRingBell = do
    doBell <- use (csResources.crConfiguration.to configActivityBell)
    when doBell $ do
        -- This is safe because we only get Nothing in appStartEvent.
        Just vty <- mh getVtyHandle
        liftIO $ ringTerminalBell $ outputIface vty

addMessageToState :: Post -> MH ()
addMessageToState new = do
  st <- use id
  asyncFetchAttachments new
  case st^.msgMap.at (postChannelId new) of
      Nothing ->
          -- When we join channels, sometimes we get the "user has
          -- been added to channel" message here BEFORE we get the
          -- websocket event that says we got added to a channel. This
          -- means the message arriving here in addMessage can't be
          -- added yet because we haven't fetched the channel metadata
          -- in the websocket handler. So to be safe we just drop the
          -- message here, but this is the only case of messages that we
          -- /expect/ to drop for this reason. Hence the check for the
          -- msgMap channel ID key presence above.
          return ()
      Just _ -> do
          now <- getNow
          let cp = toClientPost new (new^.postParentIdL)
              fromMe = (cp^.cpUser == (Just $ getId (st^.csMe))) &&
                       (isNothing $ cp^.cpUserOverride)
              updateTime = if fromMe then id else const now
              cId = postChannelId new

              doAddMessage = do
                s <- use id
                let chan = msgMap . ix cId
                    msg' = clientPostToMessage s (toClientPost new (new^.postParentIdL))
                csPostMap.ix(postId new) .= msg'
                chan.ccContents.cdMessages %= (addMessage msg')
                chan.ccInfo.cdUpdated %= updateTime
                when (not fromMe) $ maybeRingBell
                ccId <- use csCurrentChannelId
                if postChannelId new == ccId
                  then updateViewed
                  else setNewMessageCutoff cId msg'

              doHandleNewMessage = do
                  -- If the message is in reply to another message,
                  -- try to find it in the scrollback for the post's
                  -- channel. If the message isn't there, fetch it. If
                  -- we have to fetch it, don't post this message to the
                  -- channel until we have fetched the parent.
                  case getMessageForPostId st <$> cp^.cpInReplyToPost of
                      Just (ParentNotLoaded parentId) -> do
                          doAsyncWith Normal $ do
                              let theTeamId = st^.csMyTeam.teamIdL
                              p <- mmGetPost (st^.csSession) theTeamId cId parentId
                              let postMap = HM.fromList [ ( pId
                                                          , clientPostToMessage st (toClientPost x (x^.postParentIdL))
                                                          )
                                                        | (pId, x) <- HM.toList (p^.postsPostsL)
                                                        ]
                              return $ do
                                csPostMap %= HM.union postMap
                                doAddMessage
                      _ -> doAddMessage

          -- If this message was written by a user we don't know about,
          -- fetch the user's information before posting the message.
          case cp^.cpUser of
              Nothing -> doHandleNewMessage
              Just uId ->
                  case st^.usrMap.at uId of
                      Just _ -> doHandleNewMessage
                      Nothing -> do
                          handleNewUser uId
                          doAsyncWith Normal $ return doHandleNewMessage

setNewMessageCutoff :: ChannelId -> Message -> MH ()
setNewMessageCutoff cId msg =
    csChannel(cId).ccInfo.cdNewMessageCutoff %= (<|> Just (msg^.mDate))

clearNewMessageCutoff :: ChannelId -> MH ()
clearNewMessageCutoff cId =
    csChannel(cId).ccInfo.cdNewMessageCutoff .= Nothing

getNewMessageCutoff :: ChannelId -> ChatState -> Maybe UTCTime
getNewMessageCutoff cId st = do
    cc <- st^.msgMap.at cId
    cc^.ccInfo.cdNewMessageCutoff

execMMCommand :: T.Text -> T.Text -> MH ()
execMMCommand name rest = do
  cId      <- use csCurrentChannelId
  session  <- use csSession
  myTeamId <- use (csMyTeam.teamIdL)
  let mc = MinCommand
             { minComChannelId = cId
             , minComCommand   = "/" <> name <> " " <> rest
             }
      runCmd = liftIO $ do
        void $ mmExecute session myTeamId mc
      handler (HTTPResponseException err) = return (Just err)
  errMsg <- liftIO $ (runCmd >> return Nothing) `catch` handler
  case errMsg of
    Nothing -> return ()
    Just err ->
      postErrorMessage ("Error running command: " <> (T.pack err))

fetchCurrentScrollback :: MH ()
fetchCurrentScrollback = do
  cId <- use csCurrentChannelId
  currentState <- preuse (msgMap.ix(cId).ccInfo.cdCurrentState)
  didQueue <- case maybe False (== ChanUnloaded) currentState of
      True -> do
          asyncFetchScrollback Preempt cId
          return True
      False -> return False
  csChannel(cId).ccInfo.cdCurrentState %=
    if didQueue then const ChanLoadPending else id

mkChannelZipperList :: MMNames -> [ChannelId]
mkChannelZipperList chanNames =
  [ (chanNames ^. cnToChanId) HM.! i
  | i <- chanNames ^. cnChans ] ++
  [ c
  | i <- chanNames ^. cnUsers
  , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ]

setChannelTopic :: ChatState -> T.Text -> IO ()
setChannelTopic st msg = do
    let chanId = st^.csCurrentChannelId
        theTeamId = st^.csMyTeam.teamIdL
    doAsyncWithIO Normal st $ do
        void $ mmSetChannelHeader (st^.csSession) theTeamId chanId msg
        return $ msgMap.at chanId.each.ccInfo.cdHeader .= msg

channelHistoryForward :: MH ()
channelHistoryForward = do
  cId <- use csCurrentChannelId
  inputHistoryPos <- use (csInputHistoryPosition.at cId)
  inputHistory <- use csInputHistory
  case inputHistoryPos of
      Just (Just i)
        | i == 0 -> do
          -- Transition out of history navigation
          csInputHistoryPosition.at cId .= Just Nothing
          loadLastEdit
        | otherwise -> do
          let Just entry = getHistoryEntry cId newI inputHistory
              newI = i - 1
              eLines = T.lines entry
              mv = if length eLines == 1 then gotoEOL else id
          csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing)
          csInputHistoryPosition.at cId .= (Just $ Just newI)
      _ -> return ()

channelHistoryBackward :: MH ()
channelHistoryBackward = do
  cId <- use csCurrentChannelId
  inputHistoryPos <- use (csInputHistoryPosition.at cId)
  inputHistory <- use csInputHistory
  case inputHistoryPos of
      Just (Just i) ->
          let newI = i + 1
          in case getHistoryEntry cId newI inputHistory of
              Nothing -> return ()
              Just entry -> do
                  let eLines = T.lines entry
                      mv = if length eLines == 1 then gotoEOL else id
                  csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing)
                  csInputHistoryPosition.at cId .= (Just $ Just newI)
      _ ->
          let newI = 0
          in case getHistoryEntry cId newI inputHistory of
              Nothing -> return ()
              Just entry ->
                  let eLines = T.lines entry
                      mv = if length eLines == 1 then gotoEOL else id
                  in do
                    saveCurrentEdit
                    csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing)
                    csInputHistoryPosition.at cId .= (Just $ Just newI)

showHelpScreen :: HelpScreen -> MH ()
showHelpScreen screen = do
    mh $ vScrollToBeginning (viewportScroll HelpViewport)
    csMode .= ShowHelp screen

beginChannelSelect :: MH ()
beginChannelSelect = do
    csMode                        .= ChannelSelect
    csChannelSelectString         .= ""
    csChannelSelectChannelMatches .= mempty
    csChannelSelectUserMatches    .= mempty

updateChannelSelectMatches :: MH ()
updateChannelSelectMatches = do
    -- Given the current channel select string, find all the channel and
    -- user matches and then update the match lists.
    chanNameMatches <- use (csChannelSelectString.to channelNameMatch)
    chanNames   <- use (csNames.cnChans)
    userNames   <- use (to sortedUserList)
    let chanMatches = catMaybes (fmap chanNameMatches chanNames)
    let userMatches = catMaybes (fmap chanNameMatches (fmap _uiName userNames))
    let mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms]
    csChannelSelectChannelMatches .= mkMap chanMatches
    csChannelSelectUserMatches    .= mkMap userMatches

channelNameMatch :: T.Text -> T.Text -> Maybe ChannelSelectMatch
channelNameMatch patStr chanName =
    if T.null patStr
    then Nothing
    else do
        pat <- parseChannelSelectPattern patStr
        applySelectPattern pat chanName

applySelectPattern :: ChannelSelectPattern -> T.Text -> Maybe ChannelSelectMatch
applySelectPattern (CSP ty pat) chanName = do
    let applyType Infix  | pat `T.isInfixOf`  chanName =
            case T.breakOn pat chanName of
                (pre, post) -> return (pre, pat, T.drop (T.length pat) post)

        applyType Prefix | pat `T.isPrefixOf` chanName = do
            let (b, a) = T.splitAt (T.length pat) chanName
            return ("", b, a)

        applyType Suffix | pat `T.isSuffixOf` chanName = do
            let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName
            return (b, a, "")

        applyType Equal  | pat == chanName =
            return ("", chanName, "")

        applyType _ = Nothing

    (pre, m, post) <- applyType ty
    return $ ChannelSelectMatch pre m post

parseChannelSelectPattern :: T.Text -> Maybe ChannelSelectPattern
parseChannelSelectPattern pat = do
    (pat1, pfx) <- case "^" `T.isPrefixOf` pat of
        True  -> return (T.tail pat, Just Prefix)
        False -> return (pat, Nothing)

    (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of
        True  -> return (T.init pat1, Just Suffix)
        False -> return (pat1, Nothing)

    case (pfx, sfx) of
        (Nothing, Nothing)         -> return $ CSP Infix  pat2
        (Just Prefix, Nothing)     -> return $ CSP Prefix pat2
        (Nothing, Just Suffix)     -> return $ CSP Suffix pat2
        (Just Prefix, Just Suffix) -> return $ CSP Equal  pat2
        tys                        -> error $ "BUG: invalid channel select case: " <> show tys

startUrlSelect :: MH ()
startUrlSelect = do
    urls <- use (csCurrentChannel.to findUrls.to V.fromList)
    csMode    .= UrlSelect
    csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)

stopUrlSelect :: MH ()
stopUrlSelect = csMode .= Main

findUrls :: ClientChannel -> [LinkChoice]
findUrls chan =
    let msgs = chan^.ccContents.cdMessages
    in removeDuplicates $ concat $ F.toList $ F.toList <$> Seq.reverse <$> msgURLs <$> msgs

removeDuplicates :: [LinkChoice] -> [LinkChoice]
removeDuplicates = snd . go Set.empty
  where go before [] = (before, [])
        go before (x:xs) =
          let (before', xs') = go before xs in
          if (x^.linkURL) `Set.member` before'
            then (before', xs')
            else (Set.insert (x^.linkURL) before', x : xs')

msgURLs :: Message -> Seq.Seq LinkChoice
msgURLs msg | Just uname <- msg^.mUserName =
  let msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uname text url Nothing) <$>
                  (mconcat $ blockGetURLs <$> (F.toList $ msg^.mText))
      attachmentURLs = (\ a ->
                          LinkChoice
                            (msg^.mDate)
                            uname
                            ("attachment `" <> (a^.attachmentName) <> "`")
                            (a^.attachmentURL)
                            (Just (a^.attachmentFileId)))
                       <$> (msg^.mAttachments)
  in msgUrls <> attachmentURLs
msgURLs _ = mempty

openSelectedURL :: MH ()
openSelectedURL = do
  mode <- use csMode
  when (mode == UrlSelect) $ do
    selected <- use (csUrlList.to listSelectedElement)
    case selected of
        Nothing -> return ()
        Just (_, link) -> do
            opened <- openURL link
            when (not opened) $ do
                let msg = "Config option 'urlOpenCommand' missing; cannot open URL."
                postInfoMessage msg
                csMode .= Main

openURL :: LinkChoice -> MH Bool
openURL link = do
    cmd <- use (csResources.crConfiguration.to configURLOpenCommand)
    case cmd of
        Nothing ->
            return False
        Just urlOpenCommand ->
            case _linkFileId link of
              Nothing -> do
                runLoggedCommand (T.unpack urlOpenCommand) [T.unpack $ link^.linkURL]
                return True
              Just fId -> do
                sess  <- use csSession
                doAsyncWith Normal $ do
                  info     <- mmGetFileInfo sess fId
                  contents <- mmGetFile sess fId
                  cacheDir <- getUserCacheDir xdgName
                  let dir   = cacheDir </> "files" </> T.unpack (idString fId)
                      fname = dir </> T.unpack (fileInfoName info)
                  createDirectoryIfMissing True dir
                  BS.writeFile fname contents
                  return $! runLoggedCommand (T.unpack urlOpenCommand) [fname]
                return True

runLoggedCommand :: String -> [String] -> MH ()
runLoggedCommand cmd args = do
  st <- use id
  liftIO $ do
    let opener = (proc cmd args) { std_in = NoStream
                                 , std_out = CreatePipe
                                 , std_err = CreatePipe
                                 }
    result <- try $ createProcess opener
    case result of
        Left (e::SomeException) -> do
            let po = ProgramOutput cmd args "" (show e) (ExitFailure 1)
            STM.atomically $ STM.writeTChan (st^.csResources.crSubprocessLog) po
        Right (Nothing, Just outh, Just errh, ph) -> do
            ec <- waitForProcess ph
            outResult <- hGetContents outh
            errResult <- hGetContents errh
            let po = ProgramOutput cmd args outResult errResult ec
            STM.atomically $ STM.writeTChan (st^.csResources.crSubprocessLog) po
        Right _ ->
            error $ "BUG: createProcess returned unexpected result, report this at " <>
                    "https://github.com/matterhorn-chat/matterhorn"

openSelectedMessageURLs :: MH ()
openSelectedMessageURLs = do
    mode <- use csMode
    when (mode == MessageSelect) $ do
        Just curMsg <- use (to getSelectedMessage)
        let urls = msgURLs curMsg
        when (not (null urls)) $ do
            openedAll <- and <$> mapM openURL urls
            case openedAll of
                True -> csMode .= Main
                False -> do
                    let msg = "Config option 'urlOpenCommand' missing; cannot open URL."
                    postInfoMessage msg

shouldSkipMessage :: T.Text -> Bool
shouldSkipMessage "" = True
shouldSkipMessage s = T.all (`elem` (" \t"::String)) s

sendMessage :: EditMode -> T.Text -> MH ()
sendMessage mode msg =
    case shouldSkipMessage msg of
        True -> return ()
        False -> do
            status <- use csConnectionStatus
            st <- use id
            case status of
                Disconnected -> do
                    let m = "Cannot send messages while disconnected."
                    postErrorMessage m
                Connected -> do
                    let myId   = st^.csMe.userIdL
                        chanId = st^.csCurrentChannelId
                        theTeamId = st^.csMyTeam.teamIdL
                    doAsync Preempt $ do
                      case mode of
                        NewPost -> do
                            pendingPost <- mkPendingPost msg myId chanId
                            void $ mmPost (st^.csSession) theTeamId pendingPost
                        Replying _ p -> do
                            pendingPost <- mkPendingPost msg myId chanId
                            let modifiedPost =
                                    pendingPost { pendingPostParentId = Just $ postId p
                                                , pendingPostRootId = Just $ postId p
                                                }
                            void $ mmPost (st^.csSession) theTeamId modifiedPost
                        Editing p -> do
                            now <- getCurrentTime
                            let modifiedPost = p { postMessage = msg
                                                 , postPendingPostId = Nothing
                                                 , postUpdateAt = now
                                                 }
                            void $ mmUpdatePost (st^.csSession) theTeamId modifiedPost

handleNewUser :: UserId -> MH ()
handleNewUser newUserId = do
    -- Fetch the new user record.
    st <- use id
    doAsyncWith Normal $ do
        newUser <- mmGetUser (st^.csSession) newUserId
        -- Also re-load the team members so we can tell whether the new
        -- user is in the current user's team.
        teamUsers <- mmGetProfiles (st^.csSession) (st^.csMyTeam.teamIdL) 0 10000
        let uInfo = userInfoFromUser newUser (HM.member newUserId teamUsers)

        return $ do
            -- Update the name map and the list of known users
            usrMap . at newUserId .= Just uInfo
            csNames . cnUsers %= (sort . ((newUser^.userUsernameL):))