diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,29 @@ +40000.1.0 +========= + +New features: + * SOCKS 4 and 5 proxies are supported with the `ALL_PROXY`, + `HTTP_PROXY`, and `HTTPS_PROXY` environment variables, provided the + proxy URI uses the `socks4` or `socks5` scheme. + * Messages that start with a block-level element now get laid out so + that the block level element appears underneath, rather than to the + right of, the user name. This helps with long usernames such as bots. + Thanks to @kellymclaughlin for this change. + * Code blocks with fencing now display the language when syntax + highlighting is active. + * In channel scroll mode, Up/Down arrow keys scroll by just one row + * All channel and user data are now fetched more efficiently on startup + for greatly improved startup time. + +Bug fixes: + * The `/members` command now only shows active users (fixes #315) + * Reset edit mode after handling commands and message input, provide + reply context when running commands (fixes #305) + * Allow all unknown client commands to fall through to server (fixes + #306) + * Improve uniqueness comparisons for URL lists + 40000.0.2 ========= @@ -65,7 +90,7 @@ 31000.0.0 ========= -This release supports server verison 3.10.0. +This release supports server version 3.10.0. Package changes: * Upgraded mattermost-api to 31000.0.0. @@ -319,4 +344,4 @@ 30600.0.0 ========= -Initial versioned release for server verison 3.6.0. +Initial versioned release for server version 3.6.0. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -136,6 +136,9 @@ 256-color terminals) * Flagging and unflagging of posts, which are then viewable with `M-8` or `/flags` +* Support for SOCKS 4 and 5 proxies via the `ALL_PROXY`, `HTTP_PROXY`, + and `HTTPS_PROXY` environment variables. (Plain HTTP proxies are not + yet supported.) # Spell Checking Support diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -1,5 +1,5 @@ name: matterhorn -version: 40000.0.2 +version: 40000.1.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 @@ -75,7 +75,7 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5 - , mattermost-api == 40000.0.1 + , mattermost-api == 40000.1.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6 @@ -86,8 +86,8 @@ , config-ini >= 0.1.2 && < 0.2 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4 - , brick >= 0.19 && < 0.20 - , vty >= 5.15.1 && < 5.16 + , brick >= 0.23 && < 0.24 + , vty >= 5.17 && < 5.18 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 1.9 @@ -114,6 +114,8 @@ main-is: test_messages.hs other-modules: Cheapskate_QCA , Message_QCA + , Types.Messages + , Types.Posts default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables @@ -121,7 +123,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.10 - , brick >= 0.19 && < 0.20 + , brick >= 0.23 && < 0.24 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5 @@ -132,8 +134,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1 - , mattermost-api == 40000.0.1 - , mattermost-api-qc == 40000.0.1 + , mattermost-api == 40000.1.0 + , mattermost-api-qc == 40000.1.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 @@ -151,5 +153,5 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector <= 0.12.0.1 - , vty >= 5.15.1 && < 5.16 + , vty >= 5.17 && < 5.18 , xdg-basedir >= 0.2 && < 0.3 diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -5,9 +5,16 @@ import Prelude () import Prelude.Compat -import Control.Monad (when) -import Data.Monoid ((<>)) +import Control.Applicative ((<|>)) +import qualified Control.Exception as Exn +import Control.Monad.IO.Class (liftIO) +import Control.Monad (void) +import Data.Monoid ((<>)) import qualified Data.Text as T +import Lens.Micro.Platform +import qualified Network.Mattermost as MM +import qualified Network.Mattermost.Lenses as MM +import qualified Network.Mattermost.Exceptions as MM import State import State.Common @@ -58,8 +65,8 @@ (TokenArg "theme" NoArg) $ \ (themeName, ()) -> setTheme themeName , Cmd "topic" "Set the current channel's topic" - (LineArg "topic") $ \ p -> do - when (not $ T.null p) $ setChannelTopic p + (LineArg "topic") $ \ p -> + if not (T.null p) then setChannelTopic p else return () , Cmd "add-user" "Add a user to the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> addUserToCurrentChannel uname @@ -94,6 +101,42 @@ enterFlaggedPostListMode ] +execMMCommand :: T.Text -> T.Text -> MH () +execMMCommand name rest = do + cId <- use csCurrentChannelId + session <- use (csResources.crSession) + myTeamId <- use (csMyTeam.(MM.teamIdL)) + em <- use (csEditState.cedEditMode) + let mc = MM.MinCommand + { MM.minComChannelId = cId + , MM.minComCommand = "/" <> name <> " " <> rest + , MM.minComParentId = case em of + Replying _ p -> Just $ MM.getId p + Editing p -> MM.postParentId p + _ -> Nothing + , MM.minComRootId = case em of + Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p) + Editing p -> MM.postRootId p + _ -> Nothing + } + runCmd = liftIO $ do + void $ MM.mmExecute session myTeamId mc + handleHTTP (MM.HTTPResponseException err) = + return (Just (T.pack err)) + -- XXX: this might be a bit brittle in the future, because it + -- assumes the shape of an error message. We might want to + -- think about a better way of discovering this error and + -- reporting it accordingly? + handleCmdErr (MM.MattermostServerError err) = + let (_, msg) = T.breakOn ": " err in + return (Just (T.drop 2 msg)) + errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP + `Exn.catch` handleCmdErr + case errMsg of + Nothing -> return () + Just err -> + postErrorMessage ("Error running command: " <> err) + dispatchCommand :: T.Text -> MH () dispatchCommand cmd = case T.words cmd of @@ -101,9 +144,7 @@ , name == x ] -> go [] matchingCmds where go [] [] = do - let msg = ("error running command /" <> x <> ":\n" <> - "no such command") - postErrorMessage msg + execMMCommand x (T.unwords xs) go errs [] = do let msg = ("error running command /" <> x <> ":\n" <> mconcat [ " " <> e | e <- errs ]) diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -253,7 +253,7 @@ Replying msg _ -> let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply in hBox [ replyArrow - , addEllipsis $ renderMessage st msgWithoutParent True uSet cSet + , addEllipsis $ renderMessage st msgWithoutParent True uSet cSet False ] _ -> emptyWidget @@ -532,7 +532,7 @@ Nothing -> noPreview Just pm -> if T.null curStr then noPreview - else renderMessage st pm True uSet cSet + else renderMessage st pm True uSet cSet True in (maybePreviewViewport msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]") diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -30,7 +30,7 @@ renderChatMessage :: ChatState -> UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name renderChatMessage st uSet cSet renderTimeFunc msg = - let m = renderMessage st msg True uSet cSet + let m = renderMessage st msg True uSet cSet True msgAtch = if Seq.null (msg^.mAttachments) then Nothing else Just $ withDefAttr clientMessageAttr $ vBox diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -38,7 +38,7 @@ onEvent st ev = runMHEvent st $ case ev of (AppEvent e) -> onAppEvent e (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) -> do - Just vty <- mh getVtyHandle + vty <- mh getVtyHandle liftIO $ Vty.refresh vty (VtyEvent e) -> onVtyEvent e _ -> return () @@ -51,10 +51,9 @@ csConnectionStatus .= Disconnected onAppEvent WebsocketConnect = do csConnectionStatus .= Connected - refreshChannels + refreshChannelsAndUsers onAppEvent BGIdle = csWorkerIsBusy .= Nothing onAppEvent (BGBusy n) = csWorkerIsBusy .= Just n - onAppEvent (WSEvent we) = handleWSEvent we onAppEvent (RespEvent f) = f @@ -214,10 +213,10 @@ WMChannelViewed -> case webChannelId $ weBroadcast we of - Just cId -> refreshChannel False cId + Just cId -> refreshChannelById False cId Nothing -> return () WMChannelUpdated -> case webChannelId $ weBroadcast we of - Just cId -> refreshChannel False cId + Just cId -> refreshChannelById False cId Nothing -> return () diff --git a/src/Events/ChannelScroll.hs b/src/Events/ChannelScroll.hs --- a/src/Events/ChannelScroll.hs +++ b/src/Events/ChannelScroll.hs @@ -18,6 +18,10 @@ , KB "Select and open a URL posted to the current channel" (Vty.EvKey (Vty.KChar 'o') [Vty.MCtrl]) startUrlSelect + , KB "Scroll up" (Vty.EvKey Vty.KUp []) + channelScrollUp + , KB "Scroll down" (Vty.EvKey Vty.KDown []) + channelScrollDown , KB "Scroll up" (Vty.EvKey Vty.KPageUp []) channelPageUp , KB "Scroll down" (Vty.EvKey Vty.KPageDown []) diff --git a/src/Events/Main.hs b/src/Events/Main.hs --- a/src/Events/Main.hs +++ b/src/Events/Main.hs @@ -168,11 +168,14 @@ csEditState.cedEditor %= applyEdit Z.clearZipper csEditState.cedInputHistory %= addHistoryEntry allLines cId csEditState.cedInputHistoryPosition.at cId .= Nothing - csEditState.cedEditMode .= NewPost case T.uncons line of Just ('/',cmd) -> dispatchCommand cmd _ -> sendMessage mode allLines + + -- Reset the edit mode *after* handling the input so that the input + -- handler can tell whether we're editing, replying, etc. + csEditState.cedEditMode .= NewPost tabComplete :: Completion.Direction -> MH () tabComplete dir = do diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} module Markdown ( UserSet @@ -46,6 +47,7 @@ import qualified Data.Set as Set import qualified Graphics.Vty as V import Lens.Micro.Platform ((^.)) +import Control.Monad (join) import Themes import Types (ChatState, getMessageForPostId, userSigil, normalChannelSigil) @@ -62,43 +64,63 @@ , CP TopicChange ] -renderMessage :: ChatState -> Message -> Bool -> UserSet -> ChannelSet -> Widget a -renderMessage st msg renderReplyParent uSet cSet = +renderMessage :: ChatState -> Message -> Bool -> UserSet -> ChannelSet -> Bool -> Widget a +renderMessage st msg renderReplyParent uSet cSet indentBlocks = let msgUsr = case msg^.mUserName of Just u | msg^.mType `elem` omitUsernameTypes -> Nothing | otherwise -> Just u Nothing -> Nothing - mine = case msgUsr of + nameElems = case msgUsr of Just un | msg^.mType == CP Emote -> - hBox [ B.txt "*", colorUsername un - , B.txt " " - , renderMarkdown uSet cSet (msg^.mText) - ] + [ B.txt "*", colorUsername un + , B.txt " " + ] | msg^.mFlagged -> - hBox [ colorUsername un - , B.txt "[!]: " - , renderMarkdown uSet cSet (msg^.mText) - ] + [ colorUsername un + , B.txt "[!]: " + ] | otherwise -> - hBox [ colorUsername un - , B.txt ": " - , renderMarkdown uSet cSet (msg^.mText) - ] - Nothing -> renderMarkdown uSet cSet (msg^.mText) - withParent p = (replyArrow <+> p) B.<=> mine + [ colorUsername un + , B.txt ": " + ] + Nothing -> [] + rmd = renderMarkdown uSet cSet (msg^.mText) + msgWidget = layout nameElems rmd . viewl $ msg^.mText + withParent p = (replyArrow <+> p) B.<=> msgWidget in if not renderReplyParent - then mine + then msgWidget else case msg^.mInReplyToMsg of - NotAReply -> mine + NotAReply -> msgWidget InReplyTo parentId -> case getMessageForPostId st parentId of Nothing -> withParent (B.str "[loading...]") Just pm -> - let parentMsg = renderMessage st pm False uSet cSet + let parentMsg = renderMessage st pm False uSet cSet False in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg) + where + layout n m xs + | length xs > 1 = multiLnLayout n m + layout n m (C.Blockquote {} :< _) = multiLnLayout n m + layout n m (C.CodeBlock {} :< _) = multiLnLayout n m + layout n m (C.HtmlBlock {} :< _) = multiLnLayout n m + layout n m (C.List {} :< _) = multiLnLayout n m + layout n m (C.Para inlns :< _) + | F.any breakCheck inlns = multiLnLayout n m + layout n m _ = hBox $ join [n, return m] + multiLnLayout n m = + if indentBlocks + then vBox [ hBox n + , hBox [B.txt " ", m] + ] + else hBox $ n <> [m] + breakCheck C.LineBreak = True + breakCheck C.SoftBreak = True + breakCheck _ = False + + addEllipsis :: Widget a -> Widget a addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do ctx <- B.getContext @@ -186,7 +208,8 @@ Left _ -> rawCodeBlockToWidget tx Right tokLines -> let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder) - in padding <+> (B.vBox $ renderTokenLine <$> tokLines) + in (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=> + (padding <+> (B.vBox $ renderTokenLine <$> tokLines)) renderTokenLine :: Sky.SourceLine -> Widget a renderTokenLine [] = B.str " " diff --git a/src/State.hs b/src/State.hs --- a/src/State.hs +++ b/src/State.hs @@ -9,13 +9,13 @@ import Brick.Widgets.Edit (getEditContents, editContentsL) import Brick.Widgets.List (list, listMoveTo, listSelectedElement) import Control.Applicative -import Control.Exception (SomeException, catch, try) +import Control.Exception (SomeException, try) import Control.Monad.IO.Class (liftIO) import qualified Control.Concurrent.STM as STM import Data.Char (isAlphaNum) import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd) import Brick.Widgets.Edit (applyEdit) -import Control.Monad (when, unless, void) +import Control.Monad (when, unless, void, forM_) import qualified Data.ByteString as BS import Data.Function (on) import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL) @@ -40,7 +40,6 @@ import System.FilePath import Network.Mattermost -import Network.Mattermost.Exceptions import Network.Mattermost.Lenses import Config @@ -57,6 +56,7 @@ import Markdown (blockGetURLs, findVerbatimChunk) import State.Common +import State.Setup.Threads (updateUserStatuses) -- * Hard-coded constants @@ -69,25 +69,53 @@ -- | Refresh information about a specific channel. The channel -- metadata is refreshed, and if this is a loaded channel, the -- scrollback is updated as well. -refreshChannel :: Bool -> ChannelId -> MH () -refreshChannel refreshMessages cId = do +refreshChannel :: Bool -> ChannelWithData -> MH () +refreshChannel refreshMessages cwd@(ChannelWithData chan _) = do + let cId = getId chan curId <- use csCurrentChannelId - let priority = if curId == cId then Preempt else Normal - asPending doAsyncChannelMM priority (Just cId) mmGetChannel postRefreshChannel - where postRefreshChannel cId' cwd = do - updateChannelInfo cId' cwd - -- If this is an active channel, also update the Messages to - -- retrieve any that might have been missed. - when refreshMessages $ updateMessages cId' --- | Refresh information about all channels. This is usually + -- If this channel is unknown, register it first. + mChan <- preuse (csChannel(cId)) + when (isNothing mChan) $ + handleNewChannel False cwd + + updateChannelInfo cId cwd + + -- If this is an active channel or the current channel, also update + -- the Messages to retrieve any that might have been missed. + when (refreshMessages || (cId == curId)) $ + updateMessages cId + +refreshChannelById :: Bool -> ChannelId -> MH () +refreshChannelById refreshMessages cId = do + session <- use (csResources.crSession) + myTeamId <- use (csMyTeam.teamIdL) + doAsyncWith Preempt $ do + cwd <- mmGetChannel session myTeamId cId + return $ refreshChannel refreshMessages cwd + +-- | Refresh information about all channels and users. This is usually -- triggered when a reconnect event for the WebSocket to the server -- occurs. -refreshChannels :: MH () -refreshChannels = do - cIds <- use (csChannels.to (filteredChannelIds (const True))) - sequence_ $ refreshChannel True <$> cIds +refreshChannelsAndUsers :: MH () +refreshChannelsAndUsers = do + session <- use (csResources.crSession) + myTeamId <- use (csMyTeam.teamIdL) + myId <- use (csMe.userIdL) + doAsyncWith Preempt $ do + chansWithData <- mmGetAllChannelsWithDataForUser session myTeamId myId + uMap <- mmGetProfiles session myTeamId 0 10000 + return $ do + forM_ (HM.elems uMap) $ \u -> do + knownUsers <- use csUsers + case findUserById (getId u) knownUsers of + Just _ -> return () + Nothing -> handleNewUserDirect u + forM_ (HM.elems chansWithData) $ refreshChannel True + + doAsyncWith Preempt $ updateUserStatuses session + -- | Update the indicted Channel entry with the new data retrieved -- from the Mattermost server. updateChannelInfo :: ChannelId -> ChannelWithData -> MH () @@ -167,7 +195,7 @@ F4 -> mmGetPosts s t c op 0 numScrollbackPosts - asPending doAsyncChannelMM prio (Just cId) fetchMessages + asPending doAsyncChannelMM prio cId fetchMessages addObtainedMessages data FetchCase = F1 | F2 PostId | F3a | F3b PostId | F4 deriving (Eq,Show) @@ -241,11 +269,12 @@ deleteSelectedMessage = do selectedMessage <- use (to getSelectedMessage) st <- use id + cId <- use csCurrentChannelId case selectedMessage of Just msg | isMine st msg && isDeletable msg -> case msg^.mOriginalPost of Just p -> - doAsyncChannelMM Preempt Nothing + doAsyncChannelMM Preempt cId (\s t c -> mmDeletePost s t c (postId p)) (\_ _ -> do csEditState.cedEditMode .= NewPost csMode .= Main) @@ -265,7 +294,8 @@ deleteCurrentChannel = do leaveCurrentChannel csMode .= Main - doAsyncChannelMM Normal Nothing mmDeleteChannel endAsyncNOP + cId <- use csCurrentChannelId + doAsyncChannelMM Normal cId mmDeleteChannel endAsyncNOP isCurrentChannel :: ChatState -> ChannelId -> Bool isCurrentChannel st cId = st^.csCurrentChannelId == cId @@ -408,7 +438,7 @@ joinChannel :: Channel -> MH () joinChannel chan = do csMode .= Main - doAsyncChannelMM Preempt (Just $ getId chan) mmJoinChannel endAsyncNOP + doAsyncChannelMM Preempt (getId chan) mmJoinChannel endAsyncNOP -- | When another user adds us to a channel, we need to fetch the -- channel info for that channel. @@ -417,9 +447,8 @@ st <- use id doAsyncWith Normal $ do tryMM (mmGetChannel (st^.csResources.crSession) (st^.csMyTeam.teamIdL) cId) - (\(ChannelWithData chan _) -> do - return $ do - handleNewChannel (preferredChannelName chan) False chan + (\cwd -> return $ do + handleNewChannel False cwd asyncFetchScrollback Normal cId) startLeaveCurrentChannel :: MH () @@ -434,7 +463,7 @@ cId <- use csCurrentChannelId withChannel cId $ \chan -> when (canLeaveChannel (chan^.ccInfo)) $ - doAsyncChannelMM Preempt (Just cId) + doAsyncChannelMM Preempt cId mmLeaveChannel (\c () -> removeChannelFromState c) @@ -462,15 +491,17 @@ csFocus %= Z.filterZipper (/= cId) fetchCurrentChannelMembers :: MH () -fetchCurrentChannelMembers = - doAsyncChannelMM Preempt Nothing +fetchCurrentChannelMembers = do + cId <- use csCurrentChannelId + doAsyncChannelMM Preempt cId (\s t c -> mmGetChannelMembers s t c 0 10000) (\_ chanUserMap -> 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 - chanUsers = snd <$> HM.toList chanUserMap + userDeleted u = userDeleteAt u > userCreateAt u + chanUsers = filter (not . userDeleted) $ snd <$> HM.toList chanUserMap usernames = sort $ userUsername <$> (F.toList chanUsers) postInfoMessage msgStr) @@ -509,7 +540,7 @@ -- updating the client data, but it's also immune to any new or -- removed Message date fields, or anything else that would -- contribute to the viewed/updated times on the server. - doAsyncChannelMM Preempt (Just cId) mmGetChannel + doAsyncChannelMM Preempt cId mmGetChannel (\pcid cwd -> csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd) -- Update the old channel's previous viewed time (allows tracking of new messages) case prevId of @@ -530,7 +561,7 @@ Connected -> do -- Only do this if we're connected to avoid triggering noisy exceptions. pId <- use csRecentChannel - doAsyncChannelMM Preempt (Just cId) + doAsyncChannelMM Preempt cId (\s t c -> mmViewChannel s t c pId) (\c () -> setLastViewedFor pId c) Disconnected -> @@ -668,6 +699,16 @@ cId <- use csCurrentChannelId mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount +channelScrollUp :: MH () +channelScrollUp = do + cId <- use csCurrentChannelId + mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1) + +channelScrollDown :: MH () +channelScrollDown = do + cId <- use csCurrentChannelId + mh $ vScrollBy (viewportScroll (ChannelMessages cId)) 1 + channelScrollToTop :: MH () channelScrollToTop = do cId <- use csCurrentChannelId @@ -689,7 +730,7 @@ cId <- use csCurrentChannelId withChannel cId $ \chan -> let offset = length $ chan^.ccContents.cdMessages - in asPending doAsyncChannelMM Preempt (Just cId) + in asPending doAsyncChannelMM Preempt cId (\s t c -> mmGetPosts s t c offset pageAmount) (\c p -> do addObtainedMessages c p mh $ invalidateCacheEntry (ChannelMessages cId)) @@ -757,7 +798,8 @@ doAsyncWith Normal $ do -- create a new channel nc <- mmCreateDirect session tId uId - return $ handleNewChannel name True nc + cwd <- mmGetChannel session tId (getId nc) + return $ handleNewChannel True cwd else postErrorMessage ("No channel or user named " <> name) @@ -775,32 +817,102 @@ , minChannelHeader = Nothing , minChannelType = Ordinary } - tryMM (mmCreateChannel session tId minChannel) - (return . handleNewChannel name True) + tryMM (do c <- mmCreateChannel session tId minChannel + mmGetChannel session tId (getId c) + ) + (return . handleNewChannel True) -handleNewChannel :: T.Text -> Bool -> Channel -> MH () -handleNewChannel name switch nc = do - -- time to do a lot of state updating: - -- create a new ClientChannel structure - let cChannel = makeClientChannel nc - -- add it to the message map, and to the map so we can look it up by - -- user name - csNames.cnToChanId.at(name) .= Just (getId nc) +handleNewChannel :: Bool -> ChannelWithData -> MH () +handleNewChannel = handleNewChannel_ True + +handleNewChannel_ :: Bool + -- ^ Whether to permit this call to recursively + -- schedule itself for later if it can't locate + -- a DM channel user record. This is to prevent + -- uncontrolled recursion. + -> Bool + -- ^ Whether to switch to the new channel once it has + -- been installed. + -> ChannelWithData + -- ^ The channel to install. + -> MH () +handleNewChannel_ permitPostpone switch cwd@(ChannelWithData nc cData) = do + -- Create a new ClientChannel structure + let cChannel = makeClientChannel nc & + ccInfo %~ channelInfoFromChannelWithData (ChannelWithData nc cData) + + st <- use id + + -- Add it to the message map, and to the name map so we can look it up + -- by name. The name we use for the channel depends on its type: let chType = nc^.channelTypeL - -- For direct channels the username is already in the user list so - -- do nothing - when (chType /= Direct) $ - csNames.cnChans %= (sort . (name:)) - 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 - -- and we finally set our focus to the newly created channel - when switch $ setFocus (getId nc) + -- Get the channel name. If we couldn't, that means we have 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 + -- 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, and the best we can do + -- to preserve uniqueness is to use the channel name string. + -- This is undesirable but direct channels never get rendered + -- directly; they only get used by first looking up usernames. + -- So this name should never appear anywhere, but at least we + -- can go ahead and register the channel and handle events for + -- it. That isn't very useful but it's probably better than + -- ignoring this entirely. + Nothing -> return $ Just $ channelName nc + Just otherUserId -> + case getUsernameForUserId st otherUserId 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 fetched the + -- metadata. This can happen when we have a channel + -- record for a user that is no longer in the current + -- team. To avoid recursion due to a problem, ensure + -- that the rescheduled new channel handler is not + -- permitted to try this again. + -- + -- If we're already in a recursive attempt to register + -- this channel and still couldn't find a username, + -- just bail and use the synthetic name (this has the + -- same problems as above). + Nothing -> do + case permitPostpone of + False -> return $ Just $ channelName nc + True -> do + handleNewUser otherUserId + doAsyncWith Normal $ + return $ handleNewChannel_ False switch cwd + return Nothing + Just ncUsername -> + return $ Just $ ncUsername + _ -> return $ Just $ preferredChannelName nc + + case mName of + Nothing -> return () + Just name -> do + csNames.cnToChanId.at(name) .= Just (getId nc) + + -- For direct channels the username is already in the user + -- list so do nothing + when (chType /= Direct) $ + csNames.cnChans %= (sort . (name:)) + + 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 + + -- Finally, set our focus to the newly created channel if the + -- caller requested a change of channel. + when switch $ setFocus (getId nc) + editMessage :: Post -> MH () editMessage new = do st <- use id @@ -830,8 +942,7 @@ maybeRingBell = do doBell <- use (csResources.crConfiguration.to configActivityBell) when doBell $ do - -- This is safe because we only get Nothing in appStartEvent. - Just vty <- mh getVtyHandle + vty <- mh getVtyHandle liftIO $ ringTerminalBell $ outputIface vty -- | PostProcessMessageAdd is an internal value that informs the main @@ -920,7 +1031,7 @@ Just parentId -> case getMessageForPostId st parentId of Nothing -> do - doAsyncChannelMM Preempt (Just cId) + doAsyncChannelMM Preempt cId (\s t c -> mmGetPost s t c parentId) (\_ p -> let postMap = HM.fromList [ ( pId @@ -965,24 +1076,6 @@ cc <- st^?csChannel(cId) return $ cc^.ccInfo.cdNewMessageIndicator -execMMCommand :: T.Text -> T.Text -> MH () -execMMCommand name rest = do - cId <- use csCurrentChannelId - session <- use (csResources.crSession) - myTeamId <- use (csMyTeam.teamIdL) - let mc = MinCommand - { minComChannelId = cId - , minComCommand = "/" <> name <> " " <> rest - } - runCmd = liftIO $ do - void $ mmExecute session myTeamId mc - handler (HTTPResponseException err) = return (Just err) - errMsg <- liftIO $ (runCmd >> return Nothing) `catch` handler - case errMsg of - Nothing -> return () - Just err -> - postErrorMessage ("Error running command: " <> (T.pack err)) - fetchCurrentScrollback :: MH () fetchCurrentScrollback = do cId <- use csCurrentChannelId @@ -1011,8 +1104,9 @@ , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] setChannelTopic :: T.Text -> MH () -setChannelTopic msg = - doAsyncChannelMM Preempt Nothing +setChannelTopic msg = do + cId <- use csCurrentChannelId + doAsyncChannelMM Preempt cId (\s t c -> mmSetChannelHeader s t c msg) (\_ _ -> return ()) @@ -1149,15 +1243,26 @@ let msgs = chan^.ccContents.cdMessages in removeDuplicates $ concat $ F.toList $ F.toList <$> msgURLs <$> msgs -removeDuplicates :: [LinkChoice] -> [LinkChoice] -removeDuplicates = snd . go Set.empty +-- XXX: move this somewhere more sensible! + +-- | The 'nubOn' function removes duplicate elements from a list. In +-- particular, it keeps only the /last/ occurrence of each +-- element. The equality of two elements in a call to @nub f@ is +-- determined using @f x == f y@, and the resulting elements must have +-- an 'Ord' instance in order to make this function more efficient. +nubOn :: (Ord b) => (a -> b) -> [a] -> [a] +nubOn f = snd . go Set.empty where go before [] = (before, []) go before (x:xs) = - let (before', xs') = go before xs in - if (x^.linkURL) `Set.member` before' + let (before', xs') = go before xs + key = f x in + if key `Set.member` before' then (before', xs') - else (Set.insert (x^.linkURL) before', x : xs') + else (Set.insert key before', x : xs') +removeDuplicates :: [LinkChoice] -> [LinkChoice] +removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser)) + msgURLs :: Message -> Seq.Seq LinkChoice msgURLs msg | Just uname <- msg^.mUserName = let msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uname text url Nothing) <$> @@ -1323,6 +1428,14 @@ , postPendingPostId = Nothing } void $ mmUpdatePost (st^.csResources.crSession) theTeamId modifiedPost + +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 handleNewUser :: UserId -> MH () handleNewUser newUserId = doAsyncMM Normal getUserInfo updateUserState diff --git a/src/State/Common.hs b/src/State/Common.hs --- a/src/State/Common.hs +++ b/src/State/Common.hs @@ -147,8 +147,8 @@ type DoAsyncChannelMM a = AsyncPriority -- ^ the priority for this async operation - -> Maybe ChannelId - -- ^ defaults to the "current" channel if Nothing + -> ChannelId + -- ^ The channel -> (Session -> TeamId -> ChannelId -> IO a) -- ^ the asynchronous Mattermost channel-based IO operation -> (ChannelId -> a -> MH ()) @@ -158,14 +158,8 @@ -- | Performs an asynchronous IO operation on a specific channel. On -- completion, the final argument a completion function is executed in -- an MH () context in the main (brick) thread. --- --- If no channel ID is provided on input, the current channel is used; --- the completion function is always called with the channel ID upon --- which the operation was performed. doAsyncChannelMM :: DoAsyncChannelMM a -doAsyncChannelMM prio m_cId mmOp eventHandler = do - ccId <- use csCurrentChannelId - let cId = maybe ccId id m_cId +doAsyncChannelMM prio cId mmOp eventHandler = doAsyncMM prio (\s t -> mmOp s t cId) (eventHandler cId) -- | Prefix function for calling doAsyncChannelMM that will set the @@ -174,9 +168,7 @@ -- function is called, no operations are performed (i.e., this request -- is treated as a duplicate). asPending :: DoAsyncChannelMM a -> DoAsyncChannelMM a -asPending asyncOp prio m_cId mmOp eventHandler = do - ccId <- use csCurrentChannelId - let cId = maybe ccId id m_cId +asPending asyncOp prio cId mmOp eventHandler = do withChannel cId $ \chan -> let origState = chan^.ccInfo.cdCurrentState (pendState, setDone) = pendingChannelState origState @@ -184,7 +176,7 @@ then return () -- this operation already pending; do not duplicate else do csChannel(cId).ccInfo.cdCurrentState .= pendState - asyncOp prio m_cId mmOp $ \_ r -> + asyncOp prio cId mmOp $ \_ r -> do csChannel(cId).ccInfo.cdCurrentState %= setDone eventHandler cId r @@ -291,7 +283,7 @@ asyncFetchReactionsForPost :: ChannelId -> Post -> MH () asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return () - | otherwise = doAsyncChannelMM Normal (Just cId) + | otherwise = doAsyncChannelMM Normal cId (\s t c -> mmGetReactionsForPost s t c (p^.postIdL)) addReactions @@ -325,3 +317,11 @@ postErrorMessage errMsg Right () -> return () + +loadAllUsers :: Session -> IO (HM.HashMap UserId User) +loadAllUsers session = go HM.empty 0 + where go users n = do + newUsers <- mmGetUsers session (n * 50) 50 + if HM.null newUsers + then return users + else go (newUsers <> users) (n+1) diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -12,8 +12,7 @@ import Control.Monad (forM, when) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM -import Data.Maybe (listToMaybe, maybeToList, fromJust) -import Data.Monoid ((<>)) +import Data.Maybe (listToMaybe, fromJust) import qualified Data.Sequence as Seq import Data.Time.LocalTime (getCurrentTimeZone) import Lens.Micro.Platform @@ -21,7 +20,6 @@ import System.IO (Handle) import Network.Mattermost -import Network.Mattermost.Lenses import Network.Mattermost.Logging (mmLoggerDebug) import Config @@ -34,12 +32,10 @@ import State.Setup.Threads import Types import Types.Channels -import Types.Users import qualified Zipper as Z -loadFlaggedMessages :: ChatState -> IO () -loadFlaggedMessages st = doAsyncWithIO Normal st $ do - prefs <- mmGetMyPreferences (st^.csResources.crSession) +loadFlaggedMessages :: Seq.Seq Preference -> ChatState -> IO () +loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True | Just fp <- F.toList (fmap preferenceToFlaggedPost prefs) , flaggedPostStatus fp @@ -128,32 +124,29 @@ slc theme quitCondition config mempty initializeState cr myTeam myUser -loadAllUsers :: Session -> IO (HM.HashMap UserId User) -loadAllUsers session = go HM.empty 0 - where go users n = do - newUsers <- mmGetUsers session (n * 50) 50 - if HM.null newUsers - then return users - else go (newUsers <> users) (n+1) - initializeState :: ChatResources -> Team -> User -> IO ChatState initializeState cr myTeam myUser = do + prefs <- mmGetMyPreferences (cr^.crSession) + let session = cr^.crSession requestChan = cr^.crRequestQueue - let myTeamId = getId myTeam + myTeamId = getId myTeam - chans <- mmGetChannels session myTeamId + -- Get all channels, but filter down to just the one we want to start + -- in. We get all, rather than requesting by name or ID, because + -- we don't know whether the server will give us a last-viewed + -- preference, and when it doesn't, we need to look for Town Square + -- by name. Even this is ultimately not entirely correct since Town + -- Square can be renamed! + chans <- Seq.filter isTownSquare <$> mmGetChannels session myTeamId + -- Since the only channel we are dealing with is by construction the + -- last channel, we don't have to consider other cases here: msgs <- forM (F.toList chans) $ \c -> do let cChannel = makeClientChannel c & ccInfo.cdCurrentState .~ state - state = if c^.channelNameL == "town-square" - then ChanInitialSelect - else initialChannelState + state = ChanInitialSelect return (getId c, cChannel) - teamUsers <- mmGetProfiles session myTeamId 0 10000 - users <- loadAllUsers session - let mkUser u = (u^.userIdL, userInfoFromUser u (HM.member (u^.userIdL) teamUsers)) tz <- getCurrentTimeZone hist <- do result <- readHistory @@ -171,18 +164,13 @@ -- * Spell checker and spell check timer, if configured spResult <- maybeStartSpellChecker (cr^.crConfiguration) (cr^.crEventQueue) - let chanNames = mkChanNames myUser users chans - Just townSqId = chanNames ^. cnToChanId . at "town-square" + let chanNames = mkChanNames myUser mempty chans chanIds = [ (chanNames ^. cnToChanId) HM.! i - | i <- chanNames ^. cnChans ] ++ - [ c - | i <- chanNames ^. cnUsers - , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] - chanZip = Z.findRight (== townSqId) (Z.fromList chanIds) + | i <- chanNames ^. cnChans ] + chanZip = Z.fromList chanIds st = newState cr chanZip myUser myTeam tz hist spResult - & csUsers %~ flip (foldr (uncurry addUser)) (fmap mkUser users) & csChannels %~ flip (foldr (uncurry addChannel)) msgs & csNames .~ chanNames - loadFlaggedMessages st + loadFlaggedMessages prefs st return st diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -1,5 +1,6 @@ module State.Setup.Threads ( startUserRefreshThread + , updateUserStatuses , startSubprocessLoggerThread , startTimezoneMonitorThread , maybeStartSpellChecker diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -121,6 +121,8 @@ , hasUnread , channelNameFromMatch , isMine + , getUsernameForUserId + , getLastChannelPreference , userSigil , normalChannelSigil @@ -155,6 +157,7 @@ import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!) , _Just, Traversal', preuse ) import Network.Mattermost +import Network.Mattermost.Types (ChannelId(..)) import Network.Mattermost.Exceptions import Network.Mattermost.Lenses import Network.Mattermost.WebSocket @@ -203,6 +206,21 @@ } deriving (Eq, Show) data BackgroundInfo = Disabled | Active | ActiveCount deriving (Eq, Show) + +-- * Preferences + +getLastChannelPreference :: Seq.Seq Preference -> Maybe ChannelId +getLastChannelPreference prefs = + let isLastChannelIdPreference p = + and [ preferenceCategory p == PreferenceCategoryLast + , preferenceName p == PreferenceName "channel" + ] + prefChannelId p = + let PreferenceValue v = preferenceValue p + in CI $ Id v + + in prefChannelId <$> + (listToMaybe $ F.toList $ Seq.filter isLastChannelIdPreference prefs) -- * 'MMNames' structures diff --git a/src/Types/Channels.hs b/src/Types/Channels.hs --- a/src/Types/Channels.hs +++ b/src/Types/Channels.hs @@ -40,6 +40,7 @@ -- * Miscellaneous channel-related operations , canLeaveChannel , preferredChannelName + , isTownSquare ) where @@ -319,3 +320,11 @@ then NewPostsStartingAt $ m^.postCreateAtL else NewPostsAfterServerTime ts ) + +-- | Town Square is special in that its non-display name cannot be +-- changed and is a hard-coded constant server-side according to the +-- developers (as of 8/2/17). So this is a reliable way to check for +-- whether a channel is in fact that channel, even if the user has +-- changed its display name. +isTownSquare :: Channel -> Bool +isTownSquare c = c^.channelNameL == "town-square" diff --git a/src/Types/Users.hs b/src/Types/Users.hs --- a/src/Types/Users.hs +++ b/src/Types/Users.hs @@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE DeriveFunctor #-} module Types.Users @@ -18,6 +19,7 @@ , noUsers, addUser, allUsers , modifyUserById , getDMChannelName + , userIdForDMChannel ) where @@ -27,7 +29,7 @@ import Data.Monoid ((<>)) import qualified Data.Text as T import Lens.Micro.Platform -import Network.Mattermost.Types (UserId, User(..), idString) +import Network.Mattermost.Types (Id(Id), UserId(..), User(..), idString) -- * 'UserInfo' Values @@ -125,6 +127,24 @@ where [loUser, hiUser] = sort $ idString <$> [ you, me ] cname = loUser <> "__" <> hiUser + +-- | Extract the corresponding other user from a direct channel name. +-- Returns Nothing if the string is not a direct channel name or if it +-- is but neither user ID in the name matches the current user's ID. +userIdForDMChannel :: UserId + -- ^ My user ID + -> T.Text + -- ^ The channel name + -> Maybe UserId +userIdForDMChannel me chanName = + -- Direct channel names are of the form "UID__UID" where one of the + -- UIDs is mine and the other is the other channel participant. + let vals = T.splitOn "__" chanName + in case vals of + [u1, u2] -> if | (UI $ Id u1) == me -> Just $ UI $ Id u2 + | (UI $ Id u2) == me -> Just $ UI $ Id u1 + | otherwise -> Nothing + _ -> Nothing findUserByDMChannelName :: Users -> T.Text -- ^ the dm channel name