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