matterhorn-50200.17.0: src/Matterhorn/State/Messages.hs
{-# LANGUAGE MultiWayIf #-}
module Matterhorn.State.Messages
( PostToAdd(..)
, lastMsg
, sendMessage
, editMessage
, deleteMessage
, addNewPostedMessage
, addObtainedMessages
, asyncFetchMoreMessages
, asyncFetchMessagesForGap
, asyncFetchMessagesSurrounding
, fetchVisibleIfNeeded
, disconnectChannels
, toggleMessageTimestamps
, toggleVerbatimBlockTruncation
, jumpToPost
, addMessageToState
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick.Main ( getVtyHandle, invalidateCache )
import qualified Brick.Widgets.FileBrowser as FB
import Control.Exception ( SomeException, try )
import qualified Data.Aeson as A
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.Foldable as F
import qualified Data.HashMap.Strict as HM
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Graphics.Vty ( outputIface )
import Graphics.Vty.Output.Interface ( ringTerminalBell )
import Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~)
, to, at, traversed, filtered, ix, _1, _Just )
import Network.Mattermost
import qualified Network.Mattermost.Endpoints as MM
import Network.Mattermost.Lenses
import Network.Mattermost.Types
import Matterhorn.Constants
import Matterhorn.State.Channels
import Matterhorn.State.Common
import Matterhorn.State.ThreadWindow
import Matterhorn.State.MessageSelect
import Matterhorn.State.Reactions
import Matterhorn.State.Users
import Matterhorn.TimeUtils
import Matterhorn.Types
import Matterhorn.Types.Common ( sanitizeUserText )
import Matterhorn.Types.DirectionalSeq ( DirectionalSeq, SeqDirection )
-- ----------------------------------------------------------------------
-- Message gaps
-- | Called to add an UnknownGap to the end of the Messages collection
-- for all channels when the client has become disconnected from the
-- server. This gaps will later be removed by successful fetching
-- overlaps if the connection is re-established. Note that the
-- disconnect is re-iterated periodically via a re-connect timer
-- attempt, so do not duplicate gaps. Also clear any flags
-- representing a pending exchange with the server (which will now
-- never complete).
addDisconnectGaps :: MH ()
addDisconnectGaps = mapM_ onEach . filteredChannelIds (const True) =<< use csChannels
where onEach c = do addEndGap c
clearPendingFlags c
invalidateChannelRenderingCache c
-- | Websocket was disconnected, so all channels may now miss some
-- messages
disconnectChannels :: MH ()
disconnectChannels = addDisconnectGaps
toggleMessageTimestamps :: MH ()
toggleMessageTimestamps = do
mh invalidateCache
let toggle c = c { configShowMessageTimestamps = not (configShowMessageTimestamps c)
}
csResources.crConfiguration %= toggle
defaultVerbatimTruncateHeight :: Int
defaultVerbatimTruncateHeight = 25
toggleVerbatimBlockTruncation :: MH ()
toggleVerbatimBlockTruncation = do
mh invalidateCache
st <- use id
-- Restore the configured setting, or a default if the configuration
-- does not specify a setting.
let toggle Nothing = (st^.csResources.crConfiguration.configTruncateVerbatimBlocksL) <|>
Just defaultVerbatimTruncateHeight
toggle (Just _) = Nothing
csVerbatimTruncateSetting %= toggle
clearPendingFlags :: ChannelId -> MH ()
clearPendingFlags c = csChannel(c).ccInfo.cdFetchPending .= False
addEndGap :: ChannelId -> MH ()
addEndGap cId = withChannel cId $ \chan ->
let lastmsg_ = chan^.ccMessageInterface.miMessages.to reverseMessages.to lastMsg
lastIsGap = maybe False isGap lastmsg_
gapMsg = newGapMessage timeJustAfterLast
timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_
t0 = ServerTime $ originTime -- use any time for a channel with no messages yet
newGapMessage = newMessageOfType
(T.pack "Disconnected. Will refresh when connected.")
(C UnknownGapAfter)
in unless lastIsGap
(csChannels %= modifyChannelById cId (ccMessageInterface.miMessages %~ addMessage gapMsg))
lastMsg :: RetrogradeMessages -> Maybe Message
lastMsg = withFirstMessage id
-- | Send a message and attachments to the specified channel.
sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()
sendMessage chanId mode msg attachments =
when (not $ shouldSkipMessage msg) $ do
status <- use csConnectionStatus
case status of
Disconnected -> do
let m = T.concat [ "Cannot send messages while disconnected. Enable logging to "
, "get disconnection information. If Matterhorn's reconnection "
, "attempts are failing, use `/reconnect` to attempt to "
, "reconnect manually."
]
mhError $ GenericError m
Connected -> do
session <- getSession
doAsync Preempt $ do
-- Upload attachments
fileInfos <- forM attachments $ \a -> do
MM.mmUploadFile chanId (FB.fileInfoFilename $ attachmentDataFileInfo a)
(attachmentDataBytes a) session
let fileIds = Seq.fromList $
fmap fileInfoId $
concat $
(F.toList . MM.uploadResponseFileInfos) <$> fileInfos
case mode of
NewPost -> do
let pendingPost = (rawPost msg chanId) { rawPostFileIds = fileIds }
void $ MM.mmCreatePost pendingPost session
Replying _ p -> do
let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p)
, rawPostFileIds = fileIds
}
void $ MM.mmCreatePost pendingPost session
Editing p ty -> do
let body = case ty of
CP Emote -> addEmoteFormatting msg
_ -> msg
update = (postUpdateBody body) { postUpdateFileIds = if null fileIds
then Nothing
else Just fileIds
}
void $ MM.mmPatchPost (postId p) update session
shouldSkipMessage :: Text -> Bool
shouldSkipMessage "" = True
shouldSkipMessage s = T.all (`elem` (" \t"::String)) s
editMessage :: Post -> MH ()
editMessage new = do
myId <- gets myUserId
withChannel (new^.postChannelIdL) $ \chan -> do
let mTId = chan^.ccInfo.cdTeamId
mBaseUrl <- case mTId of
Nothing -> return Nothing
Just tId -> Just <$> getServerBaseUrl tId
let (msg, mentionedUsers) = clientPostToMessage (toClientPost mBaseUrl new (new^.postRootIdL))
isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)
csChannel (new^.postChannelIdL) . ccMessageInterface.miMessages . traversed . filtered isEditedMessage .= msg
invalidateChannelRenderingCache $ new^.postChannelIdL
invalidateMessageRenderingCacheByPostId $ postId new
editPostInOpenThread mTId new msg
fetchMentionedUsers mentionedUsers
when (postUserId new /= Just myId) $
csChannel (new^.postChannelIdL) %= adjustEditedThreshold new
csPostMap.ix(postId new) .= msg
asyncFetchReactionsForPost (postChannelId new) new
asyncFetchAttachments new
deleteMessage :: Post -> MH ()
deleteMessage new = do
let isDeletedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL) ||
isReplyTo (new^.postIdL) m
chan :: Traversal' ChatState ClientChannel
chan = csChannel (new^.postChannelIdL)
chan.ccMessageInterface.miMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)
chan %= adjustUpdated new
withChannel (new^.postChannelIdL) $ \ch -> do
case ch^.ccInfo.cdTeamId of
Nothing -> return ()
Just tId -> deletePostFromOpenThread tId new
invalidateChannelRenderingCache $ new^.postChannelIdL
invalidateMessageRenderingCacheByPostId $ postId new
deletePostFromOpenThread :: TeamId -> Post -> MH ()
deletePostFromOpenThread tId p = do
let isDeletedMessage m = m^.mMessageId == Just (MessagePostId $ p^.postIdL) ||
isReplyTo (p^.postIdL) m
-- If the post being deleted is in the thread, we just need to
-- remove it from the thread view. But if this effectively empties
-- the thread, that's because this was the root. In that case we
-- need to close down the window.
threadInterfaceDeleteWhere tId (p^.postChannelIdL) isDeletedMessage
ti <- use (csTeam(tId).tsThreadInterface)
when (isJust ti) $ do
isEmpty <- threadInterfaceEmpty tId
when isEmpty $ do
closeThreadWindow tId
postInfoMessage "The thread you were viewing was deleted."
addNewPostedMessage :: PostToAdd -> MH ()
addNewPostedMessage p =
addMessageToState True True p >>= postProcessMessageAdd
-- | Adds the set of Posts to the indicated channel. The Posts must all
-- be for the specified Channel. The reqCnt argument indicates how many
-- posts were requested, which will determine whether a gap message is
-- added to either end of the posts list or not.
--
-- The addTrailingGap is only True when fetching the very latest
-- messages for the channel, and will suppress the generation of a Gap
-- message following the added block of messages.
addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages cId reqCnt addTrailingGap posts = do
invalidateChannelRenderingCache cId
if null $ posts^.postsOrderL
then do when addTrailingGap $
-- Fetched at the end of the channel, but nothing was
-- available. This is common if this is a new channel
-- with no messages in it. Need to remove any gaps that
-- exist at the end of the channel.
csChannels %= modifyChannelById cId
(ccMessageInterface.miMessages %~
\msgs -> let startPoint = join $ _mMessageId <$> getLatestPostMsg msgs
in fst $ removeMatchesFromSubset isGap startPoint Nothing msgs)
return NoAction
else
-- 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)
mTId = chan^.ccInfo.cdTeamId
-- 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^.ccMessageInterface.miMessages
-- Get a list of the duplicated message PostIds between
-- the messages already in the channel and the new posts
-- to be added.
match = snd $ removeMatchesFromSubset
(\m -> maybe False (\p -> p `elem` pIdList) (messagePostId m))
(Just (MessagePostId earliestPId))
(Just (MessagePostId latestPId))
localMessages
accum m l =
case messagePostId m of
Just pId -> pId : l
Nothing -> l
dupPIds = foldr accum [] 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 isOlder =
-- newGapMessage is a helper for generating a gap
-- message
do uuid <- generateUUID
let txt = "Load " <>
(if isOlder then "older" else "newer") <>
" messages" <>
(if isOlder then " ↥↥↥" else " ↧↧↧")
ty = if isOlder
then C UnknownGapBefore
else C UnknownGapAfter
return (newMessageOfType txt ty d
& mMessageId .~ Just (MessageUUID uuid))
-- 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 (MessagePostId earliestPId)
removeEnd = if addTrailingGap || (addingAtEnd && noMoreAfter)
then Nothing
else Just (MessagePostId latestPId)
noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)
noMoreAfter = addTrailingGap || reqCnt > 0 && length pIdList < reqCnt
reAddGapBefore = earliestPId `elem` dupPIds || noMoreBefore
-- addingAtEnd used to be in reAddGapAfter but does not
-- seem to be needed. I may have missed a specific use
-- case/scenario, so I've left it commented out here for
-- debug assistance.
reAddGapAfter = latestPId `elem` dupPIds || {- addingAtEnd || -} noMoreAfter
-- The post map returned by the server will *already* have
-- all thread messages for each post that is part of a
-- thread. By calling installMessagesFromPosts 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. This also gathers up the set of all mentioned
-- usernames in the text of the messages which we need to use to
-- submit a single batch request for user metadata so we don't
-- submit one request per mention.
void $ installMessagesFromPosts mTId 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 False False . OldPost)
[ (posts^.postsPostsL) HM.! p
| p <- toList (posts^.postsOrderL)
, not (p `elem` dupPIds)
]
-- The channel messages now include all the fetched messages.
-- Things to do at this point are:
--
-- 1. Remove any duplicates just added, as well as any gaps
-- 2. Add new gaps (if needed) at either end of the added
-- messages.
-- 3. Update the "current selection" if it was on a removed message.
--
-- Do this with the updated copy of the channel's messages.
withChannelOrDefault cId () $ \updchan -> do
let updMsgs = updchan ^. ccMessageInterface.miMessages
-- Remove any gaps in the added region. If there was an
-- active message selection and it is one of the removed
-- gaps, reset the selection to the beginning or end of the
-- added region (if there are any added selectable messages,
-- otherwise just the end if the message list in it's
-- entirety, or no selection at all).
let (resultMessages, removedMessages) =
removeMatchesFromSubset isGap removeStart removeEnd updMsgs
csChannels %= modifyChannelById cId
(ccMessageInterface.miMessages .~ resultMessages)
let processTeam tId = do
-- Determine if the current selected message was one of the
-- removed messages.
selMsgId <- use (channelMessageSelect(cId).to selectMessageId)
let rmvdSel = do
i <- selMsgId -- :: Maybe MessageId
findMessage i removedMessages
rmvdSelType = _mType <$> rmvdSel
case rmvdSel of
Nothing -> return ()
Just rm ->
if isGap rm
then return () -- handled during gap insertion below
else do
-- Replaced a selected message that wasn't a gap.
-- This is unlikely, but may occur if the previously
-- selected message was just deleted by another user
-- and is in the fetched region. The choices here are
-- to move the selection, or cancel the selection.
-- Both will be unpleasant surprises for the user, but
-- cancelling the selection is probably the better
-- choice than allowing the user to perform select
-- actions on a message that isn't the one they just
-- selected.
popMode tId
channelMessageSelect(cId) .= MessageSelectState Nothing
-- 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
if reAddGapBefore
then
-- No more gaps. If the selected gap was removed, move
-- select to first (earliest) message)
case rmvdSelType of
Just (C UnknownGapBefore) ->
channelMessageSelect(cId) .= MessageSelectState (pure $ MessagePostId earliestPId)
_ -> return ()
else do
-- add a gap at the start of the newly fetched block and
-- make that the active selection if this fetch removed
-- the previously selected gap in this direction.
gapMsg <- newGapMessage (justBefore earliestDate) True
csChannels %= modifyChannelById cId
(ccMessageInterface.miMessages %~ addMessage gapMsg)
-- Move selection from old gap to new gap
case rmvdSelType of
Just (C UnknownGapBefore) -> do
channelMessageSelect(cId) .= MessageSelectState (gapMsg^.mMessageId)
_ -> return ()
if reAddGapAfter
then
-- No more gaps. If the selected gap was removed, move
-- select to last (latest) message.
case rmvdSelType of
Just (C UnknownGapAfter) ->
channelMessageSelect(cId) .= MessageSelectState (pure $ MessagePostId latestPId)
_ -> return ()
else do
-- add a gap at the end of the newly fetched block and
-- make that the active selection if this fetch removed
-- the previously selected gap in this direction.
gapMsg <- newGapMessage (justAfter latestDate) False
csChannels %= modifyChannelById cId
(ccMessageInterface.miMessages %~ addMessage gapMsg)
-- Move selection from old gap to new gap
case rmvdSelType of
Just (C UnknownGapAfter) ->
channelMessageSelect(cId) .= MessageSelectState (gapMsg^.mMessageId)
_ -> return ()
case mTId of
Nothing -> do
ts <- use csTeams
forM_ (HM.keys ts) processTeam
Just tId -> processTeam tId
-- 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) (return ())
addUnknownUsers users
-- Return the aggregated user notification action needed
-- relative to the set of added messages.
return action
-- | 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.
--
-- The first boolean argument ('doFetchMentionedUsers') indicates
-- whether this function should schedule a fetch for any mentioned
-- users in the message. This is provided so that callers can batch
-- this operation if a large collection of messages is being added
-- together, in which case we don't want this function to schedule a
-- single request per message (worst case). If you're calling this as
-- part of scrollback processing, you should pass False. Otherwise if
-- you're adding only a single message, you should pass True.
--
-- The second boolean argument ('fetchAuthor') is similar to the first
-- boolean argument but it refers to the author of the message instead
-- of any user mentions within the message body.
--
-- The third argument ('newPostData') indicates whether this message
-- is being added as part of a fetch of old messages (e.g. scrollback)
-- or if ti is a new message and affects things like whether
-- notifications are generated and if the "New Messages" marker gets
-- updated.
addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState doFetchMentionedUsers fetchAuthor 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 Nothing
False -> return $ Just $ 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 SidebarUpdateImmediate nc member
addMessageToState doFetchMentionedUsers fetchAuthor newPostData >>=
postProcessMessageAdd
return NoAction
Just ch -> do
let mTId = ch^.ccInfo.cdTeamId
mBaseUrl <- case mTId of
Nothing -> return Nothing
Just tId -> Just <$> getServerBaseUrl tId
let cp = toClientPost mBaseUrl new (new^.postRootIdL)
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
-- Do we have the user data for the post author?
case cp^.cpUser of
Nothing -> return ()
Just authorId -> when fetchAuthor $ do
authorResult <- gets (userById authorId)
when (isNothing authorResult) $
handleNewUsers (Seq.singleton authorId) (return ())
mcurTId <- use csCurrentTeamId
currCId <- case mcurTId of
Nothing -> return Nothing
Just curTId -> use (csCurrentChannelId curTId)
flags <- use (csResources.crFlaggedPosts)
let (msg', mentionedUsers) = clientPostToMessage cp
& _1.mFlagged .~ ((cp^.cpPostId) `Set.member` flags)
when doFetchMentionedUsers $
fetchMentionedUsers mentionedUsers
csPostMap.at(postId new) .= Just msg'
invalidateChannelRenderingCache cId
invalidateMessageRenderingCacheByPostId $ postId new
csChannels %= modifyChannelById cId
((ccMessageInterface.miMessages %~ addMessage msg') .
(if not ignoredJoinLeaveMessage then adjustUpdated new else id) .
(\c -> if currCId == Just cId
then c
else case newPostData of
OldPost _ -> c
RecentPost _ _ ->
updateNewMessageIndicator new c) .
(\c -> if wasMentioned
then c & ccInfo.cdMentionCount %~ succ
else c)
)
-- Check for whether the post is part of a thread
-- being viewed. If so, add the post to that thread
-- window as well.
addPostToOpenThread mTId new msg'
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 -> Just $ updatePostMap mTId p)
_ -> return ()
_ -> return ()
doAddMessage
postedChanMessage =
withChannelOrDefault (postChannelId new) NoAction $ \chan -> do
mcurrTid <- use csCurrentTeamId
case mcurrTid of
Nothing -> return NoAction
Just currTid -> do
currCId <- use (csCurrentChannelId currTid)
let notifyPref = notifyPreference (myUser st) chan
curChannelAction = if Just (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
addPostToOpenThread :: Maybe TeamId -> Post -> Message -> MH ()
addPostToOpenThread Nothing _ _ = return ()
addPostToOpenThread (Just tId) new msg =
case postRootId new of
Nothing -> return ()
Just parentId -> do
mRoot <- preuse (maybeThreadInterface(tId)._Just.miRootPostId)
when (mRoot == Just parentId) $
modifyThreadMessages tId (new^.postChannelIdL) (addMessage msg)
editPostInOpenThread :: Maybe TeamId -> Post -> Message -> MH ()
editPostInOpenThread Nothing _ _ = return ()
editPostInOpenThread (Just tId) new msg =
case postRootId new of
Nothing -> return ()
Just parentId -> do
mRoot <- preuse (maybeThreadInterface(tId)._Just.miRootPostId)
when (mRoot == Just parentId) $ do
mhLog LogGeneral "editPostInOpenThread: updating message"
let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)
modifyEachThreadMessage tId (new^.postChannelIdL)
(\m -> if isEditedMessage m then msg else m)
-- | 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 False
postOp (NotifyUser p) = maybeRingBell >> mapM_ maybeNotify p
postOp (NotifyUserAndServer p) = updateViewed False >> maybeRingBell >> mapM_ maybeNotify p
maybeNotify :: PostToAdd -> MH ()
maybeNotify (OldPost _) = do
return ()
maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned
maybeRingBell :: MH ()
maybeRingBell = do
doBell <- use (csResources.crConfiguration.configActivityBellL)
when doBell $ do
vty <- mh getVtyHandle
liftIO $ ringTerminalBell $ outputIface vty
-- | 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).
encodeToJSONstring :: A.ToJSON a => a -> String
encodeToJSONstring a = BL8.unpack $ A.encode a
-- Notification Version 2 payload definition
data NotificationV2 = NotificationV2
{ version :: Int
, message :: Text
, mention :: Bool
, from :: Text
} deriving (Show)
instance A.ToJSON NotificationV2 where
toJSON (NotificationV2 vers msg mentioned sender) =
A.object [ "version" A..= vers
, "message" A..= msg
, "mention" A..= mentioned
, "from" A..= sender
]
-- We define a notifyGetPayload for each notification version.
notifyGetPayload :: NotificationVersion -> ChatState -> Post -> Bool -> Maybe String
notifyGetPayload NotifyV1 _ _ _ = do return ""
notifyGetPayload NotifyV2 st post mentioned = do
let notification = NotificationV2 2 msg mentioned sender
return (encodeToJSONstring notification)
where
msg = sanitizeUserText $ postMessage post
sender = maybePostUsername st post
handleNotifyCommand :: Post -> Bool -> NotificationVersion -> MH ()
handleNotifyCommand post mentioned NotifyV1 = do
outputChan <- use (csResources.crSubprocessLog)
st <- use id
notifyCommand <- use (csResources.crConfiguration.configActivityNotifyCommandL)
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 outputChan (T.unpack cmd)
[notified, sender, messageString] Nothing Nothing
return Nothing
handleNotifyCommand post mentioned NotifyV2 = do
outputChan <- use (csResources.crSubprocessLog)
st <- use id
let payload = notifyGetPayload NotifyV2 st post mentioned
notifyCommand <- use (csResources.crConfiguration.configActivityNotifyCommandL)
case notifyCommand of
Nothing -> return ()
Just cmd ->
doAsyncWith Preempt $ do
runLoggedCommand outputChan (T.unpack cmd) [] payload Nothing
return Nothing
runNotifyCommand :: Post -> Bool -> MH ()
runNotifyCommand post mentioned = do
notifyVersion <- use (csResources.crConfiguration.configActivityNotifyVersionL)
case notifyVersion of
NotifyV1 -> handleNotifyCommand post mentioned NotifyV1
NotifyV2 -> handleNotifyCommand post mentioned NotifyV2
maybePostUsername :: ChatState -> Post -> T.Text
maybePostUsername st p =
fromMaybe T.empty $ do
uId <- postUserId p
usernameForUserId uId st
-- | 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.
--
-- This function assumes it is being called to add "older" messages to
-- the message history (i.e. near the beginning of the known
-- messages). It will normally try to overlap the fetch with the
-- known existing messages so that when the fetch results are
-- processed (which should be a contiguous set of messages as provided
-- by the server) there will be an overlap with existing messages; if
-- there is no overlap, then a special "gap" must be inserted in the
-- area between the existing messages and the newly fetched messages
-- to indicate that this client does not know if there are missing
-- messages there or not.
--
-- In order to achieve an overlap, this code attempts to get the
-- second oldest messages as the message ID to pass to the server as
-- the "older than" marker ('postQueryBefore'), so that the oldest
-- message here overlaps with the fetched results to ensure no gap
-- needs to be inserted. However, there may already be a gap between
-- the oldest and second-oldest messages, so this code must actually
-- search for the first set of two *contiguous* messages it is aware
-- of to avoid adding additional gaps. (It's OK if gaps are added, but
-- the user must explicitly request a check for messages in order to
-- eliminate them, so it's better to avoid adding them in the first
-- place). This code is nearly always used to extend the older
-- history of a channel that information has already been retrieved
-- from, so it's almost certain that there are at least two contiguous
-- messages to use as a starting point, but exceptions are new
-- channels and empty channels.
asyncFetchMoreMessages :: MH ()
asyncFetchMoreMessages =
withCurrentTeam $ \tId ->
withCurrentChannel tId $ \cId chan -> do
let offset = max 0 $ length (chan^.ccMessageInterface.miMessages) - 2
page = offset `div` pageAmount
usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccMessageInterface.miMessages.to reverseMessages)
sndOldestId = (messagePostId . snd) =<< usefulMsgs
query = MM.defaultPostQuery
{ MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId
, MM.postQueryPerPage = Just pageAmount
, MM.postQueryBefore = sndOldestId
}
addTrailingGap = MM.postQueryBefore query == Nothing &&
MM.postQueryPage query == Just 0
doAsyncChannelMM Preempt cId
(\s c -> MM.mmGetPostsForChannel c query s)
(\c p -> Just $ do
pp <- addObtainedMessages c (-pageAmount) addTrailingGap p
postProcessMessageAdd pp)
-- | Given a starting point and a direction to move from that point,
-- returns the closest two adjacent messages on that direction (as a
-- tuple of closest and next-closest), or Nothing if there are no
-- adjacent messages in the indicated direction.
getTwoContiguousPosts :: SeqDirection dir =>
Maybe Message
-> DirectionalSeq dir Message
-> Maybe (Message, Message)
getTwoContiguousPosts startMsg msgs =
let go start =
do anchor <- getRelMessageId (_mMessageId =<< start) msgs
hinge <- getRelMessageId (anchor^.mMessageId) msgs
if isGap anchor || isGap hinge
then go $ Just anchor
else Just (anchor, hinge)
in go startMsg
asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()
asyncFetchMessagesForGap cId gapMessage =
when (isGap gapMessage) $
withChannel cId $ \chan ->
let offset = max 0 $ length (chan^.ccMessageInterface.miMessages) - 2
page = offset `div` pageAmount
chanMsgs = chan^.ccMessageInterface.miMessages
fromMsg = Just gapMessage
fetchNewer = case gapMessage^.mType of
C UnknownGapAfter -> True
C UnknownGapBefore -> False
_ -> error "fetch gap messages: unknown gap message type"
baseId = messagePostId . snd =<<
case gapMessage^.mType of
C UnknownGapAfter -> getTwoContiguousPosts fromMsg $
reverseMessages chanMsgs
C UnknownGapBefore -> getTwoContiguousPosts fromMsg chanMsgs
_ -> error "fetch gap messages: unknown gap message type"
query = MM.defaultPostQuery
{ MM.postQueryPage = maybe (Just page) (const Nothing) baseId
, MM.postQueryPerPage = Just pageAmount
, MM.postQueryBefore = if fetchNewer then Nothing else baseId
, MM.postQueryAfter = if fetchNewer then baseId else Nothing
}
addTrailingGap = MM.postQueryBefore query == Nothing &&
MM.postQueryPage query == Just 0
in doAsyncChannelMM Preempt cId
(\s c -> MM.mmGetPostsForChannel c query s)
(\c p -> Just $ do
void $ addObtainedMessages c (-pageAmount) addTrailingGap p)
-- | Given a particular message ID, this fetches n messages before and
-- after immediately before and after the specified message in order
-- to establish some context for that message. This is frequently
-- used as a background operation when looking at search or flag
-- results so that jumping to message select mode for one of those
-- messages will show a bit of context (and it also prevents showing
-- gap messages for adjacent targets).
--
-- The result will be adding at most 2n messages to the channel, with
-- the input post ID being somewhere in the middle of the added
-- messages.
--
-- Note that this fetch will add messages to the channel, but it
-- performs no notifications or updates of new-unread indicators
-- because it is assumed to be used for non-current (previously-seen)
-- messages in background mode.
asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH ()
asyncFetchMessagesSurrounding cId pId = do
let query = MM.defaultPostQuery
{ MM.postQueryBefore = Just pId
, MM.postQueryPerPage = Just reqAmt
}
reqAmt = 5 -- both before and after
doAsyncChannelMM Preempt cId
-- first get some messages before the target, no overlap
(\s c -> MM.mmGetPostsForChannel c query s)
(\c p -> Just $ do
let last2ndId = secondToLastPostId p
void $ addObtainedMessages c (-reqAmt) False p
-- now start 2nd from end of this fetch to fetch some
-- messages forward, also overlapping with this fetch and
-- the original message ID to eliminate all gaps in this
-- surrounding set of messages.
let query' = MM.defaultPostQuery
{ MM.postQueryAfter = last2ndId
, MM.postQueryPerPage = Just $ reqAmt + 2
}
doAsyncChannelMM Preempt cId
(\s' c' -> MM.mmGetPostsForChannel c' query' s')
(\c' p' -> Just $ do
void $ addObtainedMessages c' (reqAmt + 2) False p'
)
)
where secondToLastPostId posts =
let pl = toList $ postsOrder posts
in if length pl > 1 then Just $ last $ init pl else Nothing
fetchVisibleIfNeeded :: TeamId -> MH ()
fetchVisibleIfNeeded tId = do
sts <- use csConnectionStatus
when (sts == Connected) $ do
withCurrentChannel tId $ \cId chan -> do
let msgs = chan^.ccMessageInterface.miMessages.to reverseMessages
(numRemaining, gapInDisplayable, _, rel'pId, overlap) =
foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs
gapTrail :: (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
-> Message
-> (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
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^.mMessageId <|> prev'pId, prev'pId <|> prev''pId,
ovl + if not (isPostMessage msg) then 1 else 0)
numToRequest = numRemaining + overlap
query = MM.defaultPostQuery
{ MM.postQueryPage = Just 0
, MM.postQueryPerPage = Just numToRequest
}
finalQuery = case rel'pId of
Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid }
_ -> query
op = \s c -> MM.mmGetPostsForChannel c finalQuery s
addTrailingGap = MM.postQueryBefore finalQuery == Nothing &&
MM.postQueryPage finalQuery == Just 0
when ((not $ chan^.ccInfo.cdFetchPending) && gapInDisplayable) $ do
csChannel(cId).ccInfo.cdFetchPending .= True
doAsyncChannelMM Preempt cId op
(\c p -> Just $ do
csChannel(c).ccInfo.cdFetchPending .= False
addObtainedMessages c (-numToRequest) addTrailingGap p >>= postProcessMessageAdd)
asyncFetchAttachments :: Post -> MH ()
asyncFetchAttachments p = do
let cId = p^.postChannelIdL
pId = p^.postIdL
session <- getSession
host <- use (csResources.crConn.cdHostnameL)
F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do
info <- MM.mmGetMetadataForFile fId session
let scheme = "https://"
attUrl = scheme <> host <> urlForFile fId
attachment = mkAttachment (fileInfoName info) attUrl fId
addIfMissing a as =
if isNothing $ Seq.elemIndexL a as
then a Seq.<| as
else as
addAttachment m
| m^.mMessageId == Just (MessagePostId pId) =
m & mAttachments %~ (addIfMissing attachment)
| otherwise =
m
return $ Just $ do
csChannelMessages(cId).traversed %= addAttachment
curTId <- use csCurrentTeamId
withChannel cId $ \chan -> do
let mTId = chan^.ccInfo.cdTeamId <|> curTId
case mTId of
Nothing -> return ()
Just tId -> modifyEachThreadMessage tId cId addAttachment
invalidateChannelRenderingCache cId
invalidateMessageRenderingCacheByPostId pId
-- | Given a post ID, switch to that post's channel and select the post
-- in message selection mode.
--
-- This function will do what it can to honor the request even when we
-- don't know about the post because it hasn't been fetched, or when
-- the post is in a channel that we aren't a member of. In each case a
-- reasonable effort will be made (fetch the post, join the channel)
-- before giving up.
jumpToPost :: PostId -> MH ()
jumpToPost pId = withCurrentTeam $ \tId -> do
st <- use id
case getMessageForPostId st pId of
Just msg ->
case msg ^. mChannelId of
Just cId -> do
-- Are we a member of the channel?
case findChannelById cId (st^.csChannels) of
Nothing ->
joinChannel' tId cId (Just $ jumpToPost pId)
Just _ -> do
setFocus tId cId
beginMessageSelect (csChannelMessageInterface(cId))
channelMessageSelect(cId) .= MessageSelectState (msg^.mMessageId)
Nothing ->
error "INTERNAL: selected Post ID not associated with a channel"
Nothing -> do
session <- getSession
doAsyncWith Preempt $ do
result <- try $ MM.mmGetPost pId session
return $ Just $ do
case result of
Right p -> do
-- Are we a member of the channel?
case findChannelById (postChannelId p) (st^.csChannels) of
-- If not, join it and then try jumping to
-- the post if the channel join is successful.
Nothing -> do
joinChannel' tId (postChannelId p) (Just $ jumpToPost pId)
-- Otherwise add the post to the state and
-- then jump.
Just _ -> do
void $ addMessageToState True True (OldPost p)
jumpToPost pId
Left (_::SomeException) ->
postErrorMessage' "Could not fetch linked post"