module Matterhorn.State.Reactions
  ( asyncFetchReactionsForPost
  , addReactions
  , removeReaction
  , updateReaction
  , toggleReaction
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Data.Map.Strict as Map
import           Lens.Micro.Platform
import qualified Data.Set as S

import           Network.Mattermost.Endpoints
import           Network.Mattermost.Lenses
import           Network.Mattermost.Types

import           Matterhorn.State.Async
import           Matterhorn.State.Common
import           Matterhorn.Types


-- | Queue up a fetch for the reactions of the specified post in the
-- specified channel.
asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()
asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()
asyncFetchReactionsForPost ChannelId
cId Post
p
  | Bool -> Bool
not (Post
pPost -> Getting Bool Post Bool -> Bool
forall s a. s -> Getting a s a -> a
^.Getting Bool Post Bool
Lens' Post Bool
postHasReactionsL) = () -> MH ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise = DoAsyncChannelMM [Reaction]
forall a. DoAsyncChannelMM a
doAsyncChannelMM AsyncPriority
Normal ChannelId
cId
        (\Session
s ChannelId
_ -> (Seq Reaction -> [Reaction]) -> IO (Seq Reaction) -> IO [Reaction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Seq Reaction -> [Reaction]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PostId -> Session -> IO (Seq Reaction)
mmGetReactionsForPost (Post
pPost -> Getting PostId Post PostId -> PostId
forall s a. s -> Getting a s a -> a
^.Getting PostId Post PostId
Lens' Post PostId
postIdL) Session
s))
        (\ChannelId
_ [Reaction]
rs -> MH () -> Maybe (MH ())
forall a. a -> Maybe a
Just (MH () -> Maybe (MH ())) -> MH () -> Maybe (MH ())
forall a b. (a -> b) -> a -> b
$ ChannelId -> [Reaction] -> MH ()
addReactions ChannelId
cId [Reaction]
rs)

-- | Add the specified reactions returned by the server to the relevant
-- posts in the specified channel. This should only be called in
-- response to a server API request or event. If you want to add
-- reactions to a post, start by calling @mmPostReaction@. We also
-- invalidate the cache for any rendered message corresponding to the
-- incoming reactions.
addReactions :: ChannelId -> [Reaction] -> MH ()
addReactions :: ChannelId -> [Reaction] -> MH ()
addReactions ChannelId
cId [Reaction]
rs = do
    ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cId
    ChannelId -> Traversal' ChatState Messages
csChannelMessages(ChannelId
cId) ((Messages -> Identity Messages)
 -> ChatState -> Identity ChatState)
-> (Messages -> Messages) -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Message -> Message) -> Messages -> Messages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message -> Message
upd

    -- Also update any open thread for the corresponding channel's team
    ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel ChannelId
cId ((ClientChannel -> MH ()) -> MH ())
-> (ClientChannel -> MH ()) -> MH ()
forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan -> do
        case ClientChannel
chanClientChannel
-> Getting (Maybe TeamId) ClientChannel (Maybe TeamId)
-> Maybe TeamId
forall s a. s -> Getting a s a -> a
^.(ChannelInfo -> Const (Maybe TeamId) ChannelInfo)
-> ClientChannel -> Const (Maybe TeamId) ClientChannel
Lens' ClientChannel ChannelInfo
ccInfo((ChannelInfo -> Const (Maybe TeamId) ChannelInfo)
 -> ClientChannel -> Const (Maybe TeamId) ClientChannel)
-> ((Maybe TeamId -> Const (Maybe TeamId) (Maybe TeamId))
    -> ChannelInfo -> Const (Maybe TeamId) ChannelInfo)
-> Getting (Maybe TeamId) ClientChannel (Maybe TeamId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe TeamId -> Const (Maybe TeamId) (Maybe TeamId))
-> ChannelInfo -> Const (Maybe TeamId) ChannelInfo
Lens' ChannelInfo (Maybe TeamId)
cdTeamId of
            Maybe TeamId
