1{-# LANGUAGE LambdaCase #-} 2{-# LANGUAGE MultiWayIf #-} 3module Matterhorn.State.Channels 4 ( updateViewed 5 , refreshChannel 6 , refreshChannelsAndUsers 7 , setFocus 8 , refreshChannelById 9 , applyPreferenceChange 10 , leaveChannel 11 , leaveCurrentChannel 12 , getNextUnreadChannel 13 , getNextUnreadUserOrChannel 14 , nextUnreadChannel 15 , nextUnreadUserOrChannel 16 , createOrFocusDMChannel 17 , prevChannel 18 , nextChannel 19 , recentChannel 20 , setReturnChannel 21 , resetReturnChannel 22 , hideDMChannel 23 , createGroupChannel 24 , showGroupChannelPref 25 , channelHistoryForward 26 , channelHistoryBackward 27 , handleNewChannel 28 , createOrdinaryChannel 29 , handleChannelInvite 30 , addUserByNameToCurrentChannel 31 , addUserToCurrentChannel 32 , removeUserFromCurrentChannel 33 , removeChannelFromState 34 , isRecentChannel 35 , isReturnChannel 36 , isCurrentChannel 37 , deleteCurrentChannel 38 , startLeaveCurrentChannel 39 , joinChannel 40 , joinChannel' 41 , joinChannelByName 42 , changeChannelByName 43 , setChannelTopic 44 , getCurrentChannelTopic 45 , beginCurrentChannelDeleteConfirm 46 , toggleExpandedChannelTopics 47 , updateChannelNotifyProps 48 , renameChannelUrl 49 , toggleChannelFavoriteStatus 50 ) 51where 52 53import Prelude () 54import Matterhorn.Prelude 55 56import Brick.Main ( viewportScroll, vScrollToBeginning 57 , invalidateCache, invalidateCacheEntry ) 58import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL ) 59import Control.Concurrent.Async ( runConcurrently, Concurrently(..) ) 60import Control.Exception ( SomeException, try ) 61import Data.Char ( isAlphaNum ) 62import qualified Data.HashMap.Strict as HM 63import qualified Data.Foldable as F 64import Data.List ( nub ) 65import Data.Maybe ( fromJust ) 66import qualified Data.Set as S 67import qualified Data.Sequence as Seq 68import qualified Data.Text as T 69import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL ) 70import Data.Time.Clock ( getCurrentTime ) 71import Lens.Micro.Platform 72 73import qualified Network.Mattermost.Endpoints as MM 74import Network.Mattermost.Lenses 75import Network.Mattermost.Types 76 77import Matterhorn.Constants ( normalChannelSigil ) 78import Matterhorn.InputHistory 79import Matterhorn.State.Common 80import {-# SOURCE #-} Matterhorn.State.Messages ( fetchVisibleIfNeeded ) 81import Matterhorn.State.ChannelList 82import Matterhorn.State.Users 83import Matterhorn.State.Flagging 84import Matterhorn.Types 85import Matterhorn.Types.Common 86import Matterhorn.Zipper ( Zipper ) 87import qualified Matterhorn.Zipper as Z 88 89 90updateViewed :: Bool -> MH () 91updateViewed updatePrev = do 92 csCurrentChannel.ccInfo.cdMentionCount .= 0 93 tId <- use csCurrentTeamId 94 updateViewedChan updatePrev =<< use (csCurrentChannelId tId) 95 96-- | When a new channel has been selected for viewing, this will 97-- notify the server of the change, and also update the local channel 98-- state to set the last-viewed time for the previous channel and 99-- update the viewed time to now for the newly selected channel. 100-- 101-- The boolean argument indicates whether the view time of the previous 102-- channel (if any) should be updated, too. We typically want to do that 103-- only on channel switching; when we just want to update the view time 104-- of the specified channel, False should be provided. 105updateViewedChan :: Bool -> ChannelId -> MH () 106updateViewedChan updatePrev cId = use csConnectionStatus >>= \case 107 -- Only do this if we're connected to avoid triggering noisy 108 -- exceptions. 109 Connected -> do 110 withChannel cId $ \chan -> do 111 pId <- if updatePrev 112 then do 113 case chan^.ccInfo.cdTeamId of 114 Just tId -> use (csTeam(tId).tsRecentChannel) 115 Nothing -> use (csCurrentTeam.tsRecentChannel) 116 else return Nothing 117 doAsyncChannelMM Preempt cId 118 (\s c -> MM.mmViewChannel UserMe c pId s) 119 (\c () -> Just $ setLastViewedFor pId c) 120 Disconnected -> 121 -- Cannot update server; make no local updates to avoid getting 122 -- out of sync with the server. Assumes that this is a temporary 123 -- break in connectivity and that after the connection is 124 -- restored, the user's normal activities will update state as 125 -- appropriate. If connectivity is permanently lost, managing 126 -- this state is irrelevant. 127 return () 128 129toggleExpandedChannelTopics :: MH () 130toggleExpandedChannelTopics = do 131 mh invalidateCache 132 csResources.crConfiguration.configShowExpandedChannelTopicsL %= not 133 134-- | If the current channel is a DM channel with a single user or a 135-- group of users, hide it from the sidebar and adjust the server-side 136-- preference to hide it persistently. Note that this does not actually 137-- hide the channel in our UI; we hide it in response to the preference 138-- change websocket event triggered by this function's API interaction 139-- with the server. 140-- 141-- If the current channel is any other kind of channel, complain with a 142-- usage error. 143hideDMChannel :: ChannelId -> MH () 144hideDMChannel cId = do 145 me <- gets myUser 146 session <- getSession 147 withChannel cId $ \chan -> do 148 case chan^.ccInfo.cdType of 149 Direct -> do 150 let pref = showDirectChannelPref (me^.userIdL) uId False 151 Just uId = chan^.ccInfo.cdDMUserId 152 csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing 153 doAsyncWith Preempt $ do 154 MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session 155 return Nothing 156 Group -> do 157 let pref = hideGroupChannelPref cId (me^.userIdL) 158 csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing 159 doAsyncWith Preempt $ do 160 MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session 161 return Nothing 162 _ -> do 163 mhError $ GenericError "Cannot hide this channel. Consider using /leave instead." 164 165-- | Called on async completion when the currently viewed channel has 166-- been updated (i.e., just switched to this channel) to update local 167-- state. 168setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH () 169setLastViewedFor prevId cId = do 170 chan <- use (csChannels.to (findChannelById cId)) 171 -- Update new channel's viewed time, creating the channel if needed 172 case chan of 173 Nothing -> 174 -- It's possible for us to get spurious WMChannelViewed 175 -- events from the server, e.g. for channels that have been 176 -- deleted. So here we ignore the request since it's hard to 177 -- detect it before this point. 178 return () 179 Just _ -> 180 -- The server has been sent a viewed POST update, but there is 181 -- no local information on what timestamp the server actually 182 -- recorded. There are a couple of options for setting the 183 -- local value of the viewed time: 184 -- 185 -- 1. Attempting to locally construct a value, which would 186 -- involve scanning all (User) messages in the channel 187 -- to find the maximum of the created date, the modified 188 -- date, or the deleted date, and assuming that maximum 189 -- mostly matched the server's viewed time. 190 -- 191 -- 2. Issuing a channel metadata request to get the server's 192 -- new concept of the viewed time. 193 -- 194 -- 3. Having the "chan/viewed" POST that was just issued 195 -- return a value from the server. See 196 -- https://github.com/mattermost/platform/issues/6803. 197 -- 198 -- Method 3 would be the best and most lightweight. Until that 199 -- is available, Method 2 will be used. The downside to Method 200 -- 2 is additional client-server messaging, and a delay in 201 -- updating the client data, but it's also immune to any new 202 -- or removed Message date fields, or anything else that would 203 -- contribute to the viewed/updated times on the server. 204 doAsyncChannelMM Preempt cId (\ s _ -> 205 (,) <$> MM.mmGetChannel cId s 206 <*> MM.mmGetChannelMember cId UserMe s) 207 (\pcid (cwd, member) -> Just $ csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member) 208 209 -- Update the old channel's previous viewed time (allows tracking of 210 -- new messages) 211 case prevId of 212 Nothing -> return () 213 Just p -> clearChannelUnreadStatus p 214 215-- | Refresh information about all channels and users. This is usually 216-- triggered when a reconnect event for the WebSocket to the server 217-- occurs. 218refreshChannelsAndUsers :: MH () 219refreshChannelsAndUsers = do 220 session <- getSession 221 me <- gets myUser 222 knownUsers <- gets allUserIds 223 ts <- use csTeams 224 doAsyncWith Preempt $ do 225 pairs <- forM (HM.keys ts) $ \tId -> do 226 runConcurrently $ (,) 227 <$> Concurrently (MM.mmGetChannelsForUser UserMe tId session) 228 <*> Concurrently (MM.mmGetChannelMembersForUser UserMe tId session) 229 230 let (chans, datas) = (mconcat $ fst <$> pairs, mconcat $ snd <$> pairs) 231 232 -- Collect all user IDs associated with DM channels so we can 233 -- bulk-fetch their user records. 234 let dmUsers = catMaybes $ flip map (F.toList chans) $ \chan -> 235 case chan^.channelTypeL of 236 Direct -> case userIdForDMChannel (userId me) (sanitizeUserText $ channelName chan) of 237 Nothing -> Nothing 238 Just otherUserId -> Just otherUserId 239 _ -> Nothing 240 uIdsToFetch = nub $ userId me : knownUsers <> dmUsers 241 242 dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas 243 mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap) 244 chansWithData = mkPair <$> chans 245 246 return $ Just $ 247 -- Fetch user data associated with DM channels 248 handleNewUsers (Seq.fromList uIdsToFetch) $ do 249 -- Then refresh all loaded channels 250 forM_ chansWithData $ uncurry (refreshChannel SidebarUpdateDeferred) 251 updateSidebar Nothing 252 253-- | Refresh information about a specific channel. The channel 254-- metadata is refreshed, and if this is a loaded channel, the 255-- scrollback is updated as well. 256-- 257-- The sidebar update argument indicates whether this refresh should 258-- also update the sidebar. Ordinarily you want this, so pass 259-- SidebarUpdateImmediate unless you are very sure you know what you are 260-- doing, i.e., you are very sure that a call to refreshChannel will 261-- be followed immediately by a call to updateSidebar. We provide this 262-- control so that channel refreshes can be batched and then a single 263-- updateSidebar call can be used instead of the default behavior of 264-- calling it once per refreshChannel call, which is the behavior if the 265-- immediate setting is passed here. 266refreshChannel :: SidebarUpdate -> Channel -> ChannelMember -> MH () 267refreshChannel upd chan member = do 268 ts <- use csTeams 269 let ourTeams = HM.keys ts 270 isOurTeam = case channelTeamId chan of 271 Nothing -> True 272 Just tId -> tId `elem` ourTeams 273 274 case isOurTeam of 275 False -> return () 276 True -> do 277 let cId = getId chan 278 -- If this channel is unknown, register it first. 279 mChan <- preuse (csChannel(cId)) 280 when (isNothing mChan) $ 281 handleNewChannel False upd chan member 282 283 updateChannelInfo cId chan member 284 285handleNewChannel :: Bool -> SidebarUpdate -> Channel -> ChannelMember -> MH () 286handleNewChannel = handleNewChannel_ True 287 288handleNewChannel_ :: Bool 289 -- ^ Whether to permit this call to recursively 290 -- schedule itself for later if it can't locate 291 -- a DM channel user record. This is to prevent 292 -- uncontrolled recursion. 293 -> Bool 294 -- ^ Whether to switch to the new channel once it has 295 -- been installed. 296 -> SidebarUpdate 297 -- ^ Whether to update the sidebar, in case the caller 298 -- wants to batch these before updating it. Pass 299 -- SidebarUpdateImmediate unless you know what 300 -- you are doing, i.e., unless you intend to call 301 -- updateSidebar yourself after calling this. 302 -> Channel 303 -- ^ The channel to install. 304 -> ChannelMember 305 -> MH () 306handleNewChannel_ permitPostpone switch sbUpdate nc member = do 307 -- Only add the channel to the state if it isn't already known. 308 me <- gets myUser 309 mChan <- preuse (csChannel(getId nc)) 310 case mChan of 311 Just _ -> when switch $ setFocus (getId nc) 312 Nothing -> do 313 -- Create a new ClientChannel structure 314 cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$> 315 makeClientChannel (me^.userIdL) nc 316 317 st <- use id 318 319 -- Add it to the message map, and to the name map so we 320 -- can look it up by name. The name we use for the channel 321 -- depends on its type: 322 let chType = nc^.channelTypeL 323 324 -- Get the channel name. If we couldn't, that means we have 325 -- async work to do before we can register this channel (in 326 -- which case abort because we got rescheduled). 327 register <- case chType of 328 Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of 329 Nothing -> return True 330 Just otherUserId -> 331 case userById otherUserId st of 332 -- If we found a user ID in the channel 333 -- name string but don't have that user's 334 -- metadata, postpone adding this channel 335 -- until we have fetched the metadata. This 336 -- can happen when we have a channel record 337 -- for a user that is no longer in the 338 -- current team. To avoid recursion due to a 339 -- problem, ensure that the rescheduled new 340 -- channel handler is not permitted to try 341 -- this again. 342 -- 343 -- If we're already in a recursive attempt 344 -- to register this channel and still 345 -- couldn't find a username, just bail and 346 -- use the synthetic name (this has the same 347 -- problems as above). 348 Nothing -> do 349 case permitPostpone of 350 False -> return True 351 True -> do 352 mhLog LogAPI $ T.pack $ "handleNewChannel_: about to call handleNewUsers for " <> show otherUserId 353 handleNewUsers (Seq.singleton otherUserId) (return ()) 354 doAsyncWith Normal $ 355 return $ Just $ handleNewChannel_ False switch sbUpdate nc member 356 return False 357 Just _ -> return True 358 _ -> return True 359 360 when register $ do 361 csChannels %= addChannel (getId nc) cChannel 362 when (sbUpdate == SidebarUpdateImmediate) $ do 363 -- Note that we only check for whether we should 364 -- switch to this channel when doing a sidebar 365 -- update, since that's the only case where it's 366 -- possible to do so. 367 updateSidebar (cChannel^.ccInfo.cdTeamId) 368 369 -- Finally, set our focus to the newly created 370 -- channel if the caller requested a change of 371 -- channel. Also consider the last join request 372 -- state field in case this is an asynchronous 373 -- channel addition triggered by a /join. 374 pending1 <- checkPendingChannelChange (getId nc) 375 pending2 <- case cChannel^.ccInfo.cdDMUserId of 376 Nothing -> return False 377 Just uId -> checkPendingChannelChangeByUserId uId 378 379 when (switch || isJust pending1 || pending2) $ do 380 setFocus (getId nc) 381 case pending1 of 382 Just (Just act) -> act 383 _ -> return () 384 385-- | Check to see whether the specified channel has been queued up to 386-- be switched to. Note that this condition is only cleared by the 387-- actual setFocus switch to the channel because there may be multiple 388-- operations that must complete before the channel is fully ready for 389-- display/use. 390-- 391-- Returns Just if the specified channel has a pending switch. The 392-- result is an optional action to invoke after changing to the 393-- specified channel. 394checkPendingChannelChange :: ChannelId -> MH (Maybe (Maybe (MH ()))) 395checkPendingChannelChange cId = do 396 ch <- use (csCurrentTeam.tsPendingChannelChange) 397 curTid <- use csCurrentTeamId 398 return $ case ch of 399 Just (ChangeByChannelId tId i act) -> 400 if i == cId && curTid == tId then Just act else Nothing 401 _ -> Nothing 402 403-- | Check to see whether the specified channel has been queued up to 404-- be switched to. Note that this condition is only cleared by the 405-- actual setFocus switch to the channel because there may be multiple 406-- operations that must complete before the channel is fully ready for 407-- display/use. 408-- 409-- Returns Just if the specified channel has a pending switch. The 410-- result is an optional action to invoke after changing to the 411-- specified channel. 412checkPendingChannelChangeByUserId :: UserId -> MH Bool 413checkPendingChannelChangeByUserId uId = do 414 ch <- use (csCurrentTeam.tsPendingChannelChange) 415 return $ case ch of 416 Just (ChangeByUserId i) -> 417 i == uId 418 _ -> 419 False 420 421-- | Update the indicated Channel entry with the new data retrieved from 422-- the Mattermost server. Also update the channel name if it changed. 423updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH () 424updateChannelInfo cid new member = do 425 mh $ invalidateCacheEntry $ ChannelMessages cid 426 csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member 427 withChannel cid $ \chan -> 428 updateSidebar (chan^.ccInfo.cdTeamId) 429 430setFocus :: ChannelId -> MH () 431setFocus cId = do 432 showChannelInSidebar cId True 433 setFocusWith True (Z.findRight ((== cId) . channelListEntryChannelId)) (return ()) 434 435setFocusWith :: Bool 436 -> (Zipper ChannelListGroup ChannelListEntry 437 -> Zipper ChannelListGroup ChannelListEntry) 438 -> MH () 439 -> MH () 440setFocusWith updatePrev f onNoChange = do 441 tId <- use csCurrentTeamId 442 oldZipper <- use (csCurrentTeam.tsFocus) 443 let newZipper = f oldZipper 444 newFocus = Z.focus newZipper 445 oldFocus = Z.focus oldZipper 446 447 -- If we aren't changing anything, skip all the book-keeping because 448 -- we'll end up clobbering things like tsRecentChannel. 449 if newFocus /= oldFocus 450 then do 451 mh $ invalidateCacheEntry $ ChannelSidebar tId 452 resetAutocomplete 453 preChangeChannelCommon 454 csCurrentTeam.tsFocus .= newZipper 455 456 now <- liftIO getCurrentTime 457 newCid <- use (csCurrentChannelId tId) 458 csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now 459 460 updateViewed updatePrev 461 postChangeChannelCommon 462 else onNoChange 463 464postChangeChannelCommon :: MH () 465postChangeChannelCommon = do 466 resetEditorState 467 updateChannelListScroll 468 loadLastEdit 469 fetchVisibleIfNeeded 470 471loadLastEdit :: MH () 472loadLastEdit = do 473 tId <- use csCurrentTeamId 474 cId <- use (csCurrentChannelId tId) 475 476 oldEphemeral <- preuse (csChannel(cId).ccEditState) 477 case oldEphemeral of 478 Nothing -> return () 479 Just e -> csCurrentTeam.tsEditState.cedEphemeral .= e 480 481 loadLastChannelInput 482 483loadLastChannelInput :: MH () 484loadLastChannelInput = do 485 tId <- use csCurrentTeamId 486 cId <- use (csCurrentChannelId tId) 487 inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) 488 case inputHistoryPos of 489 Just i -> loadHistoryEntryToEditor cId i 490 Nothing -> do 491 (lastEdit, lastEditMode) <- use (csCurrentTeam.tsEditState.cedEphemeral.eesLastInput) 492 csCurrentTeam.tsEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper) 493 csCurrentTeam.tsEditState.cedEditMode .= lastEditMode 494 495updateChannelListScroll :: MH () 496updateChannelListScroll = do 497 tId <- use csCurrentTeamId 498 mh $ vScrollToBeginning (viewportScroll $ ChannelList tId) 499 500preChangeChannelCommon :: MH () 501preChangeChannelCommon = do 502 tId <- use csCurrentTeamId 503 cId <- use (csCurrentChannelId tId) 504 csCurrentTeam.tsRecentChannel .= Just cId 505 saveCurrentEdit 506 507resetEditorState :: MH () 508resetEditorState = do 509 csCurrentTeam.tsEditState.cedEditMode .= NewPost 510 clearEditor 511 512clearEditor :: MH () 513clearEditor = csCurrentTeam.tsEditState.cedEditor %= applyEdit clearZipper 514 515saveCurrentEdit :: MH () 516saveCurrentEdit = do 517 saveCurrentChannelInput 518 519 oldEphemeral <- use (csCurrentTeam.tsEditState.cedEphemeral) 520 tId <- use csCurrentTeamId 521 cId <- use (csCurrentChannelId tId) 522 csChannel(cId).ccEditState .= oldEphemeral 523 524saveCurrentChannelInput :: MH () 525saveCurrentChannelInput = do 526 cmdLine <- use (csCurrentTeam.tsEditState.cedEditor) 527 mode <- use (csCurrentTeam.tsEditState.cedEditMode) 528 529 -- Only save the editor contents if the user is not navigating the 530 -- history. 531 inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) 532 533 when (isNothing inputHistoryPos) $ 534 csCurrentTeam.tsEditState.cedEphemeral.eesLastInput .= 535 (T.intercalate "\n" $ getEditContents $ cmdLine, mode) 536 537applyPreferenceChange :: Preference -> MH () 538applyPreferenceChange pref = do 539 -- always update our user preferences accordingly 540 csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref) 541 542 -- Invalidate the entire rendering cache since many things depend on 543 -- user preferences 544 mh invalidateCache 545 546 if 547 | Just f <- preferenceToFlaggedPost pref -> do 548 updateMessageFlag (flaggedPostId f) (flaggedPostStatus f) 549 550 | Just tIds <- preferenceToTeamOrder pref -> 551 applyTeamOrder tIds 552 553 | Just d <- preferenceToDirectChannelShowStatus pref -> do 554 updateSidebar Nothing 555 556 cs <- use csChannels 557 558 -- We need to check on whether this preference was to show a 559 -- channel and, if so, whether it was the one we attempted to 560 -- switch to (thus triggering the preference change). If so, 561 -- we need to switch to it now. 562 let Just cId = getDmChannelFor (directChannelShowUserId d) cs 563 case directChannelShowValue d of 564 True -> do 565 pending <- checkPendingChannelChange cId 566 case pending of 567 Just mAct -> do 568 setFocus cId 569 fromMaybe (return ()) mAct 570 Nothing -> return () 571 False -> do 572 csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing 573 574 | Just g <- preferenceToGroupChannelPreference pref -> do 575 updateSidebar Nothing 576 577 -- We need to check on whether this preference was to show a 578 -- channel and, if so, whether it was the one we attempted to 579 -- switch to (thus triggering the preference change). If so, 580 -- we need to switch to it now. 581 let cId = groupChannelId g 582 case groupChannelShow g of 583 True -> do 584 pending <- checkPendingChannelChange cId 585 case pending of 586 Just mAct -> do 587 setFocus cId 588 fromMaybe (return ()) mAct 589 Nothing -> return () 590 False -> do 591 csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing 592 593 | Just f <- preferenceToFavoriteChannelPreference pref -> do 594 updateSidebar Nothing 595 596 -- We need to check on whether this preference was to show a 597 -- channel and, if so, whether it was the one we attempted to 598 -- switch to (thus triggering the preference change). If so, 599 -- we need to switch to it now. 600 let cId = favoriteChannelId f 601 case favoriteChannelShow f of 602 True -> do 603 pending <- checkPendingChannelChange cId 604 case pending of 605 Just mAct -> do 606 setFocus cId 607 fromMaybe (return ()) mAct 608 Nothing -> return () 609 False -> do 610 csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing 611 | otherwise -> return () 612 613refreshChannelById :: ChannelId -> MH () 614refreshChannelById cId = do 615 session <- getSession 616 doAsyncWith Preempt $ do 617 cwd <- MM.mmGetChannel cId session 618 member <- MM.mmGetChannelMember cId UserMe session 619 return $ Just $ do 620 refreshChannel SidebarUpdateImmediate cwd member 621 622removeChannelFromState :: ChannelId -> MH () 623removeChannelFromState cId = do 624 withChannel cId $ \ chan -> do 625 when (chan^.ccInfo.cdType /= Direct) $ do 626 case chan^.ccInfo.cdTeamId of 627 Nothing -> return () 628 Just tId -> do 629 origFocus <- use (csCurrentChannelId tId) 630 when (origFocus == cId) nextChannelSkipPrevView 631 632 -- Update input history 633 csInputHistory %= removeChannelHistory cId 634 -- Update msgMap 635 csChannels %= removeChannel cId 636 637 case chan^.ccInfo.cdTeamId of 638 Nothing -> do 639 ts <- use csTeams 640 forM_ (HM.keys ts) $ \tId -> 641 csTeam(tId).tsFocus %= Z.filterZipper ((/= cId) . channelListEntryChannelId) 642 Just tId -> do 643 csTeam(tId).tsFocus %= Z.filterZipper ((/= cId) . channelListEntryChannelId) 644 645 updateSidebar $ chan^.ccInfo.cdTeamId 646 647nextChannel :: MH () 648nextChannel = do 649 resetReturnChannel 650 setFocusWith True Z.right (return ()) 651 652-- | This is almost never what you want; we use this when we delete a 653-- channel and we don't want to update the deleted channel's view time. 654nextChannelSkipPrevView :: MH () 655nextChannelSkipPrevView = setFocusWith False Z.right (return ()) 656 657prevChannel :: MH () 658prevChannel = do 659 resetReturnChannel 660 setFocusWith True Z.left (return ()) 661 662recentChannel :: MH () 663recentChannel = do 664 recent <- use (csCurrentTeam.tsRecentChannel) 665 case recent of 666 Nothing -> return () 667 Just cId -> do 668 ret <- use (csCurrentTeam.tsReturnChannel) 669 when (ret == Just cId) resetReturnChannel 670 setFocus cId 671 672resetReturnChannel :: MH () 673resetReturnChannel = do 674 val <- use (csCurrentTeam.tsReturnChannel) 675 case val of 676 Nothing -> return () 677 Just _ -> do 678 tId <- use csCurrentTeamId 679 mh $ invalidateCacheEntry $ ChannelSidebar tId 680 csCurrentTeam.tsReturnChannel .= Nothing 681 682gotoReturnChannel :: MH () 683gotoReturnChannel = do 684 ret <- use (csCurrentTeam.tsReturnChannel) 685 case ret of 686 Nothing -> return () 687 Just cId -> do 688 resetReturnChannel 689 setFocus cId 690 691setReturnChannel :: MH () 692setReturnChannel = do 693 ret <- use (csCurrentTeam.tsReturnChannel) 694 case ret of 695 Nothing -> do 696 tId <- use csCurrentTeamId 697 cId <- use (csCurrentChannelId tId) 698 csCurrentTeam.tsReturnChannel .= Just cId 699 mh $ invalidateCacheEntry $ ChannelSidebar tId 700 Just _ -> return () 701 702nextUnreadChannel :: MH () 703nextUnreadChannel = do 704 st <- use id 705 setReturnChannel 706 setFocusWith True (getNextUnreadChannel st) gotoReturnChannel 707 708nextUnreadUserOrChannel :: MH () 709nextUnreadUserOrChannel = do 710 st <- use id 711 setReturnChannel 712 setFocusWith True (getNextUnreadUserOrChannel st) gotoReturnChannel 713 714leaveChannel :: ChannelId -> MH () 715leaveChannel cId = leaveChannelIfPossible cId False 716 717leaveChannelIfPossible :: ChannelId -> Bool -> MH () 718leaveChannelIfPossible cId delete = do 719 st <- use id 720 me <- gets myUser 721 let isMe u = u^.userIdL == me^.userIdL 722 723 case st ^? csChannel(cId).ccInfo of 724 Nothing -> return () 725 Just cInfo -> case canLeaveChannel cInfo of 726 False -> return () 727 True -> 728 -- The server will reject an attempt to leave a private 729 -- channel if we're the only member. To check this, we 730 -- just ask for the first two members of the channel. 731 -- If there is only one, it must be us: hence the "all 732 -- isMe" check below. If there are two members, it 733 -- doesn't matter who they are, because we just know 734 -- that we aren't the only remaining member, so we can't 735 -- delete the channel. 736 doAsyncChannelMM Preempt cId 737 (\s _ -> 738 let query = MM.defaultUserQuery 739 { MM.userQueryPage = Just 0 740 , MM.userQueryPerPage = Just 2 741 , MM.userQueryInChannel = Just cId 742 } 743 in toList <$> MM.mmGetUsers query s) 744 (\_ members -> Just $ do 745 -- If the channel is private: 746 -- * leave it if we aren't the last member. 747 -- * delete it if we are. 748 -- 749 -- Otherwise: 750 -- * leave (or delete) the channel as specified 751 -- by the delete argument. 752 let func = case cInfo^.cdType of 753 Private -> case all isMe members of 754 True -> (\ s c -> MM.mmDeleteChannel c s) 755 False -> (\ s c -> MM.mmRemoveUserFromChannel c UserMe s) 756 Group -> 757 \s _ -> 758 let pref = hideGroupChannelPref cId (me^.userIdL) 759 in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s 760 _ -> if delete 761 then (\ s c -> MM.mmDeleteChannel c s) 762 else (\ s c -> MM.mmRemoveUserFromChannel c UserMe s) 763 764 doAsyncChannelMM Preempt cId func endAsyncNOP 765 ) 766 767getNextUnreadChannel :: ChatState 768 -> (Zipper a ChannelListEntry -> Zipper a ChannelListEntry) 769getNextUnreadChannel st = 770 -- The next channel with unread messages must also be a channel 771 -- other than the current one, since the zipper may be on a channel 772 -- that has unread messages and will stay that way until we leave 773 -- it- so we need to skip that channel when doing the zipper search 774 -- for the next candidate channel. 775 Z.findRight (\e -> 776 let cId = channelListEntryChannelId e 777 in channelListEntryUnread e && (cId /= st^.csCurrentChannelId(st^.csCurrentTeamId))) 778 779getNextUnreadUserOrChannel :: ChatState 780 -> Zipper a ChannelListEntry 781 -> Zipper a ChannelListEntry 782getNextUnreadUserOrChannel st z = 783 -- Find the next unread channel, prefering direct messages 784 let cur = st^.csCurrentChannelId(st^.csCurrentTeamId) 785 matches e = entryIsDMEntry e && isFresh e 786 isFresh e = channelListEntryUnread e && (channelListEntryChannelId e /= cur) 787 in fromMaybe (Z.findRight isFresh z) 788 (Z.maybeFindRight matches z) 789 790leaveCurrentChannel :: MH () 791leaveCurrentChannel = do 792 tId <- use csCurrentTeamId 793 use (csCurrentChannelId tId) >>= leaveChannel 794 795createGroupChannel :: Text -> MH () 796createGroupChannel usernameList = do 797 me <- gets myUser 798 session <- getSession 799 cs <- use csChannels 800 801 doAsyncWith Preempt $ do 802 let usernames = Seq.fromList $ fmap trimUserSigil $ T.words usernameList 803 results <- MM.mmGetUsersByUsernames usernames session 804 805 -- If we found all of the users mentioned, then create the group 806 -- channel. 807 case length results == length usernames of 808 True -> do 809 chan <- MM.mmCreateGroupMessageChannel (userId <$> results) session 810 return $ Just $ do 811 case findChannelById (channelId chan) cs of 812 Just _ -> 813 -- If we already know about the channel ID, 814 -- that means the channel already exists so 815 -- we can just switch to it. 816 setFocus (channelId chan) 817 Nothing -> do 818 tId <- use csCurrentTeamId 819 csCurrentTeam.tsPendingChannelChange .= 820 (Just $ ChangeByChannelId tId (channelId chan) Nothing) 821 let pref = showGroupChannelPref (channelId chan) (me^.userIdL) 822 doAsyncWith Normal $ do 823 MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session 824 return $ Just $ applyPreferenceChange pref 825 False -> do 826 let foundUsernames = userUsername <$> results 827 missingUsernames = S.toList $ 828 S.difference (S.fromList $ F.toList usernames) 829 (S.fromList $ F.toList foundUsernames) 830 return $ Just $ do 831 forM_ missingUsernames (mhError . NoSuchUser) 832 833channelHistoryForward :: MH () 834channelHistoryForward = do 835 resetAutocomplete 836 837 tId <- use csCurrentTeamId 838 cId <- use (csCurrentChannelId tId) 839 inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) 840 case inputHistoryPos of 841 Just i 842 | i == 0 -> do 843 -- Transition out of history navigation 844 csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= Nothing 845 loadLastChannelInput 846 | otherwise -> do 847 let newI = i - 1 848 loadHistoryEntryToEditor cId newI 849 csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) 850 _ -> return () 851 852loadHistoryEntryToEditor :: ChannelId -> Int -> MH () 853loadHistoryEntryToEditor cId idx = do 854 inputHistory <- use csInputHistory 855 case getHistoryEntry cId idx inputHistory of 856 Nothing -> return () 857 Just entry -> do 858 let eLines = T.lines entry 859 mv = if length eLines == 1 then gotoEOL else id 860 csCurrentTeam.tsEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing) 861 862channelHistoryBackward :: MH () 863channelHistoryBackward = do 864 resetAutocomplete 865 866 tId <- use csCurrentTeamId 867 cId <- use (csCurrentChannelId tId) 868 inputHistoryPos <- use (csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition) 869 saveCurrentChannelInput 870 871 let newI = maybe 0 (+ 1) inputHistoryPos 872 loadHistoryEntryToEditor cId newI 873 csCurrentTeam.tsEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) 874 875createOrdinaryChannel :: Bool -> Text -> MH () 876createOrdinaryChannel public name = do 877 session <- getSession 878 myTId <- use csCurrentTeamId 879 doAsyncWith Preempt $ do 880 -- create a new chat channel 881 let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name) 882 minChannel = MinChannel 883 { minChannelName = slug 884 , minChannelDisplayName = name 885 , minChannelPurpose = Nothing 886 , minChannelHeader = Nothing 887 , minChannelType = if public then Ordinary else Private 888 , minChannelTeamId = myTId 889 } 890 tryMM (do c <- MM.mmCreateChannel minChannel session 891 chan <- MM.mmGetChannel (getId c) session 892 member <- MM.mmGetChannelMember (getId c) UserMe session 893 return (chan, member) 894 ) 895 (return . Just . uncurry (handleNewChannel True SidebarUpdateImmediate)) 896 897-- | When we are added to a channel not locally known about, we need 898-- to fetch the channel info for that channel. 899handleChannelInvite :: ChannelId -> MH () 900handleChannelInvite cId = do 901 session <- getSession 902 doAsyncWith Normal $ do 903 member <- MM.mmGetChannelMember cId UserMe session 904 tryMM (MM.mmGetChannel cId session) 905 (\cwd -> return $ Just $ do 906 pending <- checkPendingChannelChange cId 907 handleNewChannel (isJust pending) SidebarUpdateImmediate cwd member) 908 909addUserByNameToCurrentChannel :: Text -> MH () 910addUserByNameToCurrentChannel uname = 911 withFetchedUser (UserFetchByUsername uname) addUserToCurrentChannel 912 913addUserToCurrentChannel :: UserInfo -> MH () 914addUserToCurrentChannel u = do 915 tId <- use csCurrentTeamId 916 cId <- use (csCurrentChannelId tId) 917 session <- getSession 918 let channelMember = MinChannelMember (u^.uiId) cId 919 doAsyncWith Normal $ do 920 tryMM (void $ MM.mmAddUser cId channelMember session) 921 (const $ return Nothing) 922 923removeUserFromCurrentChannel :: Text -> MH () 924removeUserFromCurrentChannel uname = 925 withFetchedUser (UserFetchByUsername uname) $ \u -> do 926 tId <- use csCurrentTeamId 927 cId <- use (csCurrentChannelId tId) 928 session <- getSession 929 doAsyncWith Normal $ do 930 tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session) 931 (const $ return Nothing) 932 933startLeaveCurrentChannel :: MH () 934startLeaveCurrentChannel = do 935 cInfo <- use (csCurrentChannel.ccInfo) 936 case cInfo^.cdType of 937 Direct -> hideDMChannel (cInfo^.cdChannelId) 938 Group -> hideDMChannel (cInfo^.cdChannelId) 939 _ -> setMode LeaveChannelConfirm 940 941deleteCurrentChannel :: MH () 942deleteCurrentChannel = do 943 setMode Main 944 tId <- use csCurrentTeamId 945 cId <- use (csCurrentChannelId tId) 946 leaveChannelIfPossible cId True 947 948isCurrentChannel :: ChatState -> ChannelId -> Bool 949isCurrentChannel st cId = st^.csCurrentChannelId(st^.csCurrentTeamId) == cId 950 951isRecentChannel :: ChatState -> ChannelId -> Bool 952isRecentChannel st cId = st^.csCurrentTeam.tsRecentChannel == Just cId 953 954isReturnChannel :: ChatState -> ChannelId -> Bool 955isReturnChannel st cId = st^.csCurrentTeam.tsReturnChannel == Just cId 956 957joinChannelByName :: Text -> MH () 958joinChannelByName rawName = do 959 session <- getSession 960 tId <- use csCurrentTeamId 961 doAsyncWith Preempt $ do 962 result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session 963 return $ Just $ case result of 964 Left (_::SomeException) -> mhError $ NoSuchChannel rawName 965 Right chan -> joinChannel $ getId chan 966 967-- | If the user is not a member of the specified channel, submit a 968-- request to join it. Otherwise switch to the channel. 969joinChannel :: ChannelId -> MH () 970joinChannel chanId = joinChannel' chanId Nothing 971 972joinChannel' :: ChannelId -> Maybe (MH ()) -> MH () 973joinChannel' chanId act = do 974 setMode Main 975 mChan <- preuse (csChannel(chanId)) 976 case mChan of 977 Just _ -> do 978 setFocus chanId 979 fromMaybe (return ()) act 980 Nothing -> do 981 myId <- gets myUserId 982 tId <- use csCurrentTeamId 983 let member = MinChannelMember myId chanId 984 csCurrentTeam.tsPendingChannelChange .= (Just $ ChangeByChannelId tId chanId act) 985 doAsyncChannelMM Preempt chanId (\ s c -> MM.mmAddUser c member s) (const $ return act) 986 987createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH () 988createOrFocusDMChannel user successAct = do 989 cs <- use csChannels 990 case getDmChannelFor (user^.uiId) cs of 991 Just cId -> do 992 setFocus cId 993 case successAct of 994 Nothing -> return () 995 Just act -> act cId 996 Nothing -> do 997 -- We have a user of that name but no channel. Time to make one! 998 myId <- gets myUserId 999 session <- getSession 1000 csCurrentTeam.tsPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId) 1001 doAsyncWith Normal $ do 1002 -- create a new channel 1003 chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session 1004 return $ successAct <*> pure (channelId chan) 1005 1006-- | This switches to the named channel or creates it if it is a missing 1007-- but valid user channel. 1008changeChannelByName :: Text -> MH () 1009changeChannelByName name = do 1010 myId <- gets myUserId 1011 mCId <- gets (channelIdByChannelName name) 1012 mDMCId <- gets (channelIdByUsername name) 1013 1014 withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do 1015 if (_uiId <$> foundUser) == Just myId 1016 then return () 1017 else do 1018 setMode Main 1019 let err = mhError $ AmbiguousName name 1020 case (mCId, mDMCId) of 1021 (Nothing, Nothing) -> 1022 case foundUser of 1023 -- We know about the user but there isn't already a DM 1024 -- channel, so create one. 1025 Just user -> createOrFocusDMChannel user Nothing 1026 -- There were no matches of any kind. 1027 Nothing -> mhError $ NoSuchChannel name 1028 (Just cId, Nothing) 1029 -- We matched a channel and there was an explicit sigil, so we 1030 -- don't care about the username match. 1031 | normalChannelSigil `T.isPrefixOf` name -> setFocus cId 1032 -- We matched both a channel and a user, even though there is 1033 -- no DM channel. 1034 | Just _ <- foundUser -> err 1035 -- We matched a channel only. 1036 | otherwise -> setFocus cId 1037 (Nothing, Just cId) -> 1038 -- We matched a DM channel only. 1039 setFocus cId 1040 (Just _, Just _) -> 1041 -- We matched both a channel and a DM channel. 1042 err 1043 1044setChannelTopic :: Text -> MH () 1045setChannelTopic msg = do 1046 tId <- use csCurrentTeamId 1047 cId <- use (csCurrentChannelId tId) 1048 let patch = defaultChannelPatch { channelPatchHeader = Just msg } 1049 doAsyncChannelMM Preempt cId 1050 (\s _ -> MM.mmPatchChannel cId patch s) 1051 (\_ _ -> Nothing) 1052 1053-- | This renames the current channel's url name. It makes a request 1054-- to the server to change the name, but does not actually change the 1055-- name in Matterhorn yet; that is handled by a websocket event handled 1056-- asynchronously. 1057renameChannelUrl :: Text -> MH () 1058renameChannelUrl name = do 1059 tId <- use csCurrentTeamId 1060 cId <- use (csCurrentChannelId tId) 1061 s <- getSession 1062 let patch = defaultChannelPatch { channelPatchName = Just name } 1063 doAsyncWith Normal $ do 1064 _ <- MM.mmPatchChannel cId patch s 1065 return Nothing 1066 1067getCurrentChannelTopic :: MH Text 1068getCurrentChannelTopic = do 1069 ch <- use csCurrentChannel 1070 return $ ch^.ccInfo.cdHeader 1071 1072beginCurrentChannelDeleteConfirm :: MH () 1073beginCurrentChannelDeleteConfirm = do 1074 tId <- use csCurrentTeamId 1075 cId <- use (csCurrentChannelId tId) 1076 withChannel cId $ \chan -> do 1077 let chType = chan^.ccInfo.cdType 1078 if chType /= Direct 1079 then setMode DeleteChannelConfirm 1080 else mhError $ GenericError "Direct message channels cannot be deleted." 1081 1082updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH () 1083updateChannelNotifyProps cId notifyProps = do 1084 withChannel cId $ \chan -> do 1085 case chan^.ccInfo.cdTeamId of 1086 Nothing -> do 1087 ts <- use csTeams 1088 forM_ (HM.keys ts) (mh . invalidateCacheEntry . ChannelSidebar) 1089 Just tId -> mh $ invalidateCacheEntry $ ChannelSidebar tId 1090 1091 csChannel(cId).ccInfo.cdNotifyProps .= notifyProps 1092 1093toggleChannelFavoriteStatus :: MH () 1094toggleChannelFavoriteStatus = do 1095 myId <- gets myUserId 1096 tId <- use csCurrentTeamId 1097 cId <- use (csCurrentChannelId tId) 1098 userPrefs <- use (csResources.crUserPreferences) 1099 session <- getSession 1100 let favPref = favoriteChannelPreference userPrefs cId 1101 trueVal = "true" 1102 prefVal = case favPref of 1103 Just True -> "" 1104 Just False -> trueVal 1105 Nothing -> trueVal 1106 pref = Preference 1107 { preferenceUserId = myId 1108 , preferenceCategory = PreferenceCategoryFavoriteChannel 1109 , preferenceName = PreferenceName $ idString cId 1110 , preferenceValue = PreferenceValue prefVal 1111 } 1112 doAsyncWith Normal $ do 1113 MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session 1114 return Nothing 1115