{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
module Matterhorn.State.Channels
( updateSidebar
, updateViewed
, updateViewedChan
, refreshChannel
, refreshChannelsAndUsers
, setFocus
, refreshChannelById
, applyPreferenceChange
, leaveChannel
, leaveCurrentChannel
, getNextUnreadChannel
, getNextUnreadUserOrChannel
, nextUnreadChannel
, nextUnreadUserOrChannel
, createOrFocusDMChannel
, clearChannelUnreadStatus
, prevChannel
, nextChannel
, recentChannel
, setReturnChannel
, resetReturnChannel
, hideDMChannel
, createGroupChannel
, showGroupChannelPref
, channelHistoryForward
, channelHistoryBackward
, handleNewChannel
, createOrdinaryChannel
, handleChannelInvite
, addUserByNameToCurrentChannel
, addUserToCurrentChannel
, removeUserFromCurrentChannel
, removeChannelFromState
, isRecentChannel
, isReturnChannel
, isCurrentChannel
, deleteCurrentChannel
, startLeaveCurrentChannel
, joinChannel
, joinChannel'
, joinChannelByName
, changeChannelByName
, setChannelTopic
, getCurrentChannelTopic
, beginCurrentChannelDeleteConfirm
, toggleChannelListVisibility
, toggleExpandedChannelTopics
, showChannelInSidebar
, updateChannelNotifyProps
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning
, invalidateCache, invalidateCacheEntry )
import Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL )
import Control.Concurrent.Async ( runConcurrently, Concurrently(..) )
import Control.Exception ( SomeException, try )
import Data.Char ( isAlphaNum )
import qualified Data.HashMap.Strict as HM
import qualified Data.Foldable as F
import Data.List ( nub )
import Data.Maybe ( fromJust )
import qualified Data.Set as S
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )
import Data.Time.Clock ( getCurrentTime )
import qualified Graphics.Vty as Vty
import Lens.Micro.Platform
import qualified Network.Mattermost.Endpoints as MM
import Network.Mattermost.Lenses
import Network.Mattermost.Types
import Matterhorn.Constants ( normalChannelSigil )
import Matterhorn.InputHistory
import Matterhorn.State.Common
import {-# SOURCE #-} Matterhorn.State.Messages ( fetchVisibleIfNeeded )
import Matterhorn.State.Users
import Matterhorn.State.Flagging
import Matterhorn.Types
import Matterhorn.Types.Common
import Matterhorn.Zipper ( Zipper )
import qualified Matterhorn.Zipper as Z
updateSidebar :: MH ()
updateSidebar = do
mh $ invalidateCacheEntry ChannelSidebar
cconfig <- use csClientConfig
oldCid <- use csCurrentChannelId
cs <- use csChannels
us <- getUsers
prefs <- use (csResources.crUserPreferences)
now <- liftIO getCurrentTime
config <- use (csResources.crConfiguration)
let zl = mkChannelZipperList now config cconfig prefs cs us
csFocus %= Z.updateList zl
newZ <- use csFocus
myId <- gets myUserId
scheduleUserStatusFetches $ myId : userIdsFromZipper newZ
let unread = sum $ (channelListGroupUnread . fst) <$> zl
title = "matterhorn" <> if unread > 0 then "(" <> show unread <> ")" else ""
vty <- mh getVtyHandle
liftIO $ Vty.setWindowTitle vty title
newCid <- use csCurrentChannelId
when (newCid /= oldCid) $
fetchVisibleIfNeeded
updateViewed :: Bool -> MH ()
updateViewed updatePrev = do
csCurrentChannel.ccInfo.cdMentionCount .= 0
updateViewedChan updatePrev =<< use csCurrentChannelId
updateViewedChan :: Bool -> ChannelId -> MH ()
updateViewedChan updatePrev cId = use csConnectionStatus >>= \case
Connected -> do
pId <- if updatePrev
then use csRecentChannel
else return Nothing
doAsyncChannelMM Preempt cId
(\s c -> MM.mmViewChannel UserMe c pId s)
(\c () -> Just $ setLastViewedFor pId c)
Disconnected ->
return ()
toggleChannelListVisibility :: MH ()
toggleChannelListVisibility = do
mh invalidateCache
csShowChannelList %= not
toggleExpandedChannelTopics :: MH ()
toggleExpandedChannelTopics = do
mh invalidateCache
csShowExpandedChannelTopics %= not
hideDMChannel :: ChannelId -> MH ()
hideDMChannel cId = do
me <- gets myUser
session <- getSession
withChannel cId $ \chan -> do
case chan^.ccInfo.cdType of
Direct -> do
let pref = showDirectChannelPref (me^.userIdL) uId False
Just uId = chan^.ccInfo.cdDMUserId
csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing
doAsyncWith Preempt $ do
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
return Nothing
Group -> do
let pref = hideGroupChannelPref cId (me^.userIdL)
csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing
doAsyncWith Preempt $ do
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
return Nothing
_ -> do
mhError $ GenericError "Cannot hide this channel. Consider using /leave instead."
setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH ()
setLastViewedFor prevId cId = do
chan <- use (csChannels.to (findChannelById cId))
case chan of
Nothing ->
return ()
Just _ ->
doAsyncChannelMM Preempt cId (\ s _ ->
(,) <$> MM.mmGetChannel cId s
<*> MM.mmGetChannelMember cId UserMe s)
(\pcid (cwd, member) -> Just $ csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member)
case prevId of
Nothing -> return ()
Just p -> clearChannelUnreadStatus p
refreshChannelsAndUsers :: MH ()
refreshChannelsAndUsers = do
session <- getSession
myTId <- gets myTeamId
me <- gets myUser
knownUsers <- gets allUserIds
doAsyncWith Preempt $ do
(chans, datas) <- runConcurrently $ (,)
<$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)
<*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)
let dmUsers = catMaybes $ flip map (F.toList chans) $ \chan ->
case chan^.channelTypeL of
Direct -> case userIdForDMChannel (userId me) (sanitizeUserText $ channelName chan) of
Nothing -> Nothing
Just otherUserId -> Just otherUserId
_ -> Nothing
uIdsToFetch = nub $ userId me : knownUsers <> dmUsers
dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas
mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap)
chansWithData = mkPair <$> chans
return $ Just $
handleNewUsers (Seq.fromList uIdsToFetch) $ do
forM_ chansWithData $ uncurry (refreshChannel SidebarUpdateDeferred)
updateSidebar
refreshChannel :: SidebarUpdate -> Channel -> ChannelMember -> MH ()
refreshChannel upd chan member = do
let cId = getId chan
myTId <- gets myTeamId
let ourTeam = channelTeamId chan == Nothing ||
Just myTId == channelTeamId chan
case not ourTeam of
True -> return ()
False -> do
mChan <- preuse (csChannel(cId))
when (isNothing mChan) $
handleNewChannel False upd chan member
updateChannelInfo cId chan member
handleNewChannel :: Bool -> SidebarUpdate -> Channel -> ChannelMember -> MH ()
handleNewChannel = handleNewChannel_ True
handleNewChannel_ :: Bool
-> Bool
-> SidebarUpdate
-> Channel
-> ChannelMember
-> MH ()
handleNewChannel_ permitPostpone switch sbUpdate nc member = do
me <- gets myUser
mChan <- preuse (csChannel(getId nc))
case mChan of
Just _ -> when switch $ setFocus (getId nc)
Nothing -> do
cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>
makeClientChannel (me^.userIdL) nc
st <- use id
let chType = nc^.channelTypeL
register <- case chType of
Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of
Nothing -> return True
Just otherUserId ->
case userById otherUserId st of
Nothing -> do
case permitPostpone of
False -> return True
True -> do
mhLog LogAPI $ T.pack $ "handleNewChannel_: about to call handleNewUsers for " <> show otherUserId
handleNewUsers (Seq.singleton otherUserId) (return ())
doAsyncWith Normal $
return $ Just $ handleNewChannel_ False switch sbUpdate nc member
return False
Just _ -> return True
_ -> return True
when register $ do
csChannels %= addChannel (getId nc) cChannel
when (sbUpdate == SidebarUpdateImmediate) $ do
updateSidebar
pending1 <- checkPendingChannelChange (getId nc)
pending2 <- case cChannel^.ccInfo.cdDMUserId of
Nothing -> return False
Just uId -> checkPendingChannelChangeByUserId uId
when (switch || isJust pending1 || pending2) $ do
setFocus (getId nc)
case pending1 of
Just (Just act) -> act
_ -> return ()
checkPendingChannelChange :: ChannelId -> MH (Maybe (Maybe (MH ())))
checkPendingChannelChange cId = do
ch <- use csPendingChannelChange
return $ case ch of
Just (ChangeByChannelId i act) ->
if i == cId then Just act else Nothing
_ -> Nothing
checkPendingChannelChangeByUserId :: UserId -> MH Bool
checkPendingChannelChangeByUserId uId = do
ch <- use csPendingChannelChange
return $ case ch of
Just (ChangeByUserId i) ->
i == uId
_ ->
False
updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH ()
updateChannelInfo cid new member = do
mh $ invalidateCacheEntry $ ChannelMessages cid
csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member
updateSidebar
setFocus :: ChannelId -> MH ()
setFocus cId = do
showChannelInSidebar cId True
setFocusWith True (Z.findRight ((== cId) . channelListEntryChannelId)) (return ())
showChannelInSidebar :: ChannelId -> Bool -> MH ()
showChannelInSidebar cId setPending = do
mChan <- preuse $ csChannel cId
me <- gets myUser
prefs <- use (csResources.crUserPreferences)
session <- getSession
case mChan of
Nothing ->
return ()
Just ch -> do
csPendingChannelChange .= Nothing
now <- liftIO getCurrentTime
csChannel(cId).ccInfo.cdSidebarShowOverride .= Just now
updateSidebar
case ch^.ccInfo.cdType of
Direct -> do
let Just uId = ch^.ccInfo.cdDMUserId
case dmChannelShowPreference prefs uId of
Just False -> do
let pref = showDirectChannelPref (me^.userIdL) uId True
when setPending $
csPendingChannelChange .= Just (ChangeByChannelId (ch^.ccInfo.cdChannelId) Nothing)
doAsyncWith Preempt $ do
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
return Nothing
_ -> return ()
Group ->
case groupChannelShowPreference prefs cId of
Just False -> do
let pref = showGroupChannelPref cId (me^.userIdL)
when setPending $
csPendingChannelChange .= Just (ChangeByChannelId (ch^.ccInfo.cdChannelId) Nothing)
doAsyncWith Preempt $ do
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
return Nothing
_ -> return ()
_ -> return ()
setFocusWith :: Bool
-> (Zipper ChannelListGroup ChannelListEntry
-> Zipper ChannelListGroup ChannelListEntry)
-> MH ()
-> MH ()
setFocusWith updatePrev f onNoChange = do
oldZipper <- use csFocus
let newZipper = f oldZipper
newFocus = Z.focus newZipper
oldFocus = Z.focus oldZipper
if newFocus /= oldFocus
then do
mh $ invalidateCacheEntry ChannelSidebar
resetAutocomplete
preChangeChannelCommon
csFocus .= newZipper
now <- liftIO getCurrentTime
newCid <- use csCurrentChannelId
csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now
updateViewed updatePrev
postChangeChannelCommon
else onNoChange
postChangeChannelCommon :: MH ()
postChangeChannelCommon = do
resetEditorState
updateChannelListScroll
loadLastEdit
fetchVisibleIfNeeded
loadLastEdit :: MH ()
loadLastEdit = do
cId <- use csCurrentChannelId
oldEphemeral <- preuse (csChannel(cId).ccEditState)
case oldEphemeral of
Nothing -> return ()
Just e -> csEditState.cedEphemeral .= e
loadLastChannelInput
loadLastChannelInput :: MH ()
loadLastChannelInput = do
cId <- use csCurrentChannelId
inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)
case inputHistoryPos of
Just i -> loadHistoryEntryToEditor cId i
Nothing -> do
(lastEdit, lastEditMode) <- use (csEditState.cedEphemeral.eesLastInput)
csEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper)
csEditState.cedEditMode .= lastEditMode
updateChannelListScroll :: MH ()
updateChannelListScroll = do
mh $ vScrollToBeginning (viewportScroll ChannelList)
preChangeChannelCommon :: MH ()
preChangeChannelCommon = do
cId <- use csCurrentChannelId
csRecentChannel .= Just cId
saveCurrentEdit
resetEditorState :: MH ()
resetEditorState = do
csEditState.cedEditMode .= NewPost
clearEditor
clearEditor :: MH ()
clearEditor = csEditState.cedEditor %= applyEdit clearZipper
saveCurrentEdit :: MH ()
saveCurrentEdit = do
saveCurrentChannelInput
oldEphemeral <- use (csEditState.cedEphemeral)
cId <- use csCurrentChannelId
csChannel(cId).ccEditState .= oldEphemeral
saveCurrentChannelInput :: MH ()
saveCurrentChannelInput = do
cmdLine <- use (csEditState.cedEditor)
mode <- use (csEditState.cedEditMode)
inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)
when (isNothing inputHistoryPos) $
csEditState.cedEphemeral.eesLastInput .=
(T.intercalate "\n" $ getEditContents $ cmdLine, mode)
hideGroupChannelPref :: ChannelId -> UserId -> Preference
hideGroupChannelPref cId uId =
Preference { preferenceCategory = PreferenceCategoryGroupChannelShow
, preferenceValue = PreferenceValue "false"
, preferenceName = PreferenceName $ idString cId
, preferenceUserId = uId
}
showGroupChannelPref :: ChannelId -> UserId -> Preference
showGroupChannelPref cId uId =
Preference { preferenceCategory = PreferenceCategoryGroupChannelShow
, preferenceValue = PreferenceValue "true"
, preferenceName = PreferenceName $ idString cId
, preferenceUserId = uId
}
showDirectChannelPref :: UserId -> UserId -> Bool -> Preference
showDirectChannelPref myId otherId s =
Preference { preferenceCategory = PreferenceCategoryDirectChannelShow
, preferenceValue = if s then PreferenceValue "true"
else PreferenceValue "false"
, preferenceName = PreferenceName $ idString otherId
, preferenceUserId = myId
}
applyPreferenceChange :: Preference -> MH ()
applyPreferenceChange pref = do
csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)
mh invalidateCache
if
| Just f <- preferenceToFlaggedPost pref -> do
updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)
| Just d <- preferenceToDirectChannelShowStatus pref -> do
updateSidebar
cs <- use csChannels
let Just cId = getDmChannelFor (directChannelShowUserId d) cs
case directChannelShowValue d of
True -> do
pending <- checkPendingChannelChange cId
case pending of
Just mAct -> do
setFocus cId
fromMaybe (return ()) mAct
Nothing -> return ()
False -> do
csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing
| Just g <- preferenceToGroupChannelPreference pref -> do
updateSidebar
let cId = groupChannelId g
case groupChannelShow g of
True -> do
pending <- checkPendingChannelChange cId
case pending of
Just mAct -> do
setFocus cId
fromMaybe (return ()) mAct
Nothing -> return ()
False -> do
csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing
| otherwise -> return ()
refreshChannelById :: ChannelId -> MH ()
refreshChannelById cId = do
session <- getSession
doAsyncWith Preempt $ do
cwd <- MM.mmGetChannel cId session
member <- MM.mmGetChannelMember cId UserMe session
return $ Just $ do
refreshChannel SidebarUpdateImmediate cwd member
removeChannelFromState :: ChannelId -> MH ()
removeChannelFromState cId = do
withChannel cId $ \ chan -> do
when (chan^.ccInfo.cdType /= Direct) $ do
origFocus <- use csCurrentChannelId
when (origFocus == cId) nextChannelSkipPrevView
csEditState.cedInputHistory %= removeChannelHistory cId
csChannels %= removeChannel cId
csFocus %= Z.filterZipper ((/= cId) . channelListEntryChannelId)
updateSidebar
nextChannel :: MH ()
nextChannel = do
resetReturnChannel
setFocusWith True Z.right (return ())
nextChannelSkipPrevView :: MH ()
nextChannelSkipPrevView = setFocusWith False Z.right (return ())
prevChannel :: MH ()
prevChannel = do
resetReturnChannel
setFocusWith True Z.left (return ())
recentChannel :: MH ()
recentChannel = do
recent <- use csRecentChannel
case recent of
Nothing -> return ()
Just cId -> do
ret <- use csReturnChannel
when (ret == Just cId) resetReturnChannel
setFocus cId
resetReturnChannel :: MH ()
resetReturnChannel = do
val <- use csReturnChannel
case val of
Nothing -> return ()
Just _ -> do
mh $ invalidateCacheEntry ChannelSidebar
csReturnChannel .= Nothing
gotoReturnChannel :: MH ()
gotoReturnChannel = do
ret <- use csReturnChannel
case ret of
Nothing -> return ()
Just cId -> do
resetReturnChannel
setFocus cId
setReturnChannel :: MH ()
setReturnChannel = do
ret <- use csReturnChannel
case ret of
Nothing -> do
cId <- use csCurrentChannelId
csReturnChannel .= Just cId
mh $ invalidateCacheEntry ChannelSidebar
Just _ -> return ()
nextUnreadChannel :: MH ()
nextUnreadChannel = do
st <- use id
setReturnChannel
setFocusWith True (getNextUnreadChannel st) gotoReturnChannel
nextUnreadUserOrChannel :: MH ()
nextUnreadUserOrChannel = do
st <- use id
setReturnChannel
setFocusWith True (getNextUnreadUserOrChannel st) gotoReturnChannel
leaveChannel :: ChannelId -> MH ()
leaveChannel cId = leaveChannelIfPossible cId False
leaveChannelIfPossible :: ChannelId -> Bool -> MH ()
leaveChannelIfPossible cId delete = do
st <- use id
me <- gets myUser
let isMe u = u^.userIdL == me^.userIdL
case st ^? csChannel(cId).ccInfo of
Nothing -> return ()
Just cInfo -> case canLeaveChannel cInfo of
False -> return ()
True ->
doAsyncChannelMM Preempt cId
(\s _ ->
let query = MM.defaultUserQuery
{ MM.userQueryPage = Just 0
, MM.userQueryPerPage = Just 2
, MM.userQueryInChannel = Just cId
}
in toList <$> MM.mmGetUsers query s)
(\_ members -> Just $ do
let func = case cInfo^.cdType of
Private -> case all isMe members of
True -> (\ s c -> MM.mmDeleteChannel c s)
False -> (\ s c -> MM.mmRemoveUserFromChannel c UserMe s)
Group ->
\s _ ->
let pref = hideGroupChannelPref cId (me^.userIdL)
in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s
_ -> if delete
then (\ s c -> MM.mmDeleteChannel c s)
else (\ s c -> MM.mmRemoveUserFromChannel c UserMe s)
doAsyncChannelMM Preempt cId func endAsyncNOP
)
getNextUnreadChannel :: ChatState
-> (Zipper a ChannelListEntry -> Zipper a ChannelListEntry)
getNextUnreadChannel st =
Z.findRight (\e ->
let cId = channelListEntryChannelId e
in hasUnread st cId && (cId /= st^.csCurrentChannelId))
getNextUnreadUserOrChannel :: ChatState
-> Zipper a ChannelListEntry
-> Zipper a ChannelListEntry
getNextUnreadUserOrChannel st z =
let cur = st^.csCurrentChannelId
matches e = entryIsDMEntry e && isFresh (channelListEntryChannelId e)
isFresh c = hasUnread st c && (c /= cur)
in fromMaybe (Z.findRight (isFresh . channelListEntryChannelId) z)
(Z.maybeFindRight matches z)
leaveCurrentChannel :: MH ()
leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel
createGroupChannel :: Text -> MH ()
createGroupChannel usernameList = do
me <- gets myUser
session <- getSession
cs <- use csChannels
doAsyncWith Preempt $ do
let usernames = Seq.fromList $ fmap trimUserSigil $ T.words usernameList
results <- MM.mmGetUsersByUsernames usernames session
case length results == length usernames of
True -> do
chan <- MM.mmCreateGroupMessageChannel (userId <$> results) session
return $ Just $ do
case findChannelById (channelId chan) cs of
Just _ ->
setFocus (channelId chan)
Nothing -> do
csPendingChannelChange .= (Just $ ChangeByChannelId (channelId chan) Nothing)
let pref = showGroupChannelPref (channelId chan) (me^.userIdL)
doAsyncWith Normal $ do
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
return $ Just $ applyPreferenceChange pref
False -> do
let foundUsernames = userUsername <$> results
missingUsernames = S.toList $
S.difference (S.fromList $ F.toList usernames)
(S.fromList $ F.toList foundUsernames)
return $ Just $ do
forM_ missingUsernames (mhError . NoSuchUser)
channelHistoryForward :: MH ()
channelHistoryForward = do
resetAutocomplete
cId <- use csCurrentChannelId
inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)
case inputHistoryPos of
Just i
| i == 0 -> do
csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing
loadLastChannelInput
| otherwise -> do
let newI = i - 1
loadHistoryEntryToEditor cId newI
csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)
_ -> return ()
loadHistoryEntryToEditor :: ChannelId -> Int -> MH ()
loadHistoryEntryToEditor cId idx = do
inputHistory <- use (csEditState.cedInputHistory)
case getHistoryEntry cId idx inputHistory of
Nothing -> return ()
Just entry -> do
let eLines = T.lines entry
mv = if length eLines == 1 then gotoEOL else id
csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)
channelHistoryBackward :: MH ()
channelHistoryBackward = do
resetAutocomplete
cId <- use csCurrentChannelId
inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)
saveCurrentChannelInput
let newI = maybe 0 (+ 1) inputHistoryPos
loadHistoryEntryToEditor cId newI
csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)
createOrdinaryChannel :: Bool -> Text -> MH ()
createOrdinaryChannel public name = do
session <- getSession
myTId <- gets myTeamId
doAsyncWith Preempt $ do
let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)
minChannel = MinChannel
{ minChannelName = slug
, minChannelDisplayName = name
, minChannelPurpose = Nothing
, minChannelHeader = Nothing
, minChannelType = if public then Ordinary else Private
, minChannelTeamId = myTId
}
tryMM (do c <- MM.mmCreateChannel minChannel session
chan <- MM.mmGetChannel (getId c) session
member <- MM.mmGetChannelMember (getId c) UserMe session
return (chan, member)
)
(return . Just . uncurry (handleNewChannel True SidebarUpdateImmediate))
handleChannelInvite :: ChannelId -> MH ()
handleChannelInvite cId = do
session <- getSession
doAsyncWith Normal $ do
member <- MM.mmGetChannelMember cId UserMe session
tryMM (MM.mmGetChannel cId session)
(\cwd -> return $ Just $ do
pending <- checkPendingChannelChange cId
handleNewChannel (isJust pending) SidebarUpdateImmediate cwd member)
addUserByNameToCurrentChannel :: Text -> MH ()
addUserByNameToCurrentChannel uname =
withFetchedUser (UserFetchByUsername uname) addUserToCurrentChannel
addUserToCurrentChannel :: UserInfo -> MH ()
addUserToCurrentChannel u = do
cId <- use csCurrentChannelId
session <- getSession
let channelMember = MinChannelMember (u^.uiId) cId
doAsyncWith Normal $ do
tryMM (void $ MM.mmAddUser cId channelMember session)
(const $ return Nothing)
removeUserFromCurrentChannel :: Text -> MH ()
removeUserFromCurrentChannel uname =
withFetchedUser (UserFetchByUsername uname) $ \u -> do
cId <- use csCurrentChannelId
session <- getSession
doAsyncWith Normal $ do
tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)
(const $ return Nothing)
startLeaveCurrentChannel :: MH ()
startLeaveCurrentChannel = do
cInfo <- use (csCurrentChannel.ccInfo)
case cInfo^.cdType of
Direct -> hideDMChannel (cInfo^.cdChannelId)
Group -> hideDMChannel (cInfo^.cdChannelId)
_ -> setMode LeaveChannelConfirm
deleteCurrentChannel :: MH ()
deleteCurrentChannel = do
setMode Main
cId <- use csCurrentChannelId
leaveChannelIfPossible cId True
isCurrentChannel :: ChatState -> ChannelId -> Bool
isCurrentChannel st cId = st^.csCurrentChannelId == cId
isRecentChannel :: ChatState -> ChannelId -> Bool
isRecentChannel st cId = st^.csRecentChannel == Just cId
isReturnChannel :: ChatState -> ChannelId -> Bool
isReturnChannel st cId = st^.csReturnChannel == Just cId
joinChannelByName :: Text -> MH ()
joinChannelByName rawName = do
session <- getSession
tId <- gets myTeamId
doAsyncWith Preempt $ do
result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session
return $ Just $ case result of
Left (_::SomeException) -> mhError $ NoSuchChannel rawName
Right chan -> joinChannel $ getId chan
joinChannel :: ChannelId -> MH ()
joinChannel chanId = joinChannel' chanId Nothing
joinChannel' :: ChannelId -> Maybe (MH ()) -> MH ()
joinChannel' chanId act = do
setMode Main
mChan <- preuse (csChannel(chanId))
case mChan of
Just _ -> do
setFocus chanId
fromMaybe (return ()) act
Nothing -> do
myId <- gets myUserId
let member = MinChannelMember myId chanId
csPendingChannelChange .= (Just $ ChangeByChannelId chanId act)
doAsyncChannelMM Preempt chanId (\ s c -> MM.mmAddUser c member s) (const $ return act)
createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH ()
createOrFocusDMChannel user successAct = do
cs <- use csChannels
case getDmChannelFor (user^.uiId) cs of
Just cId -> do
setFocus cId
case successAct of
Nothing -> return ()
Just act -> act cId
Nothing -> do
myId <- gets myUserId
session <- getSession
csPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId)
doAsyncWith Normal $ do
chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session
return $ successAct <*> pure (channelId chan)
changeChannelByName :: Text -> MH ()
changeChannelByName name = do
mCId <- gets (channelIdByChannelName name)
mDMCId <- gets (channelIdByUsername name)
withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do
let err = mhError $ AmbiguousName name
case (mCId, mDMCId) of
(Nothing, Nothing) ->
case foundUser of
Just user -> createOrFocusDMChannel user Nothing
Nothing -> mhError $ NoSuchChannel name
(Just cId, Nothing)
| normalChannelSigil `T.isPrefixOf` name -> setFocus cId
| Just _ <- foundUser -> err
| otherwise -> setFocus cId
(Nothing, Just cId) ->
setFocus cId
(Just _, Just _) ->
err
setChannelTopic :: Text -> MH ()
setChannelTopic msg = do
cId <- use csCurrentChannelId
let patch = defaultChannelPatch { channelPatchHeader = Just msg }
doAsyncChannelMM Preempt cId
(\s _ -> MM.mmPatchChannel cId patch s)
(\_ _ -> Nothing)
getCurrentChannelTopic :: MH Text
getCurrentChannelTopic = do
ch <- use csCurrentChannel
return $ ch^.ccInfo.cdHeader
beginCurrentChannelDeleteConfirm :: MH ()
beginCurrentChannelDeleteConfirm = do
cId <- use csCurrentChannelId
withChannel cId $ \chan -> do
let chType = chan^.ccInfo.cdType
if chType /= Direct
then setMode DeleteChannelConfirm
else mhError $ GenericError "Direct message channels cannot be deleted."
updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH ()
updateChannelNotifyProps cId notifyProps = do
mh $ invalidateCacheEntry ChannelSidebar
csChannel(cId).ccInfo.cdNotifyProps .= notifyProps