{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module Matterhorn.Types.Messages
(
Message(..)
, isDeletable, isReplyable, isReactable, isEditable, isReplyTo, isGap, isFlaggable
, isPinnable, isEmote, isJoinLeave, isTransition, isNewMessagesTransition
, mText, mUser, mDate, mType, mPending, mDeleted, mPinned
, mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged
, mOriginalPost, mChannelId, mMarkdownSource
, isBotMessage
, MessageType(..)
, MessageId(..)
, ThreadState(..)
, MentionedUser(..)
, isPostMessage
, messagePostId
, messageIdPostId
, UserRef(..)
, ReplyState(..)
, clientMessageToMessage
, clientPostToMessage
, clientPostReactionUserIds
, newMessageOfType
, Messages
, ChronologicalMessages
, RetrogradeMessages
, MessageOps (..)
, noMessages
, messagesLength
, filterMessages
, reverseMessages
, unreverseMessages
, splitMessages
, splitDirSeqOn
, chronologicalMsgsWithThreadStates
, retrogradeMsgsWithThreadStates
, findMessage
, getRelMessageId
, messagesHead
, messagesDrop
, getNextMessage
, getPrevMessage
, getNextMessageId
, getPrevMessageId
, getNextPostId
, getPrevPostId
, getEarliestPostMsg
, getLatestPostMsg
, getEarliestSelectableMessage
, getLatestSelectableMessage
, findLatestUserMessage
, messagesAfter
, removeMatchesFromSubset
, withFirstMessage
, msgURLs
, LinkTarget(..)
, LinkChoice(LinkChoice, _linkTarget)
, linkUser
, linkTarget
, linkTime
, linkLabel
)
where
import Prelude ()
import Matterhorn.Prelude
import Control.Monad
import qualified Data.Foldable as F
import Data.Hashable ( Hashable )
import qualified Data.Map.Strict as Map
import Data.Sequence as Seq
import qualified Data.Set as S
import Data.Tuple
import Data.UUID ( UUID )
import GHC.Generics ( Generic )
import Lens.Micro.Platform ( makeLenses )
import Network.Mattermost.Types ( ChannelId, PostId, Post
, ServerTime, UserId, FileId
)
import Matterhorn.Types.DirectionalSeq
import Matterhorn.Types.Posts
import Matterhorn.Types.RichText ( RichTextBlock(..), Element(..)
, ElementData(..), findUsernames, blockGetURLs
, ElementStyle(..), URL(..), parseMarkdown
, TeamURLName
)
data ThreadState =
NoThread
| InThreadShowParent
| InThread
deriving (Show, Eq)
data MessageId = MessagePostId PostId
| MessageUUID UUID
deriving (Eq, Read, Show, Generic, Hashable)
messageIdPostId :: MessageId -> Maybe PostId
messageIdPostId (MessagePostId p) = Just p
messageIdPostId _ = Nothing
data Message = Message
{ _mText :: Seq RichTextBlock
, _mMarkdownSource :: Text
, _mUser :: UserRef
, _mDate :: ServerTime
, _mType :: MessageType
, _mPending :: Bool
, _mDeleted :: Bool
, _mAttachments :: Seq Attachment
, _mInReplyToMsg :: ReplyState
, _mMessageId :: Maybe MessageId
, _mReactions :: Map.Map Text (S.Set UserId)
, _mOriginalPost :: Maybe Post
, _mFlagged :: Bool
, _mPinned :: Bool
, _mChannelId :: Maybe ChannelId
} deriving (Show)
isPostMessage :: Message -> Bool
isPostMessage m =
isJust (_mMessageId m >>= messageIdPostId)
messagePostId :: Message -> Maybe PostId
messagePostId m = do
mId <- _mMessageId m
messageIdPostId mId
isDeletable :: Message -> Bool
isDeletable m =
isJust (messagePostId m) &&
case _mType m of
CP NormalPost -> True
CP Emote -> True
_ -> False
isFlaggable :: Message -> Bool
isFlaggable = isJust . messagePostId
isPinnable :: Message -> Bool
isPinnable = isJust . messagePostId
isReplyable :: Message -> Bool
isReplyable m =
isJust (messagePostId m) &&
case _mType m of
CP NormalPost -> True
CP Emote -> True
_ -> False
isReactable :: Message -> Bool
isReactable m =
isJust (messagePostId m) &&
case _mType m of
CP NormalPost -> True
CP Emote -> True
_ -> False
isEditable :: Message -> Bool
isEditable m =
isJust (messagePostId m) &&
case _mType m of
CP NormalPost -> True
CP Emote -> True
_ -> False
isReplyTo :: PostId -> Message -> Bool
isReplyTo expectedParentId m =
case _mInReplyToMsg m of
NotAReply -> False
InReplyTo actualParentId -> actualParentId == expectedParentId
isGap :: Message -> Bool
isGap m = case _mType m of
C UnknownGapBefore -> True
C UnknownGapAfter -> True
_ -> False
isTransition :: Message -> Bool
isTransition m = case _mType m of
C DateTransition -> True
C NewMessagesTransition -> True
_ -> False
isNewMessagesTransition :: Message -> Bool
isNewMessagesTransition m = case _mType m of
C NewMessagesTransition -> True
_ -> False
isEmote :: Message -> Bool
isEmote m = case _mType m of
CP Emote -> True
_ -> False
isJoinLeave :: Message -> Bool
isJoinLeave m = case _mType m of
CP Join -> True
CP Leave -> True
_ -> False
data MessageType = C ClientMessageType
| CP ClientPostType
deriving (Show)
data UserRef = NoUser | UserI Bool UserId | UserOverride Bool Text
deriving (Eq, Show, Ord)
isBotMessage :: Message -> Bool
isBotMessage m =
case _mUser m of
UserI bot _ -> bot
UserOverride bot _ -> bot
NoUser -> False
data ReplyState =
NotAReply
| InReplyTo PostId
deriving (Show, Eq)
data LinkTarget =
LinkURL URL
| LinkFileId FileId
| LinkPermalink TeamURLName PostId
deriving (Eq, Show, Ord)
data LinkChoice =
LinkChoice { _linkTime :: ServerTime
, _linkUser :: UserRef
, _linkLabel :: Maybe (Seq Element)
, _linkTarget :: LinkTarget
} deriving (Eq, Show)
makeLenses ''LinkChoice
clientMessageToMessage :: ClientMessage -> Message
clientMessageToMessage cm = Message
{ _mText = parseMarkdown Nothing (cm^.cmText)
, _mMarkdownSource = cm^.cmText
, _mUser = NoUser
, _mDate = cm^.cmDate
, _mType = C $ cm^.cmType
, _mPending = False
, _mDeleted = False
, _mAttachments = Seq.empty
, _mInReplyToMsg = NotAReply
, _mMessageId = Nothing
, _mReactions = Map.empty
, _mOriginalPost = Nothing
, _mFlagged = False
, _mPinned = False
, _mChannelId = Nothing
}
data MentionedUser =
UsernameMention Text
| UserIdMention UserId
deriving (Eq, Show, Ord)
clientPostReactionUserIds :: ClientPost -> S.Set UserId
clientPostReactionUserIds cp =
S.unions $ F.toList $ cp^.cpReactions
clientPostToMessage :: ClientPost -> (Message, S.Set MentionedUser)
clientPostToMessage cp = (m, mentions)
where
mentions =
S.fromList $
(UsernameMention <$> (F.toList $ findUsernames $ cp^.cpText)) <>
(UserIdMention <$> (F.toList $ clientPostReactionUserIds cp))
m = Message { _mText = cp^.cpText
, _mMarkdownSource = cp^.cpMarkdownSource
, _mUser =
case cp^.cpUserOverride of
Just n | cp^.cpType == NormalPost -> UserOverride (cp^.cpFromWebhook) n
_ -> maybe NoUser (UserI (cp^.cpFromWebhook)) $ cp^.cpUser
, _mDate = cp^.cpDate
, _mType = CP $ cp^.cpType
, _mPending = cp^.cpPending
, _mDeleted = cp^.cpDeleted
, _mAttachments = cp^.cpAttachments
, _mInReplyToMsg =
case cp^.cpInReplyToPost of
Nothing -> NotAReply
Just pId -> InReplyTo pId
, _mMessageId = Just $ MessagePostId $ cp^.cpPostId
, _mReactions = cp^.cpReactions
, _mOriginalPost = Just $ cp^.cpOriginalPost
, _mFlagged = False
, _mPinned = cp^.cpPinned
, _mChannelId = Just $ cp^.cpChannelId
}
newMessageOfType :: Text -> MessageType -> ServerTime -> Message
newMessageOfType text typ d = Message
{ _mText = parseMarkdown Nothing text
, _mMarkdownSource = text
, _mUser = NoUser
, _mDate = d
, _mType = typ
, _mPending = False
, _mDeleted = False
, _mAttachments = Seq.empty
, _mInReplyToMsg = NotAReply
, _mMessageId = Nothing
, _mReactions = Map.empty
, _mOriginalPost = Nothing
, _mFlagged = False
, _mPinned = False
, _mChannelId = Nothing
}
makeLenses ''Message
type ChronologicalMessages = DirectionalSeq Chronological Message
type Messages = ChronologicalMessages
type RetrogradeMessages = DirectionalSeq Retrograde Message
filterMessages :: SeqDirection seq
=> (a -> Bool)
-> DirectionalSeq seq a
-> DirectionalSeq seq a
filterMessages f = onDirectedSeq (Seq.filter f)
class MessageOps a where
addMessage :: Message -> a -> a
instance MessageOps ChronologicalMessages where
addMessage m ml =
case viewr (dseq ml) of
EmptyR -> DSeq $ singleton m
_ :> l ->
case compare (m^.mDate) (l^.mDate) of
GT -> DSeq $ dseq ml |> m
EQ -> if m^.mMessageId == l^.mMessageId && isJust (m^.mMessageId)
then ml
else dirDateInsert m ml
LT -> dirDateInsert m ml
dirDateInsert :: Message -> ChronologicalMessages -> ChronologicalMessages
dirDateInsert m = onDirectedSeq $ finalize . foldr insAfter initial
where initial = (Just m, mempty)
insAfter c (Nothing, l) = (Nothing, c <| l)
insAfter c (Just n, l) =
case compare (n^.mDate) (c^.mDate) of
GT -> (Nothing, c <| (n <| l))
EQ -> if n^.mMessageId == c^.mMessageId && isJust (c^.mMessageId)
then (Nothing, c <| l)
else (Just n, c <| l)
LT -> (Just n, c <| l)
finalize (Just n, l) = n <| l
finalize (_, l) = l
noMessages :: Messages
noMessages = DSeq mempty
messagesLength :: DirectionalSeq seq a -> Int
messagesLength (DSeq ms) = Seq.length ms
reverseMessages :: Messages -> RetrogradeMessages
reverseMessages = DSeq . Seq.reverse . dseq
unreverseMessages :: RetrogradeMessages -> Messages
unreverseMessages = DSeq . Seq.reverse . dseq
splitDirSeqOn :: SeqDirection d
=> (a -> Bool)
-> DirectionalSeq d a
-> (Maybe a, (DirectionalSeq (ReverseDirection d) a,
DirectionalSeq d a))
splitDirSeqOn f msgs =
let (removed, remaining) = dirSeqBreakl f msgs
devomer = DSeq $ Seq.reverse $ dseq removed
in (withDirSeqHead id remaining, (devomer, onDirectedSeq (Seq.drop 1) remaining))
splitMessages :: Maybe MessageId
-> DirectionalSeq Chronological (Message, ThreadState)
-> (Maybe (Message, ThreadState),
( DirectionalSeq Retrograde (Message, ThreadState),
DirectionalSeq Chronological (Message, ThreadState)))
splitMessages mid msgs = splitDirSeqOn (\(m, _) -> isJust mid && m^.mMessageId == mid) msgs
threadStateFor :: Message
-> Message
-> ThreadState
threadStateFor msg prev = case msg^.mInReplyToMsg of
InReplyTo rootId ->
if | (prev^.mMessageId) == Just (MessagePostId rootId) ->
InThread
| prev^.mInReplyToMsg == msg^.mInReplyToMsg ->
InThread
| otherwise ->
InThreadShowParent
_ -> NoThread
retrogradeMsgsWithThreadStates :: RetrogradeMessages -> DirectionalSeq Retrograde (Message, ThreadState)
retrogradeMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs)
where
getMessagePredecessor ms =
let visiblePredMsg m = not (isTransition m || m^.mDeleted) in
case Seq.viewl ms of
prev Seq.:< rest ->
if visiblePredMsg prev
then Just prev
else getMessagePredecessor rest
Seq.EmptyL -> Nothing
checkAdjacentMessages s = case Seq.viewl s of
Seq.EmptyL -> mempty
m Seq.:< t ->
let new_m = case getMessagePredecessor t of
Just prev -> (m, threadStateFor m prev)
Nothing -> case m^.mInReplyToMsg of
InReplyTo _ -> (m, InThreadShowParent)
_ -> (m, NoThread)
in new_m Seq.<| checkAdjacentMessages t
chronologicalMsgsWithThreadStates :: Messages -> DirectionalSeq Chronological (Message, ThreadState)
chronologicalMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs)
where
getMessagePredecessor ms =
let visiblePredMsg m = not (isTransition m || m^.mDeleted) in
case Seq.viewr ms of
rest Seq.:> prev ->
if visiblePredMsg prev
then Just prev
else getMessagePredecessor rest
Seq.EmptyR -> Nothing
checkAdjacentMessages s = case Seq.viewr s of
Seq.EmptyR -> mempty
t Seq.:> m ->
let new_m = case getMessagePredecessor t of
Just prev -> (m, threadStateFor m prev)
Nothing -> case m^.mInReplyToMsg of
InReplyTo _ -> (m, InThreadShowParent)
_ -> (m, NoThread)
in checkAdjacentMessages t Seq.|> new_m
findMessage :: MessageId -> Messages -> Maybe Message
findMessage mid msgs =
findIndexR (\m -> m^.mMessageId == Just mid) (dseq msgs)
>>= Just . Seq.index (dseq msgs)
getNextMessage :: Maybe MessageId -> Messages -> Maybe Message
getNextMessage = getRelMessageId
getPrevMessage :: Maybe MessageId -> Messages -> Maybe Message
getPrevMessage mId = getRelMessageId mId . reverseMessages
messagesHead :: (SeqDirection seq) => DirectionalSeq seq a -> Maybe a
messagesHead = withDirSeqHead id
messagesDrop :: (SeqDirection seq) => Int -> DirectionalSeq seq a -> DirectionalSeq seq a
messagesDrop i = onDirectedSeq (Seq.drop i)
getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId
getNextMessageId mId = _mMessageId <=< getNextMessage mId
getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId
getPrevMessageId mId = _mMessageId <=< getPrevMessage mId
getNextPostId :: Maybe PostId -> Messages -> Maybe PostId
getNextPostId pid = messagePostId <=< getNextMessage (MessagePostId <$> pid)
getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId
getPrevPostId pid = messagePostId <=< getPrevMessage (MessagePostId <$> pid)
getRelMessageId :: SeqDirection dir =>
Maybe MessageId
-> DirectionalSeq dir Message
-> Maybe Message
getRelMessageId mId =
let isMId = const ((==) mId . _mMessageId) <$> mId
in getRelMessage isMId
getRelMessage :: SeqDirection dir =>
Maybe (Message -> Bool)
-> DirectionalSeq dir Message
-> Maybe Message
getRelMessage matcher msgs =
let after = case matcher of
Just matchFun -> case splitDirSeqOn matchFun msgs of
(_, (_, ms)) -> ms
Nothing -> msgs
in withDirSeqHead id $ filterMessages validSelectableMessage after
getLatestPostMsg :: Messages -> Maybe Message
getLatestPostMsg msgs =
case viewr $ dropWhileR (not . validUserMessage) (dseq msgs) of
EmptyR -> Nothing
_ :> m -> Just m
getEarliestSelectableMessage :: Messages -> Maybe Message
getEarliestSelectableMessage msgs =
case viewl $ dropWhileL (not . validSelectableMessage) (dseq msgs) of
EmptyL -> Nothing
m :< _ -> Just m
getLatestSelectableMessage :: Messages -> Maybe Message
getLatestSelectableMessage msgs =
case viewr $ dropWhileR (not . validSelectableMessage) (dseq msgs) of
EmptyR -> Nothing
_ :> m -> Just m
getEarliestPostMsg :: Messages -> Maybe Message
getEarliestPostMsg msgs =
case viewl $ dropWhileL (not . validUserMessage) (dseq msgs) of
EmptyL -> Nothing
m :< _ -> Just m
findLatestUserMessage :: (Message -> Bool) -> Messages -> Maybe Message
findLatestUserMessage f ml =
case viewr $ dropWhileR (\m -> not (validUserMessage m && f m)) $ dseq ml of
EmptyR -> Nothing
_ :> m -> Just m
validUserMessage :: Message -> Bool
validUserMessage m =
not (m^.mDeleted) && case m^.mMessageId of
Just (MessagePostId _) -> True
_ -> False
validSelectableMessage :: Message -> Bool
validSelectableMessage m = (not $ m^.mDeleted) && (isJust $ m^.mMessageId)
messagesAfter :: ServerTime -> Messages -> Messages
messagesAfter viewTime = onDirectedSeq $ takeWhileR (\m -> m^.mDate > viewTime)
removeMatchesFromSubset :: (Message -> Bool) -> Maybe MessageId -> Maybe MessageId
-> Messages -> (Messages, Messages)
removeMatchesFromSubset matching firstId lastId msgs =
let knownIds = fmap (^.mMessageId) msgs
in if isNothing firstId && isNothing lastId
then swap $ dirSeqPartition matching msgs
else if isJust firstId && firstId `elem` knownIds
then onDirSeqSubset
(\m -> m^.mMessageId == firstId)
(if isJust lastId then \m -> m^.mMessageId == lastId else const False)
(swap . dirSeqPartition matching) msgs
else if isJust lastId && lastId `elem` knownIds
then onDirSeqSubset
(const True)
(\m -> m^.mMessageId == lastId)
(swap . dirSeqPartition matching) msgs
else (msgs, noMessages)
withFirstMessage :: SeqDirection dir
=> (Message -> r)
-> DirectionalSeq dir Message
-> Maybe r
withFirstMessage = withDirSeqHead
msgURLs :: Message -> Seq LinkChoice
msgURLs msg =
let uRef = msg^.mUser
mkTarget (Right url) = LinkURL url
mkTarget (Left (tName, pId)) = LinkPermalink tName pId
mkEntry (val, text) = LinkChoice (msg^.mDate) uRef text (mkTarget val)
msgUrls = mkEntry <$> (Seq.fromList $ mconcat $ blockGetURLs <$> (toList $ msg^.mText))
attachmentURLs = (\ a ->
LinkChoice
(msg^.mDate)
uRef
(Just $ attachmentLabel a)
(LinkFileId $ a^.attachmentFileId))
<$> (msg^.mAttachments)
attachmentLabel a =
Seq.fromList [ Element Normal $ EText "attachment"
, Element Normal ESpace
, Element Code $ EText $ a^.attachmentName
]
in msgUrls <> attachmentURLs