matterhorn 40000.0.2 → 40000.1.0
raw patch · 17 files changed
+428/−179 lines, 17 filesdep ~brickdep ~mattermost-apidep ~mattermost-api-qc
Dependency ranges changed: brick, mattermost-api, mattermost-api-qc, vty
Files
- CHANGELOG.md +27/−2
- README.md +3/−0
- matterhorn.cabal +10/−8
- src/Command.hs +48/−7
- src/Draw/Main.hs +2/−2
- src/Draw/Messages.hs +1/−1
- src/Events.hs +4/−5
- src/Events/ChannelScroll.hs +4/−0
- src/Events/Main.hs +4/−1
- src/Markdown.hs +46/−23
- src/State.hs +196/−83
- src/State/Common.hs +14/−14
- src/State/Setup.hs +20/−32
- src/State/Setup/Threads.hs +1/−0
- src/Types.hs +18/−0
- src/Types/Channels.hs +9/−0
- src/Types/Users.hs +21/−1
CHANGELOG.md view
@@ -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.
README.md view
@@ -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
matterhorn.cabal view
@@ -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
src/Command.hs view
@@ -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 ])
src/Draw/Main.hs view
@@ -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 ↑]")
src/Draw/Messages.hs view
@@ -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
src/Events.hs view
@@ -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 ()
src/Events/ChannelScroll.hs view
@@ -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 [])
src/Events/Main.hs view
@@ -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
src/Markdown.hs view
@@ -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 " "
src/State.hs view
@@ -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
src/State/Common.hs view
@@ -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)
src/State/Setup.hs view
@@ -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
src/State/Setup/Threads.hs view
@@ -1,5 +1,6 @@ module State.Setup.Threads ( startUserRefreshThread+ , updateUserStatuses , startSubprocessLoggerThread , startTimezoneMonitorThread , maybeStartSpellChecker
src/Types.hs view
@@ -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
src/Types/Channels.hs view
@@ -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"
src/Types/Users.hs view
@@ -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