matterhorn-40900.0.1: src/State.hs
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module State
(
-- * Message flagging
updateMessageFlag
, flagMessage
-- * Running external programs
, runLoggedCommand
-- * Channel sidebar selection
, prevChannel
, nextChannel
, recentChannel
, nextUnreadChannel
-- * Working with channels
, createOrdinaryChannel
, startJoinChannel
, joinChannel
, joinChannelByName
, changeChannel
, disconnectChannels
, startLeaveCurrentChannel
, leaveCurrentChannel
, leaveChannel
, removeChannelFromState
, beginCurrentChannelDeleteConfirm
, deleteCurrentChannel
, loadMoreMessages
, channelScrollToTop
, channelScrollToBottom
, channelScrollUp
, channelScrollDown
, channelPageUp
, channelPageDown
, isCurrentChannel
, isRecentChannel
, getNewMessageCutoff
, getEditedMessageCutoff
, setChannelTopic
, refreshChannelById
, refreshClientConfig
, handleChannelInvite
, addUserToCurrentChannel
, removeUserFromCurrentChannel
, createGroupChannel
-- * Channel history
, channelHistoryForward
, channelHistoryBackward
-- * Working with messages
, PostToAdd(..)
, sendMessage
, msgURLs
, editMessage
, deleteMessage
, addNewPostedMessage
, fetchVisibleIfNeeded
-- * Working with users
, handleNewUsers
, handleTypingUser
-- * Startup/reconnect management
, refreshChannelsAndUsers
-- * Channel selection mode
, beginChannelSelect
, updateChannelSelectMatches
, channelSelectNext
, channelSelectPrevious
-- * Server-side preferences
, applyPreferenceChange
-- * Message selection mode
, beginMessageSelect
, flagSelectedMessage
, copyVerbatimToClipboard
, openSelectedMessageURLs
, beginConfirmDeleteSelectedMessage
, messageSelectUp
, messageSelectUpBy
, messageSelectDown
, messageSelectDownBy
, deleteSelectedMessage
, beginReplyCompose
, beginEditMessage
, getSelectedMessage
, cancelReplyOrEdit
, replyToLatestMessage
-- * URL selection mode
, startUrlSelect
, stopUrlSelect
, openSelectedURL
-- * Help
, showHelpScreen
-- * Themes
, listThemes
, setTheme
)
where
import Prelude ()
import Prelude.MH
import Brick ( invalidateCacheEntry )
import Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd )
import Brick.Themes ( themeToAttrMap )
import Brick.Widgets.Edit ( applyEdit )
import Brick.Widgets.Edit ( getEditContents, editContentsL )
import Brick.Widgets.List ( list, listMoveTo, listSelectedElement )
import Control.Concurrent ( MVar, putMVar, forkIO )
import Control.Concurrent.Async ( runConcurrently, Concurrently(..), concurrently )
import qualified Control.Concurrent.STM as STM
import Control.Exception ( SomeException, try )
import qualified Data.ByteString as BS
import Data.Char ( isAlphaNum )
import Data.Function ( on )
import qualified Data.HashMap.Strict as HM
import Data.List ( findIndex )
import Data.Maybe ( fromJust )
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )
import Data.Time ( getCurrentTime )
import qualified Data.Vector as V
import Graphics.Vty ( outputIface )
import Graphics.Vty.Output.Interface ( ringTerminalBell )
import Lens.Micro.Platform
import System.Directory ( createDirectoryIfMissing )
import System.Environment.XDG.BaseDir ( getUserCacheDir )
import System.Exit ( ExitCode(..) )
import System.FilePath
import System.IO ( hGetContents, hFlush, hPutStrLn )
import System.Process ( proc, std_in, std_out, std_err, StdStream(..)
, createProcess, waitForProcess )
import qualified Network.Mattermost.Endpoints as MM
import Network.Mattermost.Lenses
import Network.Mattermost.Types
import Config
import Constants
import FilePaths
import InputHistory
import Markdown ( blockGetURLs, findVerbatimChunk )
import Themes
import TimeUtils ( justBefore, justAfter )
import Types
import Types.Common
import Zipper ( Zipper )
import qualified Zipper as Z
import State.Common
import State.Messages
import State.Setup.Threads ( updateUserStatuses )
-- * Refreshing Channel Data
-- | Refresh information about a specific channel. The channel
-- metadata is refreshed, and if this is a loaded channel, the
-- scrollback is updated as well.
refreshChannel :: Channel -> ChannelMember -> MH ()
refreshChannel chan member = do
let cId = getId chan
myTId <- gets myTeamId
let ourTeam = channelTeamId chan == Nothing ||
Just myTId == channelTeamId chan
-- If this is a group channel that the user has chosen to hide or if
-- the channel is not a channel for the current session's team, ignore
-- the refresh request.
isHidden <- channelHiddenPreference cId
case isHidden || not ourTeam of
True -> return ()
False -> do
-- If this channel is unknown, register it first.
mChan <- preuse (csChannel(cId))
when (isNothing mChan) $
handleNewChannel False chan member
updateChannelInfo cId chan member
refreshChannelById :: ChannelId -> MH ()
refreshChannelById cId = do
session <- getSession
doAsyncWith Preempt $ do
cwd <- MM.mmGetChannel cId session
member <- MM.mmGetChannelMember cId UserMe session
return $ refreshChannel cwd member
createGroupChannel :: Text -> MH ()
createGroupChannel usernameList = do
st <- use id
me <- gets myUser
let usernames = T.words usernameList
findUserIds [] = return []
findUserIds (n:ns) = do
case userByUsername n st of
Nothing -> do
mhError $ NoSuchUser n
return []
Just u -> (u^.uiId:) <$> findUserIds ns
results <- findUserIds usernames
-- If we found all of the users mentioned, then create the group
-- channel.
when (length results == length usernames) $ do
session <- getSession
doAsyncWith Preempt $ do
chan <- MM.mmCreateGroupMessageChannel (Seq.fromList results) session
let pref = showGroupChannelPref (channelId chan) (me^.userIdL)
-- It's possible that the channel already existed, in which
-- case we want to request a preference change to show it.
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
cwd <- MM.mmGetChannel (channelId chan) session
member <- MM.mmGetChannelMember (channelId chan) UserMe session
return $ do
applyPreferenceChange pref
handleNewChannel True cwd member
channelHiddenPreference :: ChannelId -> MH Bool
channelHiddenPreference cId = do
prefs <- use (csResources.crUserPreferences.userPrefGroupChannelPrefs)
let matching = filter (\p -> fst p == cId) (HM.toList prefs)
return $ any (not . snd) matching
applyPreferenceChange :: Preference -> MH ()
applyPreferenceChange pref = do
-- always update our user preferences accordingly
csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)
if
| Just f <- preferenceToFlaggedPost pref -> do
updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)
| Just g <- preferenceToGroupChannelPreference pref -> do
let cId = groupChannelId g
mChan <- preuse $ csChannel cId
case (mChan, groupChannelShow g) of
(Just _, False) ->
-- If it has been set to hidden and we are showing it,
-- remove it from the state.
removeChannelFromState cId
(Nothing, True) ->
-- If it has been set to showing and we are not showing
-- it, ask for a load/refresh.
refreshChannelById cId
_ -> return ()
| otherwise -> return ()
-- | Refresh information about all channels and users. This is usually
-- triggered when a reconnect event for the WebSocket to the server
-- occurs.
refreshChannelsAndUsers :: MH ()
refreshChannelsAndUsers = do
-- The below code is a duplicate of mmGetAllChannelsWithDataForUser function,
-- which has been inlined here to gain a concurrency benefit.
session <- getSession
myTId <- gets myTeamId
doAsyncWith Preempt $ do
(chans, datas) <- runConcurrently $ (,)
<$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)
<*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)
let dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas
mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap)
chansWithData = mkPair <$> chans
asyncFetchAllUsers page accum final = do
doAsyncWith Preempt $ do
let pageSize = 200
userQuery = MM.defaultUserQuery
{ MM.userQueryPage = Just page
, MM.userQueryPerPage = Just pageSize
, MM.userQueryInTeam = Just myTId
}
batch <- MM.mmGetUsers userQuery session
return $ case length batch < pageSize of
True -> do
let users = accum <> batch
forM_ users $ \u -> do
when (not $ userDeleted u) $ do
result <- gets (userById (getId u))
when (isNothing result) $ handleNewUserDirect u
setUserIdSet (userId <$> users)
final
False ->
asyncFetchAllUsers (page + 1) (accum <> batch) final
return $ do
asyncFetchAllUsers 0 mempty $ do
forM_ chansWithData $ uncurry refreshChannel
lock <- use (csResources.crUserStatusLock)
setVar <- use (csResources.crUserIdSet)
doAsyncWith Preempt $ updateUserStatuses setVar lock session
-- | Refresh client-accessible server configuration information. This
-- is usually triggered when a reconnect event for the WebSocket to
-- the server occurs.
refreshClientConfig :: MH ()
refreshClientConfig = do
session <- getSession
doAsyncWith Preempt $ do
cfg <- MM.mmGetClientConfiguration (Just "old") session
return (csClientConfig .= Just cfg)
-- | Websocket was disconnected, so all channels may now miss some
-- messages
disconnectChannels :: MH ()
disconnectChannels = addDisconnectGaps
-- | Update the indicated Channel entry with the new data retrieved from
-- the Mattermost server. Also update the channel name if it changed.
updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH ()
updateChannelInfo cid new member = do
mOldChannel <- preuse $ csChannel(cid)
case mOldChannel of
Nothing -> return ()
Just old ->
let oldName = old^.ccInfo.cdName
newName = preferredChannelName new
in if oldName == newName
then return ()
else do
removeChannelName oldName
addChannelName (channelType new) cid newName
csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member
-- * 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 = getLatestPostMsg chanMsgs
when (isJust recentPost) $ do
setMode MessageSelect
csMessageSelect .= MessageSelectState (join $ ((^.mPostId) <$> recentPost))
getSelectedMessage :: ChatState -> Maybe Message
getSelectedMessage st
| appMode st /= MessageSelect && appMode st /= MessageSelectDeleteConfirm = Nothing
| otherwise = do
selPostId <- selectMessagePostId $ st^.csMessageSelect
let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages
findMessage selPostId chanMsgs
messageSelectUp :: MH ()
messageSelectUp = do
mode <- gets appMode
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
selected <- use (csMessageSelect.to selectMessagePostId)
case selected of
Just _ -> whenMode MessageSelect $ do
chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
let nextPostId = getNextPostId selected chanMsgs
csMessageSelect .= MessageSelectState (nextPostId <|> selected)
_ -> return ()
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 =
setMode MessageSelectDeleteConfirm
deleteSelectedMessage :: MH ()
deleteSelectedMessage = do
selectedMessage <- use (to getSelectedMessage)
st <- use id
cId <- use csCurrentChannelId
case selectedMessage of
Just msg | isMine st msg && isDeletable msg ->
case msg^.mOriginalPost of
Just p ->
doAsyncChannelMM Preempt cId
(\s _ _ -> MM.mmDeletePost (postId p) s)
(\_ _ -> do csEditState.cedEditMode .= NewPost
setMode Main)
Nothing -> return ()
_ -> return ()
beginCurrentChannelDeleteConfirm :: MH ()
beginCurrentChannelDeleteConfirm = do
cId <- use csCurrentChannelId
withChannel cId $ \chan -> do
let chType = chan^.ccInfo.cdType
if chType /= Direct
then setMode DeleteChannelConfirm
else mhError $ GenericError "Direct message channels cannot be deleted."
deleteCurrentChannel :: MH ()
deleteCurrentChannel = do
setMode Main
cId <- use csCurrentChannelId
leaveChannelIfPossible cId True
isCurrentChannel :: ChatState -> ChannelId -> Bool
isCurrentChannel st cId = st^.csCurrentChannelId == cId
isRecentChannel :: ChatState -> ChannelId -> Bool
isRecentChannel st cId = st^.csRecentChannel == Just cId
-- | 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 $ return ()
-- | Tell the server that the message we currently have selected
-- should have its flagged state toggled.
flagSelectedMessage :: MH ()
flagSelectedMessage = do
selected <- use (to getSelectedMessage)
case selected of
Just msg
| Just pId <- msg^.mPostId ->
flagMessage pId (not (msg^.mFlagged))
_ -> return ()
beginEditMessage :: MH ()
beginEditMessage = do
selected <- use (to getSelectedMessage)
st <- use id
case selected of
Just msg | isMine st msg && isEditable msg -> do
let Just p = msg^.mOriginalPost
setMode Main
csEditState.cedEditMode .= 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 toEdit = if msg^.mType == CP Emote
then removeEmoteFormatting $ sanitizeUserText $ postMessage p
else sanitizeUserText $ postMessage p
csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit))
_ -> return ()
removeEmoteFormatting :: T.Text -> T.Text
removeEmoteFormatting t
| "*" `T.isPrefixOf` t &&
"*" `T.isSuffixOf` t = T.init $ T.drop 1 t
| otherwise = t
addEmoteFormatting :: T.Text -> T.Text
addEmoteFormatting t = "*" <> t <> "*"
replyToLatestMessage :: MH ()
replyToLatestMessage = do
msgs <- use (csCurrentChannel . ccContents . cdMessages)
case findLatestUserMessage isReplyable msgs of
Just msg -> do let Just p = msg^.mOriginalPost
setMode 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
setMode Main
csEditState.cedEditMode .= Replying msg p
cancelReplyOrEdit :: MH ()
cancelReplyOrEdit = do
mode <- use (csEditState.cedEditMode)
case mode of
NewPost -> return ()
_ -> do
csEditState.cedEditMode .= NewPost
csEditState.cedEditor %= 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
setMode Main
-- * Joining, Leaving, and Inviting
joinChannelByName :: Text -> MH ()
joinChannelByName rawName = do
session <- getSession
tId <- gets myTeamId
doAsyncWith Preempt $ do
result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session
return $ case result of
Left (_::SomeException) -> mhError $ NoSuchChannel rawName
Right chan -> joinChannel $ getId chan
startJoinChannel :: MH ()
startJoinChannel = do
session <- getSession
myTId <- gets myTeamId
myChannels <- use (csChannels.to (filteredChannelIds (const True)))
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 <- MM.mmGetPublicChannels myTId (Just start) (Just fetchCount) session
let chans = acc <> newChans
if length newChans < fetchCount
then return chans
else loop chans (start+1)
chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0
let sortedChans = V.fromList $ toList $ Seq.sortBy (compare `on` channelName) chans
return $ do
csJoinChannelList .= (Just $ list JoinChannelList sortedChans 2)
setMode JoinChannel
csJoinChannelList .= Nothing
-- | If the user is not a member of the specified channel, submit a
-- request to join it. Otherwise switch to the channel.
joinChannel :: ChannelId -> MH ()
joinChannel chanId = do
setMode Main
mChan <- preuse (csChannel(chanId))
case mChan of
Just _ -> setFocus chanId
Nothing -> do
myId <- gets myUserId
let member = MinChannelMember myId chanId
csLastJoinRequest .= Just chanId
doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP
-- | When another user adds us to a channel, we need to fetch the
-- channel info for that channel.
handleChannelInvite :: ChannelId -> MH ()
handleChannelInvite cId = do
session <- getSession
doAsyncWith Normal $ do
member <- MM.mmGetChannelMember cId UserMe session
tryMM (MM.mmGetChannel cId session)
(\cwd -> return $ handleNewChannel False cwd member)
addUserToCurrentChannel :: Text -> MH ()
addUserToCurrentChannel uname = do
-- First: is this a valid username?
result <- gets (userByUsername uname)
case result of
Just u -> do
cId <- use csCurrentChannelId
session <- getSession
let channelMember = MinChannelMember (u^.uiId) cId
doAsyncWith Normal $ do
tryMM (void $ MM.mmAddUser cId channelMember session)
(const $ return (return ()))
_ -> do
mhError $ NoSuchUser uname
removeUserFromCurrentChannel :: Text -> MH ()
removeUserFromCurrentChannel uname = do
-- First: is this a valid username?
result <- gets (userByUsername uname)
case result of
Just u -> do
cId <- use csCurrentChannelId
session <- getSession
doAsyncWith Normal $ do
tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)
(const $ return (return ()))
_ -> do
mhError $ NoSuchUser uname
startLeaveCurrentChannel :: MH ()
startLeaveCurrentChannel = do
cInfo <- use (csCurrentChannel.ccInfo)
case canLeaveChannel cInfo of
True -> setMode LeaveChannelConfirm
False -> mhError $ GenericError "The /leave command cannot be used with this channel."
leaveCurrentChannel :: MH ()
leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel
leaveChannelIfPossible :: ChannelId -> Bool -> MH ()
leaveChannelIfPossible cId delete = do
st <- use id
me <- gets myUser
let isMe u = u^.userIdL == me^.userIdL
case st ^? csChannel(cId).ccInfo of
Nothing -> return ()
Just cInfo -> case canLeaveChannel cInfo of
False -> return ()
True ->
-- The server will reject an attempt to leave a private
-- channel if we're the only member. To check this, we
-- just ask for the first two members of the channel.
-- If there is only one, it must be us: hence the "all
-- isMe" check below. If there are two members, it
-- doesn't matter who they are, because we just know
-- that we aren't the only remaining member, so we can't
-- delete the channel.
doAsyncChannelMM Preempt cId
(\s _ _ ->
let query = MM.defaultUserQuery
{ MM.userQueryPage = Just 0
, MM.userQueryPerPage = Just 2
, MM.userQueryInChannel = Just cId
}
in toList <$> MM.mmGetUsers query s)
(\_ members -> do
-- If the channel is private:
-- * leave it if we aren't the last member.
-- * delete it if we are.
--
-- Otherwise:
-- * leave (or delete) the channel as specified
-- by the delete argument.
let func = case cInfo^.cdType of
Private -> case all isMe members of
True -> (\ s _ c -> MM.mmDeleteChannel c s)
False -> (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)
Group ->
\s _ _ ->
let pref = hideGroupChannelPref cId (me^.userIdL)
in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s
_ -> if delete
then (\ s _ c -> MM.mmDeleteChannel c s)
else (\ s _ c -> MM.mmRemoveUserFromChannel c UserMe s)
doAsyncChannelMM Preempt cId func endAsyncNOP
)
hideGroupChannelPref :: ChannelId -> UserId -> Preference
hideGroupChannelPref cId uId =
Preference { preferenceCategory = PreferenceCategoryGroupChannelShow
, preferenceValue = PreferenceValue "false"
, preferenceName = PreferenceName $ idString cId
, preferenceUserId = uId
}
showGroupChannelPref :: ChannelId -> UserId -> Preference
showGroupChannelPref cId uId =
Preference { preferenceCategory = PreferenceCategoryGroupChannelShow
, preferenceValue = PreferenceValue "true"
, preferenceName = PreferenceName $ idString cId
, preferenceUserId = uId
}
leaveChannel :: ChannelId -> MH ()
leaveChannel cId = leaveChannelIfPossible cId False
removeChannelFromState :: ChannelId -> MH ()
removeChannelFromState cId = do
withChannel cId $ \ chan -> do
let cName = chan^.ccInfo.cdName
chType = chan^.ccInfo.cdType
when (chType /= Direct) $ do
origFocus <- use csCurrentChannelId
when (origFocus == cId) nextChannel
csEditState.cedInputHistoryPosition .at cId .= Nothing
csEditState.cedLastChannelInput .at cId .= Nothing
-- Update input history
csEditState.cedInputHistory %= removeChannelHistory cId
-- Remove channel name mappings
removeChannelName cName
-- Update msgMap
csChannels %= filteredChannels ((/=) cId . fst)
-- Remove from focus zipper
csFocus %= Z.filterZipper (/= cId)
-- | Called on async completion when the currently viewed channel has
-- been updated (i.e., just switched to this channel) to update local
-- state.
setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH ()
setLastViewedFor prevId cId = do
chan <- use (csChannels.to (findChannelById cId))
-- Update new channel's viewed time, creating the channel if needed
case chan of
Nothing ->
-- It's possible for us to get spurious WMChannelViewed events
-- from the server, e.g. for channels that have been deleted.
-- So here we ignore the request since it's hard to detect it
-- before this point.
return ()
Just _ ->
-- The server has been sent a viewed POST update, but there is
-- no local information on what timestamp the server actually
-- recorded. There are a couple of options for setting the
-- local value of the viewed time:
--
-- 1. Attempting to locally construct a value, which would
-- involve scanning all (User) messages in the channel to
-- find the maximum of the created date, the modified date,
-- or the deleted date, and assuming that maximum mostly
-- matched the server's viewed time.
--
-- 2. Issuing a channel metadata request to get the server's
-- new concept of the viewed time.
--
-- 3. Having the "chan/viewed" POST that was just issued
-- return a value from the server. See
-- https://github.com/mattermost/platform/issues/6803.
--
-- Method 3 would be the best and most lightweight. Until that
-- is available, Method 2 will be used. The downside to Method
-- 2 is additional client-server messaging, and a delay in
-- updating the client data, but it's also immune to any new or
-- removed Message date fields, or anything else that would
-- contribute to the viewed/updated times on the server.
doAsyncChannelMM Preempt cId (\ s _ _ ->
(,) <$> MM.mmGetChannel cId s
<*> MM.mmGetChannelMember cId UserMe s)
(\pcid (cwd, member) -> csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member)
-- Update the old channel's previous viewed time (allows tracking of new messages)
case prevId of
Nothing -> return ()
Just p -> csChannels %= (channelByIdL p %~ (clearNewMessageIndicator . clearEditedThreshold))
updateViewed :: MH ()
updateViewed = do
csCurrentChannel.ccInfo.cdMentionCount .= 0
updateViewedChan =<< use csCurrentChannelId
-- | When a new channel has been selected for viewing, this will
-- notify the server of the change, and also update the local channel
-- state to set the last-viewed time for the previous channel and
-- update the viewed time to now for the newly selected channel.
updateViewedChan :: ChannelId -> MH ()
updateViewedChan cId = use csConnectionStatus >>= \case
Connected -> do
-- Only do this if we're connected to avoid triggering noisy exceptions.
pId <- use csRecentChannel
doAsyncChannelMM Preempt cId
(\s _ c -> MM.mmViewChannel UserMe c pId s)
(\c () -> setLastViewedFor pId c)
Disconnected ->
-- Cannot update server; make no local updates to avoid
-- getting out-of-sync with the server. Assumes that this
-- is a temporary break in connectivity and that after the
-- connection is restored, the user's normal activities will
-- update state as appropriate. If connectivity is
-- permanently lost, managing this state is irrelevant.
return ()
resetHistoryPosition :: MH ()
resetHistoryPosition = do
cId <- use csCurrentChannelId
csEditState.cedInputHistoryPosition.at cId .= Just Nothing
clearEditor :: MH ()
clearEditor = csEditState.cedEditor %= applyEdit clearZipper
loadLastEdit :: MH ()
loadLastEdit = do
cId <- use csCurrentChannelId
lastInput <- use (csEditState.cedLastChannelInput.at cId)
case lastInput of
Nothing -> return ()
Just (lastEdit, lastEditMode) -> do
csEditState.cedEditor %= (applyEdit $ insertMany (lastEdit) . clearZipper)
csEditState.cedEditMode .= lastEditMode
saveCurrentEdit :: MH ()
saveCurrentEdit = do
cId <- use csCurrentChannelId
cmdLine <- use (csEditState.cedEditor)
mode <- use (csEditState.cedEditMode)
csEditState.cedLastChannelInput.at cId .=
Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode)
resetCurrentEdit :: MH ()
resetCurrentEdit = do
cId <- use csCurrentChannelId
csEditState.cedLastChannelInput.at cId .= Nothing
updateChannelListScroll :: MH ()
updateChannelListScroll = do
mh $ vScrollToBeginning (viewportScroll ChannelList)
postChangeChannelCommon :: MH ()
postChangeChannelCommon = do
resetHistoryPosition
resetEditorState
updateChannelListScroll
loadLastEdit
resetCurrentEdit
resetEditorState :: MH ()
resetEditorState = do
csEditState.cedEditMode .= NewPost
clearEditor
preChangeChannelCommon :: MH ()
preChangeChannelCommon = do
cId <- use csCurrentChannelId
csRecentChannel .= Just cId
saveCurrentEdit
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 fType z == Direct
then z
else go (shift z)
where go z'
| fType z' /= Direct = z'
| otherwise = go (shift z')
fType onz = st^.(csChannels.to
(findChannelById (Z.focus onz))) ^?! _Just.ccInfo.cdType
getNextUnreadChannel :: ChatState
-> (Zipper ChannelId -> Zipper ChannelId)
getNextUnreadChannel st =
-- The next channel with unread messages must also be a channel
-- other than the current one, since the zipper may be on a channel
-- that has unread messages and will stay that way until we leave
-- it- so we need to skip that channel when doing the zipper search
-- for the next candidate channel.
Z.findRight (\cId -> hasUnread st cId && (cId /= st^.csCurrentChannelId))
listThemes :: MH ()
listThemes = do
let themeList = T.intercalate "\n\n" $
"Available built-in themes:" :
((" " <>) <$> internalThemeName <$> internalThemes)
postInfoMessage themeList
setTheme :: Text -> MH ()
setTheme name =
case lookupTheme name of
Nothing -> listThemes
Just it -> csResources.crTheme .=
(themeToAttrMap $ internalTheme it)
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
channelScrollUp :: MH ()
channelScrollUp = do
cId <- use csCurrentChannelId
mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1)
channelScrollDown :: MH ()
channelScrollDown = do
cId <- use csCurrentChannelId
mh $ vScrollBy (viewportScroll (ChannelMessages cId)) 1
channelScrollToTop :: MH ()
channelScrollToTop = do
cId <- use csCurrentChannelId
mh $ vScrollToBeginning (viewportScroll (ChannelMessages cId))
channelScrollToBottom :: MH ()
channelScrollToBottom = do
cId <- use csCurrentChannelId
mh $ vScrollToEnd (viewportScroll (ChannelMessages cId))
-- | Fetches additional message history for the current channel. This
-- is generally called when in ChannelScroll mode, in which state the
-- output is cached and seen via a scrolling viewport; new messages
-- received in this mode are not normally shown, but this explicit
-- user-driven fetch should be displayed, so this also invalidates the
-- cache.
asyncFetchMoreMessages :: MH ()
asyncFetchMoreMessages = do
cId <- use csCurrentChannelId
withChannel cId $ \chan ->
let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2
-- Fetch more messages prior to any existing messages, but
-- attempt to overlap with existing messages for
-- determining contiguity or gaps. Back up two messages
-- and request from there backward, which should include
-- the last message in the response. This is an attempt
-- to fetch *more* messages, so it's expected that there
-- are at least 2 messages already here, but in case there
-- aren't, just get another page from roughly the right
-- location.
first' = splitMessagesOn (^.mPostId.to isJust) (chan^.ccContents.cdMessages)
second' = splitMessagesOn (^.mPostId.to isJust) $ snd $ snd first'
query = MM.defaultPostQuery
{ MM.postQueryPage = Just (offset `div` pageAmount)
, MM.postQueryPerPage = Just pageAmount
}
& \q -> case (fst first', fst second' >>= (^.mPostId)) of
(Just _, Just i) -> q { MM.postQueryBefore = Just i
, MM.postQueryPage = Just 0
}
_ -> q
in doAsyncChannelMM Preempt cId
(\s _ c -> MM.mmGetPostsForChannel c query s)
(\c p -> do addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd
mh $ invalidateCacheEntry (ChannelMessages cId))
addNewPostedMessage :: PostToAdd -> MH ()
addNewPostedMessage p =
addMessageToState p >>= postProcessMessageAdd
addObtainedMessages :: ChannelId -> Int -> Posts -> MH PostProcessMessageAdd
addObtainedMessages cId reqCnt posts = do
-- Adding a block of server-provided messages, which are known to
-- be contiguous. Locally this may overlap with some UnknownGap
-- messages, which can therefore be removed. Alternatively the
-- new block may be discontiguous with the local blocks, in which
-- case the new block should be surrounded by UnknownGaps.
withChannelOrDefault cId NoAction $ \chan -> do
let pIdList = toList (posts^.postsOrderL)
-- the first and list PostId in the batch to be added
earliestPId = last pIdList
latestPId = head pIdList
earliestDate = postCreateAt $ (posts^.postsPostsL) HM.! earliestPId
latestDate = postCreateAt $ (posts^.postsPostsL) HM.! latestPId
localMessages = chan^.ccContents . cdMessages
match = snd $ removeMatchesFromSubset
(\m -> maybe False (\p -> p `elem` pIdList) (m^.mPostId))
(Just earliestPId) (Just latestPId) localMessages
dupPIds = catMaybes $ foldr (\m l -> m^.mPostId : l) [] match
-- If there were any matches, then there was overlap of
-- the new messages with existing messages.
-- Don't re-add matching messages (avoid overhead like
-- re-checking/re-fetching related post information, and
-- do not signal action needed for notifications), and
-- remove any gaps in the overlapping region.
newGapMessage d = newMessageOfType "Additional messages???" (C UnknownGap) d
-- If this batch contains the latest known messages, do
-- not add a following gap. A gap at this point is added
-- by a websocket disconnect, and any fetches thereafter
-- are assumed to be the most current information (until
-- another disconnect), so no gap is needed.
-- Additionally, the presence of a gap at the end for a
-- connected client causes a fetch of messages at this
-- location, so adding the gap here would cause an
-- infinite update loop.
addingAtEnd = maybe True ((<=) latestDate) $
(^.mDate) <$> getLatestPostMsg localMessages
addingAtStart = maybe True ((>=) earliestDate) $
(^.mDate) <$> getEarliestPostMsg localMessages
removeStart = if addingAtStart && noMoreBefore then Nothing else Just earliestPId
removeEnd = if addingAtEnd then Nothing else Just latestPId
noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)
noMoreAfter = reqCnt > 0 && length pIdList < reqCnt
-- The post map returned by the server will *already* have
-- all thread messages for each post that is part of a
-- thread. By calling messagesFromPosts here, we go ahead and
-- populate the csPostMap with those posts so that below, in
-- addMessageToState, we notice that we already know about reply
-- parent messages and can avoid fetching them. This converts
-- the posts to Messages and stores those and also returns
-- them, but we don't need them here. We just want the post map
-- update.
void $ messagesFromPosts posts
-- Add all the new *unique* posts into the existing channel
-- corpus, generating needed fetches of data associated with
-- the post, and determining an notification action to be
-- taken (if any).
action <- foldr andProcessWith NoAction <$>
mapM (addMessageToState . OldPost)
[ (posts^.postsPostsL) HM.! p
| p <- toList (posts^.postsOrderL)
, not (p `elem` dupPIds)
]
csChannels %= modifyChannelById cId
(ccContents.cdMessages %~ (fst . removeMatchesFromSubset isGap removeStart removeEnd))
-- Add a gap at each end of the newly fetched data, unless:
-- 1. there is an overlap
-- 2. there is no more in the indicated direction
-- a. indicated by adding messages later than any currently
-- held messages (see note above re 'addingAtEnd').
-- b. the amount returned was less than the amount requested
unless (earliestPId `elem` dupPIds || noMoreBefore) $
let gapMsg = newGapMessage (justBefore earliestDate)
in csChannels %= modifyChannelById cId
(ccContents.cdMessages %~ addMessage gapMsg)
unless (latestPId `elem` dupPIds || addingAtEnd || noMoreAfter) $
let gapMsg = newGapMessage (justAfter latestDate)
in csChannels %= modifyChannelById cId
(ccContents.cdMessages %~ addMessage gapMsg)
-- Now initiate fetches for use information for any
-- as-yet-unknown users related to this new set of messages
let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post))
Set.empty (posts^.postsPostsL)
addUnknownUsers inputUserIds = do
knownUserIds <- Set.fromList <$> gets allUserIds
let unknownUsers = Set.difference inputUserIds knownUserIds
if Set.null unknownUsers
then return ()
else handleNewUsers $ Seq.fromList $ toList unknownUsers
addUnknownUsers users
-- Return the aggregated user notification action needed
-- relative to the set of added messages.
return action
loadMoreMessages :: MH ()
loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages
-- | This switches to the named channel or creates it if it is a missing
-- but valid user channel.
changeChannel :: Text -> MH ()
changeChannel name = do
result <- gets (channelIdByName name)
user <- gets (userByUsername name)
let err = mhError $ AmbiguousName name
case result of
(Nothing, Nothing)
-- We know about the user but there isn't already a DM
-- channel, so create one.
| Just _ <- user -> attemptCreateDMChannel name
-- There were no matches of any kind.
| otherwise -> mhError $ NoSuchChannel name
(Just cId, Nothing)
-- We matched a channel and there was an explicit sigil, so we
-- don't care about the username match.
| normalChannelSigil `T.isPrefixOf` name -> setFocus cId
-- We matched both a channel and a user, even though there is
-- no DM channel.
| Just _ <- user -> err
-- We matched a channel only.
| otherwise -> setFocus cId
(Nothing, Just cId) ->
-- We matched a user only and there is already a DM channel.
setFocus cId
(Just _, Just _) ->
-- We matched both a channel and a user.
err
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 :: Text -> MH ()
attemptCreateDMChannel name = do
mCid <- gets (channelIdByUsername name)
me <- gets myUser
displayNick <- use (to useNickname)
uList <- use (to sortedUserList)
let myName = if displayNick && not (T.null $ sanitizeUserText $ userNickname me)
then sanitizeUserText $ userNickname me
else me^.userUsernameL
when (name /= myName) $ do
let uName = if displayNick
then
maybe name (view uiName)
$ findUserByNickname uList name
else name
mUid <- gets (userIdForUsername uName)
if isJust mUid && isNothing mCid
then do
-- We have a user of that name but no channel. Time to make one!
let Just uId = mUid
myId <- gets myUserId
session <- getSession
doAsyncWith Normal $ do
-- create a new channel
nc <- MM.mmCreateDirectMessageChannel (uId, myId) session -- tId uId
cwd <- MM.mmGetChannel (getId nc) session
member <- MM.mmGetChannelMember (getId nc) UserMe session
return $ handleNewChannel True cwd member
else
mhError $ NoSuchUser name
createOrdinaryChannel :: Text -> MH ()
createOrdinaryChannel name = do
session <- getSession
myTId <- gets myTeamId
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
, minChannelTeamId = myTId
}
tryMM (do c <- MM.mmCreateChannel minChannel session
chan <- MM.mmGetChannel (getId c) session
member <- MM.mmGetChannelMember (getId c) UserMe session
return (chan, member)
)
(return . uncurry (handleNewChannel True))
handleNewChannel :: Bool -> Channel -> ChannelMember -> MH ()
handleNewChannel = handleNewChannel_ True
handleNewChannel_ :: Bool
-- ^ Whether to permit this call to recursively
-- schedule itself for later if it can't locate
-- a DM channel user record. This is to prevent
-- uncontrolled recursion.
-> Bool
-- ^ Whether to switch to the new channel once it has
-- been installed.
-> Channel
-- ^ The channel to install.
-> ChannelMember
-> MH ()
handleNewChannel_ permitPostpone switch nc member = do
-- Only add the channel to the state if it isn't already known.
mChan <- preuse (csChannel(getId nc))
case mChan of
Just _ -> when switch $ setFocus (getId nc)
Nothing -> do
-- Create a new ClientChannel structure
cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>
makeClientChannel nc
st <- use id
-- Add it to the message map, and to the name map so we can look
-- it up by name. The name we use for the channel depends on its
-- type:
let chType = nc^.channelTypeL
-- Get the channel name. If we couldn't, that means we have
-- async work to do before we can register this channel (in
-- which case abort because we got rescheduled).
mName <- case chType of
Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of
-- If this is a direct channel but we can't extract a
-- user ID from the name, then it failed to parse. We
-- need to assign a channel name in our channel map,
-- and the best we can do to preserve uniqueness is to
-- use the channel name string. This is undesirable
-- but direct channels never get rendered directly;
-- they only get used by first looking up usernames.
-- So this name should never appear anywhere, but at
-- least we can go ahead and register the channel and
-- handle events for it. That isn't very useful but it's
-- probably better than ignoring this entirely.
Nothing -> return $ Just $ sanitizeUserText $ channelName nc
Just otherUserId ->
case usernameForUserId otherUserId st of
-- If we found a user ID in the channel name
-- string but don't have that user's metadata,
-- postpone adding this channel until we have
-- fetched the metadata. This can happen when
-- we have a channel record for a user that
-- is no longer in the current team. To avoid
-- recursion due to a problem, ensure that
-- the rescheduled new channel handler is not
-- permitted to try this again.
--
-- If we're already in a recursive attempt to
-- register this channel and still couldn't find
-- a username, just bail and use the synthetic
-- name (this has the same problems as above).
Nothing -> do
case permitPostpone of
False -> return $ Just $ sanitizeUserText $ channelName nc
True -> do
handleNewUsers $ Seq.singleton otherUserId
doAsyncWith Normal $
return $ handleNewChannel_ False switch nc member
return Nothing
Just ncUsername ->
return $ Just $ ncUsername
_ -> return $ Just $ preferredChannelName nc
case mName of
Nothing -> return ()
Just name -> do
addChannelName chType (getId nc) name
csChannels %= addChannel (getId nc) cChannel
refreshChannelZipper
-- Finally, set our focus to the newly created channel
-- if the caller requested a change of channel. Also
-- consider the last join request state field in case
-- this is an asynchronous channel addition triggered by
-- a /join.
lastReq <- use csLastJoinRequest
wasLast <- case lastReq of
Just cId | cId == getId nc -> do
csLastJoinRequest .= Nothing
return True
_ -> return False
when (switch || wasLast) $ setFocus (getId nc)
editMessage :: Post -> MH ()
editMessage new = do
myId <- gets myUserId
let isEditedMessage m = m^.mPostId == Just (new^.postIdL)
msg = clientPostToMessage (toClientPost new (new^.postParentIdL))
chan = csChannel (new^.postChannelIdL)
chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg
when (postUserId new /= Just myId) $
chan %= adjustEditedThreshold new
csPostMap.ix(postId new) .= msg
asyncFetchReactionsForPost (postChannelId new) new
asyncFetchAttachments new
cId <- use csCurrentChannelId
when (postChannelId new == cId) updateViewed
deleteMessage :: Post -> MH ()
deleteMessage new = do
let isDeletedMessage m = m^.mPostId == Just (new^.postIdL) ||
isReplyTo (new^.postIdL) m
chan :: Traversal' ChatState ClientChannel
chan = csChannel (new^.postChannelIdL)
chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)
chan %= adjustUpdated new
cId <- use csCurrentChannelId
when (postChannelId new == cId) updateViewed
maybePostUsername :: ChatState -> Post -> T.Text
maybePostUsername st p =
fromMaybe T.empty $ do
uId <- postUserId p
usernameForUserId uId st
runNotifyCommand :: Post -> Bool -> MH ()
runNotifyCommand post mentioned = do
outputChan <- use (csResources.crSubprocessLog)
st <- use id
notifyCommand <- use (csResources.crConfiguration.to configActivityNotifyCommand)
case notifyCommand of
Nothing -> return ()
Just cmd ->
doAsyncWith Preempt $ do
let messageString = T.unpack $ sanitizeUserText $ postMessage post
notified = if mentioned then "1" else "2"
sender = T.unpack $ maybePostUsername st post
runLoggedCommand False outputChan (T.unpack cmd)
[notified, sender, messageString] Nothing Nothing
return $ return ()
maybeNotify :: PostToAdd -> MH ()
maybeNotify (OldPost _) = do
return ()
maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned
maybeRingBell :: MH ()
maybeRingBell = do
doBell <- use (csResources.crConfiguration.to configActivityBell)
when doBell $ do
vty <- mh getVtyHandle
liftIO $ ringTerminalBell $ outputIface vty
-- | PostProcessMessageAdd is an internal value that informs the main
-- code whether the user should be notified (e.g., ring the bell) or
-- the server should be updated (e.g., that the channel has been
-- viewed). This is a monoid so that it can be folded over when there
-- are multiple inbound posts to be processed.
data PostProcessMessageAdd = NoAction
| NotifyUser [PostToAdd]
| UpdateServerViewed
| NotifyUserAndServer [PostToAdd]
andProcessWith
:: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd
andProcessWith NoAction x = x
andProcessWith x NoAction = x
andProcessWith (NotifyUserAndServer p) UpdateServerViewed = NotifyUserAndServer p
andProcessWith (NotifyUserAndServer p1) (NotifyUser p2) = NotifyUserAndServer (p1 <> p2)
andProcessWith (NotifyUserAndServer p1) (NotifyUserAndServer p2) = NotifyUserAndServer (p1 <> p2)
andProcessWith (NotifyUser p1) (NotifyUserAndServer p2) = NotifyUser (p1 <> p2)
andProcessWith (NotifyUser p1) (NotifyUser p2) = NotifyUser (p1 <> p2)
andProcessWith (NotifyUser p) UpdateServerViewed = NotifyUserAndServer p
andProcessWith UpdateServerViewed UpdateServerViewed = UpdateServerViewed
andProcessWith UpdateServerViewed (NotifyUserAndServer p) = NotifyUserAndServer p
andProcessWith UpdateServerViewed (NotifyUser p) = NotifyUserAndServer p
-- | postProcessMessageAdd performs the actual actions indicated by
-- the corresponding input value.
postProcessMessageAdd :: PostProcessMessageAdd -> MH ()
postProcessMessageAdd ppma = postOp ppma
where
postOp NoAction = return ()
postOp UpdateServerViewed = updateViewed
postOp (NotifyUser p) = maybeRingBell >> mapM_ maybeNotify p
postOp (NotifyUserAndServer p) = updateViewed >> maybeRingBell >> mapM_ maybeNotify p
-- | When we add posts to the application state, we either get them
-- from the server during scrollback fetches (here called 'OldPost') or
-- we get them from websocket events when they are posted in real time
-- (here called 'RecentPost').
data PostToAdd =
OldPost Post
-- ^ A post from the server's history
| RecentPost Post Bool
-- ^ A message posted to the channel since the user connected, along
-- with a flag indicating whether the post triggered any of the
-- user's mentions. We need an extra flag because the server
-- determines whether the post has any mentions, and that data is
-- only available in websocket events (and then provided to this
-- constructor).
-- | Adds a possibly new message to the associated channel contents.
-- Returns an indicator of whether the user should be potentially
-- notified of a change (a new message not posted by this user, a
-- mention of the user, etc.). This operation has no effect on any
-- existing UnknownGap entries and should be called when those are
-- irrelevant.
addMessageToState :: PostToAdd -> MH PostProcessMessageAdd
addMessageToState newPostData = do
let (new, wasMentioned) = case newPostData of
-- A post from scrollback history has no mention data, and
-- that's okay: we only need to track mentions to tell the user
-- that recent posts contained mentions.
OldPost p -> (p, False)
RecentPost p m -> (p, m)
st <- use id
case st ^? csChannel(postChannelId new) of
Nothing -> do
session <- getSession
doAsyncWith Preempt $ do
nc <- MM.mmGetChannel (postChannelId new) session
member <- MM.mmGetChannelMember (postChannelId new) UserMe session
let chType = nc^.channelTypeL
pref = showGroupChannelPref (postChannelId new) (myUserId st)
-- If the channel has been archived, we don't want to post
-- this message or add the channel to the state.
case channelDeleted nc of
True -> return $ return ()
False -> return $ do
-- If the incoming message is for a group channel
-- we don't know about, that's because it was
-- previously hidden by the user. We need to
-- show it, and to do that we need to update
-- the server-side preference. (That, in turn,
-- triggers a channel refresh.)
if chType == Group
then applyPreferenceChange pref
else refreshChannel nc member
addMessageToState newPostData >>= postProcessMessageAdd
return NoAction
Just _ -> do
let cp = toClientPost new (new^.postParentIdL)
fromMe = (cp^.cpUser == (Just $ myUserId st)) &&
(isNothing $ cp^.cpUserOverride)
userPrefs = st^.csResources.crUserPreferences
isJoinOrLeave = case cp^.cpType of
Join -> True
Leave -> True
_ -> False
ignoredJoinLeaveMessage =
not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave
cId = postChannelId new
doAddMessage = do
currCId <- use csCurrentChannelId
flags <- use (csResources.crFlaggedPosts)
let msg' = clientPostToMessage cp
& mFlagged .~ ((cp^.cpPostId) `Set.member` flags)
csPostMap.at(postId new) .= Just msg'
csChannels %= modifyChannelById cId
((ccContents.cdMessages %~ addMessage msg') .
(adjustUpdated new) .
(\c -> if currCId == cId
then c
else updateNewMessageIndicator new c) .
(\c -> if wasMentioned
then c & ccInfo.cdMentionCount %~ succ
else c)
)
asyncFetchReactionsForPost cId new
asyncFetchAttachments new
postedChanMessage
doHandleAddedMessage = 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 cp^.cpInReplyToPost of
Just parentId ->
case getMessageForPostId st parentId of
Nothing -> do
doAsyncChannelMM Preempt cId
(\s _ _ -> MM.mmGetThread parentId s)
(\_ p -> do
let postMap = HM.fromList [ ( pId
, clientPostToMessage
(toClientPost x (x^.postParentIdL))
)
| (pId, x) <- HM.toList (p^.postsPostsL)
]
csPostMap %= HM.union postMap
)
_ -> return ()
_ -> return ()
doAddMessage
postedChanMessage =
withChannelOrDefault (postChannelId new) NoAction $ \chan -> do
currCId <- use csCurrentChannelId
let notifyPref = notifyPreference (myUser st) chan
curChannelAction = if postChannelId new == currCId
then UpdateServerViewed
else NoAction
originUserAction =
if | fromMe -> NoAction
| ignoredJoinLeaveMessage -> NoAction
| notifyPref == NotifyOptionAll -> NotifyUser [newPostData]
| notifyPref == NotifyOptionMention
&& wasMentioned -> NotifyUser [newPostData]
| otherwise -> NoAction
return $ curChannelAction `andProcessWith` originUserAction
doHandleAddedMessage
getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator
getNewMessageCutoff cId st = do
cc <- st^?csChannel(cId)
return $ cc^.ccInfo.cdNewMessageIndicator
getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime
getEditedMessageCutoff cId st = do
cc <- st^?csChannel(cId)
cc^.ccInfo.cdEditedMessageThreshold
fetchVisibleIfNeeded :: MH ()
fetchVisibleIfNeeded = do
sts <- use csConnectionStatus
case sts of
Connected -> do
cId <- use csCurrentChannelId
withChannel cId $ \chan ->
let msgs = chan^.ccContents.cdMessages.to reverseMessages
(numRemaining, gapInDisplayable, _, rel'pId, overlap) =
foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs
gapTrail a@(_, True, _, _, _) _ = a
gapTrail a@(0, _, _, _, _) _ = a
gapTrail (a, False, b, c, d) m | isGap m = (a, True, b, c, d)
gapTrail (remCnt, _, prev'pId, prev''pId, ovl) msg =
(remCnt - 1, False, msg^.mPostId <|> prev'pId, prev'pId <|> prev''pId,
ovl + if isNothing (msg^.mPostId) then 1 else 0)
numToReq = numRemaining + overlap
query = MM.defaultPostQuery
{ MM.postQueryPage = Just 0
, MM.postQueryPerPage = Just numToReq
}
finalQuery = case rel'pId of
Nothing -> query
Just pid -> query { MM.postQueryBefore = Just pid }
op = \s _ c -> MM.mmGetPostsForChannel c finalQuery s
in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do
csChannel(cId).ccContents.cdFetchPending .= True
doAsyncChannelMM Preempt cId op
(\c p -> do addObtainedMessages c (-numToReq) p >>= postProcessMessageAdd
csChannel(c).ccContents.cdFetchPending .= False)
_ -> return ()
setChannelTopic :: Text -> MH ()
setChannelTopic msg = do
cId <- use csCurrentChannelId
let patch = defaultChannelPatch { channelPatchHeader = Just msg }
doAsyncChannelMM Preempt cId
(\s _ _ -> MM.mmPatchChannel cId patch s)
(\_ _ -> return ())
channelHistoryForward :: MH ()
channelHistoryForward = do
cId <- use csCurrentChannelId
inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)
inputHistory <- use (csEditState.cedInputHistory)
case inputHistoryPos of
Just (Just i)
| i == 0 -> do
-- Transition out of history navigation
csEditState.cedInputHistoryPosition.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
csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)
csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)
_ -> return ()
channelHistoryBackward :: MH ()
channelHistoryBackward = do
cId <- use csCurrentChannelId
inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)
inputHistory <- use (csEditState.cedInputHistory)
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
csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)
csEditState.cedInputHistoryPosition.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
csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)
csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)
showHelpScreen :: HelpTopic -> MH ()
showHelpScreen topic = do
mh $ vScrollToBeginning (viewportScroll HelpViewport)
setMode $ ShowHelp topic
beginChannelSelect :: MH ()
beginChannelSelect = do
setMode ChannelSelect
csChannelSelectState .= emptyChannelSelectState
-- Select the next match in channel selection mode.
channelSelectNext :: MH ()
channelSelectNext = updateSelectedMatch succ
-- Select the previous match in channel selection mode.
channelSelectPrevious :: MH ()
channelSelectPrevious = updateSelectedMatch pred
-- Update the channel selection mode match cursor. The argument function
-- determines how the new cursor position is computed from the old
-- one. The new cursor position is automatically wrapped around to the
-- beginning or end of the channel selection match list, so cursor
-- transformations do not have to do index validation. If the current
-- match (e.g. the sentinel "") is not found in the match list, this
-- sets the cursor position to the first match, if any.
updateSelectedMatch :: (Int -> Int) -> MH ()
updateSelectedMatch nextIndex = do
chanMatches <- use (csChannelSelectState.channelMatches)
usernameMatches <- use (csChannelSelectState.userMatches)
csChannelSelectState.selectedMatch %= \oldMatch ->
-- Make the list of all matches, in display order.
let allMatches = concat [ (ChannelMatch . matchFull) <$> chanMatches
, (UserMatch . matchFull) <$> usernameMatches
]
defaultMatch = if null allMatches
then Nothing
else Just $ allMatches !! 0
in case oldMatch of
Nothing -> defaultMatch
Just oldMatch' -> case findIndex (== oldMatch') allMatches of
Nothing -> defaultMatch
Just i ->
let newIndex = if tmpIndex < 0
then length allMatches - 1
else if tmpIndex >= length allMatches
then 0
else tmpIndex
tmpIndex = nextIndex i
in Just $ allMatches !! newIndex
updateChannelSelectMatches :: MH ()
updateChannelSelectMatches = do
-- Given the current channel select string, find all the channel and
-- user matches and then update the match lists.
input <- use (csChannelSelectState.channelSelectInput)
let pat = parseChannelSelectPattern input
chanNameMatches = case pat of
Nothing -> const Nothing
Just p -> if T.null input
then const Nothing
else applySelectPattern p
patTy = case pat of
Nothing -> Nothing
Just (CSP ty _) -> Just ty
chanNames <- gets (sort . allChannelNames)
uList <- use (to sortedUserList)
displayNick <- use (to useNickname)
let chanMatches = if patTy == Just UsersOnly
then mempty
else catMaybes (fmap chanNameMatches chanNames)
displayName uInf
| displayNick = uInf^.uiNickName.non (uInf^.uiName)
| otherwise = uInf^.uiName
usernameMatches = if patTy == Just ChannelsOnly
then mempty
else catMaybes (fmap (chanNameMatches . displayName) uList)
newInput <- use (csChannelSelectState.channelSelectInput)
csChannelSelectState.channelMatches .= chanMatches
csChannelSelectState.userMatches .= usernameMatches
csChannelSelectState.selectedMatch %= \oldMatch ->
-- If the user input exactly matches one of the matches, prefer
-- that one. Otherwise, if the previously selected match is
-- still a possible match, leave it selected. Otherwise revert
-- to the first available match.
let unames = matchFull <$> usernameMatches
cnames = matchFull <$> chanMatches
firstAvailableMatch =
if null chanMatches
then if null unames
then Nothing
else Just $ UserMatch $ head unames
else Just $ ChannelMatch $ head cnames
newMatch = case oldMatch of
Just (UserMatch u) ->
if newInput `elem` unames
then Just $ UserMatch newInput
else if u `elem` unames
then oldMatch
else firstAvailableMatch
Just (ChannelMatch c) ->
if newInput `elem` cnames
then Just $ ChannelMatch $ newInput
else if c `elem` cnames
then oldMatch
else firstAvailableMatch
Nothing -> firstAvailableMatch
in newMatch
applySelectPattern :: ChannelSelectPattern -> 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 UsersOnly | pat `T.isPrefixOf` chanName = do
let (b, a) = T.splitAt (T.length pat) chanName
return ("", b, a)
applyType ChannelsOnly | 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 chanName
parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern
parseChannelSelectPattern pat = do
let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP UsersOnly $ T.tail pat
| normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP ChannelsOnly $ T.tail pat
| otherwise -> Nothing
(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)
only <|> 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)
setMode UrlSelect
csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)
stopUrlSelect :: MH ()
stopUrlSelect = setMode Main
findUrls :: ClientChannel -> [LinkChoice]
findUrls chan =
let msgs = chan^.ccContents.cdMessages
in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs
-- XXX: move this somewhere more sensible!
-- | The 'nubOn' function removes duplicate elements from a list. In
-- particular, it keeps only the /last/ occurrence of each
-- element. The equality of two elements in a call to @nub f@ is
-- determined using @f x == f y@, and the resulting elements must have
-- an 'Ord' instance in order to make this function more efficient.
nubOn :: (Ord b) => (a -> b) -> [a] -> [a]
nubOn f = snd . go Set.empty
where go before [] = (before, [])
go before (x:xs) =
let (before', xs') = go before xs
key = f x in
if key `Set.member` before'
then (before', xs')
else (Set.insert key before', x : xs')
removeDuplicates :: [LinkChoice] -> [LinkChoice]
removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser))
msgURLs :: Message -> Seq LinkChoice
msgURLs msg
| NoUser <- msg^.mUser = mempty
| otherwise =
let uid = msg^.mUser
msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$>
(mconcat $ blockGetURLs <$> (toList $ msg^.mText))
attachmentURLs = (\ a ->
LinkChoice
(msg^.mDate)
uid
("attachment `" <> (a^.attachmentName) <> "`")
(a^.attachmentURL)
(Just (a^.attachmentFileId)))
<$> (msg^.mAttachments)
in msgUrls <> attachmentURLs
openSelectedURL :: MH ()
openSelectedURL = whenMode UrlSelect $ do
selected <- use (csUrlList.to listSelectedElement)
case selected of
Nothing -> return ()
Just (_, link) -> do
opened <- openURL link
when (not opened) $ do
mhError $ ConfigOptionMissing "urlOpenCommand"
setMode Main
openURL :: LinkChoice -> MH Bool
openURL link = do
cfg <- use (csResources.crConfiguration)
case configURLOpenCommand cfg of
Nothing ->
return False
Just urlOpenCommand -> do
session <- getSession
-- Is the URL referring to an attachment?
let act = case link^.linkFileId of
Nothing -> prepareLink link
Just fId -> prepareAttachment fId session
-- Is the URL-opening command interactive? If so, pause
-- Matterhorn and run the opener interactively. Otherwise
-- run the opener asynchronously and continue running
-- Matterhorn interactively.
case configURLOpenCommandInteractive cfg of
False -> do
outputChan <- use (csResources.crSubprocessLog)
doAsyncWith Preempt $ do
args <- act
runLoggedCommand False outputChan (T.unpack urlOpenCommand)
args Nothing Nothing
return $ return ()
True -> do
-- If there isn't a new message cutoff showing in
-- the current channel, set one. This way, while the
-- user is gone using their interactive URL opener,
-- when they return, any messages that arrive in the
-- current channel will be displayed as new.
curChan <- use csCurrentChannel
let msgs = curChan^.ccContents.cdMessages
case findLatestUserMessage isEditable msgs of
Nothing -> return ()
Just m ->
case m^.mOriginalPost of
Nothing -> return ()
Just p ->
case curChan^.ccInfo.cdNewMessageIndicator of
Hide ->
csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))
_ -> return ()
-- No need to add a gap here: the websocket
-- disconnect/reconnect events will automatically
-- handle management of messages delivered while
-- suspended.
mhSuspendAndResume $ \st -> do
args <- act
void $ runInteractiveCommand (T.unpack urlOpenCommand) args
return $ setMode' Main st
return True
prepareLink :: LinkChoice -> IO [String]
prepareLink link = return [T.unpack $ link^.linkURL]
prepareAttachment :: FileId -> Session -> IO [String]
prepareAttachment fId sess = do
-- The link is for an attachment, so fetch it and then
-- open the local copy.
(info, contents) <- concurrently (MM.mmGetMetadataForFile fId sess) (MM.mmGetFile fId sess)
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 [fname]
runInteractiveCommand :: String
-> [String]
-> IO (Either String ExitCode)
runInteractiveCommand cmd args = do
let opener = (proc cmd args) { std_in = Inherit
, std_out = Inherit
, std_err = Inherit
}
result <- try $ createProcess opener
case result of
Left (e::SomeException) -> return $ Left $ show e
Right (_, _, _, ph) -> do
ec <- waitForProcess ph
return $ Right ec
runLoggedCommand :: Bool
-- ^ Whether stdout output is expected for this program
-> STM.TChan ProgramOutput
-- ^ The output channel to send the output to
-> String
-- ^ The program name
-> [String]
-- ^ Arguments
-> Maybe String
-- ^ The stdin to send, if any
-> Maybe (MVar ProgramOutput)
-- ^ Where to put the program output when it is ready
-> IO ()
runLoggedCommand stdoutOkay outputChan cmd args mInput mOutputVar = void $ forkIO $ do
let stdIn = maybe NoStream (const CreatePipe) mInput
opener = (proc cmd args) { std_in = stdIn
, std_out = CreatePipe
, std_err = CreatePipe
}
result <- try $ createProcess opener
case result of
Left (e::SomeException) -> do
let po = ProgramOutput cmd args "" stdoutOkay (show e) (ExitFailure 1)
STM.atomically $ STM.writeTChan outputChan po
maybe (return ()) (flip putMVar po) mOutputVar
Right (stdinResult, Just outh, Just errh, ph) -> do
case stdinResult of
Just inh -> do
let Just input = mInput
hPutStrLn inh input
hFlush inh
Nothing -> return ()
ec <- waitForProcess ph
outResult <- hGetContents outh
errResult <- hGetContents errh
let po = ProgramOutput cmd args outResult stdoutOkay errResult ec
STM.atomically $ STM.writeTChan outputChan po
maybe (return ()) (flip putMVar po) mOutputVar
Right _ ->
error $ "BUG: createProcess returned unexpected result, report this at " <>
"https://github.com/matterhorn-chat/matterhorn"
openSelectedMessageURLs :: MH ()
openSelectedMessageURLs = whenMode 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 -> setMode Main
False ->
mhError $ ConfigOptionMissing "urlOpenCommand"
shouldSkipMessage :: Text -> Bool
shouldSkipMessage "" = True
shouldSkipMessage s = T.all (`elem` (" \t"::String)) s
sendMessage :: EditMode -> 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."
mhError $ GenericError m
Connected -> do
let chanId = st^.csCurrentChannelId
session <- getSession
doAsync Preempt $ do
case mode of
NewPost -> do
let pendingPost = rawPost msg chanId
void $ MM.mmCreatePost pendingPost session
Replying _ p -> do
let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p) }
void $ MM.mmCreatePost pendingPost session
Editing p ty -> do
let body = if ty == CP Emote
then addEmoteFormatting msg
else msg
void $ MM.mmPatchPost (postId p) (postUpdateBody body) session
handleNewUserDirect :: User -> MH ()
handleNewUserDirect newUser = do
let usrInfo = userInfoFromUser newUser True
addNewUser usrInfo
handleNewUsers :: Seq UserId -> MH ()
handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo addNewUsers
where getUserInfo session _ =
do nUsers <- MM.mmGetUsersByIds newUserIds session
let usrInfo u = userInfoFromUser u True
usrList = toList nUsers
return $ usrInfo <$> usrList
addNewUsers :: [UserInfo] -> MH ()
addNewUsers = mapM_ addNewUser
-- | Handle the typing events from the websocket to show the currently typing users on UI
handleTypingUser :: UserId -> ChannelId -> MH ()
handleTypingUser uId cId = do
config <- use (csResources.crConfiguration)
when (configShowTypingIndicator config) $ do
ts <- liftIO getCurrentTime -- get time now
csChannels %= modifyChannelById cId (addChannelTypingUser uId ts)