Nothing -> () -> MH ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just TeamId
tId -> TeamId -> ChannelId -> (Messages -> Messages) -> MH ()
modifyThreadMessages TeamId
tId ChannelId
cId ((Message -> Message) -> Messages -> Messages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message -> Message
upd)

    let mentions :: Set MentionedUser
mentions = [MentionedUser] -> Set MentionedUser
forall a. Ord a => [a] -> Set a
S.fromList ([MentionedUser] -> Set MentionedUser)
-> [MentionedUser] -> Set MentionedUser
forall a b. (a -> b) -> a -> b
$ UserId -> MentionedUser
UserIdMention (UserId -> MentionedUser)
-> (Reaction -> UserId) -> Reaction -> MentionedUser
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Reaction -> UserId
reactionUserId (Reaction -> MentionedUser) -> [Reaction] -> [MentionedUser]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Reaction]
rs
    Set MentionedUser -> MH ()
fetchMentionedUsers Set MentionedUser
mentions
    MH ()
invalidateRenderCache
  where upd :: Message -> Message
upd Message
msg = Message
msg Message -> (Message -> Message) -> Message
forall a b. a -> (a -> b) -> b
& (Map Text (Set UserId) -> Identity (Map Text (Set UserId)))
-> Message -> Identity Message
Lens' Message (Map Text (Set UserId))
mReactions ((Map Text (Set UserId) -> Identity (Map Text (Set UserId)))
 -> Message -> Identity Message)
-> (Map Text (Set UserId) -> Map Text (Set UserId))
-> Message
-> Message
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Maybe MessageId -> Map Text (Set UserId) -> Map Text (Set UserId)
insertAll (Message
msgMessage
-> Getting (Maybe MessageId) Message (Maybe MessageId)
-> Maybe MessageId
forall s a. s -> Getting a s a -> a
^.Getting (Maybe MessageId) Message (Maybe MessageId)
Lens' Message (Maybe MessageId)
mMessageId)
        insert :: Maybe MessageId
-> Reaction -> Map Text (Set UserId) -> Map Text (Set UserId)
insert Maybe MessageId
mId Reaction
r
          | Maybe MessageId
mId Maybe MessageId -> Maybe MessageId -> Bool
forall a. Eq a => a -> a -> Bool
== MessageId -> Maybe MessageId
forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId (Reaction
rReaction -> Getting PostId Reaction PostId -> PostId
forall s a. s -> Getting a s a -> a
^.Getting PostId Reaction PostId
Lens' Reaction PostId
reactionPostIdL)) =
              (Set UserId -> Set UserId -> Set UserId)
-> Text
-> Set UserId
-> Map Text (Set UserId)
-> Map Text (Set UserId)
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Set UserId -> Set UserId -> Set UserId
forall a. Ord a => Set a -> Set a -> Set a
S.union (Reaction
rReaction -> Getting Text Reaction Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Reaction Text
Lens' Reaction Text
reactionEmojiNameL) (UserId -> Set UserId
forall a. a -> Set a
S.singleton (UserId -> Set UserId) -> UserId -> Set UserId
forall a b. (a -> b) -> a -> b
$ Reaction
rReaction -> Getting UserId Reaction UserId -> UserId
forall s a. s -> Getting a s a -> a
^.Getting UserId Reaction UserId
Lens' Reaction UserId
reactionUserIdL)
          | Bool
otherwise = Map Text (Set UserId) -> Map Text (Set UserId)
forall a. a -> a
id
        insertAll :: Maybe MessageId -> Map Text (Set UserId) -> Map Text (Set UserId)
insertAll Maybe MessageId
mId Map Text (Set UserId)
msg = (Reaction -> Map Text (Set UserId) -> Map Text (Set UserId))
-> Map Text (Set UserId) -> [Reaction] -> Map Text (Set UserId)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Maybe MessageId
-> Reaction -> Map Text (Set UserId) -> Map Text (Set UserId)
insert Maybe MessageId
mId) Map Text (Set UserId)
msg [Reaction]
rs
        invalidateRenderCache :: MH ()
