matterhorn 40700.0.0 → 40800.0.0
raw patch · 22 files changed
+413/−215 lines, 22 filesdep ~mattermost-apidep ~mattermost-api-qc
Dependency ranges changed: mattermost-api, mattermost-api-qc
Files
- CHANGELOG.md +24/−0
- README.md +2/−7
- matterhorn.cabal +4/−4
- src/App.hs +22/−1
- src/Completion.hs +39/−39
- src/Config.hs +3/−0
- src/Draw/ChannelList.hs +3/−1
- src/Draw/Main.hs +16/−10
- src/Draw/Messages.hs +1/−1
- src/Events.hs +1/−0
- src/Events/Main.hs +54/−31
- src/LastRunState.hs +2/−2
- src/Main.hs +1/−13
- src/State.hs +105/−70
- src/State/Common.hs +2/−6
- src/State/Editing.hs +13/−1
- src/State/Messages.hs +2/−2
- src/State/Setup.hs +11/−9
- src/Types.hs +90/−16
- src/Types/Channels.hs +4/−2
- src/Types/Users.hs +10/−0
- src/Zipper.hs +4/−0
CHANGELOG.md view
@@ -1,4 +1,28 @@ +40800.0.0+=========++This release supports Mattermost server version 4.8.++New features:+ * Matterhorn now uses a connection pool with persistent server+ connections for improved performance (thanks to Abhinav Sarkar)+ * Matterhorn now honors the server-side user preference about whether+ join/leave messages should be shown or hidden.+ * Matterhorn now honors the server-side configuration setting that+ determines whether users are displayed by nickname if possible+ (thanks to Kelly McLaughlin)++New configuration settings:+ * The "hyperlinkURLs" setting controls whether Matterhorn emits+ hyperlinking escape sequences. It defaults to on, but can be disabled+ for users using terminal emulators that do not handle such escapes+ gracefully when they don't support hyperlinking (see #374)++Bug fixes:+ * On (re-)connection, Matterhorn now fetches all users rather than just+ the first few hundred.+ 40700.0.0 =========
README.md view
@@ -21,13 +21,8 @@ https://github.com/matterhorn-chat/matterhorn/releases -To fetch a release and run Matterhorn, run the following commands (where-`VERSION` and `PLATFORM` match your setup):-- wget https://github.com/matterhorn-chat/matterhorn/releases/download/<VERSION>/matterhorn-<VERSION>-<PLATFORM>.tar.gz- tar xf matterhorn-<VERSION>-<PLATFORM>.tar.gz- cd matterhorn-<VERSION>-<PLATFORM>- ./matterhorn+To run Matterhorn, unpack the binary release archive and run the+`matterhorn` binary within. When you run Matterhorn you'll be prompted for your server information and credentials. At present `matterhorn` supports only username/password
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 40700.0.0+version: 40800.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@@ -91,7 +91,7 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5- , mattermost-api == 40700.0.0+ , mattermost-api == 40800.0.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6@@ -159,8 +159,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 40700.0.0- , mattermost-api-qc == 40700.0.0+ , mattermost-api == 40800.0.0+ , mattermost-api-qc == 40800.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7
src/App.hs view
@@ -1,5 +1,6 @@ module App ( runMatterhorn+ , closeMatterhorn ) where @@ -7,13 +8,20 @@ import Prelude.Compat import Brick+import Data.Monoid ((<>))+import Control.Monad.Trans.Except (runExceptT) import qualified Graphics.Vty as Vty import Lens.Micro.Platform import System.IO (IOMode(WriteMode), openFile, hClose) import Text.Aspell (stopAspell) +import Network.Mattermost+ import Config import Options+import InputHistory+import IOUtil+import LastRunState import State.Setup import Events import Draw@@ -40,7 +48,7 @@ vty <- Vty.mkVty Vty.defaultConfig let output = Vty.outputIface vty Vty.setMode output Vty.BracketedPaste True- Vty.setMode output Vty.Hyperlink True+ Vty.setMode output Vty.Hyperlink $ configHyperlinkingMode config return vty finalSt <- customMain mkVty (Just $ st^.csResources.crEventQueue) app st@@ -54,3 +62,16 @@ Just h -> hClose h return finalSt++-- | Cleanup resources and save data for restoring on program restart.+closeMatterhorn :: ChatState -> IO ()+closeMatterhorn finalSt = do+ logIfError (mmCloseSession $ getResourceSession $ finalSt^.csResources) "Error in closing session"+ logIfError (writeHistory (finalSt^.csEditState.cedInputHistory)) "Error in writing history"+ logIfError (writeLastRunState finalSt) "Error in writing last run state"+ where+ logIfError action msg = do+ done <- runExceptT $ convertIOException $ action+ case done of+ Left err -> putStrLn $ msg <> ": " <> err+ Right _ -> return ()
src/Completion.hs view
@@ -1,56 +1,56 @@ -- Heavily inspired by tab completion from glirc: -- https://github.com/glguy/irc-core/blob/v2/src/Client/Commands/WordCompletion.hs-module Completion where+module Completion+ ( Completer(..)+ , wordComplete+ , currentAlternative+ , nextCompletion+ , previousCompletion+ )+where import Prelude () import Prelude.Compat -import Control.Applicative ( (<|>) )-import Control.Monad ( guard ) import Data.Char ( isSpace )-import Data.List ( find )+import Data.List ( sort ) import qualified Data.Set as Set-import Data.Set ( Set ) import qualified Data.Text as T -data Direction = Forwards | Backwards- deriving (Read, Show, Eq, Ord)+import qualified Zipper as Z -search :: Direction- -> T.Text -- ^ prefix- -> T.Text -- ^ current match- -> Set T.Text -- ^ potential completions- -> Maybe T.Text-search direction prefix current options- | Just next <- advanceFun direction current options- , prefix `T.isPrefixOf` next- = Just next+-- A completer stores the stateful selection of a completion alternative+-- from a sequence of alternatives. Each item in the sequence is a pair:+-- the first element of the pair is the string corresonding to the user+-- input and the second element of the pair is what will ultimately+-- replace the user's input. The two are decoupled specifically to deal+-- with permitting nickname completions to "resolve" to usernames.+data Completer =+ Completer { completionAlternatives :: Z.Zipper (T.Text, T.Text)+ } - | otherwise = case direction of- Backwards -> find (prefix `T.isPrefixOf`)- (Set.toDescList options)- Forwards -> do x <- Set.lookupGE prefix options- guard (prefix `T.isPrefixOf` x)- Just x- where- advanceFun Forwards = Set.lookupGT- advanceFun Backwards = Set.lookupLT+-- Nothing: no completions.+-- Just Left: a single completion.+-- Just Right: more than one completion.+wordComplete :: Set.Set (T.Text, T.Text) -> T.Text -> Maybe (Either T.Text Completer)+wordComplete options input =+ let curWord = currentWord input+ alts = sort $ Set.toList $ Set.filter ((curWord `T.isPrefixOf`) . fst) options+ in if null alts || T.null curWord+ then Nothing+ else if length alts == 1+ then Just $ Left $ snd $ head alts+ else Just $ Right $ Completer { completionAlternatives = Z.fromList alts+ } -wordComplete :: Direction- -> [T.Text] -- ^ priority completions- -> Set T.Text -- ^ potential completions- -> T.Text -- ^ current prompt- -> Maybe T.Text -- ^ previous search- -> Maybe T.Text -- ^ completion-wordComplete direction hints options prompt previous = do- let current = currentWord prompt- guard (not (T.null current))- case previous of- Just pattern | pattern `T.isPrefixOf` current ->- search direction pattern current options+currentAlternative :: Completer -> (T.Text, T.Text)+currentAlternative = Z.focus . completionAlternatives - _ -> find (current `T.isPrefixOf`) hints <|>- search direction current current options+nextCompletion :: Completer -> Completer+nextCompletion (Completer z) = Completer $ Z.right z++previousCompletion :: Completer -> Completer+previousCompletion (Completer z) = Completer $ Z.left z -- | trim whitespace and do any other edits we need -- to focus on the current word
src/Config.hs view
@@ -61,6 +61,8 @@ (configEnableAspell defaultConfig) configActivityBell <- fieldFlagDef "activityBell" (configActivityBell defaultConfig)+ configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs"+ (configHyperlinkingMode defaultConfig) configPass <- (Just . PasswordCommand <$> field "passcmd") <|> (Just . PasswordString <$> field "pass") <|> pure Nothing@@ -132,6 +134,7 @@ , configShowOlderEdits = True , configUserKeys = mempty , configShowTypingIndicator = False+ , configHyperlinkingMode = True } findConfig :: Maybe FilePath -> IO (Either String Config)
src/Draw/ChannelList.hs view
@@ -236,7 +236,9 @@ Nothing -> userSigilFromInfo u Just ("", _) -> userSigilFromInfo u _ -> '»' -- shows that user has a message in-progress- uname = u^.uiName+ uname = if useNickname st+ then u^.uiNickName.non (u^.uiName)+ else u^.uiName recent = maybe False (isRecentChannel st) m_chanId m_chanId = channelIdByName (u^.uiName) st unread = maybe False (hasUnread st) m_chanId
src/Draw/Main.hs view
@@ -36,6 +36,8 @@ import Draw.Messages import Draw.Util import Markdown+import Completion (Completer(..), currentAlternative)+import qualified Zipper as Z import State import Themes import TimeUtils (justAfter, justBefore)@@ -408,7 +410,10 @@ getMessageListing :: ChannelId -> ChatState -> Messages getMessageListing cId st =- st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages+ st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown)+ where isShown m+ | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True+ | otherwise = m^.mType /= CP Join && m^.mType /= CP Leave insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT@@ -496,13 +501,14 @@ , hBorder ] -completionAlternatives :: ChatState -> Widget Name-completionAlternatives st =- let alternatives = intersperse (txt " ") $ mkAlternative <$> st^.csEditState.cedCompletionAlternatives- mkAlternative val = let format = if val == st^.csEditState.cedCurrentAlternative- then visible . withDefAttr completionAlternativeCurrentAttr- else id- in format $ txt val+drawCompletionAlternatives :: Completer -> Widget Name+drawCompletionAlternatives c =+ let alternatives = intersperse (txt " ") $ mkAlternative <$> Z.toList (completionAlternatives c)+ mkAlternative (displayVal, _) =+ let format = if displayVal == (fst $ currentAlternative c)+ then visible . withDefAttr completionAlternativeCurrentAttr+ else id+ in format $ txt displayVal in hBox [ borderElem bsHorizontal , txt "[" , withDefAttr completionAlternativeListAttr $@@ -599,8 +605,8 @@ bottomBorder = case appMode st of MessageSelect -> messageSelectBottomBar st- _ -> case st^.csEditState.cedCurrentCompletion of- Just _ | length (st^.csEditState.cedCompletionAlternatives) > 1 -> completionAlternatives st+ _ -> case st^.csEditState.cedCompleter of+ Just c -> drawCompletionAlternatives c _ -> maybeSubdue $ hBox [ hLimit channelListWidth hBorder , borderElem bsIntersectB
src/Draw/Messages.hs view
@@ -31,7 +31,7 @@ nameForUserRef st uref = case uref of NoUser -> Nothing UserOverride t -> Just t- UserI uId -> usernameForUserId uId st+ UserI uId -> displaynameForUserId uId st -- | renderSingleMessage is the main message drawing function. --
src/Events.hs view
@@ -58,6 +58,7 @@ onAppEvent WebsocketConnect = do csConnectionStatus .= Connected refreshChannelsAndUsers+ refreshClientConfig onAppEvent BGIdle = csWorkerIsBusy .= Nothing onAppEvent (BGBusy n) = csWorkerIsBusy .= Just n onAppEvent (WSEvent we) =
src/Events/Main.hs view
@@ -4,7 +4,7 @@ import Prelude () import Prelude.Compat -import Brick+import Brick hiding (Direction) import Brick.Widgets.Edit import Data.Maybe (catMaybes) import Data.Monoid ((<>))@@ -17,7 +17,7 @@ import Types import Types.Channels (ccInfo, cdType, clearNewMessageIndicator, clearEditedThreshold)-import Types.Users (uiDeleted, uiName)+import Types.Users (uiDeleted, uiName, uiNickName) import Events.Keybindings import State import State.PostListOverlay (enterFlaggedPostListMode)@@ -128,7 +128,7 @@ True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KEnter []) False -> do- csEditState.cedCurrentCompletion .= Nothing+ csEditState.cedCompleter .= Nothing handleInputSubmission , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel"@@ -173,50 +173,73 @@ -- handler can tell whether we're editing, replying, etc. csEditState.cedEditMode .= NewPost -tabComplete :: Completion.Direction -> MH ()+data Direction = Forwards | Backwards++tabComplete :: Direction -> MH () tabComplete dir = do st <- use id allUIds <- gets allUserIds allChanNames <- gets allChannelNames+ displayNick <- use (to useNickname) - let completableChannels = catMaybes (flip map allChanNames $ \cname -> do+ let channelCompletions = concat $ catMaybes (flip map allChanNames $ \cname -> do -- Only permit completion of channel names for non-Group channels ch <- channelByName cname st case ch^.ccInfo.cdType of Group -> Nothing- _ -> Just cname+ _ -> Just [dupe cname, dupe $ normalChannelSigil <> cname] ) - completableUsers = catMaybes (flip map allUIds $ \uId -> do+ userCompletions = concat $ catMaybes (flip map allUIds $ \uId -> -- Only permit completion of user names for non-deleted users case userById uId st of Nothing -> Nothing+ Just u | u^.uiDeleted -> Nothing Just u ->- if u^.uiDeleted- then Nothing- else Just $ u^.uiName+ let mNick = case u^.uiNickName of+ Just nick | displayNick -> [(nick, u^.uiName)]+ _ -> []+ in Just $ [dupe $ u^.uiName, dupe $ userSigil <> u^.uiName] <> mNick ) - priorities = [] :: [T.Text]-- XXX: add recent completions to this- completions = Set.fromList (completableUsers ++- completableChannels ++- map (userSigil <>) completableUsers ++- map (normalChannelSigil <>) completableChannels ++- map ("/" <>) (commandName <$> commandList))-- line = Z.currentLine $ st^.csEditState.cedEditor.editContentsL- curComp = st^.csEditState.cedCurrentCompletion- (nextComp, alts) = case curComp of- Nothing -> let cw = currentWord line- in (Just cw, filter (cw `T.isPrefixOf`) $ Set.toList completions)- Just cw -> (Just cw, filter (cw `T.isPrefixOf`) $ Set.toList completions)+ commandCompletions = dupe <$> map ("/" <>) (commandName <$> commandList)+ dupe a = (a, a)+ completions = Set.fromList (userCompletions +++ channelCompletions +++ commandCompletions) - mb_word = wordComplete dir priorities completions line curComp- csEditState.cedCurrentCompletion .= nextComp- csEditState.cedCompletionAlternatives .= alts- let (edit, curAlternative) = case mb_word of- Nothing -> (id, "")- Just w -> (Z.insertMany w . Z.deletePrevWord, w)+ mCompleter <- use (csEditState.cedCompleter)+ case mCompleter of+ Just _ -> do+ -- Since there is already a completion in progress, cycle it+ -- according to the directional preference.+ let func = case dir of+ Forwards -> nextCompletion+ Backwards -> previousCompletion+ csEditState.cedCompleter %= fmap func+ Nothing -> do+ -- There is no completion in progress, so start a new+ -- completion from the current input.+ let line = Z.currentLine $ st^.csEditState.cedEditor.editContentsL+ case wordComplete completions line of+ Nothing ->+ -- No matches were found, so do nothing.+ return ()+ Just (Left single) ->+ -- Only a single match was found, so just replace the+ -- current word with the only match.+ csEditState.cedEditor %= applyEdit (Z.insertMany single . Z.deletePrevWord)+ Just (Right many) -> do+ -- More than one match was found, so start a+ -- completion by storing the completer state.+ csEditState.cedCompleter .= Just many - csEditState.cedEditor %= (applyEdit edit)- csEditState.cedCurrentAlternative .= curAlternative+ -- Get the current completer state (potentially just cycled to+ -- the next completion above) and update the editor with the current+ -- alternative.+ mComp <- use (csEditState.cedCompleter)+ case mComp of+ Nothing -> return ()+ Just comp -> do+ let replacement = snd $ currentAlternative comp+ csEditState.cedEditor %= applyEdit (Z.insertMany replacement . Z.deletePrevWord)
src/LastRunState.hs view
@@ -70,8 +70,8 @@ -- | Writes the run state to a file. The file is specific to the current team. -- | Writes only if the current channel is an ordrinary or a private channel.-writeLastRunState :: ChatState -> IO (Either String ())-writeLastRunState cs = runExceptT . convertIOException $+writeLastRunState :: ChatState -> IO ()+writeLastRunState cs = when (cs^.csCurrentChannel.ccInfo.cdType `elem` [Ordinary, Private]) $ do let runState = toLastRunState cs tId = myTeamId cs
src/Main.hs view
@@ -4,14 +4,10 @@ import Prelude.Compat import Data.Monoid ((<>))-import Lens.Micro.Platform import System.Exit (exitFailure) import Config import Options-import Types-import InputHistory-import LastRunState import App import Events (ensureKeybindingConsistency) @@ -32,12 +28,4 @@ exitFailure finalSt <- runMatterhorn opts config-- writeHistory (finalSt^.csEditState.cedInputHistory)-- -- Try to write the run state to a file. If it fails, just print the error- -- and do not exit with a failure status because the run state file is optional.- done <- writeLastRunState finalSt- case done of- Left err -> putStrLn $ "Error in writing last run state: " <> err- Right _ -> return ()+ closeMatterhorn finalSt
src/State.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} module State ( -- * Message flagging@@ -40,6 +41,7 @@ , getEditedMessageCutoff , setChannelTopic , refreshChannelById+ , refreshClientConfig , handleChannelInvite , addUserToCurrentChannel , removeUserFromCurrentChannel@@ -233,19 +235,18 @@ channelHiddenPreference :: ChannelId -> MH Bool channelHiddenPreference cId = do- prefs <- use (csResources.crPreferences)- let matching = filter (\p -> groupChannelId p == cId) $- catMaybes $ preferenceToGroupChannelPreference <$> (F.toList prefs)- return $ any (not . groupChannelShow) matching+ prefs <- use (csResources.crUserPreferences.userPrefGroupChannelPrefs)+ let matching = filter (\p -> fst p == cId) (HM.toList prefs)+ return $ any (not . snd) matching applyPreferenceChange :: Preference -> MH ()-applyPreferenceChange pref- | Just f <- preferenceToFlaggedPost pref =+applyPreferenceChange pref = do+ -- always update our user preferences accordingly+ csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)+ if+ | Just f <- preferenceToFlaggedPost pref -> do updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)- | Just g <- preferenceToGroupChannelPreference pref = do- -- First, go update the preferences with this change.- updatePreference pref-+ | Just g <- preferenceToGroupChannelPreference pref -> do let cId = groupChannelId g mChan <- preuse $ csChannel cId @@ -259,15 +260,7 @@ -- it, ask for a load/refresh. refreshChannelById cId _ -> return ()-applyPreferenceChange _ = return ()--updatePreference :: Preference -> MH ()-updatePreference pref = do- let replacePreference new old- | preferenceCategory old == preferenceCategory new &&- preferenceName old == preferenceName new = new- | otherwise = old- csResources.crPreferences %= fmap (replacePreference pref)+ | otherwise -> return () -- | Refresh information about all channels and users. This is usually -- triggered when a reconnect event for the WebSocket to the server@@ -278,34 +271,54 @@ -- which has been inlined here to gain a concurrency benefit. session <- getSession myTId <- gets myTeamId- let userQuery = MM.defaultUserQuery- { MM.userQueryPage = Just 0- , MM.userQueryPerPage = Just 10000- , MM.userQueryInTeam = Just myTId- } doAsyncWith Preempt $ do- (chans, datas, users) <- runConcurrently $ (,,)- <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)- <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)- <*> Concurrently (MM.mmGetUsers userQuery session)+ (chans, datas) <- runConcurrently $ (,)+ <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)+ <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session) let dataMap = HM.fromList $ F.toList $ (\d -> (channelMemberChannelId d, d)) <$> datas mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap) chansWithData = mkPair <$> chans - return $ do- forM_ users $ \u -> do- when (not $ userDeleted u) $ do- result <- gets (userById (getId u))- when (isNothing result) $ handleNewUserDirect u+ asyncFetchAllUsers page accum final = do+ doAsyncWith Preempt $ do+ let pageSize = 200+ userQuery = MM.defaultUserQuery+ { MM.userQueryPage = Just page+ , MM.userQueryPerPage = Just pageSize+ , MM.userQueryInTeam = Just myTId+ }+ batch <- MM.mmGetUsers userQuery session - forM_ chansWithData $ uncurry refreshChannel+ return $ case length batch < pageSize of+ True -> do+ let users = accum <> batch+ forM_ users $ \u -> do+ when (not $ userDeleted u) $ do+ result <- gets (userById (getId u))+ when (isNothing result) $ handleNewUserDirect u+ setUserIdSet (userId <$> users)+ final+ False ->+ asyncFetchAllUsers (page + 1) (accum <> batch) final - setUserIdSet (userId <$> users)- lock <- use (csResources.crUserStatusLock)- setVar <- use (csResources.crUserIdSet)- doAsyncWith Preempt $ updateUserStatuses setVar lock session+ return $ do+ asyncFetchAllUsers 0 mempty $ do+ forM_ chansWithData $ uncurry refreshChannel+ lock <- use (csResources.crUserStatusLock)+ setVar <- use (csResources.crUserIdSet)+ doAsyncWith Preempt $ updateUserStatuses setVar lock session +-- | Refresh client-accessible server configuration information. This+-- is usually triggered when a reconnect event for the WebSocket to+-- the server occurs.+refreshClientConfig :: MH ()+refreshClientConfig = do+ session <- getSession+ doAsyncWith Preempt $ do+ cfg <- MM.mmGetClientConfiguration (Just "old") session+ return (csClientConfig .= Just cfg)+ -- | Websocket was disconnected, so all channels may now miss some -- messages disconnectChannels :: MH ()@@ -606,9 +619,21 @@ False -> return () True -> -- The server will reject an attempt to leave a private- -- channel if we're the only member.+ -- channel if we're the only member. To check this, we+ -- just ask for the first two members of the channel.+ -- If there is only one, it must be us: hence the "all+ -- isMe" check below. If there are two members, it+ -- doesn't matter who they are, because we just know+ -- that we aren't the only remaining member, so we can't+ -- delete the channel. doAsyncChannelMM Preempt cId- fetchChannelMembers+ (\s _ _ ->+ let query = MM.defaultUserQuery+ { MM.userQueryPage = Just 0+ , MM.userQueryPerPage = Just 2+ , MM.userQueryInChannel = Just cId+ }+ in F.toList <$> MM.mmGetUsers query s) (\_ members -> do -- If the channel is private: -- * leave it if we aren't the last member.@@ -670,16 +695,6 @@ -- Remove from focus zipper csFocus %= Z.filterZipper (/= cId) -fetchChannelMembers :: Session -> TeamId -> ChannelId -> IO [User]-fetchChannelMembers s _ c = do- let query = MM.defaultUserQuery- { MM.userQueryPage = Just 0- , MM.userQueryPerPage = Just 10000- , MM.userQueryInChannel = Just c- }- chanUserMap <- MM.mmGetUsers query s- return $ F.toList chanUserMap- -- | Called on async completion when the currently viewed channel has -- been updated (i.e., just switched to this channel) to update local -- state.@@ -1086,15 +1101,26 @@ attemptCreateDMChannel :: T.Text -> MH () attemptCreateDMChannel name = do 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+ displayNick <- use (to useNickname)+ uList <- use (to sortedUserList)+ let myName = if displayNick && not (T.null $ userNickname me)+ then userNickname me+ else me^.userUsernameL+ if name == myName+ then mhError "Cannot create a DM channel with yourself"+ else do+ let uName = if displayNick+ then+ maybe name (view uiName)+ $ findUserByNickname uList name+ else name+ mUid <- gets (userIdForUsername uName)+ if isJust mUid && isNothing mCid then do -- We have a user of that name but no channel. Time to make one!+ let Just uId = mUid myId <- gets myUserId- Just uId <- gets (userIdForUsername name) session <- getSession doAsyncWith Normal $ do -- create a new channel@@ -1345,6 +1371,13 @@ let cp = toClientPost new (new^.postParentIdL) fromMe = (cp^.cpUser == (Just $ myUserId st)) && (isNothing $ cp^.cpUserOverride)+ userPrefs = st^.csResources.crUserPreferences+ isJoinOrLeave = case cp^.cpType of+ Join -> True+ Leave -> True+ _ -> False+ ignoredJoinLeaveMessage =+ not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave cId = postChannelId new doAddMessage = do@@ -1401,12 +1434,14 @@ curChannelAction = if postChannelId new == currCId then UpdateServerViewed else NoAction- originUserAction = if fromMe- then NoAction- else if notifyPref == NotifyOptionAll ||- (notifyPref == NotifyOptionMention && wasMentioned)- then NotifyUser- else NoAction+ originUserAction =+ if | fromMe -> NoAction+ | ignoredJoinLeaveMessage -> NoAction+ | notifyPref == NotifyOptionAll -> NotifyUser+ | notifyPref == NotifyOptionMention+ && wasMentioned -> NotifyUser+ | otherwise -> NoAction+ return $ curChannelAction <> originUserAction doHandleAddedMessage@@ -1539,15 +1574,11 @@ updateSelectedMatch nextIndex = do chanMatches <- use (csChannelSelectState.channelMatches) usernameMatches <- use (csChannelSelectState.userMatches)- uList <- use (to sortedUserList) csChannelSelectState.selectedMatch %= \oldMatch -> -- Make the list of all matches, in display order.- let unames = HM.keys usernameMatches- allMatches = concat [ sort $ HM.keys chanMatches- , [ u^.uiName | u <- uList- , u^.uiName `elem` unames- ]+ let allMatches = concat [ sort $ HM.keys chanMatches+ , sort $ HM.keys usernameMatches ] in case findIndex (== oldMatch) allMatches of Nothing -> if null allMatches@@ -1569,8 +1600,12 @@ chanNameMatches <- use (csChannelSelectState.channelSelectInput.to channelNameMatch) chanNames <- gets allChannelNames uList <- use (to sortedUserList)+ displayNick <- use (to useNickname) let chanMatches = catMaybes (fmap chanNameMatches chanNames)- usernameMatches = catMaybes (fmap chanNameMatches (fmap _uiName uList))+ displayName uInf+ | displayNick = uInf^.uiNickName.non (uInf^.uiName)+ | otherwise = uInf^.uiName+ usernameMatches = catMaybes (fmap (chanNameMatches . displayName) uList) mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms] newInput <- use (csChannelSelectState.channelSelectInput)@@ -1588,8 +1623,8 @@ else firstAvailableMatch unames = channelNameFromMatch <$> usernameMatches allMatches = concat [ channelNameFromMatch <$> chanMatches- , [ u^.uiName | u <- uList- , u^.uiName `elem` unames+ , [ displayName u | u <- uList+ , displayName u `elem` unames ] ] firstAvailableMatch = if null allMatches
src/State/Common.hs view
@@ -233,16 +233,12 @@ -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list postInfoMessage :: T.Text -> MH ()-postInfoMessage err = do- msg <- newClientMessage Informative err- doAsyncWith Normal (return $ addClientMessage msg)+postInfoMessage err = addClientMessage =<< newClientMessage Informative err -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list postErrorMessage' :: T.Text -> MH ()-postErrorMessage' err = do- msg <- newClientMessage Error err- doAsyncWith Normal (return $ addClientMessage msg)+postErrorMessage' err = addClientMessage =<< newClientMessage Error err -- | Raise a rich error mhError :: T.Text -> MH ()
src/State/Editing.hs view
@@ -102,6 +102,7 @@ [ kb "Transpose the final two characters" (EvKey (KChar 't') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.transposeChars+ csEditState.cedCompleter .= Nothing , kb "Go to the start of the current line" (EvKey (KChar 'a') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.gotoBOL@@ -111,30 +112,39 @@ , kb "Delete the character at the cursor" (EvKey (KChar 'd') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.deleteChar+ csEditState.cedCompleter .= Nothing , kb "Delete from the cursor to the start of the current line" (EvKey (KChar 'u') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.killToBOL+ csEditState.cedCompleter .= Nothing , kb "Move one character to the right" (EvKey (KChar 'f') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveRight+ csEditState.cedCompleter .= Nothing , kb "Move one character to the left" (EvKey (KChar 'b') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveLeft+ csEditState.cedCompleter .= Nothing , kb "Move one word to the right" (EvKey (KChar 'f') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.moveWordRight+ csEditState.cedCompleter .= Nothing , kb "Move one word to the left" (EvKey (KChar 'b') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.moveWordLeft+ csEditState.cedCompleter .= Nothing , kb "Delete the word to the left of the cursor" (EvKey KBS [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.deletePrevWord+ csEditState.cedCompleter .= Nothing , kb "Delete the word to the left of the cursor" (EvKey (KChar 'w') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.deletePrevWord+ csEditState.cedCompleter .= Nothing , kb "Delete the word to the right of the cursor" (EvKey (KChar 'd') [MMeta]) $ do csEditState.cedEditor %= applyEdit Z.deleteWord+ csEditState.cedCompleter .= Nothing , kb "Move the cursor to the beginning of the input" (EvKey KHome []) $ do csEditState.cedEditor %= applyEdit gotoHome@@ -147,10 +157,12 @@ let restOfLine = Z.currentLine (Z.killToBOL z) csEditState.cedYankBuffer .= restOfLine csEditState.cedEditor %= applyEdit Z.killToEOL+ csEditState.cedCompleter .= Nothing , kb "Paste the current buffer contents at the cursor" (EvKey (KChar 'y') [MCtrl]) $ do buf <- use (csEditState.cedYankBuffer) csEditState.cedEditor %= applyEdit (Z.insertMany buf)+ csEditState.cedCompleter .= Nothing ] where withUserTypingAction (KB {..}) =@@ -211,7 +223,7 @@ sendUserTypingAction | otherwise -> return () - csEditState.cedCurrentCompletion .= Nothing+ csEditState.cedCompleter .= Nothing liftIO $ resetSpellCheckTimer $ st^.csEditState
src/State/Messages.hs view
@@ -65,10 +65,10 @@ -- Flagged messages -loadFlaggedMessages :: Seq.Seq Preference -> ChatState -> IO ()+loadFlaggedMessages :: Seq.Seq FlaggedPost -> ChatState -> IO () loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True- | Just fp <- F.toList (fmap preferenceToFlaggedPost prefs)+ | fp <- F.toList prefs , flaggedPostStatus fp ]
src/State/Setup.hs view
@@ -62,19 +62,19 @@ Nothing -> id Just f -> \ cd -> cd `withLogger` mmLoggerDebug f - let loginLoop cInfo = do+ poolCfg = ConnectionPoolConfig { cpIdleConnTimeout = 60+ , cpStripesCount = 1+ , cpMaxConnCount = 5+ }+ loginLoop cInfo = do cd <- fmap setLogger $- -- we don't implement HTTP fallback right now, we just- -- go straight for HTTP if someone has indicated that- -- they want it. We probably should in the future- -- always try HTTPS first, and then, if the- -- configuration option is there, try falling back to- -- HTTP. if (configUnsafeUseHTTP initialConfig) then initConnectionDataInsecure (cInfo^.ciHostname) (fromIntegral (cInfo^.ciPort))+ poolCfg else initConnectionData (cInfo^.ciHostname) (fromIntegral (cInfo^.ciPort))+ poolCfg let login = Login { username = cInfo^.ciUsername , password = cInfo^.ciPassword@@ -130,6 +130,7 @@ wac <- STM.newTChanIO prefs <- mmGetUsersPreferences UserMe session+ let userPrefs = setUserPreferences prefs defaultUserPreferences let themeName = case configTheme config of Nothing -> internalThemeName defaultTheme@@ -161,7 +162,8 @@ eventChan <- newBChan 25 let cr = ChatResources session cd requestChan eventChan- slc wac (themeToAttrMap custTheme) userStatusLock userIdSet config mempty prefs+ slc wac (themeToAttrMap custTheme) userStatusLock+ userIdSet config mempty userPrefs initializeState cr myTeam me @@ -246,7 +248,7 @@ st = newState startupState & csChannels %~ flip (foldr (uncurry addChannel)) msgs - loadFlaggedMessages (cr^.crPreferences) st+ loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st -- Trigger an initial websocket refresh writeBChan (cr^.crEventQueue) RefreshWebsocketEvent
src/Types.hs view
@@ -72,6 +72,7 @@ , csChannels , csChannelSelectState , csEditState+ , csClientConfig , timeZone , whenMode , setMode@@ -84,10 +85,8 @@ , cedSpellChecker , cedMisspellings , cedEditMode- , cedCompletionAlternatives- , cedCurrentCompletion+ , cedCompleter , cedEditor- , cedCurrentAlternative , cedMultiline , cedInputHistory , cedInputHistoryPosition@@ -112,7 +111,7 @@ , listFromUserSearchResults , ChatResources(ChatResources)- , crPreferences+ , crUserPreferences , crEventQueue , crTheme , crSubprocessLog@@ -126,6 +125,14 @@ , getSession , getResourceSession + , UserPreferences(UserPreferences)+ , userPrefShowJoinLeave+ , userPrefFlaggedPostList+ , userPrefGroupChannelPrefs++ , defaultUserPreferences+ , setUserPreferences+ , WebsocketAction(..) , Cmd(..)@@ -171,6 +178,8 @@ , addNewUser , setUserIdSet , channelMentionCount+ , useNickname+ , displaynameForUserId , raiseInternalEvent , userSigil@@ -192,6 +201,7 @@ import Brick.AttrMap (AttrMap) import Brick.Widgets.Edit (Editor, editor) import Brick.Widgets.List (List, list)+import Control.Applicative ((<|>)) import Control.Monad (when) import qualified Control.Concurrent.STM as STM import Control.Concurrent.MVar (MVar)@@ -211,11 +221,12 @@ import qualified Data.Set as Set import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!), (.=) , (%=), (^?)- , use, _Just, Traversal', preuse, (^..), folded, to )+ , use, _Just, Traversal', preuse, (^..), folded, to, view ) import Network.Mattermost (ConnectionData) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses import Network.Mattermost.Types+import Network.Mattermost.Types.Config import Network.Mattermost.WebSocket (WebsocketEvent) import Network.Connection (HostNotResolved, HostCannotConnect) import qualified Data.Text as T@@ -231,6 +242,7 @@ import Types.Posts import Types.Messages import Types.Users+import Completion (Completer) -- * Configuration @@ -267,6 +279,7 @@ , configShowTypingIndicator :: Bool , configAbsPath :: Maybe FilePath , configUserKeys :: KeyConfig+ , configHyperlinkingMode :: Bool } deriving (Eq, Show) data BackgroundInfo = Disabled | Active | ActiveCount deriving (Eq, Show)@@ -423,6 +436,38 @@ , programExitCode :: ExitCode } +data UserPreferences = UserPreferences+ { _userPrefShowJoinLeave :: Bool+ , _userPrefFlaggedPostList :: Seq.Seq FlaggedPost+ , _userPrefGroupChannelPrefs :: HM.HashMap ChannelId Bool+ }++defaultUserPreferences :: UserPreferences+defaultUserPreferences = UserPreferences+ { _userPrefShowJoinLeave = True+ , _userPrefFlaggedPostList = mempty+ , _userPrefGroupChannelPrefs = mempty+ }++setUserPreferences :: Seq.Seq Preference -> UserPreferences -> UserPreferences+setUserPreferences = flip (F.foldr go)+ where go p u+ | Just fp <- preferenceToFlaggedPost p =+ u { _userPrefFlaggedPostList =+ _userPrefFlaggedPostList u Seq.|> fp+ }+ | Just gp <- preferenceToGroupChannelPreference p =+ u { _userPrefGroupChannelPrefs =+ HM.insert+ (groupChannelId gp)+ (groupChannelShow gp)+ (_userPrefGroupChannelPrefs u)+ }+ | preferenceName p == PreferenceName "join_leave" =+ u { _userPrefShowJoinLeave =+ preferenceValue p /= PreferenceValue "false" }+ | otherwise = u+ -- | 'ChatResources' represents configuration and -- connection-related information, as opposed to -- current model or view information. Information@@ -441,9 +486,10 @@ , _crUserIdSet :: STM.TVar (Seq.Seq UserId) , _crConfiguration :: Config , _crFlaggedPosts :: Set.Set PostId- , _crPreferences :: Seq.Seq Preference+ , _crUserPreferences :: UserPreferences } + -- | The 'ChatEditState' value contains the editor widget itself -- as well as history and metadata we need for editing-related -- operations.@@ -454,9 +500,7 @@ , _cedInputHistory :: InputHistory , _cedInputHistoryPosition :: HM.HashMap ChannelId (Maybe Int) , _cedLastChannelInput :: HM.HashMap ChannelId (T.Text, EditMode)- , _cedCurrentCompletion :: Maybe T.Text- , _cedCurrentAlternative :: T.Text- , _cedCompletionAlternatives :: [T.Text]+ , _cedCompleter :: Maybe Completer , _cedYankBuffer :: T.Text , _cedSpellChecker :: Maybe (Aspell, IO ()) , _cedMisspellings :: Set.Set T.Text@@ -477,9 +521,7 @@ , _cedInputHistory = hist , _cedInputHistoryPosition = mempty , _cedLastChannelInput = mempty- , _cedCurrentCompletion = Nothing- , _cedCompletionAlternatives = []- , _cedCurrentAlternative = ""+ , _cedCompleter = Nothing , _cedEditMode = NewPost , _cedYankBuffer = "" , _cedSpellChecker = sp@@ -559,6 +601,7 @@ , _csMessageSelect :: MessageSelectState , _csPostListOverlay :: PostListOverlayState , _csUserListOverlay :: UserListOverlayState+ , _csClientConfig :: Maybe ClientConfig } data StartupStateInfo =@@ -595,6 +638,7 @@ , _csMessageSelect = MessageSelectState Nothing , _csPostListOverlay = PostListOverlayState mempty Nothing , _csUserListOverlay = nullUserListOverlayState+ , _csClientConfig = Nothing } nullUserListOverlayState :: UserListOverlayState@@ -759,6 +803,7 @@ makeLenses ''PostListOverlayState makeLenses ''UserListOverlayState makeLenses ''ChannelSelectState+makeLenses ''UserPreferences getSession :: MH Session getSession = use (csResources.crSession)@@ -831,20 +876,49 @@ setUserStatus :: UserId -> T.Text -> MH () setUserStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) +nicknameForUserId :: UserId -> ChatState -> Maybe T.Text+nicknameForUserId uId st = _uiNickName =<< findUserById uId (st^.csUsers)+ usernameForUserId :: UserId -> ChatState -> Maybe T.Text usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers) +displaynameForUserId :: UserId -> ChatState -> Maybe T.Text+displaynameForUserId uId st+ | useNickname st =+ nicknameForUserId uId st <|> usernameForUserId uId st+ | otherwise =+ usernameForUserId uId st+ 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+ let userInfos = st^.csUsers.to allUsers+ uName = if useNickname st+ then+ maybe name (view uiName)+ $ findUserByNickname userInfos name+ else name+ nameToChanId = st^.csNames.cnToChanId+ in HM.lookup (trimAnySigil uName) nameToChanId +useNickname :: ChatState -> Bool+useNickname st = case st^?csClientConfig._Just.to clientConfigTeammateNameDisplay of+ Just "nickname_full_name" ->+ True+ _ ->+ False+ channelByName :: T.Text -> ChatState -> Maybe ClientChannel-channelByName name st = do- cId <- channelIdByName name st+channelByName n st = do+ let userInfos = st^.csUsers.to allUsers+ uName = if useNickname st+ then+ maybe n (view uiName)+ $ findUserByNickname userInfos n+ else n+ cId <- channelIdByName uName st findChannelById cId (st^.csChannels) trimAnySigil :: T.Text -> T.Text
src/Types/Channels.hs view
@@ -62,7 +62,7 @@ , emptyChannelNotifyProps ) import Types.Messages (Messages, noMessages, addMessage, clientMessageToMessage)-import Types.Posts (ClientMessageType(UnknownGap), newClientMessage)+import Types.Posts (ClientMessageType(UnknownGap), newClientMessage, postIsLeave, postIsJoin) import Types.Users (TypingUsers, noTypingUsers, addTypingUser) -- * Channel representations@@ -266,7 +266,9 @@ -- | Adjust updated time based on a message, ensuring that the updated -- time does not move backward. adjustUpdated :: Post -> ClientChannel -> ClientChannel-adjustUpdated m =+adjustUpdated m+ | postIsLeave m || postIsJoin m = id+ | otherwise = ccInfo.cdUpdated %~ max (maxPostTimestamp m) adjustEditedThreshold :: Post -> ClientChannel -> ClientChannel
src/Types/Users.hs view
@@ -17,6 +17,7 @@ , findUserById , findUserByName , findUserByDMChannelName+ , findUserByNickname , noUsers, addUser, allUsers , modifyUserById , getDMChannelName@@ -31,6 +32,7 @@ ) where +import Data.Foldable (find) import Data.Semigroup ((<>), Max(..)) import qualified Data.HashMap.Strict as HM import Data.List (sort)@@ -159,6 +161,14 @@ case filter ((== name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of (usr : []) -> Just usr _ -> Nothing++-- | Get the User information given the user's name. This is an exact+-- match on the nickname field, not necessarily the presented name.+findUserByNickname :: [UserInfo] -> T.Text -> Maybe UserInfo+findUserByNickname uList nick =+ find (nickCheck nick) uList+ where+ nickCheck n = maybe False (== n) . _uiNickName -- | Extract a specific user from the collection and perform an -- endomorphism operation on it, then put it back into the collection.
src/Zipper.hs view
@@ -1,6 +1,7 @@ module Zipper ( Zipper , fromList+ , toList , focus , focusL , left@@ -52,6 +53,9 @@ -- Turn a list into a wraparound zipper, focusing on the head fromList :: [a] -> Zipper a fromList xs = Zipper { zFocus = 0, zElems = xs }++toList :: Zipper a -> [a]+toList = zElems -- Shift the focus until a given element is found, or return the -- same zipper if none applies