matterhorn 40600.1.0 → 40700.0.0
raw patch · 28 files changed
+1009/−315 lines, 28 filesdep ~mattermost-apidep ~mattermost-api-qc
Dependency ranges changed: mattermost-api, mattermost-api-qc
Files
- CHANGELOG.md +34/−0
- matterhorn.cabal +7/−4
- src/Command.hs +18/−7
- src/Connection.hs +2/−1
- src/Draw.hs +2/−0
- src/Draw/ChannelList.hs +6/−8
- src/Draw/Main.hs +5/−6
- src/Draw/Messages.hs +1/−1
- src/Draw/PostListOverlay.hs +3/−3
- src/Draw/ShowHelp.hs +2/−0
- src/Draw/UserListOverlay.hs +124/−0
- src/Events.hs +16/−9
- src/Events/JoinChannel.hs +3/−1
- src/Events/Keybindings.hs +7/−0
- src/Events/Main.hs +11/−18
- src/Events/UserListOverlay.hs +35/−0
- src/LastRunState.hs +5/−4
- src/Login.hs +5/−0
- src/Scripts.hs +3/−3
- src/State.hs +122/−188
- src/State/Common.hs +13/−8
- src/State/PostListOverlay.hs +3/−3
- src/State/Setup.hs +13/−13
- src/State/Setup/Threads.hs +4/−7
- src/State/UserListOverlay.hs +304/−0
- src/Types.hs +236/−24
- src/Types/KeyEvents.hs +18/−0
- src/Types/Users.hs +7/−7
CHANGELOG.md view
@@ -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 =========
matterhorn.cabal view
@@ -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
src/Command.hs view
@@ -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
src/Connection.hs view
@@ -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
src/Draw.hs view
@@ -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
src/Draw/ChannelList.hs view
@@ -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
src/Draw/Main.hs view
@@ -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"
src/Draw/Messages.hs view
@@ -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. --
src/Draw/PostListOverlay.hs view
@@ -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)) <=>
src/Draw/ShowHelp.hs view
@@ -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
+ src/Draw/UserListOverlay.hs view
@@ -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 <> ">"))
src/Events.hs view
@@ -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 ()
src/Events/JoinChannel.hs view
@@ -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
src/Events/Keybindings.hs view
@@ -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' ]
src/Events/Main.hs view
@@ -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
+ src/Events/UserListOverlay.hs view
@@ -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+ ]
src/LastRunState.hs view
@@ -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
src/Login.hs view
@@ -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)) =
src/Scripts.hs view
@@ -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 =
src/State.hs view
@@ -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 ()
src/State/Common.hs view
@@ -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 ()
src/State/PostListOverlay.hs view
@@ -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
src/State/Setup.hs view
@@ -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
src/State/Setup/Threads.hs view
@@ -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))
+ src/State/UserListOverlay.hs view
@@ -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)
src/Types.hs view
@@ -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
src/Types/KeyEvents.hs view
@@ -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"
src/Types/Users.hs view
@@ -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]