matterhorn-50200.2.0: src/State/Messages.hs
{-# LANGUAGE MultiWayIf #-}
module State.Messages
( PostToAdd(..)
, addDisconnectGaps
, lastMsg
, sendMessage
, editMessage
, deleteMessage
, addNewPostedMessage
, addObtainedMessages
, asyncFetchMoreMessages
, asyncFetchMessagesForGap
, asyncFetchMessagesSurrounding
, fetchVisibleIfNeeded
, disconnectChannels
)
where
import Prelude ()
import Prelude.MH
import Brick.Main ( getVtyHandle, invalidateCacheEntry )
import qualified Brick.Widgets.FileBrowser as FB
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 )
import Network.Mattermost
import qualified Network.Mattermost.Endpoints as MM
import Network.Mattermost.Lenses
import Network.Mattermost.Types
import Constants
import State.Channels
import State.Common
import State.Reactions
import State.Users
import TimeUtils
import Types
import Types.Common ( sanitizeUserText )
import 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
mh $ invalidateCacheEntry (ChannelMessages c)
-- | Websocket was disconnected, so all channels may now miss some
-- messages
disconnectChannels :: MH ()
disconnectChannels = addDisconnectGaps
clearPendingFlags :: ChannelId -> MH ()
clearPendingFlags c = csChannel(c).ccContents.cdFetchPending .= False
addEndGap :: ChannelId -> MH ()
addEndGap cId = withChannel cId $ \chan ->
let lastmsg_ = chan^.ccContents.cdMessages.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 (ccContents.cdMessages %~ 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 = "Cannot send messages while disconnected."
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
let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)
(msg, mentionedUsers) = clientPostToMessage (toClientPost new (new^.postRootIdL))
chan = csChannel (new^.postChannelIdL)
chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg
mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)
fetchUsersByUsername $ F.toList mentionedUsers
when (postUserId new /= Just myId) $
chan %= 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.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)
chan %= adjustUpdated new
mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)
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 =
if null $ posts^.postsOrderL
then 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)
-- 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
-- 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.
(_, mentionedUsers) <- installMessagesFromPosts posts
fetchUsersByUsername $ F.toList mentionedUsers
-- 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 ^. ccContents . cdMessages
-- 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
(ccContents.cdMessages .~ resultMessages)
-- Determine if the current selected message was one of the
-- removed messages.
selMsgId <- use (csMessageSelect.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.
setMode Main
csMessageSelect .= 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) ->
csMessageSelect .= 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
(ccContents.cdMessages %~ addMessage gapMsg)
-- Move selection from old gap to new gap
case rmvdSelType of
Just (C UnknownGapBefore) -> do
csMessageSelect .= 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) ->
csMessageSelect .= 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
(ccContents.cdMessages %~ addMessage gapMsg)
-- Move selection from old gap to new gap
case rmvdSelType of
Just (C UnknownGapAfter) ->
csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)
_ -> return ()
-- 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 ('fetchMentionedUsers') 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 fetchMentionedUsers 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 fetchMentionedUsers fetchAuthor newPostData >>= postProcessMessageAdd
return NoAction
Just _ -> do
let cp = toClientPost 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 ())
currCId <- use csCurrentChannelId
flags <- use (csResources.crFlaggedPosts)
let (msg', mentionedUsers) = clientPostToMessage cp
& _1.mFlagged .~ ((cp^.cpPostId) `Set.member` flags)
when fetchMentionedUsers $
fetchUsersByUsername $ F.toList mentionedUsers
csPostMap.at(postId new) .= Just msg'
mh $ invalidateCacheEntry (ChannelMessages cId)
csChannels %= modifyChannelById cId
((ccContents.cdMessages %~ addMessage msg') .
(adjustUpdated new) .
(\c -> if currCId == cId
then c
else case newPostData of
OldPost _ -> c
RecentPost _ _ ->
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 -> Just $ updatePostMap p)
_ -> 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
-- | 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.to configActivityBell)
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).
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 Nothing
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 = do
cId <- use csCurrentChannelId
withChannel cId $ \chan ->
let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2
page = offset `div` pageAmount
usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.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
in doAsyncChannelMM Preempt cId
(\s _ c -> MM.mmGetPostsForChannel c query s)
(\c p -> Just $ do
pp <- addObtainedMessages c (-pageAmount) addTrailingGap p
postProcessMessageAdd pp
mh $ invalidateCacheEntry (ChannelMessages cId))
-- | 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^.ccContents.cdMessages) - 2
page = offset `div` pageAmount
chanMsgs = chan^.ccContents.cdMessages
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
mh $ invalidateCacheEntry (ChannelMessages cId))
-- | 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
mh $ invalidateCacheEntry (ChannelMessages cId)
-- 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'
mh $ invalidateCacheEntry (ChannelMessages cId)
)
)
where secondToLastPostId posts =
let pl = toList $ postsOrder posts
in if length pl > 1 then Just $ last $ init pl else Nothing
fetchVisibleIfNeeded :: MH ()
fetchVisibleIfNeeded = do
sts <- use csConnectionStatus
when (sts == 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^.mMessageId <|> prev'pId, prev'pId <|> prev''pId,
ovl + if not (isPostMessage msg) then 1 else 0)
numToReq = numRemaining + overlap
query = MM.defaultPostQuery
{ MM.postQueryPage = Just 0
, MM.postQueryPerPage = Just numToReq
}
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
in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do
csChannel(cId).ccContents.cdFetchPending .= True
doAsyncChannelMM Preempt cId op
(\c p -> Just $ do
addObtainedMessages c (-numToReq) addTrailingGap p >>= postProcessMessageAdd
csChannel(c).ccContents.cdFetchPending .= False)
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
csChannel(cId).ccContents.cdMessages.traversed %= addAttachment
mh $ invalidateCacheEntry $ ChannelMessages cId