{-# 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 as BSL
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 )
addDisconnectGaps :: MH ()
addDisconnectGaps :: MH ()
addDisconnectGaps = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ChannelId -> MH ()
onEach forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClientChannel -> Bool) -> ClientChannels -> [ChannelId]
filteredChannelIds (forall a b. a -> b -> a
const Bool
True) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' ChatState ClientChannels
csChannels
where onEach :: ChannelId -> MH ()
onEach ChannelId
c = do ChannelId -> MH ()
addEndGap ChannelId
c
ChannelId -> MH ()
clearPendingFlags ChannelId
c
ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
c
disconnectChannels :: MH ()
disconnectChannels :: MH ()
disconnectChannels = MH ()
addDisconnectGaps
toggleMessageTimestamps :: MH ()
toggleMessageTimestamps :: MH ()
toggleMessageTimestamps = do
forall a. EventM Name ChatState a -> MH a
mh forall n s. Ord n => EventM n s ()
invalidateCache
let toggle :: Config -> Config
toggle Config
c = Config
c { configShowMessageTimestamps :: Bool
configShowMessageTimestamps = Bool -> Bool
not (Config -> Bool
configShowMessageTimestamps Config
c)
}
Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfiguration forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Config -> Config
toggle
defaultVerbatimTruncateHeight :: Int
defaultVerbatimTruncateHeight :: Int
defaultVerbatimTruncateHeight = Int
25
toggleVerbatimBlockTruncation :: MH ()
toggleVerbatimBlockTruncation :: MH ()
toggleVerbatimBlockTruncation = do
forall a. EventM Name ChatState a -> MH a
mh forall n s. Ord n => EventM n s ()
invalidateCache
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
let toggle :: Maybe a -> Maybe Int
toggle Maybe a
Nothing = (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config (Maybe Int)
configTruncateVerbatimBlocksL) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
forall a. a -> Maybe a
Just Int
defaultVerbatimTruncateHeight
toggle (Just a
_) = forall a. Maybe a
Nothing
Lens' ChatState (Maybe Int)
csVerbatimTruncateSetting forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= forall {a}. Maybe a -> Maybe Int
toggle
clearPendingFlags :: ChannelId -> MH ()
clearPendingFlags :: ChannelId -> MH ()
clearPendingFlags ChannelId
c = ChannelId -> Traversal' ChatState ClientChannel
csChannel(ChannelId
c)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Bool
cdFetchPending forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
addEndGap :: ChannelId -> MH ()
addEndGap :: ChannelId -> MH ()
addEndGap ChannelId
cId = ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel ChannelId
cId forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan ->
let lastmsg_ :: Maybe Message
lastmsg_ = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessagesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Messages -> RetrogradeMessages
reverseMessagesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to RetrogradeMessages -> Maybe Message
lastMsg
lastIsGap :: Bool
lastIsGap = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Message -> Bool
isGap Maybe Message
lastmsg_
gapMsg :: Message
gapMsg = ServerTime -> Message
newGapMessage ServerTime
timeJustAfterLast
timeJustAfterLast :: ServerTime
timeJustAfterLast = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ServerTime
t0 (ServerTime -> ServerTime
justAfter forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> ServerTime
_mDate) Maybe Message
lastmsg_
t0 :: ServerTime
t0 = UTCTime -> ServerTime
ServerTime forall a b. (a -> b) -> a -> b
$ UTCTime
originTime
newGapMessage :: ServerTime -> Message
newGapMessage = Hostname -> MessageType -> ServerTime -> Message
newMessageOfType
(String -> Hostname
T.pack String
"Disconnected. Will refresh when connected.")
(ClientMessageType -> MessageType
C ClientMessageType
UnknownGapAfter)
in forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
lastIsGap
(Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId (Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. MessageOps a => Message -> a -> a
addMessage Message
gapMsg))
lastMsg :: RetrogradeMessages -> Maybe Message
lastMsg :: RetrogradeMessages -> Maybe Message
lastMsg = forall dir r.
SeqDirection dir =>
(Message -> r) -> DirectionalSeq dir Message -> Maybe r
withFirstMessage forall a. a -> a
id
sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()
sendMessage :: ChannelId -> EditMode -> Hostname -> [AttachmentData] -> MH ()
sendMessage ChannelId
chanId EditMode
mode Hostname
msg [AttachmentData]
attachments =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Hostname -> Bool
shouldSkipMessage Hostname
msg) forall a b. (a -> b) -> a -> b
$ do
ConnectionStatus
status <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' ChatState ConnectionStatus
csConnectionStatus
case ConnectionStatus
status of
ConnectionStatus
Disconnected -> do
let m :: Hostname
m = [Hostname] -> Hostname
T.concat [ Hostname
"Cannot send messages while disconnected. Enable logging to "
, Hostname
"get disconnection information. If Matterhorn's reconnection "
, Hostname
"attempts are failing, use `/reconnect` to attempt to "
, Hostname
"reconnect manually."
]
MHError -> MH ()
mhError forall a b. (a -> b) -> a -> b
$ Hostname -> MHError
GenericError Hostname
m
ConnectionStatus
Connected -> do
Session
session <- MH Session
getSession
AsyncPriority -> IO () -> MH ()
doAsync AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
[UploadResponse]
fileInfos <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [AttachmentData]
attachments forall a b. (a -> b) -> a -> b
$ \AttachmentData
a -> do
ChannelId -> String -> ByteString -> Session -> IO UploadResponse
MM.mmUploadFile ChannelId
chanId (FileInfo -> String
FB.fileInfoFilename forall a b. (a -> b) -> a -> b
$ AttachmentData -> FileInfo
attachmentDataFileInfo AttachmentData
a)
(AttachmentData -> ByteString
attachmentDataBytes AttachmentData
a) Session
session
let fileIds :: Seq FileId
fileIds = forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileInfo -> FileId
fileInfoId forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
(forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. UploadResponse -> Seq FileInfo
MM.uploadResponseFileInfos) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [UploadResponse]
fileInfos
case EditMode
mode of
EditMode
NewPost -> do
let pendingPost :: RawPost
pendingPost = (Hostname -> ChannelId -> RawPost
rawPost Hostname
msg ChannelId
chanId) { rawPostFileIds :: Seq FileId
rawPostFileIds = Seq FileId
fileIds }
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ RawPost -> Session -> IO Post
MM.mmCreatePost RawPost
pendingPost Session
session
Replying Message
_ Post
p -> do
let pendingPost :: RawPost
pendingPost = (Hostname -> ChannelId -> RawPost
rawPost Hostname
msg ChannelId
chanId) { rawPostRootId :: Maybe PostId
rawPostRootId = Post -> Maybe PostId
postRootId Post
p forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Post -> PostId
postId Post
p)
, rawPostFileIds :: Seq FileId
rawPostFileIds = Seq FileId
fileIds
}
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ RawPost -> Session -> IO Post
MM.mmCreatePost RawPost
pendingPost Session
session
Editing Post
p MessageType
ty -> do
let body :: Hostname
body = case MessageType
ty of
CP ClientPostType
Emote -> Hostname -> Hostname
addEmoteFormatting Hostname
msg
MessageType
_ -> Hostname
msg
update :: PostUpdate
update = (Hostname -> PostUpdate
postUpdateBody Hostname
body) { postUpdateFileIds :: Maybe (Seq FileId)
postUpdateFileIds = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq FileId
fileIds
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just Seq FileId
fileIds
}
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ PostId -> PostUpdate -> Session -> IO Post
MM.mmPatchPost (Post -> PostId
postId Post
p) PostUpdate
update Session
session
shouldSkipMessage :: Text -> Bool
shouldSkipMessage :: Hostname -> Bool
shouldSkipMessage Hostname
"" = Bool
True
shouldSkipMessage Hostname
s = (Char -> Bool) -> Hostname -> Bool
T.all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
" \t"::String)) Hostname
s
editMessage :: Post -> MH ()
editMessage :: Post -> MH ()
editMessage Post
new = do
UserId
myId <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ChatState -> UserId
myUserId
ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL) forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan -> do
let mTId :: Maybe TeamId
mTId = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo (Maybe TeamId)
cdTeamId
Maybe TeamBaseURL
mBaseUrl <- case Maybe TeamId
mTId of
Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just TeamId
tId -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TeamId -> MH TeamBaseURL
getServerBaseUrl TeamId
tId
let (Message
msg, Set MentionedUser
mentionedUsers) = ClientPost -> (Message, Set MentionedUser)
clientPostToMessage (Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost Maybe TeamBaseURL
mBaseUrl Post
new (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post (Maybe PostId)
postRootIdL))
isEditedMessage :: Message -> Bool
isEditedMessage Message
m = Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId forall a b. (a -> b) -> a -> b
$ Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL)
ChannelId -> Traversal' ChatState ClientChannel
csChannel (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b.
Traversable f =>
Traversal (f a) (f b) a b
traversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> Traversal' a a
filtered Message -> Bool
isEditedMessage forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Message
msg
ChannelId -> MH ()
invalidateChannelRenderingCache forall a b. (a -> b) -> a -> b
$ Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL
PostId -> MH ()
invalidateMessageRenderingCacheByPostId forall a b. (a -> b) -> a -> b
$ Post -> PostId
postId Post
new
Maybe TeamId -> Post -> Message -> MH ()
editPostInOpenThread Maybe TeamId
mTId Post
new Message
msg
Set MentionedUser -> MH ()
fetchMentionedUsers Set MentionedUser
mentionedUsers
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Post -> Maybe UserId
postUserId Post
new forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just UserId
myId) forall a b. (a -> b) -> a -> b
$
ChannelId -> Traversal' ChatState ClientChannel
csChannel (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Post -> ClientChannel -> ClientChannel
adjustEditedThreshold Post
new
Lens' ChatState (HashMap PostId Message)
csPostMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix(Post -> PostId
postId Post
new) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Message
msg
ChannelId -> Post -> MH ()
asyncFetchReactionsForPost (Post -> ChannelId
postChannelId Post
new) Post
new
Post -> MH ()
asyncFetchAttachments Post
new
deleteMessage :: Post -> MH ()
deleteMessage :: Post -> MH ()
deleteMessage Post
new = do
let isDeletedMessage :: Message -> Bool
isDeletedMessage Message
m = Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId forall a b. (a -> b) -> a -> b
$ Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL) Bool -> Bool -> Bool
||
PostId -> Message -> Bool
isReplyTo (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL) Message
m
chan :: Traversal' ChatState ClientChannel
chan :: Traversal' ChatState ClientChannel
chan = ChannelId -> Traversal' ChatState ClientChannel
csChannel (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL)
Traversal' ChatState ClientChannel
chanforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessagesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b.
Traversable f =>
Traversal (f a) (f b) a b
traversedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a. (a -> Bool) -> Traversal' a a
filtered Message -> Bool
isDeletedMessage forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (forall a b. a -> (a -> b) -> b
& Lens' Message Bool
mDeleted forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True)
Traversal' ChatState ClientChannel
chan forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Post -> ClientChannel -> ClientChannel
adjustUpdated Post
new
ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL) forall a b. (a -> b) -> a -> b
$ \ClientChannel
ch -> do
case ClientChannel
chforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo (Maybe TeamId)
cdTeamId of
Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TeamId
tId -> TeamId -> Post -> MH ()
deletePostFromOpenThread TeamId
tId Post
new
ChannelId -> MH ()
invalidateChannelRenderingCache forall a b. (a -> b) -> a -> b
$ Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL
PostId -> MH ()
invalidateMessageRenderingCacheByPostId forall a b. (a -> b) -> a -> b
$ Post -> PostId
postId Post
new
deletePostFromOpenThread :: TeamId -> Post -> MH ()
deletePostFromOpenThread :: TeamId -> Post -> MH ()
deletePostFromOpenThread TeamId
tId Post
p = do
let isDeletedMessage :: Message -> Bool
isDeletedMessage Message
m = Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId forall a b. (a -> b) -> a -> b
$ Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL) Bool -> Bool -> Bool
||
PostId -> Message -> Bool
isReplyTo (Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL) Message
m
TeamId -> ChannelId -> (Message -> Bool) -> MH ()
threadInterfaceDeleteWhere TeamId
tId (Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL) Message -> Bool
isDeletedMessage
Maybe ThreadInterface
ti <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> Lens' ChatState TeamState
csTeam(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' TeamState (Maybe ThreadInterface)
tsThreadInterface)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isJust Maybe ThreadInterface
ti) forall a b. (a -> b) -> a -> b
$ do
Bool
isEmpty <- TeamId -> MH Bool
threadInterfaceEmpty TeamId
tId
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isEmpty forall a b. (a -> b) -> a -> b
$ do
TeamId -> MH ()
closeThreadWindow TeamId
tId
Hostname -> MH ()
postInfoMessage Hostname
"The thread you were viewing was deleted."
addNewPostedMessage :: PostToAdd -> MH ()
addNewPostedMessage :: PostToAdd -> MH ()
addNewPostedMessage PostToAdd
p =
Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState Bool
True Bool
True PostToAdd
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PostProcessMessageAdd -> MH ()
postProcessMessageAdd
addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages ChannelId
cId Int
reqCnt Bool
addTrailingGap Posts
posts = do
ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cId
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (Seq PostId)
postsOrderL
then do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
addTrailingGap forall a b. (a -> b) -> a -> b
$
Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId
(Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~
\Messages
msgs -> let startPoint :: Maybe MessageId
startPoint = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ Message -> Maybe MessageId
_mMessageId forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages -> Maybe Message
getLatestPostMsg Messages
msgs
in forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (Message -> Bool)
-> Maybe MessageId
-> Maybe MessageId
-> Messages
-> (Messages, Messages)
removeMatchesFromSubset Message -> Bool
isGap Maybe MessageId
startPoint forall a. Maybe a
Nothing Messages
msgs)
forall (m :: * -> *) a. Monad m => a -> m a
return PostProcessMessageAdd
NoAction
else
forall a. ChannelId -> a -> (ClientChannel -> MH a) -> MH a
withChannelOrDefault ChannelId
cId PostProcessMessageAdd
NoAction forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan -> do
let pIdList :: [PostId]
pIdList = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (Seq PostId)
postsOrderL)
mTId :: Maybe TeamId
mTId = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo (Maybe TeamId)
cdTeamId
earliestPId :: PostId
earliestPId = forall a. [a] -> a
last [PostId]
pIdList
latestPId :: PostId
latestPId = forall a. [a] -> a
head [PostId]
pIdList
earliestDate :: ServerTime
earliestDate = Post -> ServerTime
postCreateAt forall a b. (a -> b) -> a -> b
$ (Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (HashMap PostId Post)
postsPostsL) forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HM.! PostId
earliestPId
latestDate :: ServerTime
latestDate = Post -> ServerTime
postCreateAt forall a b. (a -> b) -> a -> b
$ (Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (HashMap PostId Post)
postsPostsL) forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HM.! PostId
latestPId
localMessages :: Messages
localMessages = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages
match :: Messages
match = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ (Message -> Bool)
-> Maybe MessageId
-> Maybe MessageId
-> Messages
-> (Messages, Messages)
removeMatchesFromSubset
(\Message
m -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (\PostId
p -> PostId
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PostId]
pIdList) (Message -> Maybe PostId
messagePostId Message
m))
(forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId PostId
earliestPId))
(forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId PostId
latestPId))
Messages
localMessages
accum :: Message -> [PostId] -> [PostId]
accum Message
m [PostId]
l =
case Message -> Maybe PostId
messagePostId Message
m of
Just PostId
pId -> PostId
pId forall a. a -> [a] -> [a]
: [PostId]
l
Maybe PostId
Nothing -> [PostId]
l
dupPIds :: [PostId]
dupPIds = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Message -> [PostId] -> [PostId]
accum [] Messages
match
newGapMessage :: ServerTime -> Bool -> MH Message
newGapMessage ServerTime
d Bool
isOlder =
do UUID
uuid <- MH UUID
generateUUID
let txt :: Hostname
txt = Hostname
"Load " forall a. Semigroup a => a -> a -> a
<>
(if Bool
isOlder then Hostname
"older" else Hostname
"newer") forall a. Semigroup a => a -> a -> a
<>
Hostname
" messages" forall a. Semigroup a => a -> a -> a
<>
(if Bool
isOlder then Hostname
" ↥↥↥" else Hostname
" ↧↧↧")
ty :: MessageType
ty = if Bool
isOlder
then ClientMessageType -> MessageType
C ClientMessageType
UnknownGapBefore
else ClientMessageType -> MessageType
C ClientMessageType
UnknownGapAfter
forall (m :: * -> *) a. Monad m => a -> m a
return (Hostname -> MessageType -> ServerTime -> Message
newMessageOfType Hostname
txt MessageType
ty ServerTime
d
forall a b. a -> (a -> b) -> b
& Lens' Message (Maybe MessageId)
mMessageId forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Maybe a
Just (UUID -> MessageId
MessageUUID UUID
uuid))
addingAtEnd :: Bool
addingAtEnd = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ServerTime
latestDate forall a. Ord a => a -> a -> Bool
>=) forall a b. (a -> b) -> a -> b
$
(forall s a. s -> Getting a s a -> a
^.Lens' Message ServerTime
mDate) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages -> Maybe Message
getLatestPostMsg Messages
localMessages
addingAtStart :: Bool
addingAtStart = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (ServerTime
earliestDate forall a. Ord a => a -> a -> Bool
<=) forall a b. (a -> b) -> a -> b
$
(forall s a. s -> Getting a s a -> a
^.Lens' Message ServerTime
mDate) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages -> Maybe Message
getEarliestPostMsg Messages
localMessages
removeStart :: Maybe MessageId
removeStart = if Bool
addingAtStart Bool -> Bool -> Bool
&& Bool
noMoreBefore
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId PostId
earliestPId)
removeEnd :: Maybe MessageId
removeEnd = if Bool
addTrailingGap Bool -> Bool -> Bool
|| (Bool
addingAtEnd Bool -> Bool -> Bool
&& Bool
noMoreAfter)
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId PostId
latestPId)
noMoreBefore :: Bool
noMoreBefore = Int
reqCnt forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [PostId]
pIdList forall a. Ord a => a -> a -> Bool
< (-Int
reqCnt)
noMoreAfter :: Bool
noMoreAfter = Bool
addTrailingGap Bool -> Bool -> Bool
|| Int
reqCnt forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [PostId]
pIdList forall a. Ord a => a -> a -> Bool
< Int
reqCnt
reAddGapBefore :: Bool
reAddGapBefore = PostId
earliestPId forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PostId]
dupPIds Bool -> Bool -> Bool
|| Bool
noMoreBefore
reAddGapAfter :: Bool
reAddGapAfter = PostId
latestPId forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PostId]
dupPIds Bool -> Bool -> Bool
|| Bool
noMoreAfter
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Maybe TeamId -> Posts -> MH Messages
installMessagesFromPosts Maybe TeamId
mTId Posts
posts
PostProcessMessageAdd
action <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr PostProcessMessageAdd
-> PostProcessMessageAdd -> PostProcessMessageAdd
andProcessWith PostProcessMessageAdd
NoAction forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState Bool
False Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. Post -> PostToAdd
OldPost)
[ (Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (HashMap PostId Post)
postsPostsL) forall k v.
(Eq k, Hashable k, HasCallStack) =>
HashMap k v -> k -> v
HM.! PostId
p
| PostId
p <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (Seq PostId)
postsOrderL)
, Bool -> Bool
not (PostId
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [PostId]
dupPIds)
]
forall a. ChannelId -> a -> (ClientChannel -> MH a) -> MH a
withChannelOrDefault ChannelId
cId () forall a b. (a -> b) -> a -> b
$ \ClientChannel
updchan -> do
let updMsgs :: Messages
updMsgs = ClientChannel
updchan forall s a. s -> Getting a s a -> a
^. Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages
let (Messages
resultMessages, Messages
removedMessages) =
(Message -> Bool)
-> Maybe MessageId
-> Maybe MessageId
-> Messages
-> (Messages, Messages)
removeMatchesFromSubset Message -> Bool
isGap Maybe MessageId
removeStart Maybe MessageId
removeEnd Messages
updMsgs
Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId
(Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> b -> s -> t
.~ Messages
resultMessages)
let processTeam :: TeamId -> MH ()
processTeam TeamId
tId = do
Maybe MessageId
selMsgId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to MessageSelectState -> Maybe MessageId
selectMessageId)
let rmvdSel :: Maybe Message
rmvdSel = do
MessageId
i <- Maybe MessageId
selMsgId
MessageId -> Messages -> Maybe Message
findMessage MessageId
i Messages
removedMessages
rmvdSelType :: Maybe MessageType
rmvdSelType = Message -> MessageType
_mType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Message
rmvdSel
case Maybe Message
rmvdSel of
Maybe Message
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Message
rm ->
if Message -> Bool
isGap Message
rm
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
TeamId -> MH ()
popMode TeamId
tId
ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe MessageId -> MessageSelectState
MessageSelectState forall a. Maybe a
Nothing
if Bool
reAddGapBefore
then
case Maybe MessageType
rmvdSelType of
Just (C ClientMessageType
UnknownGapBefore) ->
ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe MessageId -> MessageSelectState
MessageSelectState (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PostId -> MessageId
MessagePostId PostId
earliestPId)
Maybe MessageType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Message
gapMsg <- ServerTime -> Bool -> MH Message
newGapMessage (ServerTime -> ServerTime
justBefore ServerTime
earliestDate) Bool
True
Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId
(Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. MessageOps a => Message -> a -> a
addMessage Message
gapMsg)
case Maybe MessageType
rmvdSelType of
Just (C ClientMessageType
UnknownGapBefore) -> do
ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe MessageId -> MessageSelectState
MessageSelectState (Message
gapMsgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId)
Maybe MessageType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
if Bool
reAddGapAfter
then
case Maybe MessageType
rmvdSelType of
Just (C ClientMessageType
UnknownGapAfter) ->
ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe MessageId -> MessageSelectState
MessageSelectState (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PostId -> MessageId
MessagePostId PostId
latestPId)
Maybe MessageType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
Message
gapMsg <- ServerTime -> Bool -> MH Message
newGapMessage (ServerTime -> ServerTime
justAfter ServerTime
latestDate) Bool
False
Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId
(Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. MessageOps a => Message -> a -> a
addMessage Message
gapMsg)
case Maybe MessageType
rmvdSelType of
Just (C ClientMessageType
UnknownGapAfter) ->
ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe MessageId -> MessageSelectState
MessageSelectState (Message
gapMsgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId)
Maybe MessageType
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Maybe TeamId
mTId of
Maybe TeamId
Nothing -> do
HashMap TeamId TeamState
ts <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' ChatState (HashMap TeamId TeamState)
csTeams
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k v. HashMap k v -> [k]
HM.keys HashMap TeamId TeamState
ts) TeamId -> MH ()
processTeam
Just TeamId
tId -> TeamId -> MH ()
processTeam TeamId
tId
let users :: Set UserId
users = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Post
post Set UserId
s -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set UserId
s (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> Set a -> Set a
Set.insert Set UserId
s) (Post -> Maybe UserId
postUserId Post
post))
forall a. Set a
Set.empty (Posts
postsforall s a. s -> Getting a s a -> a
^.Lens' Posts (HashMap PostId Post)
postsPostsL)
addUnknownUsers :: Set UserId -> MH ()
addUnknownUsers Set UserId
inputUserIds = do
Set UserId
knownUserIds <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ChatState -> [UserId]
allUserIds
let unknownUsers :: Set UserId
unknownUsers = forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set UserId
inputUserIds Set UserId
knownUserIds
if forall a. Set a -> Bool
Set.null Set UserId
unknownUsers
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else Seq UserId -> MH () -> MH ()
handleNewUsers (forall a. [a] -> Seq a
Seq.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set UserId
unknownUsers) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
Set UserId -> MH ()
addUnknownUsers Set UserId
users
forall (m :: * -> *) a. Monad m => a -> m a
return PostProcessMessageAdd
action
addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState Bool
doFetchMentionedUsers Bool
fetchAuthor PostToAdd
newPostData = do
let (Post
new, Bool
wasMentioned) = case PostToAdd
newPostData of
OldPost Post
p -> (Post
p, Bool
False)
RecentPost Post
p Bool
m -> (Post
p, Bool
m)
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
case ChatState
st forall s a. s -> Getting (First a) s a -> Maybe a
^? ChannelId -> Traversal' ChatState ClientChannel
csChannel(Post -> ChannelId
postChannelId Post
new) of
Maybe ClientChannel
Nothing -> do
Session
session <- MH Session
getSession
AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
Channel
nc <- ChannelId -> Session -> IO Channel
MM.mmGetChannel (Post -> ChannelId
postChannelId Post
new) Session
session
ChannelMember
member <- ChannelId -> UserParam -> Session -> IO ChannelMember
MM.mmGetChannelMember (Post -> ChannelId
postChannelId Post
new) UserParam
UserMe Session
session
let chType :: Type
chType = Channel
ncforall s a. s -> Getting a s a -> a
^.Lens' Channel Type
channelTypeL
pref :: Preference
pref = ChannelId -> UserId -> Preference
showGroupChannelPref (Post -> ChannelId
postChannelId Post
new) (ChatState -> UserId
myUserId ChatState
st)
case Channel -> Bool
channelDeleted Channel
nc of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
if Type
chType forall a. Eq a => a -> a -> Bool
== Type
Group
then Preference -> MH ()
applyPreferenceChange Preference
pref
else SidebarUpdate -> Channel -> ChannelMember -> MH ()
refreshChannel SidebarUpdate
SidebarUpdateImmediate Channel
nc ChannelMember
member
Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState Bool
doFetchMentionedUsers Bool
fetchAuthor PostToAdd
newPostData forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
PostProcessMessageAdd -> MH ()
postProcessMessageAdd
forall (m :: * -> *) a. Monad m => a -> m a
return PostProcessMessageAdd
NoAction
Just ClientChannel
ch -> do
let mTId :: Maybe TeamId
mTId = ClientChannel
chforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo (Maybe TeamId)
cdTeamId
Maybe TeamBaseURL
mBaseUrl <- case Maybe TeamId
mTId of
Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just TeamId
tId -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TeamId -> MH TeamBaseURL
getServerBaseUrl TeamId
tId
let cp :: ClientPost
cp = Maybe TeamBaseURL -> Post -> Maybe PostId -> ClientPost
toClientPost Maybe TeamBaseURL
mBaseUrl Post
new (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post (Maybe PostId)
postRootIdL)
fromMe :: Bool
fromMe = (ClientPost
cpforall s a. s -> Getting a s a -> a
^.Lens' ClientPost (Maybe UserId)
cpUser forall a. Eq a => a -> a -> Bool
== (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ChatState -> UserId
myUserId ChatState
st)) Bool -> Bool -> Bool
&&
(forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ ClientPost
cpforall s a. s -> Getting a s a -> a
^.Lens' ClientPost (Maybe Hostname)
cpUserOverride)
userPrefs :: UserPreferences
userPrefs = ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources UserPreferences
crUserPreferences
isJoinOrLeave :: Bool
isJoinOrLeave = case ClientPost
cpforall s a. s -> Getting a s a -> a
^.Lens' ClientPost ClientPostType
cpType of
ClientPostType
Join -> Bool
True
ClientPostType
Leave -> Bool
True
ClientPostType
_ -> Bool
False
ignoredJoinLeaveMessage :: Bool
ignoredJoinLeaveMessage =
Bool -> Bool
not (UserPreferences
userPrefsforall s a. s -> Getting a s a -> a
^.Lens' UserPreferences Bool
userPrefShowJoinLeave) Bool -> Bool -> Bool
&& Bool
isJoinOrLeave
cId :: ChannelId
cId = Post -> ChannelId
postChannelId Post
new
doAddMessage :: MH PostProcessMessageAdd
doAddMessage = do
case ClientPost
cpforall s a. s -> Getting a s a -> a
^.Lens' ClientPost (Maybe UserId)
cpUser of
Maybe UserId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just UserId
authorId -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fetchAuthor forall a b. (a -> b) -> a -> b
$ do
Maybe UserInfo
authorResult <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (UserId -> ChatState -> Maybe UserInfo
userById UserId
authorId)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Maybe a -> Bool
isNothing Maybe UserInfo
authorResult) forall a b. (a -> b) -> a -> b
$
Seq UserId -> MH () -> MH ()
handleNewUsers (forall a. a -> Seq a
Seq.singleton UserId
authorId) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
Maybe TeamId
mcurTId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use SimpleGetter ChatState (Maybe TeamId)
csCurrentTeamId
Maybe ChannelId
currCId <- case Maybe TeamId
mcurTId of
Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just TeamId
curTId -> forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> SimpleGetter ChatState (Maybe ChannelId)
csCurrentChannelId TeamId
curTId)
Set PostId
flags <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (Set PostId)
crFlaggedPosts)
let (Message
msg', Set MentionedUser
mentionedUsers) = ClientPost -> (Message, Set MentionedUser)
clientPostToMessage ClientPost
cp
forall a b. a -> (a -> b) -> b
& forall s t a b. Field1 s t a b => Lens s t a b
_1forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Message Bool
mFlagged forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((ClientPost
cpforall s a. s -> Getting a s a -> a
^.Lens' ClientPost PostId
cpPostId) forall a. Ord a => a -> Set a -> Bool
`Set.member` Set PostId
flags)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doFetchMentionedUsers forall a b. (a -> b) -> a -> b
$
Set MentionedUser -> MH ()
fetchMentionedUsers Set MentionedUser
mentionedUsers
Lens' ChatState (HashMap PostId Message)
csPostMapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at(Post -> PostId
postId Post
new) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= forall a. a -> Maybe a
Just Message
msg'
ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cId
PostId -> MH ()
invalidateMessageRenderingCacheByPostId forall a b. (a -> b) -> a -> b
$ Post -> PostId
postId Post
new
Lens' ChatState ClientChannels
csChannels forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= ChannelId
-> (ClientChannel -> ClientChannel)
-> ClientChannels
-> ClientChannels
modifyChannelById ChannelId
cId
((Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. MessageOps a => Message -> a -> a
addMessage Message
msg') forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(if Bool -> Bool
not Bool
ignoredJoinLeaveMessage then Post -> ClientChannel -> ClientChannel
adjustUpdated Post
new else forall a. a -> a
id) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(\ClientChannel
c -> if Maybe ChannelId
currCId forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just ChannelId
cId
then ClientChannel
c
else case PostToAdd
newPostData of
OldPost Post
_ -> ClientChannel
c
RecentPost Post
_ Bool
_ ->
Post -> ClientChannel -> ClientChannel
updateNewMessageIndicator Post
new ClientChannel
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
(\ClientChannel
c -> if Bool
wasMentioned
then ClientChannel
c forall a b. a -> (a -> b) -> b
& Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Int
cdMentionCount forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Enum a => a -> a
succ
else ClientChannel
c)
)
Maybe TeamId -> Post -> Message -> MH ()
addPostToOpenThread (Maybe TeamId
mTId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TeamId
mcurTId) Post
new Message
msg'
ChannelId -> Post -> MH ()
asyncFetchReactionsForPost ChannelId
cId Post
new
Post -> MH ()
asyncFetchAttachments Post
new
MH PostProcessMessageAdd
postedChanMessage
doHandleAddedMessage :: MH PostProcessMessageAdd
doHandleAddedMessage = do
case ClientPost
cpforall s a. s -> Getting a s a -> a
^.Lens' ClientPost (Maybe PostId)
cpInReplyToPost of
Just PostId
parentId ->
case ChatState -> PostId -> Maybe Message
getMessageForPostId ChatState
st PostId
parentId of
Maybe Message
Nothing -> do
forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Preempt ChannelId
cId
(\Session
s ChannelId
_ -> PostId -> Session -> IO Posts
MM.mmGetThread PostId
parentId Session
s)
(\ChannelId
_ Posts
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe TeamId -> Posts -> MH ()
updatePostMap Maybe TeamId
mTId Posts
p)
Maybe Message
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe PostId
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
MH PostProcessMessageAdd
doAddMessage
postedChanMessage :: MH PostProcessMessageAdd
postedChanMessage =
forall a. ChannelId -> a -> (ClientChannel -> MH a) -> MH a
withChannelOrDefault (Post -> ChannelId
postChannelId Post
new) PostProcessMessageAdd
NoAction forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan -> do
Maybe TeamId
mcurrTid <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use SimpleGetter ChatState (Maybe TeamId)
csCurrentTeamId
case Maybe TeamId
mcurrTid of
Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return PostProcessMessageAdd
NoAction
Just TeamId
currTid -> do
Maybe ChannelId
currCId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (TeamId -> SimpleGetter ChatState (Maybe ChannelId)
csCurrentChannelId TeamId
currTid)
let notifyPref :: NotifyOption
notifyPref = User -> ClientChannel -> NotifyOption
notifyPreference (ChatState -> User
myUser ChatState
st) ClientChannel
chan
curChannelAction :: PostProcessMessageAdd
curChannelAction = if forall a. a -> Maybe a
Just (Post -> ChannelId
postChannelId Post
new) forall a. Eq a => a -> a -> Bool
== Maybe ChannelId
currCId
then PostProcessMessageAdd
UpdateServerViewed
else PostProcessMessageAdd
NoAction
originUserAction :: PostProcessMessageAdd
originUserAction =
if | Bool
fromMe -> PostProcessMessageAdd
NoAction
| Bool
ignoredJoinLeaveMessage -> PostProcessMessageAdd
NoAction
| NotifyOption
notifyPref forall a. Eq a => a -> a -> Bool
== NotifyOption
NotifyOptionAll -> [PostToAdd] -> PostProcessMessageAdd
NotifyUser [PostToAdd
newPostData]
| NotifyOption
notifyPref forall a. Eq a => a -> a -> Bool
== NotifyOption
NotifyOptionMention
Bool -> Bool -> Bool
&& Bool
wasMentioned -> [PostToAdd] -> PostProcessMessageAdd
NotifyUser [PostToAdd
newPostData]
| Bool
otherwise -> PostProcessMessageAdd
NoAction
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ PostProcessMessageAdd
curChannelAction PostProcessMessageAdd
-> PostProcessMessageAdd -> PostProcessMessageAdd
`andProcessWith` PostProcessMessageAdd
originUserAction
MH PostProcessMessageAdd
doHandleAddedMessage
addPostToOpenThread :: Maybe TeamId -> Post -> Message -> MH ()
addPostToOpenThread :: Maybe TeamId -> Post -> Message -> MH ()
addPostToOpenThread Maybe TeamId
Nothing Post
_ Message
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
addPostToOpenThread (Just TeamId
tId) Post
new Message
msg =
case Post -> Maybe PostId
postRootId Post
new of
Maybe PostId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PostId
parentId -> do
Maybe PostId
mRoot <- forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse (TeamId -> Lens' ChatState (Maybe ThreadInterface)
maybeThreadInterface(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Justforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i1 i2.
Lens (MessageInterface n i1) (MessageInterface n i2) i1 i2
miRootPostId)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe PostId
mRoot forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just PostId
parentId) forall a b. (a -> b) -> a -> b
$
TeamId -> ChannelId -> (Messages -> Messages) -> MH ()
modifyThreadMessages TeamId
tId (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL) (forall a. MessageOps a => Message -> a -> a
addMessage Message
msg)
editPostInOpenThread :: Maybe TeamId -> Post -> Message -> MH ()
editPostInOpenThread :: Maybe TeamId -> Post -> Message -> MH ()
editPostInOpenThread Maybe TeamId
Nothing Post
_ Message
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
editPostInOpenThread (Just TeamId
tId) Post
new Message
msg =
case Post -> Maybe PostId
postRootId Post
new of
Maybe PostId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PostId
parentId -> do
Maybe PostId
mRoot <- forall s (m :: * -> *) a.
MonadState s m =>
Getting (First a) s a -> m (Maybe a)
preuse (TeamId -> Lens' ChatState (Maybe ThreadInterface)
maybeThreadInterface(TeamId
tId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall a a'. Traversal (Maybe a) (Maybe a') a a'
_Justforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i1 i2.
Lens (MessageInterface n i1) (MessageInterface n i2) i1 i2
miRootPostId)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe PostId
mRoot forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just PostId
parentId) forall a b. (a -> b) -> a -> b
$ do
LogCategory -> Hostname -> MH ()
mhLog LogCategory
LogGeneral Hostname
"editPostInOpenThread: updating message"
let isEditedMessage :: Message -> Bool
isEditedMessage Message
m = Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId forall a b. (a -> b) -> a -> b
$ Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL)
TeamId -> ChannelId -> (Message -> Message) -> MH ()
modifyEachThreadMessage TeamId
tId (Post
newforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL)
(\Message
m -> if Message -> Bool
isEditedMessage Message
m then Message
msg else Message
m)
data PostProcessMessageAdd = NoAction
| NotifyUser [PostToAdd]
| UpdateServerViewed
| NotifyUserAndServer [PostToAdd]
andProcessWith
:: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd
andProcessWith :: PostProcessMessageAdd
-> PostProcessMessageAdd -> PostProcessMessageAdd
andProcessWith PostProcessMessageAdd
NoAction PostProcessMessageAdd
x = PostProcessMessageAdd
x
andProcessWith PostProcessMessageAdd
x PostProcessMessageAdd
NoAction = PostProcessMessageAdd
x
andProcessWith (NotifyUserAndServer [PostToAdd]
p) PostProcessMessageAdd
UpdateServerViewed = [PostToAdd] -> PostProcessMessageAdd
NotifyUserAndServer [PostToAdd]
p
andProcessWith (NotifyUserAndServer [PostToAdd]
p1) (NotifyUser [PostToAdd]
p2) = [PostToAdd] -> PostProcessMessageAdd
NotifyUserAndServer ([PostToAdd]
p1 forall a. Semigroup a => a -> a -> a
<> [PostToAdd]
p2)
andProcessWith (NotifyUserAndServer [PostToAdd]
p1) (NotifyUserAndServer [PostToAdd]
p2) = [PostToAdd] -> PostProcessMessageAdd
NotifyUserAndServer ([PostToAdd]
p1 forall a. Semigroup a => a -> a -> a
<> [PostToAdd]
p2)
andProcessWith (NotifyUser [PostToAdd]
p1) (NotifyUserAndServer [PostToAdd]
p2) = [PostToAdd] -> PostProcessMessageAdd
NotifyUser ([PostToAdd]
p1 forall a. Semigroup a => a -> a -> a
<> [PostToAdd]
p2)
andProcessWith (NotifyUser [PostToAdd]
p1) (NotifyUser [PostToAdd]
p2) = [PostToAdd] -> PostProcessMessageAdd
NotifyUser ([PostToAdd]
p1 forall a. Semigroup a => a -> a -> a
<> [PostToAdd]
p2)
andProcessWith (NotifyUser [PostToAdd]
p) PostProcessMessageAdd
UpdateServerViewed = [PostToAdd] -> PostProcessMessageAdd
NotifyUserAndServer [PostToAdd]
p
andProcessWith PostProcessMessageAdd
UpdateServerViewed PostProcessMessageAdd
UpdateServerViewed = PostProcessMessageAdd
UpdateServerViewed
andProcessWith PostProcessMessageAdd
UpdateServerViewed (NotifyUserAndServer [PostToAdd]
p) = [PostToAdd] -> PostProcessMessageAdd
NotifyUserAndServer [PostToAdd]
p
andProcessWith PostProcessMessageAdd
UpdateServerViewed (NotifyUser [PostToAdd]
p) = [PostToAdd] -> PostProcessMessageAdd
NotifyUserAndServer [PostToAdd]
p
postProcessMessageAdd :: PostProcessMessageAdd -> MH ()
postProcessMessageAdd :: PostProcessMessageAdd -> MH ()
postProcessMessageAdd PostProcessMessageAdd
ppma = PostProcessMessageAdd -> MH ()
postOp PostProcessMessageAdd
ppma
where
postOp :: PostProcessMessageAdd -> MH ()
postOp PostProcessMessageAdd
NoAction = forall (m :: * -> *) a. Monad m => a -> m a
return ()
postOp PostProcessMessageAdd
UpdateServerViewed = Bool -> MH ()
updateViewed Bool
False
postOp (NotifyUser [PostToAdd]
p) = MH ()
maybeRingBell forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PostToAdd -> MH ()
maybeNotify [PostToAdd]
p
postOp (NotifyUserAndServer [PostToAdd]
p) = Bool -> MH ()
updateViewed Bool
False forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MH ()
maybeRingBell forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PostToAdd -> MH ()
maybeNotify [PostToAdd]
p
maybeNotify :: PostToAdd -> MH ()
maybeNotify :: PostToAdd -> MH ()
maybeNotify (OldPost Post
_) = do
forall (m :: * -> *) a. Monad m => a -> m a
return ()
maybeNotify (RecentPost Post
post Bool
mentioned) = Post -> Bool -> MH ()
runNotifyCommand Post
post Bool
mentioned
maybeRingBell :: MH ()
maybeRingBell :: MH ()
maybeRingBell = do
Bool
doBell <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config Bool
configActivityBellL)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
doBell forall a b. (a -> b) -> a -> b
$ do
Vty
vty <- forall a. EventM Name ChatState a -> MH a
mh forall n s. EventM n s Vty
getVtyHandle
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Output -> IO ()
ringTerminalBell forall a b. (a -> b) -> a -> b
$ Vty -> Output
outputIface Vty
vty
data PostToAdd =
OldPost Post
| RecentPost Post Bool
data NotificationV2 = NotificationV2
{ NotificationV2 -> Int
version :: Int
, NotificationV2 -> Hostname
message :: Text
, NotificationV2 -> Bool
mention :: Bool
, NotificationV2 -> Hostname
from :: Text
} deriving (Int -> NotificationV2 -> ShowS
[NotificationV2] -> ShowS
NotificationV2 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotificationV2] -> ShowS
$cshowList :: [NotificationV2] -> ShowS
show :: NotificationV2 -> String
$cshow :: NotificationV2 -> String
showsPrec :: Int -> NotificationV2 -> ShowS
$cshowsPrec :: Int -> NotificationV2 -> ShowS
Show)
instance A.ToJSON NotificationV2 where
toJSON :: NotificationV2 -> Value
toJSON (NotificationV2 Int
vers Hostname
msg Bool
mentioned Hostname
sender) =
[Pair] -> Value
A.object [ Key
"version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Int
vers
, Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Hostname
msg
, Key
"mention" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
mentioned
, Key
"from" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Hostname
sender
]
data NotificationV3 = NotificationV3
{ NotificationV3 -> Int
notifyV3Version :: Int
, NotificationV3 -> Hostname
notifyV3Message :: Text
, NotificationV3 -> Bool
notifyV3Mention :: Bool
, NotificationV3 -> Hostname
notifyV3From :: Text
, NotificationV3 -> Hostname
notifyV3MessageType :: Text
} deriving (Int -> NotificationV3 -> ShowS
[NotificationV3] -> ShowS
NotificationV3 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NotificationV3] -> ShowS
$cshowList :: [NotificationV3] -> ShowS
show :: NotificationV3 -> String
$cshow :: NotificationV3 -> String
showsPrec :: Int -> NotificationV3 -> ShowS
$cshowsPrec :: Int -> NotificationV3 -> ShowS
Show)
instance A.ToJSON NotificationV3 where
toJSON :: NotificationV3 -> Value
toJSON (NotificationV3 Int
vers Hostname
msg Bool
mentioned Hostname
sender Hostname
msgTy) =
[Pair] -> Value
A.object [ Key
"version" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Int
vers
, Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Hostname
msg
, Key
"mention" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Bool
mentioned
, Key
"from" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Hostname
sender
, Key
"messageType" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
A..= Hostname
msgTy
]
notifyGetPayload :: NotificationVersion -> ChatState -> Post -> Bool -> Maybe BSL.ByteString
notifyGetPayload :: NotificationVersion
-> ChatState -> Post -> Bool -> Maybe ByteString
notifyGetPayload NotificationVersion
NotifyV1 ChatState
_ Post
_ Bool
_ = do forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Monoid a => a
mempty
notifyGetPayload NotificationVersion
NotifyV2 ChatState
st Post
post Bool
mentioned = do
let notification :: NotificationV2
notification = Int -> Hostname -> Bool -> Hostname -> NotificationV2
NotificationV2 Int
2 Hostname
msg Bool
mentioned Hostname
sender
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> ByteString
A.encode NotificationV2
notification)
where
msg :: Hostname
msg = UserText -> Hostname
sanitizeUserText forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
post
sender :: Hostname
sender = ChatState -> Post -> Hostname
maybePostUsername ChatState
st Post
post
notifyGetPayload NotificationVersion
NotifyV3 ChatState
st Post
post Bool
mentioned = do
let notification :: NotificationV3
notification = Int -> Hostname -> Bool -> Hostname -> Hostname -> NotificationV3
NotificationV3 Int
3 Hostname
msg Bool
mentioned Hostname
sender Hostname
msgTy
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. ToJSON a => a -> ByteString
A.encode NotificationV3
notification)
where
msg :: Hostname
msg = UserText -> Hostname
sanitizeUserText forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
post
sender :: Hostname
sender = ChatState -> Post -> Hostname
maybePostUsername ChatState
st Post
post
msgTy :: Hostname
msgTy = case Post -> PostType
postType Post
post of
PostType
PostTypeJoinChannel -> Hostname
"joinChannel"
PostType
PostTypeLeaveChannel -> Hostname
"leaveChannel"
PostType
PostTypeAddToChannel -> Hostname
"addToChannel"
PostType
PostTypeRemoveFromChannel -> Hostname
"removeFromChannel"
PostType
PostTypeHeaderChange -> Hostname
"headerChange"
PostType
PostTypeDisplayNameChange -> Hostname
"displayNameChange"
PostType
PostTypePurposeChange -> Hostname
"purposeChange"
PostType
PostTypeChannelDeleted -> Hostname
"channelDeleted"
PostType
PostTypeEphemeral -> Hostname
"ephemeral"
PostTypeUnknown Hostname
_ -> Hostname
"unknown"
handleNotifyCommand :: Post -> Bool -> NotificationVersion -> MH ()
handleNotifyCommand :: Post -> Bool -> NotificationVersion -> MH ()
handleNotifyCommand Post
post Bool
mentioned NotificationVersion
NotifyV1 = do
TChan ProgramOutput
outputChan <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog)
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
Maybe Hostname
notifyCommand <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config (Maybe Hostname)
configActivityNotifyCommandL)
case Maybe Hostname
notifyCommand of
Maybe Hostname
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Hostname
cmd ->
AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
let messageString :: String
messageString = Hostname -> String
T.unpack forall a b. (a -> b) -> a -> b
$ UserText -> Hostname
sanitizeUserText forall a b. (a -> b) -> a -> b
$ Post -> UserText
postMessage Post
post
notified :: String
notified = if Bool
mentioned then String
"1" else String
"2"
sender :: String
sender = Hostname -> String
T.unpack forall a b. (a -> b) -> a -> b
$ ChatState -> Post -> Hostname
maybePostUsername ChatState
st Post
post
TChan ProgramOutput
-> String
-> [String]
-> Maybe ByteString
-> Maybe (MVar ProgramOutput)
-> IO ()
runLoggedCommand TChan ProgramOutput
outputChan (Hostname -> String
T.unpack Hostname
cmd)
[String
notified, String
sender, String
messageString] forall a. Maybe a
Nothing forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
handleNotifyCommand Post
post Bool
mentioned NotificationVersion
NotifyV2 = do
TChan ProgramOutput
outputChan <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog)
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
let payload :: Maybe ByteString
payload = NotificationVersion
-> ChatState -> Post -> Bool -> Maybe ByteString
notifyGetPayload NotificationVersion
NotifyV2 ChatState
st Post
post Bool
mentioned
Maybe Hostname
notifyCommand <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config (Maybe Hostname)
configActivityNotifyCommandL)
case Maybe Hostname
notifyCommand of
Maybe Hostname
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Hostname
cmd ->
AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
TChan ProgramOutput
-> String
-> [String]
-> Maybe ByteString
-> Maybe (MVar ProgramOutput)
-> IO ()
runLoggedCommand TChan ProgramOutput
outputChan (Hostname -> String
T.unpack Hostname
cmd) [] Maybe ByteString
payload forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
handleNotifyCommand Post
post Bool
mentioned NotificationVersion
NotifyV3 = do
TChan ProgramOutput
outputChan <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources (TChan ProgramOutput)
crSubprocessLog)
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
let payload :: Maybe ByteString
payload = NotificationVersion
-> ChatState -> Post -> Bool -> Maybe ByteString
notifyGetPayload NotificationVersion
NotifyV3 ChatState
st Post
post Bool
mentioned
Maybe Hostname
notifyCommand <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config (Maybe Hostname)
configActivityNotifyCommandL)
case Maybe Hostname
notifyCommand of
Maybe Hostname
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Hostname
cmd ->
AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
TChan ProgramOutput
-> String
-> [String]
-> Maybe ByteString
-> Maybe (MVar ProgramOutput)
-> IO ()
runLoggedCommand TChan ProgramOutput
outputChan (Hostname -> String
T.unpack Hostname
cmd) [] Maybe ByteString
payload forall a. Maybe a
Nothing
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
runNotifyCommand :: Post -> Bool -> MH ()
runNotifyCommand :: Post -> Bool -> MH ()
runNotifyCommand Post
post Bool
mentioned = do
NotificationVersion
notifyVersion <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources Config
crConfigurationforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' Config NotificationVersion
configActivityNotifyVersionL)
Post -> Bool -> NotificationVersion -> MH ()
handleNotifyCommand Post
post Bool
mentioned NotificationVersion
notifyVersion
maybePostUsername :: ChatState -> Post -> T.Text
maybePostUsername :: ChatState -> Post -> Hostname
maybePostUsername ChatState
st Post
p =
forall a. a -> Maybe a -> a
fromMaybe Hostname
T.empty forall a b. (a -> b) -> a -> b
$ do
UserId
uId <- Post -> Maybe UserId
postUserId Post
p
UserId -> ChatState -> Maybe Hostname
usernameForUserId UserId
uId ChatState
st
asyncFetchMoreMessages :: MH ()
asyncFetchMoreMessages :: MH ()
asyncFetchMoreMessages =
(TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId ->
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
chan -> do
let offset :: Int
offset = forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length (ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages) forall a. Num a => a -> a -> a
- Int
2
page :: Int
page = Int
offset forall a. Integral a => a -> a -> a
`div` Int
pageAmount
usefulMsgs :: Maybe (Message, Message)
usefulMsgs = forall dir.
SeqDirection dir =>
Maybe Message
-> DirectionalSeq dir Message -> Maybe (Message, Message)
getTwoContiguousPosts forall a. Maybe a
Nothing (ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessagesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Messages -> RetrogradeMessages
reverseMessages)
sndOldestId :: Maybe PostId
sndOldestId = (Message -> Maybe PostId
messagePostId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe (Message, Message)
usefulMsgs
query :: PostQuery
query = PostQuery
MM.defaultPostQuery
{ postQueryPage :: Maybe Int
MM.postQueryPage = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just Int
page) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) Maybe PostId
sndOldestId
, postQueryPerPage :: Maybe Int
MM.postQueryPerPage = forall a. a -> Maybe a
Just Int
pageAmount
, postQueryBefore :: Maybe PostId
MM.postQueryBefore = Maybe PostId
sndOldestId
}
addTrailingGap :: Bool
addTrailingGap = PostQuery -> Maybe PostId
MM.postQueryBefore PostQuery
query forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
PostQuery -> Maybe Int
MM.postQueryPage PostQuery
query forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
0
forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Preempt ChannelId
cId
(\Session
s ChannelId
c -> ChannelId -> PostQuery -> Session -> IO Posts
MM.mmGetPostsForChannel ChannelId
c PostQuery
query Session
s)
(\ChannelId
c Posts
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
PostProcessMessageAdd
pp <- ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages ChannelId
c (-Int
pageAmount) Bool
addTrailingGap Posts
p
PostProcessMessageAdd -> MH ()
postProcessMessageAdd PostProcessMessageAdd
pp)
getTwoContiguousPosts :: SeqDirection dir =>
Maybe Message
-> DirectionalSeq dir Message
-> Maybe (Message, Message)
getTwoContiguousPosts :: forall dir.
SeqDirection dir =>
Maybe Message
-> DirectionalSeq dir Message -> Maybe (Message, Message)
getTwoContiguousPosts Maybe Message
startMsg DirectionalSeq dir Message
msgs =
let go :: Maybe Message -> Maybe (Message, Message)
go Maybe Message
start =
do Message
anchor <- forall dir.
SeqDirection dir =>
Maybe MessageId -> DirectionalSeq dir Message -> Maybe Message
getRelMessageId (Message -> Maybe MessageId
_mMessageId forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Message
start) DirectionalSeq dir Message
msgs
Message
hinge <- forall dir.
SeqDirection dir =>
Maybe MessageId -> DirectionalSeq dir Message -> Maybe Message
getRelMessageId (Message
anchorforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId) DirectionalSeq dir Message
msgs
if Message -> Bool
isGap Message
anchor Bool -> Bool -> Bool
|| Message -> Bool
isGap Message
hinge
then Maybe Message -> Maybe (Message, Message)
go forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Message
anchor
else forall a. a -> Maybe a
Just (Message
anchor, Message
hinge)
in Maybe Message -> Maybe (Message, Message)
go Maybe Message
startMsg
asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()
asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()
asyncFetchMessagesForGap ChannelId
cId Message
gapMessage =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Message -> Bool
isGap Message
gapMessage) forall a b. (a -> b) -> a -> b
$
ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel ChannelId
cId forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan ->
let offset :: Int
offset = forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length (ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages) forall a. Num a => a -> a -> a
- Int
2
page :: Int
page = Int
offset forall a. Integral a => a -> a -> a
`div` Int
pageAmount
chanMsgs :: Messages
chanMsgs = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessages
fromMsg :: Maybe Message
fromMsg = forall a. a -> Maybe a
Just Message
gapMessage
fetchNewer :: Bool
fetchNewer = case Message
gapMessageforall s a. s -> Getting a s a -> a
^.Lens' Message MessageType
mType of
C ClientMessageType
UnknownGapAfter -> Bool
True
C ClientMessageType
UnknownGapBefore -> Bool
False
MessageType
_ -> forall a. HasCallStack => String -> a
error String
"fetch gap messages: unknown gap message type"
baseId :: Maybe PostId
baseId = Message -> Maybe PostId
messagePostId forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
case Message
gapMessageforall s a. s -> Getting a s a -> a
^.Lens' Message MessageType
mType of
C ClientMessageType
UnknownGapAfter -> forall dir.
SeqDirection dir =>
Maybe Message
-> DirectionalSeq dir Message -> Maybe (Message, Message)
getTwoContiguousPosts Maybe Message
fromMsg forall a b. (a -> b) -> a -> b
$
Messages -> RetrogradeMessages
reverseMessages Messages
chanMsgs
C ClientMessageType
UnknownGapBefore -> forall dir.
SeqDirection dir =>
Maybe Message
-> DirectionalSeq dir Message -> Maybe (Message, Message)
getTwoContiguousPosts Maybe Message
fromMsg Messages
chanMsgs
MessageType
_ -> forall a. HasCallStack => String -> a
error String
"fetch gap messages: unknown gap message type"
query :: PostQuery
query = PostQuery
MM.defaultPostQuery
{ postQueryPage :: Maybe Int
MM.postQueryPage = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. a -> Maybe a
Just Int
page) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) Maybe PostId
baseId
, postQueryPerPage :: Maybe Int
MM.postQueryPerPage = forall a. a -> Maybe a
Just Int
pageAmount
, postQueryBefore :: Maybe PostId
MM.postQueryBefore = if Bool
fetchNewer then forall a. Maybe a
Nothing else Maybe PostId
baseId
, postQueryAfter :: Maybe PostId
MM.postQueryAfter = if Bool
fetchNewer then Maybe PostId
baseId else forall a. Maybe a
Nothing
}
addTrailingGap :: Bool
addTrailingGap = PostQuery -> Maybe PostId
MM.postQueryBefore PostQuery
query forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
PostQuery -> Maybe Int
MM.postQueryPage PostQuery
query forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
0
in forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Preempt ChannelId
cId
(\Session
s ChannelId
c -> ChannelId -> PostQuery -> Session -> IO Posts
MM.mmGetPostsForChannel ChannelId
c PostQuery
query Session
s)
(\ChannelId
c Posts
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages ChannelId
c (-Int
pageAmount) Bool
addTrailingGap Posts
p)
asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH ()
asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH ()
asyncFetchMessagesSurrounding ChannelId
cId PostId
pId = do
let query :: PostQuery
query = PostQuery
MM.defaultPostQuery
{ postQueryBefore :: Maybe PostId
MM.postQueryBefore = forall a. a -> Maybe a
Just PostId
pId
, postQueryPerPage :: Maybe Int
MM.postQueryPerPage = forall a. a -> Maybe a
Just Int
reqAmt
}
reqAmt :: Int
reqAmt = Int
5
forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Preempt ChannelId
cId
(\Session
s ChannelId
c -> ChannelId -> PostQuery -> Session -> IO Posts
MM.mmGetPostsForChannel ChannelId
c PostQuery
query Session
s)
(\ChannelId
c Posts
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
let last2ndId :: Maybe PostId
last2ndId = Posts -> Maybe PostId
secondToLastPostId Posts
p
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages ChannelId
c (-Int
reqAmt) Bool
False Posts
p
let query' :: PostQuery
query' = PostQuery
MM.defaultPostQuery
{ postQueryAfter :: Maybe PostId
MM.postQueryAfter = Maybe PostId
last2ndId
, postQueryPerPage :: Maybe Int
MM.postQueryPerPage = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int
reqAmt forall a. Num a => a -> a -> a
+ Int
2
}
forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Preempt ChannelId
cId
(\Session
s' ChannelId
c' -> ChannelId -> PostQuery -> Session -> IO Posts
MM.mmGetPostsForChannel ChannelId
c' PostQuery
query' Session
s')
(\ChannelId
c' Posts
p' -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages ChannelId
c' (Int
reqAmt forall a. Num a => a -> a -> a
+ Int
2) Bool
False Posts
p'
)
)
where secondToLastPostId :: Posts -> Maybe PostId
secondToLastPostId Posts
posts =
let pl :: [PostId]
pl = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Posts -> Seq PostId
postsOrder Posts
posts
in if forall (t :: * -> *) a. Foldable t => t a -> Int
length [PostId]
pl forall a. Ord a => a -> a -> Bool
> Int
1 then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
init [PostId]
pl else forall a. Maybe a
Nothing
fetchVisibleIfNeeded :: TeamId -> MH ()
fetchVisibleIfNeeded :: TeamId -> MH ()
fetchVisibleIfNeeded TeamId
tId = do
ConnectionStatus
sts <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use Lens' ChatState ConnectionStatus
csConnectionStatus
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ConnectionStatus
sts forall a. Eq a => a -> a -> Bool
== ConnectionStatus
Connected) forall a b. (a -> b) -> a -> b
$ do
TeamId -> (ChannelId -> ClientChannel -> MH ()) -> MH ()
withCurrentChannel TeamId
tId forall a b. (a -> b) -> a -> b
$ \ChannelId
cId ClientChannel
chan -> do
let msgs :: RetrogradeMessages
msgs = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel (MessageInterface Name ())
ccMessageInterfaceforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall n i. Lens' (MessageInterface n i) Messages
miMessagesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Messages -> RetrogradeMessages
reverseMessages
(Int
numRemaining, Bool
gapInDisplayable, Maybe MessageId
_, Maybe MessageId
rel'pId, Int
overlap) =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
-> Message -> (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
gapTrail (Int
numScrollbackPosts, Bool
False, forall a. Maybe a
Nothing, forall a. Maybe a
Nothing, Int
2) RetrogradeMessages
msgs
gapTrail :: (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
-> Message
-> (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
gapTrail :: (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
-> Message -> (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
gapTrail a :: (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
a@(Int
_, Bool
True, Maybe MessageId
_, Maybe MessageId
_, Int
_) Message
_ = (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
a
gapTrail a :: (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
a@(Int
0, Bool
_, Maybe MessageId
_, Maybe MessageId
_, Int
_) Message
_ = (Int, Bool, Maybe MessageId, Maybe MessageId, Int)
a
gapTrail (Int
a, Bool
False, Maybe MessageId
b, Maybe MessageId
c, Int
d) Message
m | Message -> Bool
isGap Message
m = (Int
a, Bool
True, Maybe MessageId
b, Maybe MessageId
c, Int
d)
gapTrail (Int
remCnt, Bool
_, Maybe MessageId
prev'pId, Maybe MessageId
prev''pId, Int
ovl) Message
msg =
(Int
remCnt forall a. Num a => a -> a -> a
- Int
1, Bool
False, Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe MessageId
prev'pId, Maybe MessageId
prev'pId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe MessageId
prev''pId,
Int
ovl forall a. Num a => a -> a -> a
+ if Bool -> Bool
not (Message -> Bool
isPostMessage Message
msg) then Int
1 else Int
0)
numToRequest :: Int
numToRequest = Int
numRemaining forall a. Num a => a -> a -> a
+ Int
overlap
query :: PostQuery
query = PostQuery
MM.defaultPostQuery
{ postQueryPage :: Maybe Int
MM.postQueryPage = forall a. a -> Maybe a
Just Int
0
, postQueryPerPage :: Maybe Int
MM.postQueryPerPage = forall a. a -> Maybe a
Just Int
numToRequest
}
finalQuery :: PostQuery
finalQuery = case Maybe MessageId
rel'pId of
Just (MessagePostId PostId
pid) -> PostQuery
query { postQueryBefore :: Maybe PostId
MM.postQueryBefore = forall a. a -> Maybe a
Just PostId
pid }
Maybe MessageId
_ -> PostQuery
query
op :: Session -> ChannelId -> IO Posts
op = \Session
s ChannelId
c -> ChannelId -> PostQuery -> Session -> IO Posts
MM.mmGetPostsForChannel ChannelId
c PostQuery
finalQuery Session
s
addTrailingGap :: Bool
addTrailingGap = PostQuery -> Maybe PostId
MM.postQueryBefore PostQuery
finalQuery forall a. Eq a => a -> a -> Bool
== forall a. Maybe a
Nothing Bool -> Bool -> Bool
&&
PostQuery -> Maybe Int
MM.postQueryPage PostQuery
finalQuery forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Int
0
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Bool
cdFetchPending) Bool -> Bool -> Bool
&& Bool
gapInDisplayable) forall a b. (a -> b) -> a -> b
$ do
ChannelId -> Traversal' ChatState ClientChannel
csChannel(ChannelId
cId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Bool
cdFetchPending forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
True
forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Preempt ChannelId
cId Session -> ChannelId -> IO Posts
op
(\ChannelId
c Posts
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
ChannelId -> Traversal' ChatState ClientChannel
csChannel(ChannelId
c)forall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo Bool
cdFetchPending forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Bool
False
ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd
addObtainedMessages ChannelId
c (-Int
numToRequest) Bool
addTrailingGap Posts
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= PostProcessMessageAdd -> MH ()
postProcessMessageAdd)
asyncFetchAttachments :: Post -> MH ()
asyncFetchAttachments :: Post -> MH ()
asyncFetchAttachments Post
p = do
let cId :: ChannelId
cId = Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post ChannelId
postChannelIdL
pId :: PostId
pId = Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post PostId
postIdL
Session
session <- MH Session
getSession
Hostname
host <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use (Lens' ChatState ChatResources
csResourcesforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChatResources ConnectionData
crConnforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ConnectionData Hostname
cdHostnameL)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ (Post
pforall s a. s -> Getting a s a -> a
^.Lens' Post (Seq FileId)
postFileIdsL) forall a b. (a -> b) -> a -> b
$ \FileId
fId -> AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Normal forall a b. (a -> b) -> a -> b
$ do
FileInfo
info <- FileId -> Session -> IO FileInfo
MM.mmGetMetadataForFile FileId
fId Session
session
let scheme :: Hostname
scheme = Hostname
"https://"
attUrl :: Hostname
attUrl = Hostname
scheme forall a. Semigroup a => a -> a -> a
<> Hostname
host forall a. Semigroup a => a -> a -> a
<> FileId -> Hostname
urlForFile FileId
fId
attachment :: Attachment
attachment = Hostname -> Hostname -> FileId -> Attachment
mkAttachment (FileInfo -> Hostname
fileInfoName FileInfo
info) Hostname
attUrl FileId
fId
addIfMissing :: a -> Seq a -> Seq a
addIfMissing a
a Seq a
as =
if forall a. Maybe a -> Bool
isNothing forall a b. (a -> b) -> a -> b
$ forall a. Eq a => a -> Seq a -> Maybe Int
Seq.elemIndexL a
a Seq a
as
then a
a forall a. a -> Seq a -> Seq a
Seq.<| Seq a
as
else Seq a
as
addAttachment :: Message -> Message
addAttachment Message
m
| Message
mforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId PostId
pId) =
Message
m forall a b. a -> (a -> b) -> b
& Lens' Message (Seq Attachment)
mAttachments forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall {a}. Eq a => a -> Seq a -> Seq a
addIfMissing Attachment
attachment)
| Bool
otherwise =
Message
m
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
ChannelId -> Traversal' ChatState Messages
csChannelMessages(ChannelId
cId)forall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b.
Traversable f =>
Traversal (f a) (f b) a b
traversed forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= Message -> Message
addAttachment
Maybe TeamId
curTId <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use SimpleGetter ChatState (Maybe TeamId)
csCurrentTeamId
ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel ChannelId
cId forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan -> do
let mTId :: Maybe TeamId
mTId = ClientChannel
chanforall s a. s -> Getting a s a -> a
^.Lens' ClientChannel ChannelInfo
ccInfoforall b c a. (b -> c) -> (a -> b) -> a -> c
.Lens' ChannelInfo (Maybe TeamId)
cdTeamId forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TeamId
curTId
case Maybe TeamId
mTId of
Maybe TeamId
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just TeamId
tId -> TeamId -> ChannelId -> (Message -> Message) -> MH ()
modifyEachThreadMessage TeamId
tId ChannelId
cId Message -> Message
addAttachment
ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cId
PostId -> MH ()
invalidateMessageRenderingCacheByPostId PostId
pId
jumpToPost :: PostId -> MH ()
jumpToPost :: PostId -> MH ()
jumpToPost PostId
pId = (TeamId -> MH ()) -> MH ()
withCurrentTeam forall a b. (a -> b) -> a -> b
$ \TeamId
tId -> do
ChatState
st <- forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use forall a. a -> a
id
case ChatState -> PostId -> Maybe Message
getMessageForPostId ChatState
st PostId
pId of
Just Message
msg ->
case Message
msg forall s a. s -> Getting a s a -> a
^. Lens' Message (Maybe ChannelId)
mChannelId of
Just ChannelId
cId -> do
case ChannelId -> ClientChannels -> Maybe ClientChannel
findChannelById ChannelId
cId (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ClientChannels
csChannels) of
Maybe ClientChannel
Nothing ->
TeamId -> ChannelId -> Maybe (MH ()) -> MH ()
joinChannel' TeamId
tId ChannelId
cId (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PostId -> MH ()
jumpToPost PostId
pId)
Just ClientChannel
_ -> do
TeamId -> ChannelId -> MH ()
setFocus TeamId
tId ChannelId
cId
forall n i. Lens' ChatState (MessageInterface n i) -> MH ()
beginMessageSelect (ChannelId -> Lens' ChatState (MessageInterface Name ())
csChannelMessageInterface(ChannelId
cId))
ChannelId -> Lens' ChatState MessageSelectState
channelMessageSelect(ChannelId
cId) forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe MessageId -> MessageSelectState
MessageSelectState (Message
msgforall s a. s -> Getting a s a -> a
^.Lens' Message (Maybe MessageId)
mMessageId)
Maybe ChannelId
Nothing ->
forall a. HasCallStack => String -> a
error String
"INTERNAL: selected Post ID not associated with a channel"
Maybe Message
Nothing -> do
Session
session <- MH Session
getSession
AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt forall a b. (a -> b) -> a -> b
$ do
Either SomeException Post
result <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ PostId -> Session -> IO Post
MM.mmGetPost PostId
pId Session
session
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ do
case Either SomeException Post
result of
Right Post
p -> do
case ChannelId -> ClientChannels -> Maybe ClientChannel
findChannelById (Post -> ChannelId
postChannelId Post
p) (ChatState
stforall s a. s -> Getting a s a -> a
^.Lens' ChatState ClientChannels
csChannels) of
Maybe ClientChannel
Nothing -> do
TeamId -> ChannelId -> Maybe (MH ()) -> MH ()
joinChannel' TeamId
tId (Post -> ChannelId
postChannelId Post
p) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PostId -> MH ()
jumpToPost PostId
pId)
Just ClientChannel
_ -> do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd
addMessageToState Bool
True Bool
True (Post -> PostToAdd
OldPost Post
p)
PostId -> MH ()
jumpToPost PostId
pId
Left (SomeException
_::SomeException) ->
Hostname -> MH ()
postErrorMessage' Hostname
"Could not fetch linked post"