1module Matterhorn.State.Flagging
2  ( loadFlaggedMessages
3  , updateMessageFlag
4  )
5where
6
7import           Prelude ()
8import           Matterhorn.Prelude
9
10import           Data.Function ( on )
11import qualified Data.Set as Set
12import qualified Data.HashMap.Strict as HM
13import           Lens.Micro.Platform
14
15import           Network.Mattermost.Types
16
17import           Matterhorn.State.Common
18import           Matterhorn.Types
19
20
21loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO ()
22loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do
23  return $ Just $ do
24      sequence_ [ updateMessageFlag (flaggedPostId fp) True
25                | fp <- toList prefs
26                , flaggedPostStatus fp
27                ]
28
29
30-- | Update the UI to reflect the flagged/unflagged state of a
31-- message. This __does not__ talk to the Mattermost server, but
32-- rather is the function we call when the Mattermost server notifies
33-- us of flagged or unflagged messages.
34updateMessageFlag :: PostId -> Bool -> MH ()
35updateMessageFlag pId f = do
36  if f
37    then csResources.crFlaggedPosts %= Set.insert pId
38    else csResources.crFlaggedPosts %= Set.delete pId
39  msgMb <- use (csPostMap.at(pId))
40  case msgMb of
41    Just msg
42      | Just cId <- msg^.mChannelId -> withChannel cId $ \chan -> do
43      let isTargetMessage m = m^.mMessageId == Just (MessagePostId pId)
44      csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f
45      csPostMap.ix(pId).mFlagged .= f
46
47      let mTId = chan^.ccInfo.cdTeamId
48          updatePostOverlay :: TeamId -> MH ()
49          updatePostOverlay tId = do
50              -- We also want to update the post overlay if this happens
51              -- while we're we're observing it
52              mode <- use (csTeam tId.tsMode)
53              case mode of
54                PostListOverlay PostListFlagged
55                  | f ->
56                      csTeam tId.tsPostListOverlay.postListPosts %=
57                        addMessage (msg & mFlagged .~ True)
58
59                  -- deleting here is tricky, because it means that we
60                  -- need to move the focus somewhere: we'll try moving
61                  -- it _up_ unless we can't, in which case we'll try
62                  -- moving it down.
63                  | otherwise -> do
64                      selId <- use (csTeam tId.tsPostListOverlay.postListSelected)
65                      posts <- use (csTeam tId.tsPostListOverlay.postListPosts)
66                      let nextId = case getNextPostId selId posts of
67                            Nothing -> getPrevPostId selId posts
68                            Just x  -> Just x
69                      csTeam tId.tsPostListOverlay.postListSelected .= nextId
70                      csTeam tId.tsPostListOverlay.postListPosts %=
71                        filterMessages (((/=) `on` _mMessageId) msg)
72                _ -> return ()
73
74      case mTId of
75          Nothing -> do
76              ts <- use csTeams
77              forM_ (HM.keys ts) updatePostOverlay
78          Just tId -> updatePostOverlay tId
79
80    _ -> return ()
81