1module Matterhorn.State.MessageSelect
2  (
3  -- * Message selection mode
4    beginMessageSelect
5  , flagSelectedMessage
6  , pinSelectedMessage
7  , viewSelectedMessage
8  , fillSelectedGap
9  , yankSelectedMessageVerbatim
10  , yankSelectedMessage
11  , openSelectedMessageURLs
12  , beginConfirmDeleteSelectedMessage
13  , messageSelectUp
14  , messageSelectUpBy
15  , messageSelectDown
16  , messageSelectDownBy
17  , messageSelectFirst
18  , messageSelectLast
19  , deleteSelectedMessage
20  , beginReplyCompose
21  , beginEditMessage
22  , flagMessage
23  , getSelectedMessage
24  )
25where
26
27import           Prelude ()
28import           Matterhorn.Prelude
29
30import           Brick ( invalidateCache )
31import           Brick.Widgets.Edit ( applyEdit )
32import           Data.Text.Zipper ( clearZipper, insertMany )
33import           Lens.Micro.Platform
34
35import qualified Network.Mattermost.Endpoints as MM
36import           Network.Mattermost.Types
37
38import           Matterhorn.Clipboard ( copyToClipboard )
39import           Matterhorn.State.Common
40import           Matterhorn.State.Links
41import           Matterhorn.State.Messages
42import           Matterhorn.Types
43import           Matterhorn.Types.RichText ( findVerbatimChunk )
44import           Matterhorn.Types.Common
45import           Matterhorn.Windows.ViewMessage
46
47
48-- | In these modes, we allow access to the selected message state.
49messageSelectCompatibleModes :: [Mode]
50messageSelectCompatibleModes =
51    [ MessageSelect
52    , MessageSelectDeleteConfirm
53    , ReactionEmojiListOverlay
54    ]
55
56getSelectedMessage :: ChatState -> Maybe Message
57getSelectedMessage st
58    | not (st^.csCurrentTeam.tsMode `elem` messageSelectCompatibleModes) = Nothing
59    | otherwise = do
60        selMsgId <- selectMessageId $ st^.csCurrentTeam.tsMessageSelect
61        let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages
62        findMessage selMsgId chanMsgs
63
64beginMessageSelect :: MH ()
65beginMessageSelect = do
66    -- Invalidate the rendering cache since we cache messages to speed
67    -- up the selection UI responsiveness. (See Draw.Messages for
68    -- caching behavior.)
69    mh invalidateCache
70
71    -- Get the number of messages in the current channel and set the
72    -- currently selected message index to be the most recently received
73    -- message that corresponds to a Post (i.e. exclude informative
74    -- messages).
75    --
76    -- If we can't find one at all, we ignore the mode switch request
77    -- and just return.
78    chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)
79    let recentMsg = getLatestSelectableMessage chanMsgs
80
81    when (isJust recentMsg) $ do
82        setMode MessageSelect
83        csCurrentTeam.tsMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId)
84
85-- | Tell the server that the message we currently have selected
86-- should have its flagged state toggled.
87flagSelectedMessage :: MH ()
88flagSelectedMessage = do
89  selected <- use (to getSelectedMessage)
90  case selected of
91    Just msg
92      | isFlaggable msg, Just pId <- messagePostId msg ->
93        flagMessage pId (not (msg^.mFlagged))
94    _        -> return ()
95
96-- | Tell the server that the message we currently have selected
97-- should have its pinned state toggled.
98pinSelectedMessage :: MH ()
99pinSelectedMessage = do
100  selected <- use (to getSelectedMessage)
101  case selected of
102    Just msg
103      | isPinnable msg, Just pId <- messagePostId msg ->
104        pinMessage pId (not (msg^.mPinned))
105    _ -> return ()
106
107viewSelectedMessage :: MH ()
108viewSelectedMessage = do
109  selected <- use (to getSelectedMessage)
110  case selected of
111    Just msg
112      | not (isGap msg) -> viewMessage msg
113    _        -> return ()
114
115fillSelectedGap :: MH ()
116fillSelectedGap = do
117  selected <- use (to getSelectedMessage)
118  case selected of
119    Just msg
120      | isGap msg -> do tId <- use csCurrentTeamId
121                        cId <- use (csCurrentChannelId tId)
122                        asyncFetchMessagesForGap cId msg
123    _        -> return ()
124
125viewMessage :: Message -> MH ()
126viewMessage m = do
127    tId <- use csCurrentTeamId
128    let w = tabbedWindow VMTabMessage (viewMessageWindowTemplate tId) MessageSelect (78, 25)
129    csCurrentTeam.tsViewedMessage .= Just (m, w)
130    runTabShowHandlerFor (twValue w) w
131    setMode ViewMessage
132
133yankSelectedMessageVerbatim :: MH ()
134yankSelectedMessageVerbatim = do
135    selectedMessage <- use (to getSelectedMessage)
136    case selectedMessage of
137        Nothing -> return ()
138        Just m -> do
139            setMode Main
140            case findVerbatimChunk (m^.mText) of
141                Just txt -> copyToClipboard txt
142                Nothing  -> return ()
143
144yankSelectedMessage :: MH ()
145yankSelectedMessage = do
146    selectedMessage <- use (to getSelectedMessage)
147    case selectedMessage of
148        Nothing -> return ()
149        Just m -> do
150            setMode Main
151            copyToClipboard $ m^.mMarkdownSource
152
153openSelectedMessageURLs :: MH ()
154openSelectedMessageURLs = whenMode MessageSelect $ do
155    mCurMsg <- use (to getSelectedMessage)
156    curMsg <- case mCurMsg of
157        Nothing -> error "BUG: openSelectedMessageURLs: no selected message available"
158        Just m -> return m
159
160    let urls = msgURLs curMsg
161    when (not (null urls)) $ do
162        openedAll <- and <$> mapM (openLinkTarget . _linkTarget) urls
163        case openedAll of
164            True -> return ()
165            False ->
166                mhError $ ConfigOptionMissing "urlOpenCommand"
167
168beginConfirmDeleteSelectedMessage :: MH ()
169beginConfirmDeleteSelectedMessage = do
170    st <- use id
171    selected <- use (to getSelectedMessage)
172    case selected of
173        Just msg | isDeletable msg && isMine st msg ->
174            setMode MessageSelectDeleteConfirm
175        _ -> return ()
176
177messageSelectUp :: MH ()
178messageSelectUp = do
179    mode <- use (csCurrentTeam.tsMode)
180    selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId)
181    case selected of
182        Just _ | mode == MessageSelect -> do
183            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
184            let nextMsgId = getPrevMessageId selected chanMsgs
185            csCurrentTeam.tsMessageSelect .= MessageSelectState (nextMsgId <|> selected)
186        _ -> return ()
187
188messageSelectDown :: MH ()
189messageSelectDown = do
190    selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId)
191    case selected of
192        Just _ -> whenMode MessageSelect $ do
193            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
194            let nextMsgId = getNextMessageId selected chanMsgs
195            csCurrentTeam.tsMessageSelect .= MessageSelectState (nextMsgId <|> selected)
196        _ -> return ()
197
198messageSelectDownBy :: Int -> MH ()
199messageSelectDownBy amt
200    | amt <= 0 = return ()
201    | otherwise =
202        messageSelectDown >> messageSelectDownBy (amt - 1)
203
204messageSelectUpBy :: Int -> MH ()
205messageSelectUpBy amt
206    | amt <= 0 = return ()
207    | otherwise =
208      messageSelectUp >> messageSelectUpBy (amt - 1)
209
210messageSelectFirst :: MH ()
211messageSelectFirst = do
212    selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId)
213    case selected of
214        Just _ -> whenMode MessageSelect $ do
215            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
216            case getEarliestSelectableMessage chanMsgs of
217              Just firstMsg ->
218                csCurrentTeam.tsMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)
219              Nothing -> mhLog LogError "No first message found from current message?!"
220        _ -> return ()
221
222messageSelectLast :: MH ()
223messageSelectLast = do
224    selected <- use (csCurrentTeam.tsMessageSelect.to selectMessageId)
225    case selected of
226        Just _ -> whenMode MessageSelect $ do
227            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)
228            case getLatestSelectableMessage chanMsgs of
229              Just lastSelMsg ->
230                csCurrentTeam.tsMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)
231              Nothing -> mhLog LogError "No last message found from current message?!"
232        _ -> return ()
233
234deleteSelectedMessage :: MH ()
235deleteSelectedMessage = do
236    selectedMessage <- use (to getSelectedMessage)
237    st <- use id
238    tId <- use csCurrentTeamId
239    cId <- use (csCurrentChannelId tId)
240    case selectedMessage of
241        Just msg | isMine st msg && isDeletable msg ->
242            case msg^.mOriginalPost of
243              Just p ->
244                  doAsyncChannelMM Preempt cId
245                      (\s _ -> MM.mmDeletePost (postId p) s)
246                      (\_ _ -> Just $ do
247                          csCurrentTeam.tsEditState.cedEditMode .= NewPost
248                          setMode Main)
249              Nothing -> return ()
250        _ -> return ()
251
252beginReplyCompose :: MH ()
253beginReplyCompose = do
254    selected <- use (to getSelectedMessage)
255    case selected of
256        Just msg | isReplyable msg -> do
257            rootMsg <- getReplyRootMessage msg
258            let Just p = rootMsg^.mOriginalPost
259            setMode Main
260            csCurrentTeam.tsEditState.cedEditMode .= Replying rootMsg p
261        _ -> return ()
262
263beginEditMessage :: MH ()
264beginEditMessage = do
265    selected <- use (to getSelectedMessage)
266    st <- use id
267    case selected of
268        Just msg | isMine st msg && isEditable msg -> do
269            let Just p = msg^.mOriginalPost
270            setMode Main
271            csCurrentTeam.tsEditState.cedEditMode .= Editing p (msg^.mType)
272            -- If the post that we're editing is an emote, we need
273            -- to strip the formatting because that's only there to
274            -- indicate that the post is an emote. This is annoying and
275            -- can go away one day when there is an actual post type
276            -- value of "emote" that we can look at. Note that the
277            -- removed formatting needs to be reinstated just prior to
278            -- issuing the API call to update the post.
279            let sanitized = sanitizeUserText $ postMessage p
280            let toEdit = if isEmote msg
281                         then removeEmoteFormatting sanitized
282                         else sanitized
283            csCurrentTeam.tsEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper)
284        _ -> return ()
285
286-- | Tell the server that we have flagged or unflagged a message.
287flagMessage :: PostId -> Bool -> MH ()
288flagMessage pId f = do
289  session <- getSession
290  myId <- gets myUserId
291  doAsyncWith Normal $ do
292    let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost
293    doFlag myId pId session
294    return Nothing
295
296-- | Tell the server that we have pinned or unpinned a message.
297pinMessage :: PostId -> Bool -> MH ()
298pinMessage pId f = do
299  session <- getSession
300  doAsyncWith Normal $ do
301    let doPin = if f then MM.mmPinPostToChannel else MM.mmUnpinPostToChannel
302    void $ doPin pId session
303    return Nothing
304