matterhorn-90000.0.0: src/Matterhorn/State/Teams.hs
{-# LANGUAGE RankNTypes #-}
module Matterhorn.State.Teams
( nextTeam
, prevTeam
, handleJoinTeam
, handleLeaveTeam
, handleUpdateTeam
, buildTeamState
, moveCurrentTeamLeft
, moveCurrentTeamRight
, setTeam
, newSaveAttachmentDialog
, newChannelTopicDialog
, newThreadInterface
, makeClientChannel
, cycleTeamMessageInterfaceFocus
)
where
import Prelude ()
import Matterhorn.Prelude
import Brick ( getName )
import qualified Brick.BChan as BCH
import Brick.Main ( invalidateCache, hScrollToBeginning, viewportScroll, makeVisible )
import Brick.Widgets.List ( list )
import Brick.Widgets.Edit ( editor, applyEdit )
import Brick.Focus ( focusRing )
import qualified Data.Sequence as Seq
import qualified Data.Text as T
import Data.Time.Clock ( getCurrentTime )
import qualified Data.Text.Zipper as Z2
import qualified Data.HashMap.Strict as HM
import Lens.Micro.Platform ( (%=), (.=), at )
import Text.Aspell ( Aspell )
import Network.Mattermost.Lenses ( userIdL, channelTypeL, channelPurposeL
, channelHeaderL, channelTeamIdL, channelIdL
, channelLastPostAtL
)
import Network.Mattermost.Types ( TeamId, Team, Channel, User, userId
, getId, channelId, teamId, UserParam(..)
, teamOrderPref, Post, ChannelId, postId
, emptyChannelNotifyProps, UserId
, channelName, Type(..), channelDisplayName
, Channel, ChannelMember
, channelMemberMsgCount
, channelTotalMsgCount
, UserParam(UserById)
)
import qualified Network.Mattermost.Endpoints as MM
import Matterhorn.Types
import Matterhorn.Types.Common
import Matterhorn.Types.DirectionalSeq ( emptyDirSeq )
import Matterhorn.Types.NonemptyStack
import Matterhorn.LastRunState
import Matterhorn.State.Async
import Matterhorn.State.ChannelList
import Matterhorn.State.Channels
import {-# SOURCE #-} Matterhorn.State.ThreadWindow
import {-# SOURCE #-} Matterhorn.State.Messages
import Matterhorn.State.Setup.Threads ( newSpellCheckTimer )
import qualified Matterhorn.Zipper as Z
-- | Move right in the channel list to select the next team.
nextTeam :: MH ()
nextTeam = setTeamFocusWith Z.right
-- | Move left in the channel list to select the previous team.
prevTeam :: MH ()
prevTeam = setTeamFocusWith Z.left
-- | Set the current team directly
setTeam :: TeamId -> MH ()
setTeam tId = setTeamFocusWith $ Z.findRight (== tId)
-- | Change the selected team with the specified team zipper
-- transformation. This function also takes care of book-keeping
-- necessary during team switching.
setTeamFocusWith :: (Z.Zipper () TeamId -> Z.Zipper () TeamId) -> MH ()
setTeamFocusWith f = do
-- Before we leave this team to view another one, indicate that
-- we've viewed the current team's currently-selected channel so
-- that this team doesn't get left with an unread indicator once we
-- are looking at the other team. We do this when switching channels
-- within a team in the same way.
updateViewed True
csTeamZipper %= f
withCurrentTeam postChangeTeamCommon
-- | Book-keeping common to all team selection changes.
postChangeTeamCommon :: TeamId -> MH ()
postChangeTeamCommon tId = do
updateViewed False
fetchVisibleIfNeeded tId
mh $ do
hScrollToBeginning (viewportScroll TeamList)
makeVisible $ SelectedChannelListEntry tId
-- | Fetch the specified team and add it to the application state.
--
-- This is called in response to a server event indicating that the
-- current user was added to the team.
handleJoinTeam :: TeamId -> MH ()
handleJoinTeam tId = do
session <- getSession
cr <- use csResources
me <- use csMe
curTs <- use csTeams
let myTIds = HM.keys curTs
when (not $ tId `elem` myTIds) $ do
mhLog LogGeneral $ T.pack $ "Joining team " <> show tId
doAsyncWith Normal $ do
t <- MM.mmGetTeam tId session
(ts, chans) <- buildTeamState cr me t
return $ Just $ do
addTeamState ts chans
updateSidebar $ Just tId
updateWindowTitle
refreshTeamZipper
-- | Remove the specified team to the application state.
--
-- This is called in response to a server event indicating that the
-- current user was removed from the team.
handleLeaveTeam :: TeamId -> MH ()
handleLeaveTeam tId =
doAsyncWith Normal $ return $ Just $ do
mhLog LogGeneral $ T.pack $ "Leaving team " <> show tId
removeTeam tId
updateWindowTitle
-- Invalidating the cache here expunges any cached message
-- renderings from the team we are leaving.
mh invalidateCache
-- | Fetch the specified team's metadata and update it in the
-- application state.
--
-- This is called in response to a server event indicating that the
-- specified team was updated in some way.
handleUpdateTeam :: TeamId -> MH ()
handleUpdateTeam tId = do
session <- getSession
mhLog LogGeneral $ T.pack $ "Updating team " <> show tId
doAsyncWith Normal $ do
t <- MM.mmGetTeam tId session
return $ Just $ do
updateTeam t
-- Invalidate the cache since we happen to know that the
-- team name is in the cached sidebar.
mh invalidateCache
-- | Set the team zipper ordering with the specified transformation,
-- which is expected to be either 'moveLeft' or 'moveRight'.
setTeamOrderWith :: (TeamId -> [TeamId] -> [TeamId]) -> MH ()
setTeamOrderWith transform = do
session <- getSession
me <- use csMe
mtId <- use csCurrentTeamId
z <- use csTeamZipper
let tIds = teamZipperIds z
newList = maybe tIds (\tId -> transform tId tIds) mtId
doAsyncWith Normal $ do
let pref = teamOrderPref (me^.userIdL) newList
MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session
return Nothing
-- | Move the selected team left in the team list.
moveCurrentTeamLeft :: MH ()
moveCurrentTeamLeft = setTeamOrderWith moveLeft
-- | Move the selected team right in the team list.
moveCurrentTeamRight :: MH ()
moveCurrentTeamRight = setTeamOrderWith moveRight
-- | Build a new 'TeamState' for the specified team.
--
-- This function starts a new spell checker thread for the team's
-- message editor, loads the last-run state for the team (to ensure that
-- the initially-selected channel is honored), and fetches the channel
-- metadata for the team.
--
-- This returns the resulting team state as well as the channels
-- associated with the team. The caller is responsible for adding the
-- channels and the team state to the application state.
buildTeamState :: ChatResources -> User -> Team -> IO (TeamState, ClientChannels)
buildTeamState cr me team = do
let tId = teamId team
session = getResourceSession cr
config = cr^.crConfiguration
eventQueue = cr^.crEventQueue
lrsResult <- readLastRunState tId
let mLrs = case lrsResult of
Right lrs | isValidLastRunState cr me lrs -> Just lrs
_ -> Nothing
-- Create a predicate to find the last selected channel by
-- checking the last run state.
isLastSelectedChannel = maybe isTownSquare (\lrs c -> Just (channelId c) == lrs^.lrsSelectedChannelId) mLrs
-- Get all channels, but filter down to just the one we want
-- to start in. We get all, rather than requesting by name or
-- ID, because we don't know whether the server will give us a
-- last-viewed preference. We first try to find a channel matching
-- with the last selected channel ID, failing which we look for the
-- Town Square channel by name.
userChans <- MM.mmGetChannelsForUser UserMe tId session
let lastSelectedChans = Seq.filter isLastSelectedChannel userChans
chans = if Seq.null lastSelectedChans
then Seq.filter isTownSquare userChans
else lastSelectedChans
-- Since the only channel we are dealing with is by construction the
-- last channel, we don't have to consider other cases here:
chanPairs <- forM (toList chans) $ \c -> do
m <- MM.mmGetChannelMember (getId c) (UserById $ userId me) session
cChannel <- makeClientChannel eventQueue (cr^.crSpellChecker) (userId me) (Just tId) c m
return (getId c, cChannel)
now <- getCurrentTime
let chanIds = mkChannelZipperList (config^.configChannelListSortingL) now config tId
Nothing (cr^.crUserPreferences)
mempty clientChans noUsers
chanZip = Z.fromList chanIds
clientChans = foldr (uncurry addChannel) noChannels chanPairs
-- If the configuration says to open any last open thread, then
-- schedule it to be opened.
when (configShowLastOpenThread config) $ do
let maybeOpenThread = do
lrs <- mLrs
(cId, pId) <- lrs^.lrsOpenThread
return $ scheduleMH cr (openThreadWindow tId cId pId)
fromMaybe (return ()) maybeOpenThread
let ts = newTeamState config team chanZip
return (ts, clientChans)
-- | Add a new 'TeamState' and corresponding channels to the application
-- state.
addTeamState :: TeamState -> ClientChannels -> MH ()
addTeamState ts chans = do
let tId = teamId $ _tsTeam ts
csTeams.at tId .= Just ts
csChannels %= (chans <>)
-- | Update the specified team metadata in the application state (only
-- if we are already a member of that team).
updateTeam :: Team -> MH ()
updateTeam t = do
let tId = teamId t
ts <- use csTeams
when (tId `elem` HM.keys ts) $ do
csTeam(tId).tsTeam .= t
-- | Remove the specified team from the application state.
removeTeam :: TeamId -> MH ()
removeTeam tId = do
csTeams.at tId .= Nothing
setTeamFocusWith $ Z.filterZipper (/= tId)
cycleTeamMessageInterfaceFocus :: TeamId -> MH ()
cycleTeamMessageInterfaceFocus tId =
csTeam(tId) %= messageInterfaceFocusNext
emptyEditStateForChannel :: Maybe Aspell -> BCH.BChan MHEvent -> Maybe TeamId -> ChannelId -> IO (EditState Name)
emptyEditStateForChannel checker eventQueue tId cId = do
reset <- case checker of
Nothing -> return Nothing
Just as -> Just <$> (newSpellCheckTimer as eventQueue $ MIChannel cId)
let editorName = MessageInput cId
attachmentListName = AttachmentList cId
return $ newEditState editorName attachmentListName tId cId NewPost True reset
emptyEditStateForThread :: Maybe Aspell -> BCH.BChan MHEvent -> TeamId -> ChannelId -> EditMode -> IO (EditState Name)
emptyEditStateForThread checker eventQueue tId cId initialEditMode = do
reset <- case checker of
Nothing -> return Nothing
Just as -> Just <$> (newSpellCheckTimer as eventQueue $ MITeamThread tId)
let editorName = ThreadMessageInput cId
attachmentListName = ThreadEditorAttachmentList cId
return $ newEditState editorName attachmentListName (Just tId) cId initialEditMode False reset
newThreadInterface :: Maybe Aspell
-> BCH.BChan MHEvent
-> TeamId
-> ChannelId
-> Message
-> Post
-> Messages
-> IO ThreadInterface
newThreadInterface checker eventQueue tId cId rootMsg rootPost msgs = do
es <- emptyEditStateForThread checker eventQueue tId cId (Replying rootMsg rootPost)
return $ newMessageInterface cId (postId rootPost) msgs es (MITeamThread tId) (FromThreadIn cId)
newChannelMessageInterface :: Maybe Aspell
-> BCH.BChan MHEvent
-> Maybe TeamId
-> ChannelId
-> Messages
-> IO ChannelMessageInterface
newChannelMessageInterface checker eventQueue tId cId msgs = do
es <- emptyEditStateForChannel checker eventQueue tId cId
return $ newMessageInterface cId () msgs es (MIChannel cId) (FromChannel cId)
newMessageInterface :: ChannelId
-> i
-> Messages
-> EditState Name
-> MessageInterfaceTarget
-> URLListSource
-> MessageInterface Name i
newMessageInterface cId pId msgs es target src =
let urlListName = UrlList eName
eName = getName $ es^.esEditor
in MessageInterface { _miMessages = msgs
, _miRootPostId = pId
, _miChannelId = cId
, _miMessageSelect = MessageSelectState Nothing
, _miMode = Compose
, _miEditor = es
, _miTarget = target
, _miUrlListSource = src
, _miUrlList = URLList { _ulList = list urlListName mempty 2
, _ulSource = Nothing
}
, _miSaveAttachmentDialog = newSaveAttachmentDialog eName "(unused)"
}
newTeamState :: Config
-> Team
-> Z.Zipper ChannelListGroup ChannelListEntry
-> TeamState
newTeamState config team chanList =
let tId = teamId team
in TeamState { _tsModeStack = newStack Main
, _tsFocus = chanList
, _tsTeam = team
, _tsPostListWindow = PostListWindowState emptyDirSeq Nothing
, _tsUserListWindow = nullUserListWindowState tId
, _tsChannelListWindow = nullChannelListWindowState tId
, _tsChannelSelectState = emptyChannelSelectState tId
, _tsChannelTopicDialog = newChannelTopicDialog tId ""
, _tsNotifyPrefs = Nothing
, _tsPendingChannelChange = Nothing
, _tsRecentChannel = Nothing
, _tsReturnChannel = Nothing
, _tsViewedMessage = Nothing
, _tsThemeListWindow = nullThemeListWindowState tId
, _tsReactionEmojiListWindow = nullEmojiListWindowState tId
, _tsChannelListSorting = configChannelListSorting config
, _tsThreadInterface = Nothing
, _tsMessageInterfaceFocus = FocusCurrentChannel
}
nullChannelListWindowState :: TeamId -> ListWindowState Channel ChannelSearchScope
nullChannelListWindowState tId =
let newList rs = list (JoinChannelList tId) rs 2
in ListWindowState { _listWindowSearchResults = newList mempty
, _listWindowSearchInput = editor (JoinChannelListSearchInput tId) (Just 1) ""
, _listWindowSearchScope = AllChannels
, _listWindowSearching = False
, _listWindowEnterHandler = const $ return False
, _listWindowNewList = newList
, _listWindowFetchResults = const $ const $ const $ return mempty
, _listWindowRecordCount = Nothing
}
nullThemeListWindowState :: TeamId -> ListWindowState InternalTheme ()
nullThemeListWindowState tId =
let newList rs = list (ThemeListSearchResults tId) rs 3
in ListWindowState { _listWindowSearchResults = newList mempty
, _listWindowSearchInput = editor (ThemeListSearchInput tId) (Just 1) ""
, _listWindowSearchScope = ()
, _listWindowSearching = False
, _listWindowEnterHandler = const $ return False
, _listWindowNewList = newList
, _listWindowFetchResults = const $ const $ const $ return mempty
, _listWindowRecordCount = Nothing
}
nullUserListWindowState :: TeamId -> ListWindowState UserInfo UserSearchScope
nullUserListWindowState tId =
let newList rs = list (UserListSearchResults tId) rs 1
in ListWindowState { _listWindowSearchResults = newList mempty
, _listWindowSearchInput = editor (UserListSearchInput tId) (Just 1) ""
, _listWindowSearchScope = AllUsers Nothing
, _listWindowSearching = False
, _listWindowEnterHandler = const $ return False
, _listWindowNewList = newList
, _listWindowFetchResults = const $ const $ const $ return mempty
, _listWindowRecordCount = Nothing
}
nullEmojiListWindowState :: TeamId -> ListWindowState (Bool, T.Text) ()
nullEmojiListWindowState tId =
let newList rs = list (ReactionEmojiList tId) rs 1
in ListWindowState { _listWindowSearchResults = newList mempty
, _listWindowSearchInput = editor (ReactionEmojiListInput tId) (Just 1) ""
, _listWindowSearchScope = ()
, _listWindowSearching = False
, _listWindowEnterHandler = const $ return False
, _listWindowNewList = newList
, _listWindowFetchResults = const $ const $ const $ return mempty
, _listWindowRecordCount = Nothing
}
-- | Make a new channel topic editor window state.
newChannelTopicDialog :: TeamId -> T.Text -> ChannelTopicDialogState
newChannelTopicDialog tId t =
ChannelTopicDialogState { _channelTopicDialogEditor = editor (ChannelTopicEditor tId) Nothing t
, _channelTopicDialogFocus = focusRing [ ChannelTopicEditor tId
, ChannelTopicSaveButton tId
, ChannelTopicCancelButton tId
]
}
-- | Make a new attachment-saving editor window state.
newSaveAttachmentDialog :: Name -> T.Text -> SaveAttachmentDialogState Name
newSaveAttachmentDialog n t =
SaveAttachmentDialogState { _attachmentPathEditor = applyEdit Z2.gotoEOL $
editor (AttachmentPathEditor n) (Just 1) t
, _attachmentPathDialogFocus = focusRing [ AttachmentPathEditor n
, AttachmentPathSaveButton n
, AttachmentPathCancelButton n
]
}
makeClientChannel :: (MonadIO m)
=> BCH.BChan MHEvent
-> Maybe Aspell
-> UserId
-> Maybe TeamId
-> Channel
-> ChannelMember
-> m ClientChannel
makeClientChannel eventQueue spellChecker myId tId nc member = do
msgs <- emptyChannelMessages
mi <- liftIO $ newChannelMessageInterface spellChecker eventQueue tId (getId nc) msgs
return ClientChannel { _ccInfo = initialChannelInfo myId nc member
, _ccMessageInterface = mi
}
initialChannelInfo :: UserId -> Channel -> ChannelMember -> ChannelInfo
initialChannelInfo myId chan member =
let updated = chan ^. channelLastPostAtL
in ChannelInfo { _cdChannelId = chan^.channelIdL
, _cdTeamId = chan^.channelTeamIdL
, _cdViewed = Nothing
, _cdNewMessageIndicator = Hide
, _cdEditedMessageThreshold = Nothing
, _cdMentionCount = 0
, _cdUpdated = updated
, _cdName = preferredChannelName chan
, _cdDisplayName = sanitizeUserText $ channelDisplayName chan
, _cdHeader = sanitizeUserText $ chan^.channelHeaderL
, _cdPurpose = sanitizeUserText $ chan^.channelPurposeL
, _cdType = chan^.channelTypeL
, _cdNotifyProps = emptyChannelNotifyProps
, _cdDMUserId = if chan^.channelTypeL == Direct
then userIdForDMChannel myId $
sanitizeUserText $ channelName chan
else Nothing
, _cdSidebarShowOverride = Nothing
, _cdFetchPending = False
, _cdTotalMessageCount = channelTotalMsgCount chan
, _cdViewedMessageCount = channelMemberMsgCount member
}