matterhorn-50200.0.0: src/Types/Messages.hs
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-|
The 'Message' is a single displayed event in a Channel. All Messages
have a date/time, and messages that represent posts to the channel
have a (hash) ID, and displayable text, along with other attributes.
All Messages are sorted chronologically. There is no assumption that
the server date/time is synchronized with the local date/time, so all
of the Message ordering uses the server's date/time.
The mattermost-api retrieves a 'Post' from the server, briefly encodes
the useful portions of that as a 'ClientPost' object and then converts
it to a 'Message' inserting this result it into the collection of
Messages associated with a Channel. The PostID of the message
uniquely identifies that message and can be used to interact with the
server for subsequent operations relative to that message's 'Post'.
The date/time associated with these messages is generated by the
server.
There are also "messages" generated directly by the Matterhorn client
which can be used to display additional, client-related information to
the user. Examples of these client messages are: date boundaries, the
"new messages" marker, errors from invoking the browser, etc. These
client-generated messages will have a date/time although it is locally
generated (usually by relation to an associated Post).
Most other Matterhorn operations primarily are concerned with
user-posted messages (@case mMessageId of Just _@ or @case mType of CP
_@), but others will include client-generated messages (@case mMessageId
of Nothing@ or @case mType of C _@).
--}
module Types.Messages
( -- * Message and operations on a single Message
Message(..)
, isDeletable, isReplyable, isEditable, isReplyTo, isGap, isFlaggable
, mText, mUser, mDate, mType, mPending, mDeleted
, mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged
, mOriginalPost, mChannelId, mMarkdownSource
, MessageType(..)
, MessageId(..)
, isPostMessage
, messagePostId
, messageIdPostId
, UserRef(..)
, ReplyState(..)
, clientMessageToMessage
, newMessageOfType
-- * Message Collections
, Messages
, ChronologicalMessages
, RetrogradeMessages
, MessageOps (..)
, noMessages
, filterMessages
, reverseMessages
, unreverseMessages
-- * Operations on Posted Messages
, splitMessages
, splitMessagesOn
, splitRetrogradeMessagesOn
, findMessage
, getNextMessageId
, getPrevMessageId
, getNextPostId
, getPrevPostId
, getEarliestPostMsg
, getLatestPostMsg
, getLatestSelectableMessage
, findLatestUserMessage
-- * Operations on any Message type
, messagesAfter
, removeMatchesFromSubset
, withFirstMessage
, msgURLs
, altInlinesString
, LinkChoice(LinkChoice)
, linkUser
, linkURL
, linkTime
, linkName
, linkFileId
)
where
import Prelude ()
import Prelude.MH
import Cheapskate ( Blocks )
import qualified Cheapskate as C
import qualified Data.Foldable as F
import Data.Hashable ( Hashable )
import qualified Data.Map.Strict as Map
import Data.Sequence as Seq
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 Types.DirectionalSeq
import Types.Posts
-- ----------------------------------------------------------------------
-- * Messages
data MessageId = MessagePostId PostId
| MessageUUID UUID
deriving (Eq, Read, Show, Generic, Hashable)
messageIdPostId :: MessageId -> Maybe PostId
messageIdPostId (MessagePostId p) = Just p
messageIdPostId _ = Nothing
-- | A 'Message' is any message we might want to render, either from
-- Mattermost itself or from a client-internal source.
data Message = Message
{ _mText :: Blocks
, _mMarkdownSource :: Text
, _mUser :: UserRef
, _mDate :: ServerTime
, _mType :: MessageType
, _mPending :: Bool
, _mDeleted :: Bool
, _mAttachments :: Seq Attachment
, _mInReplyToMsg :: ReplyState
, _mMessageId :: Maybe MessageId
, _mReactions :: Map.Map Text Int
, _mOriginalPost :: Maybe Post
, _mFlagged :: 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) &&
_mType m `elem` [CP NormalPost, CP Emote]
isFlaggable :: Message -> Bool
isFlaggable = isJust . messagePostId
isReplyable :: Message -> Bool
isReplyable m =
isJust (messagePostId m) &&
(_mType m `elem` [CP NormalPost, CP Emote])
isEditable :: Message -> Bool
isEditable m =
isJust (messagePostId m) &&
_mType m `elem` [CP NormalPost, CP Emote]
isReplyTo :: PostId -> Message -> Bool
isReplyTo expectedParentId m =
case _mInReplyToMsg m of
NotAReply -> False
InReplyTo actualParentId -> actualParentId == expectedParentId
isGap :: Message -> Bool
isGap m = _mType m == C UnknownGap
-- | A 'Message' is the representation we use for storage and
-- rendering, so it must be able to represent either a
-- post from Mattermost or an internal message. This represents
-- the union of both kinds of post types.
data MessageType = C ClientMessageType
| CP ClientPostType
deriving (Eq, Show)
-- | There may be no user (usually an internal message), a reference
-- to a user (by Id), or the server may have supplied a specific
-- username (often associated with bots).
data UserRef = NoUser | UserI UserId | UserOverride Text
deriving (Eq, Show, Ord)
-- | The 'ReplyState' of a message represents whether a message
-- is a reply, and if so, to what message
data ReplyState =
NotAReply
| InReplyTo PostId
deriving (Show)
-- | This type represents links to things in the 'open links' view.
data LinkChoice =
LinkChoice { _linkTime :: ServerTime
, _linkUser :: UserRef
, _linkName :: Text
, _linkURL :: Text
, _linkFileId :: Maybe FileId
} deriving (Eq, Show)
makeLenses ''LinkChoice
-- | Convert a 'ClientMessage' to a 'Message'. A 'ClientMessage' is
-- one that was generated by the Matterhorn client and which the
-- server knows nothing about. For example, an error message
-- associated with passing a link to the local browser.
clientMessageToMessage :: ClientMessage -> Message
clientMessageToMessage cm = Message
{ _mText = getBlocks (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
, _mChannelId = Nothing
}
newMessageOfType :: Text -> MessageType -> ServerTime -> Message
newMessageOfType text typ d = Message
{ _mText = getBlocks 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
, _mChannelId = Nothing
}
-- ** 'Message' Lenses
makeLenses ''Message
-- ----------------------------------------------------------------------
-- * Message Collections
-- | A wrapper for an ordered, unique list of 'Message' values.
--
-- This type has (and promises) the following instances: Show,
-- Functor, Monoid, Foldable, Traversable
type ChronologicalMessages = DirectionalSeq Chronological Message
type Messages = ChronologicalMessages
-- | There are also cases where the list of 'Message' values are kept
-- in reverse order (most recent -> oldest); these cases are
-- represented by the `RetrogradeMessages` type.
type RetrogradeMessages = DirectionalSeq Retrograde Message
-- ** Common operations on Messages
filterMessages ::
SeqDirection seq =>
(Message -> Bool) ->
DirectionalSeq seq Message ->
DirectionalSeq seq Message
filterMessages p = onDirectedSeq (Seq.filter p)
class MessageOps a where
-- | addMessage inserts a date in proper chronological order, with
-- the following extra functionality:
-- * no duplication (by PostId)
-- * no duplication (adjacent UnknownGap entries)
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
-- | Reverse the order of the messages
reverseMessages :: Messages -> RetrogradeMessages
reverseMessages = DSeq . Seq.reverse . dseq
-- | Unreverse the order of the messages
unreverseMessages :: RetrogradeMessages -> Messages
unreverseMessages = DSeq . Seq.reverse . dseq
-- | Splits the message list at first message where the specified
-- predicate returns true. The result is the message where the split
-- occurred, followed by the messages preceeding the split point (in
-- retrograde order) and the messages following the split point). If
-- the predicate never matches a message before reaching the end of
-- the list, then the matched message is None and all of the messages
-- are in the first (retrograde) collection of of messages.
splitMessagesOn :: (Message -> Bool)
-> Messages
-> (Maybe Message, (RetrogradeMessages, Messages))
splitMessagesOn = splitMsgSeqOn
-- | Similar to 'splitMessagesOn', but taking RetrogradeMessages as input.
splitRetrogradeMessagesOn :: (Message -> Bool)
-> RetrogradeMessages
-> (Maybe Message, (Messages, RetrogradeMessages))
splitRetrogradeMessagesOn = splitMsgSeqOn
-- n.b., the splitMessagesOn and splitRetrogradeMessagesOn could be
-- unified into the following, but that will require TypeFamilies or
-- similar to relate d and r SeqDirection types. For now, it's
-- simplier to just have two API endpoints.
splitMsgSeqOn :: (SeqDirection d, SeqDirection r) =>
(Message -> Bool)
-> DirectionalSeq d Message
-> (Maybe Message, (DirectionalSeq r Message, DirectionalSeq d Message))
splitMsgSeqOn f msgs =
let (removed, remaining) = dirSeqBreakl f msgs
devomer = DSeq $ Seq.reverse $ dseq removed
in (withDirSeqHead id remaining, (devomer, onDirectedSeq (Seq.drop 1) remaining))
-- ----------------------------------------------------------------------
-- * Operations on Posted Messages
-- | Searches for the specified MessageId and returns a tuple where the
-- first element is the Message associated with the MessageId (if it
-- exists), and the second element is another tuple: the first element
-- of the second is all the messages from the beginning of the list to
-- the message just before the MessageId message (or all messages if not
-- found) *in reverse order*, and the second element of the second are
-- all the messages that follow the found message (none if the message
-- was never found) in *forward* order.
splitMessages :: Maybe MessageId
-> Messages
-> (Maybe Message, (RetrogradeMessages, Messages))
splitMessages mid msgs = splitMessagesOn (\m -> isJust mid && m^.mMessageId == mid) msgs
-- | findMessage searches for a specific message as identified by the
-- PostId. The search starts from the most recent messages because
-- that is the most likely place the message will occur.
findMessage :: MessageId -> Messages -> Maybe Message
findMessage mid msgs =
findIndexR (\m -> m^.mMessageId == Just mid) (dseq msgs)
>>= Just . Seq.index (dseq msgs)
-- | Look forward for the first Message with an ID that follows the
-- specified PostId
getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId
getNextMessageId = getRelMessageId foldl
-- | Look backwards for the first Message with an ID that comes before
-- the specified MessageId.
getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId
getPrevMessageId = getRelMessageId $ foldr . flip
-- | Look forward for the first Message with an ID that follows the
-- specified PostId
getNextPostId :: Maybe PostId -> Messages -> Maybe PostId
getNextPostId = getRelPostId foldl
-- | Look backwards for the first Post with an ID that comes before
-- the specified PostId.
getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId
getPrevPostId = getRelPostId $ foldr . flip
-- | Find the next MessageId after the specified MessageId (if there is
-- one) by folding in the specified direction
getRelMessageId :: ((Either MessageId (Maybe MessageId)
-> Message
-> Either MessageId (Maybe MessageId))
-> Either MessageId (Maybe MessageId)
-> Messages
-> Either MessageId (Maybe MessageId))
-> Maybe MessageId
-> Messages
-> Maybe MessageId
getRelMessageId folD jp = case jp of
Nothing -> \msgs -> (getLatestPostMsg msgs >>= _mMessageId)
Just p -> either (const Nothing) id . folD fnd (Left p)
where fnd = either fndp fndnext
fndp c v = if v^.mMessageId == Just c then Right Nothing else Left c
idOfPost m = if m^.mDeleted then Nothing else m^.mMessageId
fndnext n m = Right (n <|> idOfPost m)
-- | Find the next PostId after the specified PostId (if there is
-- one) by folding in the specified direction
getRelPostId :: ((Either PostId (Maybe PostId)
-> Message
-> Either PostId (Maybe PostId))
-> Either PostId (Maybe PostId)
-> Messages
-> Either PostId (Maybe PostId))
-> Maybe PostId
-> Messages
-> Maybe PostId
getRelPostId folD jp = case jp of
Nothing -> \msgs -> do
latest <- getLatestPostMsg msgs
mId <- latest^.mMessageId
case mId of
MessagePostId pId -> return pId
_ -> Nothing
Just p -> either (const Nothing) id . folD fnd (Left p)
where fnd = either fndp fndnext
fndp c v = if v^.mMessageId == Just (MessagePostId c) then Right Nothing else Left c
idOfPost m = if m^.mDeleted
then Nothing
else case m^.mMessageId of
Just (MessagePostId pId) -> Just pId
_ -> Nothing
fndnext n m = Right (n <|> idOfPost m)
-- | Find the most recent message that is a Post (as opposed to a
-- local message) (if any).
getLatestPostMsg :: Messages -> Maybe Message
getLatestPostMsg msgs =
case viewr $ dropWhileR (not . validUserMessage) (dseq msgs) of
EmptyR -> Nothing
_ :> m -> Just m
-- | Find the most recent message that is a message with an ID.
getLatestSelectableMessage :: Messages -> Maybe Message
getLatestSelectableMessage msgs =
case viewr $ dropWhileR (not . validSelectableMessage) (dseq msgs) of
EmptyR -> Nothing
_ :> m -> Just m
-- | Find the earliest message that is a Post (as opposed to a
-- local message) (if any).
getEarliestPostMsg :: Messages -> Maybe Message
getEarliestPostMsg msgs =
case viewl $ dropWhileL (not . validUserMessage) (dseq msgs) of
EmptyL -> Nothing
m :< _ -> Just m
-- | Find the most recent message that is a message posted by a user
-- that matches the test (if any), skipping local client messages and
-- any user event that is not a message (i.e. find a normal message or
-- an emote).
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)
-- ----------------------------------------------------------------------
-- * Operations on any Message type
-- | Return all messages that were posted after the specified date/time.
messagesAfter :: ServerTime -> Messages -> Messages
messagesAfter viewTime = onDirectedSeq $ takeWhileR (\m -> m^.mDate > viewTime)
-- | Removes any Messages (all types) for which the predicate is true
-- from the specified subset of messages (identified by a starting and
-- ending MessageId, inclusive) and returns the resulting list (from
-- start to finish, irrespective of 'firstId' and 'lastId') and the
-- list of removed items.
--
-- start | end | operates-on | (test) case
-- --------------------------------------------------------|-------------
-- Nothing | Nothing | entire list | C1
-- Nothing | Just found | start --> found] | C2
-- Nothing | Just missing | nothing [suggest invalid] | C3
-- Just found | Nothing | [found --> end | C4
-- Just found | Just found | [found --> found] | C5
-- Just found | Just missing | [found --> end | C6
-- Just missing | Nothing | nothing [suggest invalid] | C7
-- Just missing | Just found | start --> found] | C8
-- Just missing | Just missing | nothing [suggest invalid] | C9
--
-- @removeMatchesFromSubset matchPred fromId toId msgs = (remaining, removed)@
--
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)
-- | Performs an operation on the first Message, returning just the
-- result of that operation, or Nothing if there were no messages.
-- Note that the message is not necessarily a posted user message.
withFirstMessage :: SeqDirection dir => (Message -> r) -> DirectionalSeq dir Message -> Maybe r
withFirstMessage = withDirSeqHead
msgURLs :: Message -> Seq LinkChoice
msgURLs msg
| NoUser <- msg^.mUser = mempty
| otherwise =
let uid = msg^.mUser
msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uid text url Nothing) <$>
(mconcat $ blockGetURLs <$> (toList $ msg^.mText))
attachmentURLs = (\ a ->
LinkChoice
(msg^.mDate)
uid
("attachment `" <> (a^.attachmentName) <> "`")
(a^.attachmentURL)
(Just (a^.attachmentFileId)))
<$> (msg^.mAttachments)
in msgUrls <> attachmentURLs
blockGetURLs :: C.Block -> Seq.Seq (Text, Text)
blockGetURLs (C.Para is) = mconcat $ inlineGetURLs <$> toList is
blockGetURLs (C.Header _ is) = mconcat $ inlineGetURLs <$> toList is
blockGetURLs (C.Blockquote bs) = mconcat $ blockGetURLs <$> toList bs
blockGetURLs (C.List _ _ bss) = mconcat $ mconcat $ (blockGetURLs <$>) <$> (toList <$> bss)
blockGetURLs _ = mempty
inlineGetURLs :: C.Inline -> Seq.Seq (Text, Text)
inlineGetURLs (C.Emph is) = mconcat $ inlineGetURLs <$> toList is
inlineGetURLs (C.Strong is) = mconcat $ inlineGetURLs <$> toList is
inlineGetURLs (C.Link is url "") = (url, inlinesText is) Seq.<| (mconcat $ inlineGetURLs <$> toList is)
inlineGetURLs (C.Link is _ url) = (url, inlinesText is) Seq.<| (mconcat $ inlineGetURLs <$> toList is)
inlineGetURLs (C.Image is url _) = Seq.singleton (url, inlinesText is)
inlineGetURLs _ = mempty
inlinesText :: Seq C.Inline -> Text
inlinesText = F.fold . fmap go
where go (C.Str t) = t
go C.Space = " "
go C.SoftBreak = " "
go C.LineBreak = " "
go (C.Emph is) = F.fold (fmap go is)
go (C.Strong is) = F.fold (fmap go is)
go (C.Code t) = t
go (C.Link is _ _) = F.fold (fmap go is)
go (C.Image is _ _) = "[image" <> altInlinesString is <> "]"
go (C.Entity t) = t
go (C.RawHtml t) = t
altInlinesString :: Seq C.Inline -> Text
altInlinesString is | Seq.null is = ""
| otherwise = ":" <> inlinesText is