matterhorn-40800.0.2: src/Types/Messages.hs
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-|
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 mPostId of Just _@ or @case mType of CP
_@), but others will include client-generated messages (@case mPostId
of Nothing@ or @case mType of C _@).
--}
module Types.Messages
( -- * Message and operations on a single Message
Message(..)
, isDeletable, isReplyable, isEditable, isReplyTo, isGap
, mText, mUser, mDate, mType, mPending, mDeleted
, mAttachments, mInReplyToMsg, mPostId, mReactions, mFlagged
, mOriginalPost, mChannelId
, MessageType(..)
, UserRef(..)
, ReplyState(..)
, clientMessageToMessage
, newMessageOfType
-- * Message Collections
, Messages
, ChronologicalMessages
, RetrogradeMessages
, MessageOps (..)
, noMessages
, filterMessages
, reverseMessages
, unreverseMessages
-- * Operations on Posted Messages
, splitMessages
, splitMessagesOn
, splitRetrogradeMessagesOn
, findMessage
, getNextPostId
, getPrevPostId
, getEarliestPostMsg
, getLatestPostMsg
, findLatestUserMessage
-- * Operations on any Message type
, messagesAfter
, removeMatchesFromSubset
, withFirstMessage
)
where
import Cheapskate (Blocks)
import qualified Data.Map.Strict as Map
import Data.Sequence as Seq
import Data.Tuple
import Lens.Micro.Platform (makeLenses)
import Network.Mattermost.Types (ChannelId, PostId, Post, ServerTime, UserId)
import Types.DirectionalSeq
import Types.Posts
import Prelude ()
import Prelude.MH
-- ----------------------------------------------------------------------
-- * Messages
-- | 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
, _mUser :: UserRef
, _mDate :: ServerTime
, _mType :: MessageType
, _mPending :: Bool
, _mDeleted :: Bool
, _mAttachments :: Seq Attachment
, _mInReplyToMsg :: ReplyState
, _mPostId :: Maybe PostId
, _mReactions :: Map.Map Text Int
, _mOriginalPost :: Maybe Post
, _mFlagged :: Bool
, _mChannelId :: Maybe ChannelId
} deriving (Show)
isDeletable :: Message -> Bool
isDeletable m = _mType m `elem` [CP NormalPost, CP Emote]
isReplyable :: Message -> Bool
isReplyable m = _mType m `elem` [CP NormalPost, CP Emote]
isEditable :: Message -> Bool
isEditable 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)
-- | 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)
, _mUser = NoUser
, _mDate = cm^.cmDate
, _mType = C $ cm^.cmType
, _mPending = False
, _mDeleted = False
, _mAttachments = Seq.empty
, _mInReplyToMsg = NotAReply
, _mPostId = Nothing
, _mReactions = Map.empty
, _mOriginalPost = Nothing
, _mFlagged = False
, _mChannelId = Nothing
}
newMessageOfType :: Text -> MessageType -> ServerTime -> Message
newMessageOfType text typ d = Message
{ _mText = getBlocks text
, _mUser = NoUser
, _mDate = d
, _mType = typ
, _mPending = False
, _mDeleted = False
, _mAttachments = Seq.empty
, _mInReplyToMsg = NotAReply
, _mPostId = 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^.mPostId == l^.mPostId && isJust (m^.mPostId)
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^.mPostId == c^.mPostId && isJust (c^.mPostId)
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 PostId and returns a tuple where the
-- first element is the Message associated with the PostId (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 PostId 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 PostId
-> Messages
-> (Maybe Message, (RetrogradeMessages, Messages))
splitMessages pid msgs = splitMessagesOn (\m -> isJust pid && m^.mPostId == pid) 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 :: PostId -> Messages -> Maybe Message
findMessage pid msgs =
findIndexR (\m -> m^.mPostId == Just pid) (dseq msgs)
>>= Just . Seq.index (dseq msgs)
-- | Look forward for the first Message that corresponds to a user
-- Post (i.e. has a post ID) that follows the specified PostId
getNextPostId :: Maybe PostId -> Messages -> Maybe PostId
getNextPostId = getRelPostId foldl
-- | Look backwards for the first Message that corresponds to a user
-- Post (i.e. has a post ID) that comes before the specified PostId.
getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId
getPrevPostId = getRelPostId $ foldr . flip
-- | 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 -> (getLatestPostMsg msgs >>= _mPostId)
Just p -> either (const Nothing) id . folD fnd (Left p)
where fnd = either fndp fndnext
fndp c v = if v^.mPostId == Just c then Right Nothing else Left c
idOfPost m = if m^.mDeleted then Nothing else m^.mPostId
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 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 = isJust (m^.mPostId) && not (m^.mDeleted)
-- ----------------------------------------------------------------------
-- * 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 PostId, 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 PostId -> Maybe PostId
-> Messages -> (Messages, Messages)
removeMatchesFromSubset matching firstId lastId msgs =
let knownIds = fmap (^.mPostId) msgs
in if isNothing firstId && isNothing lastId
then swap $ dirSeqPartition matching msgs
else if isJust firstId && firstId `elem` knownIds
then onDirSeqSubset
(\m -> m^.mPostId == firstId)
(if isJust lastId then \m -> m^.mPostId == lastId else const False)
(swap . dirSeqPartition matching) msgs
else if isJust lastId && lastId `elem` knownIds
then onDirSeqSubset
(const True)
(\m -> m^.mPostId == 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