invalidateRenderCache = do
            [Reaction] -> (Reaction -> MH ()) -> MH ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Reaction]
rs ((Reaction -> MH ()) -> MH ()) -> (Reaction -> MH ()) -> MH ()
forall a b. (a -> b) -> a -> b
$ \Reaction
r ->
                PostId -> MH ()
invalidateMessageRenderingCacheByPostId (PostId -> MH ()) -> PostId -> MH ()
forall a b. (a -> b) -> a -> b
$ Reaction
rReaction -> Getting PostId Reaction PostId -> PostId
forall s a. s -> Getting a s a -> a
^.Getting PostId Reaction PostId
Lens' Reaction PostId
reactionPostIdL

-- | Remove the specified reaction from its message in the specified
-- channel. This should only be called in response to a server event
-- instructing us to remove the reaction. If you want to trigger such an
-- event, use @updateReaction@. We also invalidate the cache for any
-- rendered message corresponding to the removed reaction.
removeReaction :: Reaction -> ChannelId -> MH ()
removeReaction :: Reaction -> ChannelId -> MH ()
removeReaction Reaction
r ChannelId
cId = do
    ChannelId -> MH ()
invalidateChannelRenderingCache ChannelId
cId
    ChannelId -> Traversal' ChatState Messages
csChannelMessages(ChannelId
cId) ((Messages -> Identity Messages)
 -> ChatState -> Identity ChatState)
-> (Messages -> Messages) -> MH ()
forall s (m :: * -> *) a b.
MonadState s m =>
ASetter s s a b -> (a -> b) -> m ()
%= (Message -> Message) -> Messages -> Messages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message -> Message
upd

    -- Also update any open thread for the corresponding channel's team
    ChannelId -> (ClientChannel -> MH ()) -> MH ()
withChannel ChannelId
cId ((ClientChannel -> MH ()) -> MH ())
-> (ClientChannel -> MH ()) -> MH ()
forall a b. (a -> b) -> a -> b
$ \ClientChannel
chan -> do
        case ClientChannel
chanClientChannel
-> Getting (Maybe TeamId) ClientChannel (Maybe TeamId)
-> Maybe TeamId
forall s a. s -> Getting a s a -> a
^.(ChannelInfo -> Const (Maybe TeamId) ChannelInfo)
-> ClientChannel -> Const (Maybe TeamId) ClientChannel
Lens' ClientChannel ChannelInfo
ccInfo((ChannelInfo -> Const (Maybe TeamId) ChannelInfo)
 -> ClientChannel -> Const (Maybe TeamId) ClientChannel)
-> ((Maybe TeamId -> Const (Maybe TeamId) (Maybe TeamId))
    -> ChannelInfo -> Const (Maybe TeamId) ChannelInfo)
-> Getting (Maybe TeamId) ClientChannel (Maybe TeamId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Maybe TeamId -> Const (Maybe TeamId) (Maybe TeamId))
-> ChannelInfo -> Const (Maybe TeamId) ChannelInfo
Lens' ChannelInfo (Maybe TeamId)
cdTeamId of
            Maybe TeamId
Nothing -> () -> MH ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            Just TeamId
tId -> TeamId -> ChannelId -> (Messages -> Messages) -> MH ()
modifyThreadMessages TeamId
tId ChannelId
cId ((Message -> Message) -> Messages -> Messages
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Message -> Message
upd)

    MH ()
invalidateRenderCache
  where upd :: Message -> Message
upd Message
m | Message
mMessage
-> Getting (Maybe MessageId) Message (Maybe MessageId)
-> Maybe MessageId
forall s a. s -> Getting a s a -> a
^.Getting (Maybe MessageId) Message (Maybe MessageId)
Lens' Message (Maybe MessageId)
mMessageId Maybe MessageId -> Maybe MessageId -> Bool
forall a. Eq a => a -> a -> Bool
== MessageId -> Maybe MessageId
forall a. a -> Maybe a
Just (PostId -> MessageId
MessagePostId (PostId -> MessageId) -> PostId -> MessageId
forall a b. (a -> b) -> a -> b
$ Reaction
rReaction -> Getting PostId Reaction PostId -> PostId
forall s a. s -> Getting a s a -> a
^.Getting PostId Reaction PostId
Lens' Reaction PostId
reactionPostIdL) =
                  Message
