diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,38 @@ +40700.0.0 +========= + +This release supports Mattermost server version 4.7. + +New features: + * The `/focus` command with no arguments now starts channel selection + mode, equivalent to the default binding of `C-g`. + * The `/join` command now accepts an optional channel name argument. If + provided, the named channel is joined (#361). + * A new user browser was added! The user browser presents a list of + users and the ability to search users by name. The new user list + powers some new and existing commands: + * A new `/msg` command is used to browse known users and select a + user with `Enter` to begin a private chat session with the selected + user. + * A new `/add-user` command is used to add users to the current + channel. The list shows users who are not already members of the + channelcurrent and `Enter` adds the selected user to the channel. + * The existing `/members` command now shows a browsable user list of + members of the current channel. `Enter` begins a private chat + session with the selected user. + +Bug fixes: + * Missing `urlOpenCommand`s are now reported as error messages rather + than informative messages. + * More login-related exceptions are now displayed in a more readable + format on the login screen (#358). + * Channel selection mode now prefers an exact match as the initial + cursor selection if one exists (#356). + * Replies now indicate the correct parent message in the message list. + * The multi-line editor help message now shows the active binding + (previously `M-e`). + 40600.1.0 ========= diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 40600.1.0 +version: 40700.0.0 synopsis: Terminal client for the Mattermost chat system description: This is a terminal client for the Mattermost chat system. Please see the README for a list of @@ -41,6 +41,7 @@ State.PostListOverlay State.Setup State.Setup.Threads + State.UserListOverlay Zipper Themes Draw @@ -51,6 +52,7 @@ Draw.LeaveChannelConfirm Draw.DeleteChannelConfirm Draw.PostListOverlay + Draw.UserListOverlay Draw.JoinChannel Draw.Util InputHistory @@ -65,6 +67,7 @@ Events.ChannelSelect Events.PostListOverlay Events.UrlSelect + Events.UserListOverlay Events.LeaveChannelConfirm Events.DeleteChannelConfirm HelpTopics @@ -88,7 +91,7 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5 - , mattermost-api == 40600.1.0 + , mattermost-api == 40700.0.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 @@ -156,8 +159,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 40600.1.0 - , mattermost-api-qc == 40600.1.0 + , mattermost-api == 40700.0.0 + , mattermost-api-qc == 40700.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -21,6 +21,7 @@ import State.Editing (toggleMessagePreview) import State.Common import State.PostListOverlay +import State.UserListOverlay import Types import HelpTopics import Scripts @@ -73,11 +74,13 @@ beginCurrentChannelDeleteConfirm , Cmd "members" "Show the current channel's members" NoArg $ \ () -> - fetchCurrentChannelMembers + enterChannelMembersUserList , Cmd "leave" "Leave the current channel" NoArg $ \ () -> startLeaveCurrentChannel - , Cmd "join" "Join a channel" NoArg $ \ () -> + , Cmd "join" "Browse the list of available channels" NoArg $ \ () -> startJoinChannel + , Cmd "join" "Join the specified channel" (TokenArg "channel" NoArg) $ \(n, ()) -> + joinChannelByName n , Cmd "theme" "List the available themes" NoArg $ \ () -> listThemes , Cmd "theme" "Set the color theme" @@ -86,6 +89,12 @@ , Cmd "topic" "Set the current channel's topic" (LineArg "topic") $ \ p -> if not (T.null p) then setChannelTopic p else return () + , Cmd "add-user" "Search for a user to add to the current channel" + NoArg $ \ () -> + enterChannelInviteUserList + , Cmd "msg" "Chat with a user privately" + NoArg $ \ () -> + enterDMSearchUserList , Cmd "add-user" "Add a user to the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> addUserToCurrentChannel uname @@ -97,6 +106,8 @@ , Cmd "focus" "Focus on a named channel" (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name + , Cmd "focus" "Select from available channels" NoArg $ \ () -> + beginChannelSelect , Cmd "help" "Show this help screen" NoArg $ \ _ -> showHelpScreen mainHelpTopic , Cmd "help" "Show help about a particular topic" @@ -106,7 +117,7 @@ let msg = ("Unknown help topic: `" <> topicName <> "`. " <> (T.unlines $ "Available topics are:" : knownTopics)) knownTopics = (" - " <>) <$> helpTopicName <$> helpTopics - postErrorMessage msg + mhError msg Just topic -> showHelpScreen topic , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> @@ -138,9 +149,9 @@ execMMCommand :: T.Text -> T.Text -> MH () execMMCommand name rest = do cId <- use csCurrentChannelId - session <- use (csResources.crSession) + session <- getSession em <- use (csEditState.cedEditMode) - tId <- use (csMyTeam.to MM.teamId) + tId <- gets myTeamId let mc = MM.MinCommand { MM.minComChannelId = cId , MM.minComCommand = "/" <> name <> " " <> rest @@ -174,7 +185,7 @@ case errMsg of Nothing -> return () Just err -> - postErrorMessage ("Error running command: " <> err) + mhError ("Error running command: " <> err) dispatchCommand :: T.Text -> MH () dispatchCommand cmd = @@ -189,7 +200,7 @@ go errs [] = do let msg = ("error running command /" <> x <> ":\n" <> mconcat [ " " <> e | e <- errs ]) - postErrorMessage msg + mhError msg go errs (Cmd _ _ spec exe : cs) = case matchArgs spec xs of Left e -> go (e:errs) cs diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -25,10 +25,11 @@ connectWebsockets :: MH () connectWebsockets = do st <- use id + session <- getSession liftIO $ do let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg) shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e) - runWS = WS.mmWithWebSocket (st^.csResources.crSession) shunt $ \ws -> do + runWS = WS.mmWithWebSocket session shunt $ \ws -> do writeBChan (st^.csResources.crEventQueue) WebsocketConnect processWebsocketActions st ws 1 HM.empty void $ forkIO $ runWS `catch` handleTimeout 1 st diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -10,6 +10,7 @@ import Draw.LeaveChannelConfirm import Draw.DeleteChannelConfirm import Draw.PostListOverlay +import Draw.UserListOverlay import Draw.JoinChannel draw :: ChatState -> [Widget Name] @@ -26,3 +27,4 @@ MessageSelectDeleteConfirm -> drawMain st DeleteChannelConfirm -> drawDeleteChannelConfirm st PostListOverlay contents -> drawPostListOverlay contents st + UserListOverlay -> drawUserListOverlay st diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -23,6 +23,7 @@ import qualified Data.Sequence as Seq import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) import qualified Data.Text as T import Draw.Util @@ -31,7 +32,6 @@ import Themes import Types import Types.Users -import Types.Channels type GroupName = T.Text @@ -198,8 +198,8 @@ getOrdinaryChannels :: ChatState -> Maybe Int -> Seq.Seq ChannelListEntry getOrdinaryChannels st _ = Seq.fromList [ ChannelListEntry sigil n unread mentions recent current Nothing - | n <- (st ^. csNames . cnChans) - , let Just chan = st ^. csNames . cnToChanId . at n + | n <- allChannelNames st + , let Just chan = channelIdByName n st unread = hasUnread st chan recent = isRecentChannel st chan current = isCurrentChannel st chan @@ -207,7 +207,7 @@ Nothing -> normalChannelSigil Just ("", _) -> normalChannelSigil _ -> "»" - mentions = maybe 0 id (st^?csChannel(chan).ccInfo.cdMentionCount) + mentions = channelMentionCount chan st ] -- | Extract the names and information about Direct Message channels @@ -238,12 +238,10 @@ _ -> '»' -- shows that user has a message in-progress uname = u^.uiName recent = maybe False (isRecentChannel st) m_chanId - m_chanId = st^.csNames.cnToChanId.at (u^.uiName) + m_chanId = channelIdByName (u^.uiName) st unread = maybe False (hasUnread st) m_chanId current = maybe False (isCurrentChannel st) m_chanId - mentions = case m_chanId of - Just cId -> maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) - Nothing -> 0 + mentions = fromMaybe 0 $ channelMentionCount <$> m_chanId <*> pure st ] (h, t) = Seq.breakl entryIsCurrent es in case height of diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -29,7 +29,6 @@ import Lens.Micro.Platform import Network.Mattermost.Types (ChannelId, Type(Direct), ServerTime(..), UserId) -import Network.Mattermost.Lenses import qualified Graphics.Vty as Vty @@ -303,7 +302,7 @@ quote n = "\"" <> n <> "\"" nick = maybe "" quote $ u^.uiNickName in s - foundUser = findUserByDMChannelName (st^.csUsers) chnName (st^.csMe^.userIdL) + foundUser = userByDMChannelName chnName (myUserId st) st maybeTopic = if T.null topicStr then "" else " - " <> topicStr @@ -529,7 +528,7 @@ inputPreview st hs | not $ st^.csShowMessagePreview = emptyWidget | otherwise = thePreview where - uId = st^.csMe.userIdL + uId = myUserId st -- Insert a cursor sentinel into the input text just before -- rendering the preview. We use the inserted sentinel (which is -- not rendered) to get brick to ensure that the line the cursor is @@ -612,10 +611,10 @@ showTypingUsers = case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of [] -> emptyWidget - [uId] | Just un <- getUsernameForUserId st uId -> + [uId] | Just un <- usernameForUserId uId st -> txt $ un <> " is typing" - [uId1, uId2] | Just un1 <- getUsernameForUserId st uId1 - , Just un2 <- getUsernameForUserId st uId2 -> + [uId1, uId2] | Just un1 <- usernameForUserId uId1 st + , Just un2 <- usernameForUserId uId2 st -> txt $ un1 <> " and " <> un2 <> " are typing" _ -> txt "several people are typing" diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -31,7 +31,7 @@ nameForUserRef st uref = case uref of NoUser -> Nothing UserOverride t -> Just t - UserI uId -> getUsernameForUserId st uId + UserI uId -> usernameForUserId uId st -- | renderSingleMessage is the main message drawing function. -- diff --git a/src/Draw/PostListOverlay.hs b/src/Draw/PostListOverlay.hs --- a/src/Draw/PostListOverlay.hs +++ b/src/Draw/PostListOverlay.hs @@ -82,9 +82,9 @@ | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) -> case chan^.ccInfo.cdType of Direct - | Just u <- findUserByDMChannelName (st^.csUsers) - (chan^.ccInfo.cdName) - (st^.csMe.userIdL) -> + | Just u <- userByDMChannelName (chan^.ccInfo.cdName) + (myUserId st) + st -> (forceAttr channelNameAttr (txt (T.singleton '@' <> u^.uiName)) <=> (str " " <+> renderedMsg)) _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to mkChannelName)) <=> diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -30,6 +30,7 @@ import Events.Main import Events.MessageSelect import Events.PostListOverlay +import Events.UserListOverlay import State.Editing (editingKeybindings) import Markdown (renderText) import Options (mhVersion) @@ -331,6 +332,7 @@ , ("Message Select Mode", messageSelectKeybindings kc) , ("Text Editing", editingKeybindings) , ("Flagged Messages", postListOverlayKeybindings kc) + , ("User Listings", userListOverlayKeybindings kc) ] helpBox :: Name -> Widget Name -> Widget Name diff --git a/src/Draw/UserListOverlay.hs b/src/Draw/UserListOverlay.hs new file mode 100644 --- /dev/null +++ b/src/Draw/UserListOverlay.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Draw.UserListOverlay where + +import Prelude () +import Prelude.Compat + +import Control.Monad.Trans.Reader (withReaderT) +import qualified Data.Foldable as F +import qualified Data.Text as T +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) +import qualified Graphics.Vty as V +import Lens.Micro.Platform + +import Brick +import Brick.Widgets.Border +import Brick.Widgets.Edit +import qualified Brick.Widgets.List as L +import Brick.Widgets.Center + +import Themes +import Types +import Types.Users +import Draw.Main +import Draw.Util (userSigilFromInfo) + +hLimitWithPadding :: Int -> Widget n -> Widget n +hLimitWithPadding pad contents = Widget + { hSize = Fixed + , vSize = (vSize contents) + , render = + withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents + } + +drawUserListOverlay :: ChatState -> [Widget Name] +drawUserListOverlay st = + drawUsersBox (st^.csUserListOverlay) : + (forceAttr "invalid" <$> drawMain st) + +-- | Draw a PostListOverlay as a floating overlay on top of whatever +-- is rendered beneath it +drawUsersBox :: UserListOverlayState -> Widget Name +drawUsersBox st = + centerLayer $ hLimitWithPadding 10 $ vLimit 25 $ + borderWithLabel contentHeader body + where + body = vBox [ (padRight (Pad 1) $ str promptMsg) <+> + renderEditor (txt . T.unlines) True (st^.userListSearchInput) + , cursorPositionBorder + , userResultList + ] + plural 1 = "" + plural _ = "s" + cursorPositionBorder = case st^.userListSearchResults.L.listSelectedL of + Nothing -> hBorder + Just _ -> + let msg = case st^.userListRequestingMore of + True -> "Fetching more results..." + False -> "Showing " <> show numSearchResults <> " result" <> plural numSearchResults + -- NOTE: one day when we resume doing + -- pagination, we want to reinstate the + -- following logic instead of the False case + -- above. Please see State.UserListOverlay for + -- details. + -- + -- False -> case st^.userListHasAllResults of + -- True -> "Showing all results (" <> show numSearchResults <> ")" + -- False -> "Showing first " <> + -- show numSearchResults <> + -- " result" <> plural numSearchResults + in hBorderWithLabel $ str $ "[" <> msg <> "]" + + scope = st^.userListSearchScope + promptMsg = case scope of + ChannelMembers _ -> "Search channel members:" + ChannelNonMembers _ -> "Search users:" + AllUsers -> "Search users:" + + userResultList = + if st^.userListSearching + then showMessage "Searching..." + else showResults + + showMessage = center . withDefAttr clientEmphAttr . str + + showResults + | numSearchResults == 0 = + showMessage $ case scope of + ChannelMembers _ -> "No users in channel." + ChannelNonMembers _ -> "All users in your team are already in this channel." + AllUsers -> "No users found." + | otherwise = renderedUserList + + contentHeader = str $ case scope of + ChannelMembers _ -> "Channel Members" + ChannelNonMembers _ -> "Invite Users to Channel" + AllUsers -> "Users On This Server" + + renderedUserList = L.renderList renderUser True (st^.userListSearchResults) + numSearchResults = F.length $ st^.userListSearchResults.L.listElementsL + + sanitize = T.strip . T.replace "\t" " " + usernameWidth = 20 + renderUser foc ui = + (if foc then forceAttr L.listSelectedFocusedAttr else id) $ + vLimit 2 $ + padRight Max $ + hBox $ (padRight (Pad 1) $ colorUsername (ui^.uiName) (T.singleton $ userSigilFromInfo ui)) + : (hLimit usernameWidth $ padRight Max $ colorUsername (ui^.uiName) (ui^.uiName)) + : extras + where + extras = padRight (Pad 1) <$> catMaybes [mFullname, mNickname, mEmail] + mFullname = if (not (T.null (ui^.uiFirstName)) || not (T.null (ui^.uiLastName))) + then Just $ txt $ (sanitize $ ui^.uiFirstName) <> " " <> (sanitize $ ui^.uiLastName) + else Nothing + mNickname = case ui^.uiNickName of + Just n | n /= (ui^.uiName) -> Just $ txt $ "(" <> n <> ")" + _ -> Nothing + mEmail = if (T.null $ ui^.uiEmail) + then Nothing + else Just $ modifyDefAttr (`V.withURL` ("mailto:" <> ui^.uiEmail)) $ + withDefAttr urlAttr (txt ("<" <> ui^.uiEmail <> ">")) diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -38,6 +38,7 @@ import Events.UrlSelect import Events.MessageSelect import Events.PostListOverlay +import Events.UserListOverlay onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState) onEvent st ev = runMHEvent st (onEv >> fetchVisibleIfNeeded) @@ -66,13 +67,18 @@ let msg = "An unexpected error has occurred! The exception encountered was:\n " <> T.pack (show e) <> "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" - postErrorMessage msg + mhError msg onAppEvent (WebsocketParseError e) = do let msg = "A websocket message could not be parsed:\n " <> T.pack e <> "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" - postErrorMessage msg + mhError msg +onAppEvent (IEvent e) = do + handleIEvent e +handleIEvent :: InternalEvent -> MH () +handleIEvent (DisplayError msg) = postErrorMessage' msg + onVtyEvent :: Vty.Event -> MH () onVtyEvent e = do -- Even if we aren't showing the help UI when a resize occurs, we @@ -97,19 +103,19 @@ MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e DeleteChannelConfirm -> onEventDeleteChannelConfirm e PostListOverlay _ -> onEventPostListOverlay e + UserListOverlay -> onEventUserListOverlay e handleWSEvent :: WebsocketEvent -> MH () handleWSEvent we = do - myId <- use (csMe.userIdL) - myTeamId <- use (csMyTeam.teamIdL) + myId <- gets myUserId + myTId <- gets myTeamId case weEvent we of WMPosted | Just p <- wepPost (weData we) -> do -- If the message is a header change, also update the -- channel metadata. - myUserId <- use (csMe.userIdL) let wasMentioned = case wepMentions (weData we) of - Just lst -> myUserId `Set.member` lst + Just lst -> myId `Set.member` lst _ -> False addNewPostedMessage $ RecentPost p wasMentioned | otherwise -> return () @@ -125,13 +131,13 @@ WMStatusChange | Just status <- wepStatus (weData we) , Just uId <- wepUserId (weData we) -> - updateStatus uId status + setUserStatus uId status | otherwise -> return () WMUserAdded | Just cId <- webChannelId (weBroadcast we) -> when (wepUserId (weData we) == Just myId && - wepTeamId (weData we) == Just myTeamId) $ + wepTeamId (weData we) == Just myTId) $ handleChannelInvite cId | otherwise -> return () @@ -152,7 +158,7 @@ WMChannelDeleted | Just cId <- wepChannelId (weData we) -> - when (webTeamId (weBroadcast we) == Just myTeamId) $ + when (webTeamId (weBroadcast we) == Just myTId) $ removeChannelFromState cId | otherwise -> return () @@ -210,6 +216,7 @@ -- We aren't sure whether there is anything we should do about -- these yet: WMUpdateTeam -> return () + WMTeamDeleted -> return () WMUserUpdated -> return () WMLeaveTeam -> return () diff --git a/src/Events/JoinChannel.hs b/src/Events/JoinChannel.hs --- a/src/Events/JoinChannel.hs +++ b/src/Events/JoinChannel.hs @@ -7,6 +7,8 @@ import qualified Graphics.Vty as Vty import Lens.Micro.Platform +import Network.Mattermost.Types (getId) + import Types import State (joinChannel) @@ -33,7 +35,7 @@ Nothing -> return () Just l -> case listSelectedElement l of Nothing -> return () - Just (_, chan) -> joinChannel chan + Just (_, chan) -> joinChannel (getId chan) onEventJoinChannel (Vty.EvKey Vty.KEsc []) = do setMode Main onEventJoinChannel _ = do diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -123,6 +123,13 @@ SelectUpEvent -> [ key 'k', kb Vty.KUp ] SelectDownEvent -> [ key 'j', kb Vty.KDown ] + ActivateListItemEvent -> [ kb Vty.KEnter ] + + -- search selection - like SelectUp/Down above but need to not + -- conflict with editor inputs + SearchSelectUpEvent -> [ ctrl (key 'p'), kb Vty.KUp ] + SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ] + FlagMessageEvent -> [ key 'f' ] YankMessageEvent -> [ key 'y' ] DeleteMessageEvent -> [ key 'd' ] diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -17,7 +17,7 @@ import Types import Types.Channels (ccInfo, cdType, clearNewMessageIndicator, clearEditedThreshold) -import Types.Users (uiDeleted, findUserById) +import Types.Users (uiDeleted, uiName) import Events.Keybindings import State import State.PostListOverlay (enterFlaggedPostListMode) @@ -35,12 +35,6 @@ handleKeyboardEvent mainKeybindings $ \ ev -> case ev of (Vty.EvPaste bytes) -> handlePaste bytes _ -> handleEditingInput ev - -- conf <- use (csResources.crConfiguration) - -- let keyMap = mainKeybindings (configUserKeys conf) - -- case e of - -- _ | Just kb <- lookupKeybinding e keyMap -> kbAction kb - -- (Vty.EvPaste bytes) -> handlePaste bytes - -- _ -> handleEditingInput e mainKeybindings :: KeyConfig -> [Keybinding] mainKeybindings = mkKeybindings @@ -182,26 +176,25 @@ tabComplete :: Completion.Direction -> MH () tabComplete dir = do st <- use id - knownUsers <- use csUsers + allUIds <- gets allUserIds + allChanNames <- gets allChannelNames - let completableChannels = catMaybes (flip map (st^.csNames.cnChans) $ \cname -> do + let completableChannels = catMaybes (flip map allChanNames $ \cname -> do -- Only permit completion of channel names for non-Group channels - cId <- st^.csNames.cnToChanId.at cname - let cType = st^?csChannel(cId).ccInfo.cdType - case cType of - Just Group -> Nothing - _ -> Just cname + ch <- channelByName cname st + case ch^.ccInfo.cdType of + Group -> Nothing + _ -> Just cname ) - completableUsers = catMaybes (flip map (st^.csNames.cnUsers) $ \uname -> do + completableUsers = catMaybes (flip map allUIds $ \uId -> do -- Only permit completion of user names for non-deleted users - uId <- st^.csNames.cnToUserId.at uname - case findUserById uId knownUsers of + case userById uId st of Nothing -> Nothing Just u -> if u^.uiDeleted then Nothing - else Just uname + else Just $ u^.uiName ) priorities = [] :: [T.Text]-- XXX: add recent completions to this diff --git a/src/Events/UserListOverlay.hs b/src/Events/UserListOverlay.hs new file mode 100644 --- /dev/null +++ b/src/Events/UserListOverlay.hs @@ -0,0 +1,35 @@ +module Events.UserListOverlay where + +import Control.Monad (when) +import qualified Graphics.Vty as Vty + +import Brick.Widgets.Edit (handleEditorEvent) + +import Types +import Events.Keybindings +import State.UserListOverlay + +onEventUserListOverlay :: Vty.Event -> MH () +onEventUserListOverlay = + handleKeyboardEvent userListOverlayKeybindings $ \e -> do + -- Get the editor content before the event. + before <- userListSearchString + + -- Handle the editor input event. + mhHandleEventLensed (csUserListOverlay.userListSearchInput) handleEditorEvent e + + -- Get the editor content after the event. If the string changed, + -- start a new search. + after <- userListSearchString + when (before /= after) resetUserListSearch + +-- | The keybindings we want to use while viewing a user list overlay +userListOverlayKeybindings :: KeyConfig -> [Keybinding] +userListOverlayKeybindings = mkKeybindings + [ mkKb CancelEvent "Close the user search list" exitUserListMode + , mkKb SearchSelectUpEvent "Select the previous user" userListSelectUp + , mkKb SearchSelectDownEvent "Select the next user" userListSelectDown + , mkKb PageDownEvent "Page down in the user list" userListPageDown + , mkKb PageUpEvent "Page up in the user list" userListPageUp + , mkKb ActivateListItemEvent "Interact with the selected user" userListActivateCurrent + ] diff --git a/src/LastRunState.hs b/src/LastRunState.hs --- a/src/LastRunState.hs +++ b/src/LastRunState.hs @@ -61,7 +61,7 @@ toLastRunState cs = LastRunState { _lrsHost = cs^.csResources.crConn.cdHostnameL , _lrsPort = cs^.csResources.crConn.cdPortL - , _lrsUserId = cs^.csMe.userIdL + , _lrsUserId = myUserId cs , _lrsSelectedChannelId = cs^.csCurrentChannelId } @@ -74,7 +74,8 @@ writeLastRunState cs = runExceptT . convertIOException $ when (cs^.csCurrentChannel.ccInfo.cdType `elem` [Ordinary, Private]) $ do let runState = toLastRunState cs - tId = cs^.csMyTeam.teamIdL + tId = myTeamId cs + lastRunStateFile <- lastRunStateFilePath $ unId $ toId tId createDirectoryIfMissing True $ dropFileName lastRunStateFile BS.writeFile lastRunStateFile $ LBS.toStrict $ A.encode runState @@ -91,7 +92,7 @@ -- | Checks if the given last run state is valid for the current server and user. isValidLastRunState :: ChatResources -> User -> LastRunState -> Bool -isValidLastRunState cr myUser rs = +isValidLastRunState cr me rs = rs^.lrsHost == cr^.crConn.cdHostnameL && rs^.lrsPort == cr^.crConn.cdPortL - && rs^.lrsUserId == myUser^.userIdL + && rs^.lrsUserId == me^.userIdL diff --git a/src/Login.hs b/src/Login.hs --- a/src/Login.hs +++ b/src/Login.hs @@ -20,6 +20,7 @@ import qualified Data.Text as T import Graphics.Vty import System.Exit (exitSuccess) +import qualified System.IO.Error as Err import Network.Mattermost.Exceptions (LoginFailureException(..)) @@ -128,6 +129,10 @@ "Could not connect to server" renderAuthError (ResolveError _) = "Could not resolve server hostname" +renderAuthError (AuthIOError err) + | Err.isDoesNotExistErrorType (Err.ioeGetErrorType err) = + "Unable to connect to the network" + | otherwise = "GetAddrInfo: " <> T.pack (Err.ioeGetErrorString err) renderAuthError (OtherAuthError e) = T.pack $ show e renderAuthError (LoginError (LoginFailureException msg)) = diff --git a/src/Scripts.hs b/src/Scripts.hs --- a/src/Scripts.hs +++ b/src/Scripts.hs @@ -32,10 +32,10 @@ "$ chmod u+x " <> T.pack scriptPath <> "\n" <> "```\n" <> "to correct this error. " <> scriptHelpAddendum) - postErrorMessage msg + mhError msg ScriptNotFound -> do let msg = ("No script named " <> scriptName <> " was found") - postErrorMessage msg + mhError msg runScript :: STM.TChan ProgramOutput -> FilePath -> T.Text -> IO (MH ()) runScript outputChan fp text = do @@ -70,7 +70,7 @@ mconcat [ " - " <> T.pack cmd <> "\n" | cmd <- nonexecs ] <> "\n" <> scriptHelpAddendum) - postErrorMessage errMsg + mhError errMsg scriptHelpAddendum :: T.Text scriptHelpAddendum = diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -18,6 +18,7 @@ , createOrdinaryChannel , startJoinChannel , joinChannel + , joinChannelByName , changeChannel , disconnectChannels , startLeaveCurrentChannel @@ -38,7 +39,6 @@ , getNewMessageCutoff , getEditedMessageCutoff , setChannelTopic - , fetchCurrentChannelMembers , refreshChannelById , handleChannelInvite , addUserToCurrentChannel @@ -60,7 +60,6 @@ -- * Working with users , handleNewUsers - , updateStatus , handleTypingUser -- * Startup/reconnect management @@ -129,7 +128,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import Data.List (sort, findIndex) -import Data.Maybe (maybeToList, isJust, fromJust, catMaybes, isNothing) +import Data.Maybe (isJust, fromJust, catMaybes, isNothing) import Data.Monoid ((<>)) import qualified Data.Set as Set import qualified Data.Text as T @@ -194,7 +193,7 @@ refreshChannelById :: ChannelId -> MH () refreshChannelById cId = do - session <- use (csResources.crSession) + session <- getSession doAsyncWith Preempt $ do cwd <- MM.mmGetChannel cId session member <- MM.mmGetChannelMember cId UserMe session @@ -202,24 +201,24 @@ createGroupChannel :: T.Text -> MH () createGroupChannel usernameList = do - users <- use csUsers - me <- use csMe + st <- use id + me <- gets myUser let usernames = T.words usernameList findUserIds [] = return [] findUserIds (n:ns) = do - case findUserByName users n of + case userByUsername n st of Nothing -> do - postErrorMessage $ "No such user: " <> n + mhError $ "No such user: " <> n return [] - Just (uId, _) -> (uId:) <$> findUserIds ns + Just u -> (u^.uiId:) <$> findUserIds ns results <- findUserIds usernames -- If we found all of the users mentioned, then create the group -- channel. when (length results == length usernames) $ do - session <- use (csResources.crSession) + session <- getSession doAsyncWith Preempt $ do chan <- MM.mmCreateGroupMessageChannel (Seq.fromList results) session let pref = showGroupChannelPref (channelId chan) (me^.userIdL) @@ -277,17 +276,17 @@ refreshChannelsAndUsers = do -- The below code is a duplicate of mmGetAllChannelsWithDataForUser function, -- which has been inlined here to gain a concurrency benefit. - session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) + session <- getSession + myTId <- gets myTeamId let userQuery = MM.defaultUserQuery { MM.userQueryPage = Just 0 , MM.userQueryPerPage = Just 10000 - , MM.userQueryInTeam = Just myTeamId + , MM.userQueryInTeam = Just myTId } doAsyncWith Preempt $ do (chans, datas, users) <- runConcurrently $ (,,) - <$> Concurrently (MM.mmGetChannelsForUser UserMe myTeamId session) - <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTeamId session) + <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session) + <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session) <*> Concurrently (MM.mmGetUsers userQuery session) let dataMap = HM.fromList $ F.toList $ (\d -> (channelMemberChannelId d, d)) <$> datas @@ -297,17 +296,15 @@ return $ do forM_ users $ \u -> do when (not $ userDeleted u) $ do - knownUsers <- use csUsers - case findUserById (getId u) knownUsers of - Just _ -> return () - Nothing -> handleNewUserDirect u + result <- gets (userById (getId u)) + when (isNothing result) $ handleNewUserDirect u forM_ chansWithData $ uncurry refreshChannel - userSet <- use (csResources.crUserIdSet) - liftIO $ STM.atomically $ STM.writeTVar userSet (fmap userId users) + setUserIdSet (userId <$> users) lock <- use (csResources.crUserStatusLock) - doAsyncWith Preempt $ updateUserStatuses userSet lock session + setVar <- use (csResources.crUserIdSet) + doAsyncWith Preempt $ updateUserStatuses setVar lock session -- | Websocket was disconnected, so all channels may now miss some -- messages @@ -332,24 +329,6 @@ csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member -addChannelName :: Type -> ChannelId -> T.Text -> MH () -addChannelName chType cid name = do - csNames.cnToChanId.at(name) .= Just cid - - -- For direct channels the username is already in the user list so - -- do nothing - existingNames <- use $ csNames.cnChans - when (chType /= Direct && (not $ name `elem` existingNames)) $ - csNames.cnChans %= (sort . (name:)) - -removeChannelName :: T.Text -> MH () -removeChannelName name = do - -- Flush cnToChanId - csNames.cnToChanId.at name .= Nothing - -- Flush cnChans - csNames.cnChans %= filter (/= name) - - -- * Message selection mode beginMessageSelect :: MH () @@ -437,7 +416,7 @@ let chType = chan^.ccInfo.cdType if chType /= Direct then setMode DeleteChannelConfirm - else postErrorMessage "The /delete-channel command cannot be used with direct message channels." + else mhError "The /delete-channel command cannot be used with direct message channels." deleteCurrentChannel :: MH () deleteCurrentChannel = do @@ -451,12 +430,11 @@ isRecentChannel :: ChatState -> ChannelId -> Bool isRecentChannel st cId = st^.csRecentChannel == Just cId - -- | Tell the server that we have flagged or unflagged a message. flagMessage :: PostId -> Bool -> MH () flagMessage pId f = do - session <- use (csResources.crSession) - myId <- use (csMe.userIdL) + session <- getSession + myId <- gets myUserId doAsyncWith Normal $ do let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost doFlag myId pId session @@ -526,10 +504,20 @@ -- * Joining, Leaving, and Inviting +joinChannelByName :: T.Text -> MH () +joinChannelByName rawName = do + session <- getSession + tId <- gets myTeamId + doAsyncWith Preempt $ do + result <- try $ MM.mmGetChannelByName tId (trimAnySigil rawName) session + return $ case result of + Left (_::SomeException) -> mhError $ T.pack $ "No such channel: " <> (show rawName) + Right chan -> joinChannel $ getId chan + startJoinChannel :: MH () startJoinChannel = do - session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) + session <- getSession + myTId <- gets myTeamId myChannels <- use (csChannels.to (filteredChannelIds (const True))) doAsyncWith Preempt $ do -- We don't get to just request all channels, so we request channels in @@ -537,7 +525,7 @@ -- then wait for the user to demand more. let fetchCount = 50 loop acc start = do - newChans <- MM.mmGetPublicChannels myTeamId (Just start) (Just fetchCount) session + newChans <- MM.mmGetPublicChannels myTId (Just start) (Just fetchCount) session let chans = acc <> newChans if length newChans < fetchCount then return chans @@ -550,58 +538,58 @@ setMode JoinChannel csJoinChannelList .= Nothing -joinChannel :: Channel -> MH () -joinChannel chan = do +joinChannel :: ChannelId -> MH () +joinChannel chanId = do setMode Main - myId <- use (csMe.userIdL) - let member = MinChannelMember myId (getId chan) - doAsyncChannelMM Preempt (getId chan) (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP + myId <- gets myUserId + let member = MinChannelMember myId chanId + doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP -- | When another user adds us to a channel, we need to fetch the -- channel info for that channel. handleChannelInvite :: ChannelId -> MH () handleChannelInvite cId = do - st <- use id + session <- getSession doAsyncWith Normal $ do - member <- MM.mmGetChannelMember cId UserMe (st^.csResources.crSession) - tryMM (MM.mmGetChannel cId (st^.csResources.crSession)) + member <- MM.mmGetChannelMember cId UserMe session + tryMM (MM.mmGetChannel cId session) (\cwd -> return $ handleNewChannel False cwd member) addUserToCurrentChannel :: T.Text -> MH () addUserToCurrentChannel uname = do -- First: is this a valid username? - usrs <- use csUsers - case findUserByName usrs uname of - Just (uid, _) -> do + result <- gets (userByUsername uname) + case result of + Just u -> do cId <- use csCurrentChannelId - session <- use (csResources.crSession) - let channelMember = MinChannelMember uid cId + session <- getSession + let channelMember = MinChannelMember (u^.uiId) cId doAsyncWith Normal $ do - tryMM (void $ MM.mmAddUser cId channelMember session) -- session myTeamId cId uid) + tryMM (void $ MM.mmAddUser cId channelMember session) (const $ return (return ())) _ -> do - postErrorMessage ("No such user: " <> uname) + mhError ("No such user: " <> uname) removeUserFromCurrentChannel :: T.Text -> MH () removeUserFromCurrentChannel uname = do -- First: is this a valid username? - usrs <- use csUsers - case findUserByName usrs uname of - Just (uid, _) -> do + result <- gets (userByUsername uname) + case result of + Just u -> do cId <- use csCurrentChannelId - session <- use (csResources.crSession) + session <- getSession doAsyncWith Normal $ do - tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById uid) session) + tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session) (const $ return (return ())) _ -> do - postErrorMessage ("No such user: " <> uname) + mhError ("No such user: " <> uname) startLeaveCurrentChannel :: MH () startLeaveCurrentChannel = do cInfo <- use (csCurrentChannel.ccInfo) case canLeaveChannel cInfo of True -> setMode LeaveChannelConfirm - False -> postErrorMessage "The /leave command cannot be used with this channel." + False -> mhError "The /leave command cannot be used with this channel." leaveCurrentChannel :: MH () leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel @@ -609,7 +597,7 @@ leaveChannelIfPossible :: ChannelId -> Bool -> MH () leaveChannelIfPossible cId delete = do st <- use id - me <- use csMe + me <- gets myUser let isMe u = u^.userIdL == me^.userIdL case st ^? csChannel(cId).ccInfo of @@ -670,9 +658,7 @@ chType = chan^.ccInfo.cdType when (chType /= Direct) $ do origFocus <- use csCurrentChannelId - when (origFocus == cId) $ do - st <- use id - setFocusWith (getNextNonDMChannel st Z.right) + when (origFocus == cId) nextChannel csEditState.cedInputHistoryPosition .at cId .= Nothing csEditState.cedLastChannelInput .at cId .= Nothing -- Update input history @@ -684,21 +670,6 @@ -- Remove from focus zipper csFocus %= Z.filterZipper (/= cId) -fetchCurrentChannelMembers :: MH () -fetchCurrentChannelMembers = do - cId <- use csCurrentChannelId - doAsyncChannelMM Preempt cId - fetchChannelMembers - (\_ chanUsers -> do - -- Construct a message listing them all and post it to the - -- channel: - let msgStr = "Channel members (" <> (T.pack $ show $ length chanUsers) <> "):\n" <> - T.intercalate ", " usernames - usernames = sort $ userUsername <$> filteredUsers - filteredUsers = filter (not . userDeleted) chanUsers - - postInfoMessage msgStr) - fetchChannelMembers :: Session -> TeamId -> ChannelId -> IO [User] fetchChannelMembers s _ c = do let query = MM.defaultUserQuery @@ -788,9 +759,6 @@ cId <- use csCurrentChannelId csEditState.cedInputHistoryPosition.at cId .= Just Nothing -updateStatus :: UserId -> T.Text -> MH () -updateStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) - clearEditor :: MH () clearEditor = csEditState.cedEditor %= applyEdit clearZipper @@ -1069,40 +1037,31 @@ -- Now initiate fetches for use information for any -- as-yet-unknown users related to this new set of messages - let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post)) Set.empty (posts^.postsPostsL) - addUnknownUsers st inputUserIds = - let knownUserIds = allUserIds (st^.csUsers) - unknownUsers = Set.difference inputUserIds knownUserIds - in if Set.null unknownUsers + addUnknownUsers inputUserIds = do + knownUserIds <- Set.fromList <$> gets allUserIds + let unknownUsers = Set.difference inputUserIds knownUserIds + if Set.null unknownUsers then return () else handleNewUsers $ Seq.fromList $ F.toList unknownUsers - st <- use id - addUnknownUsers st users + addUnknownUsers users -- Return the aggregated user notification action needed -- relative to the set of added messages. return action - loadMoreMessages :: MH () loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages -channelByName :: ChatState -> T.Text -> Maybe ChannelId -channelByName st n - | normalChannelSigil `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n) - | userSigil `T.isPrefixOf` n = st ^. csNames . cnToChanId . at (T.tail n) - | otherwise = st ^. csNames . cnToChanId . at n - -- | This switches to the named channel or creates it if it is a missing -- but valid user channel. changeChannel :: T.Text -> MH () changeChannel name = do - st <- use id - case channelByName st name of + result <- gets (channelIdByName name) + case result of Just cId -> setFocus cId Nothing -> attemptCreateDMChannel name @@ -1126,17 +1085,17 @@ attemptCreateDMChannel :: T.Text -> MH () attemptCreateDMChannel name = do - users <- use (csNames.cnUsers) - nameToChanId <- use (csNames.cnToChanId) - myName <- use (csMe.userUsernameL) - if name == myName - then postErrorMessage ("Cannot create a DM channel with yourself") - else if name `elem` users && not (name `HM.member` nameToChanId) + mCid <- gets (channelIdByName name) + mUid <- gets (userIdForUsername name) + me <- gets myUser + if name == me^.userUsernameL + then mhError ("Cannot create a DM channel with yourself") + else if isJust mUid && isNothing mCid then do -- We have a user of that name but no channel. Time to make one! - myId <- use (csMe.userIdL) - Just uId <- use (csNames.cnToUserId.at(name)) - session <- use (csResources.crSession) + myId <- gets myUserId + Just uId <- gets (userIdForUsername name) + session <- getSession doAsyncWith Normal $ do -- create a new channel nc <- MM.mmCreateDirectMessageChannel (uId, myId) session -- tId uId @@ -1144,12 +1103,12 @@ member <- MM.mmGetChannelMember (getId nc) UserMe session return $ handleNewChannel True cwd member else - postErrorMessage ("No channel or user named " <> name) + mhError ("No channel or user named " <> name) createOrdinaryChannel :: T.Text -> MH () createOrdinaryChannel name = do - session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) + session <- getSession + myTId <- gets myTeamId doAsyncWith Preempt $ do -- create a new chat channel let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name) @@ -1159,7 +1118,7 @@ , minChannelPurpose = Nothing , minChannelHeader = Nothing , minChannelType = Ordinary - , minChannelTeamId = myTeamId + , minChannelTeamId = myTId } tryMM (do c <- MM.mmCreateChannel minChannel session chan <- MM.mmGetChannel (getId c) session @@ -1204,7 +1163,7 @@ -- async work to do before we can register this channel (in -- which case abort because we got rescheduled). mName <- case chType of - Direct -> case userIdForDMChannel (st^.csMe.userIdL) $ channelName nc of + Direct -> case userIdForDMChannel (myUserId st) $ channelName nc of -- If this is a direct channel but we can't extract a -- user ID from the name, then it failed to parse. We -- need to assign a channel name in our channel map, @@ -1218,7 +1177,7 @@ -- probably better than ignoring this entirely. Nothing -> return $ Just $ channelName nc Just otherUserId -> - case getUsernameForUserId st otherUserId of + case usernameForUserId otherUserId st of -- If we found a user ID in the channel name -- string but don't have that user's metadata, -- postpone adding this channel until we have @@ -1252,13 +1211,7 @@ csChannels %= addChannel (getId nc) cChannel - -- We should figure out how to do this better: this adds - -- it to the channel zipper in such a way that we don't - -- ever change our focus to something else, which is - -- kind of silly - names <- use csNames - let newZip = Z.updateList (mkChannelZipperList names) - csFocus %= newZip + refreshChannelZipper -- Finally, set our focus to the newly created channel -- if the caller requested a change of channel. @@ -1266,7 +1219,7 @@ editMessage :: Post -> MH () editMessage new = do - myId <- use (csMe.userIdL) + myId <- gets myUserId let isEditedMessage m = m^.mPostId == Just (new^.postIdL) msg = clientPostToMessage (toClientPost new (new^.postParentIdL)) chan = csChannel (new^.postChannelIdL) @@ -1362,13 +1315,13 @@ st <- use id case st ^? csChannel(postChannelId new) of Nothing -> do - session <- use (csResources.crSession) + session <- getSession doAsyncWith Preempt $ do nc <- MM.mmGetChannel (postChannelId new) session member <- MM.mmGetChannelMember (postChannelId new) UserMe session let chType = nc^.channelTypeL - pref = showGroupChannelPref (postChannelId new) (st^.csMe.userIdL) + pref = showGroupChannelPref (postChannelId new) (myUserId st) -- If the channel has been archived, we don't want to post -- this message or add the channel to the state. @@ -1390,7 +1343,7 @@ return NoAction Just _ -> do let cp = toClientPost new (new^.postParentIdL) - fromMe = (cp^.cpUser == (Just $ getId (st^.csMe))) && + fromMe = (cp^.cpUser == (Just $ myUserId st)) && (isNothing $ cp^.cpUserOverride) cId = postChannelId new @@ -1444,7 +1397,7 @@ withChannelOrDefault (postChannelId new) NoAction $ \chan -> do currCId <- use csCurrentChannelId - let notifyPref = notifyPreference (st^.csMe) chan + let notifyPref = notifyPreference (myUser st) chan curChannelAction = if postChannelId new == currCId then UpdateServerViewed else NoAction @@ -1502,14 +1455,6 @@ _ -> return () -mkChannelZipperList :: MMNames -> [ChannelId] -mkChannelZipperList chanNames = - [ (chanNames ^. cnToChanId) HM.! i - | i <- chanNames ^. cnChans ] ++ - [ c - | i <- chanNames ^. cnUsers - , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] - setChannelTopic :: T.Text -> MH () setChannelTopic msg = do cId <- use csCurrentChannelId @@ -1622,20 +1567,25 @@ -- Given the current channel select string, find all the channel and -- user matches and then update the match lists. chanNameMatches <- use (csChannelSelectState.channelSelectInput.to channelNameMatch) - chanNames <- use (csNames.cnChans) + chanNames <- gets allChannelNames uList <- use (to sortedUserList) let chanMatches = catMaybes (fmap chanNameMatches chanNames) usernameMatches = catMaybes (fmap chanNameMatches (fmap _uiName uList)) mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms] + + newInput <- use (csChannelSelectState.channelSelectInput) csChannelSelectState.channelMatches .= mkMap chanMatches csChannelSelectState.userMatches .= mkMap usernameMatches csChannelSelectState.selectedMatch %= \oldMatch -> - -- If the previously selected match is still a possible match, - -- leave it selected. Otherwise revert to the first available - -- match. - let newMatch = if oldMatch `elem` allMatches - then oldMatch - else firstAvailableMatch + -- If the user input exactly matches one of the matches, prefer + -- that one. Otherwise, if the previously selected match is + -- still a possible match, leave it selected. Otherwise revert + -- to the first available match. + let newMatch = if newInput `elem` allMatches + then newInput + else if oldMatch `elem` allMatches + then oldMatch + else firstAvailableMatch unames = channelNameFromMatch <$> usernameMatches allMatches = concat [ channelNameFromMatch <$> chanMatches , [ u^.uiName | u <- uList @@ -1753,8 +1703,7 @@ Just (_, link) -> do opened <- openURL link when (not opened) $ do - let msg = "Config option 'urlOpenCommand' missing; cannot open URL." - postInfoMessage msg + mhError "Config option 'urlOpenCommand' missing; cannot open URL." setMode Main openURL :: LinkChoice -> MH Bool @@ -1764,10 +1713,12 @@ Nothing -> return False Just urlOpenCommand -> do + session <- getSession + -- Is the URL referring to an attachment? let act = case link^.linkFileId of Nothing -> prepareLink link - Just fId -> prepareAttachment fId + Just fId -> prepareAttachment fId session -- Is the URL-opening command interactive? If so, pause -- Matterhorn and run the opener interactively. Otherwise @@ -1775,10 +1726,9 @@ -- Matterhorn interactively. case configURLOpenCommandInteractive cfg of False -> do - st <- use id outputChan <- use (csResources.crSubprocessLog) doAsyncWith Preempt $ do - args <- act st + args <- act runLoggedCommand False outputChan (T.unpack urlOpenCommand) args Nothing Nothing return $ return () @@ -1806,20 +1756,19 @@ -- suspended. mhSuspendAndResume $ \st -> do - args <- act st + args <- act void $ runInteractiveCommand (T.unpack urlOpenCommand) args return $ setMode' Main st return True -prepareLink :: LinkChoice -> ChatState -> IO [String] -prepareLink link _ = return [T.unpack $ link^.linkURL] +prepareLink :: LinkChoice -> IO [String] +prepareLink link = return [T.unpack $ link^.linkURL] -prepareAttachment :: FileId -> ChatState -> IO [String] -prepareAttachment fId st = do +prepareAttachment :: FileId -> Session -> IO [String] +prepareAttachment fId sess = do -- The link is for an attachment, so fetch it and then -- open the local copy. - let sess = st^.csResources.crSession (info, contents) <- concurrently (MM.mmGetMetadataForFile fId sess) (MM.mmGetFile fId sess) cacheDir <- getUserCacheDir xdgName @@ -1897,9 +1846,8 @@ openedAll <- and <$> mapM openURL urls case openedAll of True -> setMode Main - False -> do - let msg = "Config option 'urlOpenCommand' missing; cannot open URL." - postInfoMessage msg + False -> + mhError "Config option 'urlOpenCommand' missing; cannot open URL." shouldSkipMessage :: T.Text -> Bool shouldSkipMessage "" = True @@ -1915,50 +1863,36 @@ case status of Disconnected -> do let m = "Cannot send messages while disconnected." - postErrorMessage m + mhError m Connected -> do let chanId = st^.csCurrentChannelId + session <- getSession doAsync Preempt $ do case mode of NewPost -> do let pendingPost = rawPost msg chanId - void $ MM.mmCreatePost pendingPost (st^.csResources.crSession) + void $ MM.mmCreatePost pendingPost session Replying _ p -> do - let pendingPost = (rawPost msg chanId) { rawPostRootId = Just (postId p) } - void $ MM.mmCreatePost pendingPost (st^.csResources.crSession) + let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p) } + void $ MM.mmCreatePost pendingPost session Editing p -> do - void $ MM.mmUpdatePost (postId p) (postUpdate msg) (st^.csResources.crSession) + void $ MM.mmUpdatePost (postId p) (postUpdate msg) session handleNewUserDirect :: User -> MH () handleNewUserDirect newUser = do let usrInfo = userInfoFromUser newUser True - newUserId = getId newUser - csUsers %= addUser newUserId usrInfo - csNames . cnUsers %= (sort . ((newUser^.userUsernameL):)) - csNames . cnToUserId . at (newUser^.userUsernameL) .= Just newUserId - userSet <- use (csResources.crUserIdSet) - liftIO $ STM.atomically $ STM.modifyTVar userSet $ (newUserId Seq.<|) + addNewUser usrInfo handleNewUsers :: Seq.Seq UserId -> MH () -handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo updateUserStates +handleNewUsers newUserIds = doAsyncMM Preempt getUserInfo addNewUsers where getUserInfo session _ = do nUsers <- MM.mmGetUsersByIds newUserIds session let usrInfo u = userInfoFromUser u True usrList = F.toList nUsers - return $ zip usrList (usrInfo <$> usrList) - - updateUserStates :: [(User, UserInfo)] -> MH () - updateUserStates pairs = mapM_ updateUserState pairs + return $ usrInfo <$> usrList - updateUserState :: (User, UserInfo) -> MH () - updateUserState (newUser, uInfo) = - -- Update the name map and the list of known users - do let uId = userId newUser - csUsers %= addUser uId uInfo - csNames . cnUsers %= (sort . ((newUser^.userUsernameL):)) - csNames . cnToUserId . at (newUser^.userUsernameL) .= Just uId - userSet <- use (csResources.crUserIdSet) - liftIO $ STM.atomically $ STM.modifyTVar userSet $ (uId Seq.<|) + addNewUsers :: [UserInfo] -> MH () + addNewUsers = mapM_ addNewUser -- | Handle the typing events from the websocket to show the currently typing users on UI handleTypingUser :: UserId -> ChannelId -> MH () diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -40,7 +40,7 @@ result <- liftIO $ try act case result of Left (MattermostError { mattermostErrorMessage = msg }) -> - return $ postErrorMessage msg + return $ mhError msg Right value -> liftIO $ onSuccess value -- * Background Computation @@ -138,10 +138,10 @@ -- context -> MH () doAsyncMM prio mmOp eventHandler = do - session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) + session <- getSession + tId <- gets myTeamId doAsyncWith prio $ do - r <- mmOp session myTeamId + r <- mmOp session tId return $ eventHandler r -- | Helper type for a function to perform an asynchronous MM operation @@ -205,7 +205,7 @@ asyncFetchAttachments p = do let cId = (p^.postChannelIdL) pId = (p^.postIdL) - session <- use (csResources.crSession) + session <- getSession host <- use (csResources.crConn.cdHostnameL) F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do info <- mmGetMetadataForFile fId session @@ -239,11 +239,16 @@ -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list -postErrorMessage :: T.Text -> MH () -postErrorMessage err = do +postErrorMessage' :: T.Text -> MH () +postErrorMessage' err = do msg <- newClientMessage Error err doAsyncWith Normal (return $ addClientMessage msg) +-- | Raise a rich error +mhError :: T.Text -> MH () +mhError err = do + raiseInternalEvent (DisplayError err) + postErrorMessageIO :: T.Text -> ChatState -> IO ChatState postErrorMessageIO err st = do msg <- newClientMessage Error err @@ -288,6 +293,6 @@ MissingCommands cmds -> "Could not set clipboard due to missing one of the " <> "required program(s): " <> (T.pack $ show cmds) - postErrorMessage errMsg + mhError errMsg Right () -> return () diff --git a/src/State/PostListOverlay.hs b/src/State/PostListOverlay.hs --- a/src/State/PostListOverlay.hs +++ b/src/State/PostListOverlay.hs @@ -29,7 +29,7 @@ -- | Create a PostListOverlay with flagged messages from the server. enterFlaggedPostListMode :: MH () enterFlaggedPostListMode = do - session <- use (csResources.crSession) + session <- getSession doAsyncWith Preempt $ do posts <- mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery session return $ do @@ -40,8 +40,8 @@ -- server. enterSearchResultPostListMode :: Text -> MH () enterSearchResultPostListMode terms = do - session <- use (csResources.crSession) - tId <- teamId <$> use csMyTeam + session <- getSession + tId <- gets myTeamId enterPostListMode (PostListSearch terms True) noMessages doAsyncWith Preempt $ do posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -15,7 +15,6 @@ import Control.Monad (forM, when) import Data.Monoid ((<>)) import qualified Data.Foldable as F -import qualified Data.HashMap.Strict as HM import Data.Maybe (listToMaybe, fromMaybe, fromJust, isNothing) import qualified Data.Sequence as Seq import qualified Data.Text as T @@ -23,6 +22,7 @@ import System.Exit (exitFailure) import System.FilePath ((), isRelative, dropFileName) import System.IO (Handle) +import System.IO.Error (catchIOError) import Network.Mattermost.Endpoints import Network.Mattermost.Types @@ -82,6 +82,7 @@ result <- (Right <$> mmLogin cd login) `catch` (\e -> return $ Left $ ResolveError e) `catch` (\e -> return $ Left $ ConnectError e) + `catchIOError` (\e -> return $ Left $ AuthIOError e) `catch` (\e -> return $ Left $ OtherAuthError e) -- Update the config with the entered settings so that later, @@ -104,7 +105,7 @@ interactiveGatherCredentials cInfo (Just e) >>= loginLoop - (session, myUser, cd, config) <- loginLoop connInfo + (session, me, cd, config) <- loginLoop connInfo teams <- mmGetUsersTeams UserMe session when (Seq.null teams) $ do @@ -162,13 +163,13 @@ let cr = ChatResources session cd requestChan eventChan slc wac (themeToAttrMap custTheme) userStatusLock userIdSet config mempty prefs - initializeState cr myTeam myUser + initializeState cr myTeam me initializeState :: ChatResources -> Team -> User -> IO ChatState -initializeState cr myTeam myUser = do - let session = cr^.crSession +initializeState cr myTeam me = do + let session = getResourceSession cr requestChan = cr^.crRequestQueue - myTeamId = getId myTeam + myTId = getId myTeam -- Create a predicate to find the last selected channel by reading the -- run state file. If unable to read or decode or validate the file, this @@ -176,7 +177,7 @@ isLastSelectedChannel <- do result <- readLastRunState $ teamId myTeam case result of - Right lrs | isValidLastRunState cr myUser lrs -> return $ \c -> + Right lrs | isValidLastRunState cr me lrs -> return $ \c -> channelId c == lrs^.lrsSelectedChannelId _ -> return isTownSquare @@ -186,7 +187,7 @@ -- 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. -- This is not entirely correct since the Town Square channel can be renamed! - userChans <- mmGetChannelsForUser UserMe myTeamId session + userChans <- mmGetChannelsForUser UserMe myTId session let lastSelectedChans = Seq.filter isLastSelectedChannel userChans chans = if Seq.null lastSelectedChans then Seq.filter isTownSquare userChans @@ -229,22 +230,21 @@ -- End thread startup ---------------------------------------------- - let chanNames = mkChanNames myUser mempty chans - chanIds = [ (chanNames ^. cnToChanId) HM.! i - | i <- chanNames ^. cnChans ] + let names = mkNames me mempty chans + chanIds = getChannelIdsInOrder names chanZip = Z.fromList chanIds startupState = StartupStateInfo { startupStateResources = cr , startupStateChannelZipper = chanZip - , startupStateConnectedUser = myUser + , startupStateConnectedUser = me , startupStateTeam = myTeam , startupStateTimeZone = tz , startupStateInitialHistory = hist , startupStateSpellChecker = spResult + , startupStateNames = names } st = newState startupState & csChannels %~ flip (foldr (uncurry addChannel)) msgs - & csNames .~ chanNames loadFlaggedMessages (cr^.crPreferences) st diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -17,11 +17,10 @@ import qualified Control.Concurrent.STM as STM import Control.Concurrent.STM.Delay import Control.Exception (SomeException, try, finally) -import Control.Monad (forever, when, void) +import Control.Monad (forever, when, void, forM_) import Control.Monad.IO.Class (liftIO) import Data.List (isInfixOf) import qualified Data.Foldable as F -import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Maybe (catMaybes) @@ -55,10 +54,8 @@ Just () | not (F.null users) -> do statuses <- mmGetUserStatusByIds users session `finally` putMVar lock () return $ do - let statusMap = HM.fromList [ (statusUserId s, statusStatus s) | s <- F.toList statuses ] - setStatus u = u & uiStatus .~ (newsts u) - newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline - csUsers . mapped %= setStatus + forM_ statuses $ \s -> + setUserStatus (statusUserId s) (statusStatus s) Just () -> putMVar lock () >> return (return ()) _ -> return $ return () @@ -128,7 +125,7 @@ let msg = T.pack $ "An error occurred when running " <> show progName <> "; see " <> logPath <> " for details." - postErrorMessage msg + mhError msg logMonitor (Just (logPath, logHandle)) diff --git a/src/State/UserListOverlay.hs b/src/State/UserListOverlay.hs new file mode 100644 --- /dev/null +++ b/src/State/UserListOverlay.hs @@ -0,0 +1,304 @@ +module State.UserListOverlay + ( enterChannelMembersUserList + , enterChannelInviteUserList + , enterDMSearchUserList + , resetUserListSearch + , exitUserListMode + + , userListActivateCurrent + , userListSelectDown + , userListSelectUp + , userListPageDown + , userListPageUp + + , userListSearchString + ) +where + +import Control.Monad (when) +import Data.Monoid ((<>)) +import qualified Data.Vector as Vec +import qualified Data.Foldable as F +import qualified Data.Text as T +import qualified Data.Sequence as Seq +import qualified Data.HashMap.Strict as HM +import Data.Maybe (fromMaybe) +import Lens.Micro.Platform +import qualified Network.Mattermost.Endpoints as MM +import Network.Mattermost.Types +import qualified Data.Text.Zipper as Z + +import qualified Brick.Widgets.List as L +import qualified Brick.Widgets.Edit as E + +import Types +import Types.Users +import State.Common +import State (changeChannel, addUserToCurrentChannel) + +-- | Show the user list overlay for searching/showing members of the +-- current channel. +enterChannelMembersUserList :: MH () +enterChannelMembersUserList = do + cId <- use csCurrentChannelId + myId <- gets myUserId + enterUserListMode (ChannelMembers cId) + (\u -> case u^.uiId /= myId of + True -> changeChannel (u^.uiName) >> return True + False -> return False + ) + +-- | Show the user list overlay for showing users that are not members +-- of the current channel for the purpose of adding them to the +-- channel. +enterChannelInviteUserList :: MH () +enterChannelInviteUserList = do + cId <- use csCurrentChannelId + myId <- gets myUserId + enterUserListMode (ChannelNonMembers cId) + (\u -> case u^.uiId /= myId of + True -> addUserToCurrentChannel (u^.uiName) >> return True + False -> return False + ) + +-- | Show the user list overlay for showing all users for the purpose of +-- starting a direct message channel with another user. +enterDMSearchUserList :: MH () +enterDMSearchUserList = do + myId <- gets myUserId + enterUserListMode AllUsers + (\u -> case u^.uiId /= myId of + True -> changeChannel (u^.uiName) >> return True + False -> return False + ) + +-- | Interact with the currently-selected user (depending on how the +-- overlay is configured). +userListActivateCurrent :: MH () +userListActivateCurrent = do + mItem <- L.listSelectedElement <$> use (csUserListOverlay.userListSearchResults) + case mItem of + Nothing -> return () + Just (_, user) -> do + handler <- use (csUserListOverlay.userListEnterHandler) + activated <- handler user + if activated + then setMode Main + else return () + +-- | Show the user list overlay with the given search scope, and issue a +-- request to gather the first search results. +enterUserListMode :: UserSearchScope -> (UserInfo -> MH Bool) -> MH () +enterUserListMode scope enterHandler = do + csUserListOverlay.userListSearchScope .= scope + csUserListOverlay.userListSelected .= Nothing + csUserListOverlay.userListSearchInput.E.editContentsL %= Z.clearZipper + csUserListOverlay.userListEnterHandler .= enterHandler + csUserListOverlay.userListSearching .= False + csUserListOverlay.userListHasAllResults .= False + setMode UserListOverlay + resetUserListSearch + +resetUserListSearch :: MH () +resetUserListSearch = do + searchPending <- use (csUserListOverlay.userListSearching) + + when (not searchPending) $ do + searchString <- userListSearchString + csUserListOverlay.userListSearching .= True + csUserListOverlay.userListHasAllResults .= False + csUserListOverlay.userListSearchResults .= listFromUserSearchResults mempty + session <- getSession + scope <- use (csUserListOverlay.userListSearchScope) + myTId <- gets myTeamId + doAsyncWith Preempt $ do + results <- fetchInitialResults myTId scope session searchString + return $ do + let lst = listFromUserSearchResults results + csUserListOverlay.userListSearchResults .= lst + -- NOTE: Disabled for now. See the hack note below for + -- details. + -- + -- csUserListOverlay.userListHasAllResults .= (length results < searchResultsChunkSize) + csUserListOverlay.userListSearching .= False + + -- Now that the results are available, check to see if the + -- search string changed since this request was submitted. + -- If so, issue another search. + afterSearchString <- userListSearchString + when (searchString /= afterSearchString) resetUserListSearch + +userInfoFromPair :: User -> T.Text -> UserInfo +userInfoFromPair u status = + userInfoFromUser u True & uiStatus .~ statusFromText status + +-- | Clear out the state of the user list overlay and return to the Main +-- mode. +exitUserListMode :: MH () +exitUserListMode = do + csUserListOverlay.userListSearchResults .= listFromUserSearchResults mempty + csUserListOverlay.userListSelected .= Nothing + csUserListOverlay.userListEnterHandler .= (const $ return False) + setMode Main + +-- | Move the selection up in the user list overlay by one user. +userListSelectUp :: MH () +userListSelectUp = userListMove L.listMoveUp + +-- | Move the selection down in the user list overlay by one user. +userListSelectDown :: MH () +userListSelectDown = userListMove L.listMoveDown + +-- | Move the selection up in the user list overlay by a page of users +-- (userListPageSize). +userListPageUp :: MH () +userListPageUp = userListMove (L.listMoveBy (-1 * userListPageSize)) + +-- | Move the selection down in the user list overlay by a page of users +-- (userListPageSize). +userListPageDown :: MH () +userListPageDown = userListMove (L.listMoveBy userListPageSize) + +-- | Transform the user list results in some way, e.g. by moving the +-- cursor, and then check to see whether the modification warrants a +-- prefetch of more search results. +userListMove :: (L.List Name UserInfo -> L.List Name UserInfo) -> MH () +userListMove f = do + csUserListOverlay.userListSearchResults %= f + -- NOTE! Do not enable this. See the docs for maybePrefetchNextChunk. + -- For now we want to keep the code around in case it can be + -- reinstated in the future. + -- maybePrefetchNextChunk + +-- | We'll attempt to prefetch the next page of results if the cursor +-- gets within this many positions of the last result we have. +selectionPrefetchDelta :: Int +selectionPrefetchDelta = 10 + +-- Prefetch the next chunk of user list search results if all of the +-- following are true: +-- +-- * the search string is empty (because we can't paginate searches, +-- just fetches for all users), and +-- * cursor is within selectionPrefetchDelta positions of the end of +-- list, and +-- * the length of the current results list is exactly a multiple of +-- fetching chunk size (thus indicating a very high probability that +-- there are more results to be fetched). +-- +-- NOTE: this function should be reinstated and called in 'userListMove' +-- if we start using the /users endpoint again in the future. See the +-- hack note in the getUserSearchResultsPage below for details. In the +-- mean time, no pagination of results is possible so no prefetching +-- should be done. +_maybePrefetchNextChunk :: MH () +_maybePrefetchNextChunk = do + gettingMore <- use (csUserListOverlay.userListRequestingMore) + hasAll <- use (csUserListOverlay.userListHasAllResults) + searchString <- userListSearchString + curIdx <- use (csUserListOverlay.userListSearchResults.L.listSelectedL) + numResults <- use (csUserListOverlay.userListSearchResults.to F.length) + + let selectionNearEnd = case curIdx of + Nothing -> False + Just i -> numResults - (i + 1) < selectionPrefetchDelta + + when (not hasAll && T.null searchString && not gettingMore && selectionNearEnd) $ do + let pageNum = numResults `div` searchResultsChunkSize + + csUserListOverlay.userListRequestingMore .= True + session <- getSession + scope <- use (csUserListOverlay.userListSearchScope) + myTId <- gets myTeamId + doAsyncWith Preempt $ do + newChunk <- getUserSearchResultsPage pageNum myTId scope session searchString + return $ do + -- Because we only ever append, this is safe to do w.r.t. + -- the selected index of the list. If we ever prepended or + -- removed, we'd also need to manage the selection index + -- to ensure it stays in bounds. + csUserListOverlay.userListSearchResults.L.listElementsL %= (<> newChunk) + csUserListOverlay.userListRequestingMore .= False + + -- If we got fewer results than we asked for, then we have + -- them all! + -- + -- NOTE: disabled for now, see the hack note below. + -- + -- csUserListOverlay.userListHasAllResults .= + -- (length newChunk < searchResultsChunkSize) + +-- | The number of users in a "page" for cursor movement purposes. +userListPageSize :: Int +userListPageSize = 10 + +-- | Perform an initial request for search results in the specified +-- scope. +fetchInitialResults :: TeamId -> UserSearchScope -> Session -> T.Text -> IO (Vec.Vector UserInfo) +fetchInitialResults = getUserSearchResultsPage 0 + +searchResultsChunkSize :: Int +searchResultsChunkSize = 40 + +getUserSearchResultsPage :: Int + -- ^ The page number of results to fetch, starting at zero. + -> TeamId + -- ^ My team ID. + -> UserSearchScope + -- ^ The scope to search + -> Session + -- ^ The connection session + -> T.Text + -- ^ The search string + -> IO (Vec.Vector UserInfo) +getUserSearchResultsPage _pageNum myTId scope s searchString = do + -- Unfortunately, we don't get pagination control when there is a + -- search string in effect. We'll get at most 100 results from a + -- search. + let query = UserSearch { userSearchTerm = if T.null searchString then " " else searchString + -- Hack alert: Searching with the string " " + -- above is a hack to use the search + -- endpoint to get "all users" instead of + -- those matching a particular non-empty + -- non-whitespace string. This is because + -- only the search endpoint provides a + -- control to eliminate deleted users from + -- the results. If we don't do this, and + -- use the /users endpoint instead, we'll + -- get deleted users in those results and + -- then those deleted users will disappear + -- from the results once the user enters a + -- non-empty string string. + , userSearchAllowInactive = False + , userSearchWithoutTeam = False + , userSearchInChannelId = case scope of + ChannelMembers cId -> Just cId + _ -> Nothing + , userSearchNotInTeamId = Nothing + , userSearchNotInChannelId = case scope of + ChannelNonMembers cId -> Just cId + _ -> Nothing + , userSearchTeamId = case scope of + ChannelNonMembers _ -> Just myTId + _ -> Nothing + } + users <- MM.mmSearchUsers query s + + let uList = F.toList users + uIds = userId <$> uList + + -- Now fetch status info for the users we got. + case null uList of + False -> do + statuses <- MM.mmGetUserStatusByIds (Seq.fromList uIds) s + let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- F.toList statuses ] + usersWithStatus = [ userInfoFromPair u (fromMaybe "" $ HM.lookup (userId u) statusMap) + | u <- uList + ] + + return $ Vec.fromList usersWithStatus + True -> return mempty + +userListSearchString :: MH T.Text +userListSearchString = + (head . E.getEditContents) <$> use (csUserListOverlay.userListSearchInput) diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -10,6 +10,7 @@ , MessageSelectState(..) , ProgramOutput(..) , MHEvent(..) + , InternalEvent(..) , Name(..) , ChannelSelectMatch(..) , StartupStateInfo(..) @@ -32,11 +33,9 @@ , RequestChan , MMNames - , mkChanNames - , cnUsers - , cnToUserId - , cnToChanId - , cnChans + , mkNames + , refreshChannelZipper + , getChannelIdsInOrder , LinkChoice(LinkChoice) , linkUser @@ -63,17 +62,15 @@ , csPostMap , csRecentChannel , csPostListOverlay + , csUserListOverlay , csMyTeam , csMessageSelect , csJoinChannelList , csConnectionStatus , csWorkerIsBusy - , csNames - , csUsers , csChannel , csChannels , csChannelSelectState - , csMe , csEditState , timeZone , whenMode @@ -100,11 +97,24 @@ , postListSelected , postListPosts + , UserSearchScope(..) + + , UserListOverlayState + , userListSelected + , userListSearchResults + , userListSearchInput + , userListSearchScope + , userListSearching + , userListRequestingMore + , userListHasAllResults + , userListEnterHandler + + , listFromUserSearchResults + , ChatResources(ChatResources) , crPreferences , crEventQueue , crTheme - , crSession , crSubprocessLog , crWebsocketActionChan , crRequestQueue @@ -113,6 +123,8 @@ , crFlaggedPosts , crConn , crConfiguration + , getSession + , getResourceSession , WebsocketAction(..) @@ -137,9 +149,29 @@ , userList , hasUnread , channelNameFromMatch + , trimAnySigil , isMine - , getUsernameForUserId + , setUserStatus + , myUser + , myUserId + , myTeamId + , usernameForUserId + , userIdForUsername + , userByDMChannelName + , userByUsername + , channelIdByName + , channelByName + , userById + , allUserIds + , allChannelNames + , allUsernames , sortedUserList + , removeChannelName + , addChannelName + , addNewUser + , setUserIdSet + , channelMentionCount + , raiseInternalEvent , userSigil , normalChannelSigil @@ -160,14 +192,15 @@ import Brick.AttrMap (AttrMap) import Brick.Widgets.Edit (Editor, editor) import Brick.Widgets.List (List, list) +import Control.Monad (when) import qualified Control.Concurrent.STM as STM import Control.Concurrent.MVar (MVar) import Control.Exception (SomeException) import qualified Control.Monad.State as St import Control.Monad.State (gets) -import Control.Monad (when) import qualified Data.Foldable as F import qualified Data.Sequence as Seq +import qualified Data.Vector as Vec import Data.HashMap.Strict (HashMap) import Data.Time (UTCTime) import Data.Time.LocalTime.TimeZone.Series (TimeZoneSeries) @@ -177,6 +210,7 @@ import Data.Monoid import qualified Data.Set as Set import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!), (.=) + , (%=), (^?) , use, _Just, Traversal', preuse, (^..), folded, to ) import Network.Mattermost (ConnectionData) import Network.Mattermost.Exceptions @@ -188,7 +222,7 @@ import System.Exit (ExitCode) import Text.Aspell (Aspell) -import Zipper (Zipper, focusL) +import Zipper (Zipper, focusL, updateList) import InputHistory @@ -250,12 +284,8 @@ -- ^ Mapping from user names to 'UserId' values } --- | An empty 'MMNames' record -emptyMMNames :: MMNames -emptyMMNames = MMNames mempty mempty mempty mempty - -mkChanNames :: User -> HM.HashMap UserId User -> Seq.Seq Channel -> MMNames -mkChanNames myUser users chans = MMNames +mkNames :: User -> HM.HashMap UserId User -> Seq.Seq Channel -> MMNames +mkNames myUser users chans = MMNames { _cnChans = sort [ preferredChannelName c | c <- F.toList chans, channelType c /= Direct ] @@ -277,6 +307,22 @@ makeLenses ''MMNames +-- ** 'MMNames' functions + +mkChannelZipperList :: MMNames -> [ChannelId] +mkChannelZipperList chanNames = + getChannelIdsInOrder chanNames ++ + getDMChannelIdsInOrder chanNames + +getChannelIdsInOrder :: MMNames -> [ChannelId] +getChannelIdsInOrder n = [ (n ^. cnToChanId) HM.! i | i <- n ^. cnChans ] + +getDMChannelIdsInOrder :: MMNames -> [ChannelId] +getDMChannelIdsInOrder n = + [ c | i <- n ^. cnUsers + , c <- maybeToList (HM.lookup i (n ^. cnToChanId)) + ] + -- * Internal Names and References -- | This 'Name' type is the value used in `brick` to identify the @@ -294,6 +340,8 @@ | JoinChannelList | UrlList | MessagePreviewViewport + | UserListSearchInput + | UserListSearchResults deriving (Eq, Show, Ord) -- | The sum type of exceptions we expect to encounter on authentication @@ -302,6 +350,7 @@ data AuthenticationException = ConnectError HostCannotConnect | ResolveError HostNotResolved + | AuthIOError IOError | LoginError LoginFailureException | OtherAuthError SomeException deriving (Show) @@ -479,6 +528,7 @@ | MessageSelect | MessageSelectDeleteConfirm | PostListOverlay PostListContents + | UserListOverlay deriving (Eq) -- | We're either connected or we're not. @@ -508,6 +558,7 @@ , _csJoinChannelList :: Maybe (List Name Channel) , _csMessageSelect :: MessageSelectState , _csPostListOverlay :: PostListOverlayState + , _csUserListOverlay :: UserListOverlayState } data StartupStateInfo = @@ -518,15 +569,16 @@ , startupStateTimeZone :: TimeZoneSeries , startupStateInitialHistory :: InputHistory , startupStateSpellChecker :: Maybe (Aspell, IO ()) + , startupStateNames :: MMNames } newState :: StartupStateInfo -> ChatState -newState (StartupStateInfo rs i u m tz hist sp) = ChatState +newState (StartupStateInfo rs i u m tz hist sp ns) = ChatState { _csResources = rs , _csFocus = i , _csMe = u , _csMyTeam = m - , _csNames = emptyMMNames + , _csNames = ns , _csChannels = noChannels , _csPostMap = HM.empty , _csUsers = noUsers @@ -542,8 +594,27 @@ , _csJoinChannelList = Nothing , _csMessageSelect = MessageSelectState Nothing , _csPostListOverlay = PostListOverlayState mempty Nothing + , _csUserListOverlay = nullUserListOverlayState } +nullUserListOverlayState :: UserListOverlayState +nullUserListOverlayState = + UserListOverlayState { _userListSearchResults = listFromUserSearchResults mempty + , _userListSelected = Nothing + , _userListSearchInput = editor UserListSearchInput (Just 1) "" + , _userListSearchScope = AllUsers + , _userListSearching = False + , _userListRequestingMore = False + , _userListHasAllResults = False + , _userListEnterHandler = const $ return False + } + +listFromUserSearchResults :: Vec.Vector UserInfo -> List Name UserInfo +listFromUserSearchResults rs = + -- NB: The item height here needs to actually match the UI drawing + -- in Draw.UserListOverlay. + list UserListSearchResults rs 1 + type ChannelSelectMap = HM.HashMap T.Text ChannelSelectMatch data ChannelSelectState = @@ -569,6 +640,22 @@ , _postListSelected :: Maybe PostId } +data UserListOverlayState = UserListOverlayState + { _userListSearchResults :: List Name UserInfo + , _userListSelected :: Maybe PostId + , _userListSearchInput :: Editor T.Text Name + , _userListSearchScope :: UserSearchScope + , _userListSearching :: Bool + , _userListRequestingMore :: Bool + , _userListHasAllResults :: Bool + , _userListEnterHandler :: UserInfo -> MH Bool + } + +data UserSearchScope = + ChannelMembers ChannelId + | ChannelNonMembers ChannelId + | AllUsers + -- | Actions that can be sent on the websocket to the server. data WebsocketAction = UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box @@ -656,15 +743,29 @@ -- ^ background worker is idle | BGBusy (Maybe Int) -- ^ background worker is busy (with n requests) + | IEvent InternalEvent + -- ^ MH-internal events +data InternalEvent + = DisplayError T.Text + -- ^ Display a generic error message to the user + deriving (Eq, Show) + -- ** Application State Lenses makeLenses ''ChatResources makeLenses ''ChatState makeLenses ''ChatEditState makeLenses ''PostListOverlayState +makeLenses ''UserListOverlayState makeLenses ''ChannelSelectState +getSession :: MH Session +getSession = use (csResources.crSession) + +getResourceSession :: ChatResources -> Session +getResourceSession = _crSession + whenMode :: Mode -> MH () -> MH () whenMode m act = do curMode <- use csMode @@ -710,8 +811,13 @@ -- ** 'ChatState' Helper Functions +raiseInternalEvent :: InternalEvent -> MH () +raiseInternalEvent ev = do + queue <- use (csResources.crEventQueue) + St.liftIO $ writeBChan queue (IEvent ev) + isMine :: ChatState -> Message -> Bool -isMine st msg = (UserI $ st^.csMe.userIdL) == msg^.mUser +isMine st msg = (UserI $ myUserId st) == msg^.mUser getMessageForPostId :: ChatState -> PostId -> Maybe Message getMessageForPostId st pId = st^.csPostMap.at(pId) @@ -722,9 +828,85 @@ = st^.csPostMap.at(pId) | otherwise = Nothing -getUsernameForUserId :: ChatState -> UserId -> Maybe T.Text -getUsernameForUserId st uId = _uiName <$> findUserById uId (st^.csUsers) +setUserStatus :: UserId -> T.Text -> MH () +setUserStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) +usernameForUserId :: UserId -> ChatState -> Maybe T.Text +usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers) + +userIdForUsername :: T.Text -> ChatState -> Maybe UserId +userIdForUsername name st = st^.csNames.cnToUserId.at name + +channelIdByName :: T.Text -> ChatState -> Maybe ChannelId +channelIdByName name st = + let nameToChanId = st^.csNames.cnToChanId + in HM.lookup (trimAnySigil name) nameToChanId + +channelByName :: T.Text -> ChatState -> Maybe ClientChannel +channelByName name st = do + cId <- channelIdByName name st + findChannelById cId (st^.csChannels) + +trimAnySigil :: T.Text -> T.Text +trimAnySigil n + | normalChannelSigil `T.isPrefixOf` n = T.tail n + | userSigil `T.isPrefixOf` n = T.tail n + | otherwise = n + +addNewUser :: UserInfo -> MH () +addNewUser u = do + csUsers %= addUser u + + let uname = u^.uiName + uid = u^.uiId + csNames.cnUsers %= (sort . (uname:)) + csNames.cnToUserId.at uname .= Just uid + + userSet <- use (csResources.crUserIdSet) + St.liftIO $ STM.atomically $ STM.modifyTVar userSet $ (uid Seq.<|) + +setUserIdSet :: Seq.Seq UserId -> MH () +setUserIdSet ids = do + userSet <- use (csResources.crUserIdSet) + St.liftIO $ STM.atomically $ STM.writeTVar userSet ids + +addChannelName :: Type -> ChannelId -> T.Text -> MH () +addChannelName chType cid name = do + csNames.cnToChanId.at(name) .= Just cid + + -- For direct channels the username is already in the user list so + -- do nothing + existingNames <- gets allChannelNames + when (chType /= Direct && (not $ name `elem` existingNames)) $ + csNames.cnChans %= (sort . (name:)) + +channelMentionCount :: ChannelId -> ChatState -> Int +channelMentionCount cId st = + maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) + +allChannelNames :: ChatState -> [T.Text] +allChannelNames st = st^.csNames.cnChans + +allUsernames :: ChatState -> [T.Text] +allUsernames st = st^.csNames.cnChans + +removeChannelName :: T.Text -> MH () +removeChannelName name = do + -- Flush cnToChanId + csNames.cnToChanId.at name .= Nothing + -- Flush cnChans + csNames.cnChans %= filter (/= name) + +-- Rebuild the channel zipper contents from the current names collection. +refreshChannelZipper :: MH () +refreshChannelZipper = do + -- We should figure out how to do this better: this adds it to the + -- channel zipper in such a way that we don't ever change our focus + -- to something else, which is kind of silly + names <- use csNames + let newZip = updateList (mkChannelZipperList names) + csFocus %= newZip + clientPostToMessage :: ClientPost -> Message clientPostToMessage cp = Message { _mText = cp^.cpText @@ -785,7 +967,37 @@ userList :: ChatState -> [UserInfo] userList st = filter showUser $ allUsers (st^.csUsers) where showUser u = not (isSelf u) && (u^.uiInTeam) - isSelf u = (st^.csMe.userIdL) == (u^.uiId) + isSelf u = (myUserId st) == (u^.uiId) + +allUserIds :: ChatState -> [UserId] +allUserIds st = getAllUserIds $ st^.csUsers + +userById :: UserId -> ChatState -> Maybe UserInfo +userById uId st = findUserById uId (st^.csUsers) + +myUserId :: ChatState -> UserId +myUserId st = myUser st ^. userIdL + +myTeamId :: ChatState -> TeamId +myTeamId st = st ^. csMyTeam . teamIdL + +myUser :: ChatState -> User +myUser st = st^.csMe + +userByDMChannelName :: T.Text + -- ^ the dm channel name + -> UserId + -- ^ me + -> ChatState + -> Maybe UserInfo + -- ^ you +userByDMChannelName name self st = + findUserByDMChannelName (st^.csUsers) name self + +userByUsername :: T.Text -> ChatState -> Maybe UserInfo +userByUsername name st = do + uId <- userIdForUsername name st + userById uId st sortedUserList :: ChatState -> [UserInfo] sortedUserList st = sortBy cmp yes <> sortBy cmp no diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -67,6 +67,14 @@ | SelectUpEvent | SelectDownEvent + -- search select events---these need to not be valid editor inputs + -- (such as 'j' and 'k') + | SearchSelectUpEvent + | SearchSelectDownEvent + + -- E.g. Pressing enter on an item in a list to do something with it + | ActivateListItemEvent + | FlagMessageEvent | YankMessageEvent | DeleteMessageEvent @@ -110,6 +118,11 @@ , SelectUpEvent , SelectDownEvent + , ActivateListItemEvent + + , SearchSelectUpEvent + , SearchSelectDownEvent + , FlagMessageEvent , YankMessageEvent , DeleteMessageEvent @@ -285,6 +298,11 @@ SelectUpEvent -> "select-up" SelectDownEvent -> "select-down" + + SearchSelectUpEvent -> "search-select-up" + SearchSelectDownEvent -> "search-select-down" + + ActivateListItemEvent -> "activate-list-item" FlagMessageEvent -> "flag-message" YankMessageEvent -> "yank-message" diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -17,7 +17,7 @@ , findUserById , findUserByName , findUserByDMChannelName - , noUsers, addUser, allUsers, allUserIds + , noUsers, addUser, allUsers , modifyUserById , getDMChannelName , userIdForDMChannel @@ -27,6 +27,7 @@ , addTypingUser , allTypingUsers , expireTypingUsers + , getAllUserIds ) where @@ -34,7 +35,6 @@ import qualified Data.HashMap.Strict as HM import Data.List (sort) import Data.Maybe (listToMaybe, maybeToList) -import qualified Data.Set as Set import qualified Data.Text as T import Data.Time (UTCTime) import Lens.Micro.Platform @@ -114,12 +114,12 @@ noUsers :: Users noUsers = AllUsers HM.empty --- | Add a member to the existing collection of Users -addUser :: UserId -> UserInfo -> Users -> Users -addUser uId userinfo = AllUsers . HM.insert uId userinfo . _ofUsers +getAllUserIds :: Users -> [UserId] +getAllUserIds = HM.keys . _ofUsers -allUserIds :: Users -> Set.Set UserId -allUserIds = Set.fromList . HM.keys . _ofUsers +-- | Add a member to the existing collection of Users +addUser :: UserInfo -> Users -> Users +addUser userinfo = AllUsers . HM.insert (userinfo^.uiId) userinfo . _ofUsers -- | Get a list of all known users allUsers :: Users -> [UserInfo]