diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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//matterhorn--.tar.gz - tar xf matterhorn--.tar.gz - cd matterhorn-- - ./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 diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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 () diff --git a/src/Completion.hs b/src/Completion.hs --- a/src/Completion.hs +++ b/src/Completion.hs @@ -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 diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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) diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -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 diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -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 diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -31,7 +31,7 @@ nameForUserRef st uref = case uref of NoUser -> Nothing UserOverride t -> Just t - UserI uId -> usernameForUserId uId st + UserI uId -> displaynameForUserId uId st -- | renderSingleMessage is the main message drawing function. -- diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -58,6 +58,7 @@ onAppEvent WebsocketConnect = do csConnectionStatus .= Connected refreshChannelsAndUsers + refreshClientConfig onAppEvent BGIdle = csWorkerIsBusy .= Nothing onAppEvent (BGBusy n) = csWorkerIsBusy .= Just n onAppEvent (WSEvent we) = diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -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) diff --git a/src/LastRunState.hs b/src/LastRunState.hs --- a/src/LastRunState.hs +++ b/src/LastRunState.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -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 diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -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 () diff --git a/src/State/Editing.hs b/src/State/Editing.hs --- a/src/State/Editing.hs +++ b/src/State/Editing.hs @@ -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 diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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 ] diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -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 diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -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. diff --git a/src/Zipper.hs b/src/Zipper.hs --- a/src/Zipper.hs +++ b/src/Zipper.hs @@ -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