m Message -> (Message -> Message) -> Message
forall a b. a -> (a -> b) -> b
& (Map Text (Set UserId) -> Identity (Map Text (Set UserId)))
-> Message -> Identity Message
Lens' Message (Map Text (Set UserId))
mReactions ((Map Text (Set UserId) -> Identity (Map Text (Set UserId)))
 -> Message -> Identity Message)
-> (Map Text (Set UserId) -> Map Text (Set UserId))
-> Message
-> Message
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ((Maybe (Set UserId) -> Maybe (Set UserId))
-> Text -> Map Text (Set UserId) -> Map Text (Set UserId)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Set UserId) -> Maybe (Set UserId)
forall (f :: * -> *). Functor f => f (Set UserId) -> f (Set UserId)
delReaction (Reaction
rReaction -> Getting Text Reaction Text -> Text
forall s a. s -> Getting a s a -> a
^.Getting Text Reaction Text
Lens' Reaction Text
reactionEmojiNameL))
              | Bool
otherwise = Message
m
        delReaction :: f (Set UserId) -> f (Set UserId)
delReaction f (Set UserId)
mUs = UserId -> Set UserId -> Set UserId
forall a. Ord a => a -> Set a -> Set a
S.delete (Reaction
rReaction -> Getting UserId Reaction UserId -> UserId
forall s a. s -> Getting a s a -> a
^.Getting UserId Reaction UserId
Lens' Reaction UserId
reactionUserIdL) (Set UserId -> Set UserId) -> f (Set UserId) -> f (Set UserId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Set UserId)
mUs
        invalidateRenderCache :: MH ()
invalidateRenderCache =
            PostId -> MH ()
invalidateMessageRenderingCacheByPostId (PostId -> MH ()) -> PostId -> MH ()
forall a b. (a -> b) -> a -> b
$ Reaction
rReaction -> Getting PostId Reaction PostId -> PostId
forall s a. s -> Getting a s a -> a
^.Getting PostId Reaction PostId
Lens' Reaction PostId
reactionPostIdL

-- | Set or unset a reaction on a post.
updateReaction :: PostId -> Text -> Bool -> MH ()
updateReaction :: PostId -> Text -> Bool -> MH ()
updateReaction PostId
pId Text
text Bool
value = do
    Session
session <- MH Session
getSession
    UserId
myId <- (ChatState -> UserId) -> MH UserId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ChatState -> UserId
myUserId
    if Bool
value
      then AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
forall a b. (a -> b) -> a -> b
$ do
                PostId -> UserId -> Text -> Session -> IO ()
mmPostReaction PostId
pId UserId
myId Text
text Session
session
                Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing
      else AsyncPriority -> IO (Maybe (MH ())) -> MH ()
doAsyncWith AsyncPriority
Preempt (IO (Maybe (MH ())) -> MH ()) -> IO (Maybe (MH ())) -> MH ()
forall a b. (a -> b) -> a -> b
$ do
                PostId -> UserId -> Text -> Session -> IO ()
mmDeleteReaction PostId
pId UserId
myId Text
text Session
session
                Maybe (MH ()) -> IO (Maybe (MH ()))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (MH ())
forall a. Maybe a
Nothing

-- | Toggle a reaction on a post.
toggleReaction :: PostId -> Text -> Set UserId -> MH ()
toggleReaction :: PostId -> Text -> Set UserId -> MH ()
toggleReaction PostId
pId Text
text Set UserId
uIds = do
    UserId
myId <- (ChatState -> UserId) -> MH UserId
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ChatState -> UserId
myUserId
    let current :: Bool
current = UserId
myId UserId -> Set UserId -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set UserId
uIds
    PostId -> Text -> Bool -> MH ()
updateReaction PostId
pId Text
text (Bool -> Bool
not Bool
current)