matterhorn 40000.1.0 → 40400.0.0
raw patch · 34 files changed
+2041/−656 lines, 34 filesdep ~brickdep ~mattermost-apidep ~mattermost-api-qcnew-uploader
Dependency ranges changed: brick, mattermost-api, mattermost-api-qc, vty
Files
- CHANGELOG.md +80/−3
- PRACTICES.md +142/−0
- README.md +10/−2
- matterhorn.cabal +16/−9
- scripts/cowsay +7/−0
- scripts/figlet +7/−0
- scripts/rot13 +4/−0
- src/App.hs +65/−0
- src/Command.hs +8/−1
- src/Config.hs +23/−6
- src/Connection.hs +3/−2
- src/Constants.hs +8/−0
- src/Draw/ChannelList.hs +14/−29
- src/Draw/Main.hs +17/−17
- src/Draw/Messages.hs +12/−6
- src/Draw/PostListOverlay.hs +11/−3
- src/Draw/ShowHelp.hs +90/−1
- src/Events.hs +103/−113
- src/Events/ChannelSelect.hs +17/−20
- src/Events/Main.hs +21/−5
- src/Events/ShowHelp.hs +1/−1
- src/HelpTopics.hs +6/−0
- src/Main.hs +10/−83
- src/Markdown.hs +109/−13
- src/Scripts.hs +4/−1
- src/State.hs +631/−181
- src/State/Editing.hs +12/−20
- src/State/PostListOverlay.hs +14/−0
- src/State/Setup.hs +46/−14
- src/State/Setup/Threads.hs +65/−12
- src/Themes.hs +361/−73
- src/Types.hs +79/−39
- src/Types/Channels.hs +37/−2
- src/Types/Users.hs +8/−0
CHANGELOG.md view
@@ -1,11 +1,88 @@+40400.0.0+========= +This release supports server version 4.4.++New features:+ * The active color theme can be customized by creating a theme+ customization file and setting the new `themeCustomizationFile`+ option. This setting lets you override any foreground color,+ background color, or style of any aspect of the Matterhorn interface.+ For details on the format of the customization file, please see the+ "Themes" help in Matterhorn with the `/help themes` command.+ * Edited posts are now displayed with a trailling "edited"+ marker. This change includes some new behavior and a new+ configuration option:+ * When you visit a post that has recent edits, the "edited" marker+ will be highlighted. This highlight can be dismissed in the same+ way as the "New Messages" cutoff, using the `M-l` keybinding.+ * This feature can be turned off using by setting the+ `showOlderEdits` configuration option to `False`.+ * New commands:+ * The `/remove-user` command removes a user from a channel.+ * The `/group-msg` command creates a new private group channel+ including several users.+ * The `/search [term]` command searches the chat history for posts+ that include the provided text and displays those posts in an+ overlay. Thanks to @abhin4v for this change!+ * Matterhorn now includes embedded hyperlinks using terminal escape+ sequences in terminals that support them. For more information on+ terminal support for hyperlink escape sequences, please see [this+ gist](https://gist.github.com/egmontkob/eb114294efbcd5adb1944c9f3cb5feda)+ and its associated discussion.+ * The width of the channel list (in columns) is now configurable with+ `channelListWidth`, which defaults to 20.+ * The `urlOpenCommand` can now be an interactive terminal-based+ program (such as a terminal-based web browser) but this requires+ the configuration option `urlOpenCommandIsInteractive` to be set to+ `True`. This defaults to `False` and should not be changed if the+ `urlOpenCommand` is not a terminal-based program.+ * The current selection in channel select mode can be moved forward+ and backward with `C-n` and `C-p`. (fixes #139)+ * Quotation blocks now include visible characters in addition to+ indentation.+ * We now honor the server's notification settings for channels.++Bug fixes:+ * New direct-message channels are properly added to running sessions+ (fixes #264)+ * No more reporting of "resource vanished" exceptions (fixes #116)+ * Missing editing keybindings now included in edit binding list+ (fixes #139)+ * Websocket message parse failures no longer result in crashes (fixes+ #297)+ * The sidebar no longer shows deleted users (fixes #316)+ * Tab-completion no longer includes deleted users (fixes #320)+ * User status updates are now rate-limited (fixes #282)+ * Private channels can be deleted successfully (fixes #304)+ * External commands now run in the background in their own thread and+ do not block the main UI (fixes #270)+ * Channel renaming is honored at runtime and does not require a+ restart (fixes #324)+ * Group channel show/hide preferences are observed, which in practice+ means a user can now 'leave' a several-user group channel+ * New channels will not appear twice in the sidebar (fixes #327)+ * New messages to previously-hidden group channels will cause the+ group channel to be shown again (fixes #326)+++Package changes:+ * PRACTICES.md is now listed in extra-doc-files.+ * Three scripts usable with the `/sh` command are now listed in+ extra-doc-files:+ * `cowsay` runs the message text through the `cowsay` shell command+ and formats the output as a verbatim block. This command requires+ the `cowsay` command-line program to be installed externally.+ * `figlet` runs the message text through the `figlet` shell command+ and formats the output as a verbatim block. This command requires+ the `figlet` command-line program to be installed externally.+ * `rot13` runs the trivial ROT13 subsitution cipher over the+ message text and otherwise passes it through unchanged.+ 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.
+ PRACTICES.md view
@@ -0,0 +1,142 @@++Matterhorn Project Practices+============================++This document captures some important project practices that we employ.+If you want to contribute to Matterhorn, for best results, please follow+these practices.++Many of the practices described below are really about serving some+overall concerns:++ * We want to provide a working program to people who want to use it,+ * We want to manage inevitable software evolution, and+ * We want to reduce waste through good team coordination.++Branching+---------++ * The `master` branch should be stable enough to be release-ready at+ all times. This promise helps us be agile in the event of a need to+ do an unplanned release.++ * The `develop` branch is where development occurs.++ * New feature development begins and stays on a new feature branch,+ typically named `feature/FEATURENAME`, until it is declared stable+ enough to be merged. Once more testing of a feature is needed,+ especially in concert with other work, it should be merged to+ `develop`.++ * Once `develop` has been deemed stable enough to release, it can be+ merged to `master`.++ * When a feature branch implementation is complete, before merging to+ `develop` we do a code review that is appropriate to the level of+ complexity and risk of the work being merged, which may involve an+ in-person code tour but typically involves just commit review with+ questions and requests for changes. We do this to ensure that other+ team members are aware of the ramifications of the work, to provide+ an opportunity for feedback, and to get fresh eyes on the work to+ spot problems that won't be evident to its author.++ * Bug fixes and other small, uncontroversial changes can be committed+ directly to `master` and merged back into `develop`. This ensures+ that bug fixes are not held up by other development work in case a+ bugfix release is desired.++Issue Tracking+--------------++ * We use the GitHub issue tracker for user bug reports and feature+ requests, and to capture our own intentions about planned and+ potential work.++ * We use milestones to group tickets for big efforts, such as server+ compatibility releases or planning cycles.++ * When creating issues, we try to make issues as actionable as possible+ when the scope and details are well-understood, but this isn't always+ possible. If we can't be concrete about what a ticket entails, we+ assign the label `high-level` to indicate that more team discussion+ or context-gathering will be required before a concrete plan can be+ made. We also use the label `high-level` to indicate any ticket with+ insufficient detail that needs further discussion before we can+ tackle it.++Workflow+--------++ * When planning big efforts, we strive to get team alignment on the+ scope of planned efforts. Creation of a ticket does not necessarily+ mean that we have gotten team alignment or settled on scope. The+ appropriate scope will be a function of time and availability,+ pragmatism, feature parity with upstream, motivation, etc.++ * When doing refactoring that may be risky or touch a lot of the+ program, we strive to break the job down into a sequence of+ incremental changes that each produce a working program and+ ultimately get us where we want to be.++ * When planning new work, we strive to get input from the team before+ the work begins, rather than after it is completed, to reduce waste+ and to ensure that the work is well-informed. The bigger or more+ impactful the change, the more important this is - and it applies to+ work done in spare time as well as at work.++ * If resources allow, consider pair programming as a means of tackling+ bigger, cross-cutting problems. Although it costs more in terms of+ person-hours, it can be a very effective technique for producing+ better designs with fewer bugs and more mind-sharing.++ * For experimental work or new features, consider "prototyping" or+ "throwaway coding," in which the first implementation of a new+ feature is *intended* to be discarded upon completion. Rather than+ producing code, the result of this is the learning that occurs+ when exploring a design. Then, having learned, one can embark on a+ better-informed implementation.++Design+------++We would like issues not to linger too long unaddressed, because then+the meaning of "open ticket" is ambiguous to us and to end users: is it+planned? Is it well-understood? It's unclear.++But we can only tackle so many things, and sometimes we don't even know+enough about what's involved in a task to know its level of effort. So+in the mean time, before we can investigate, the ticket lingers.++Once we're learning what is inovlved, using the ticket as a place to+hash out ideas or collect context is annoying because using ticket+comments for that isn't effective.++To address these concerns:++ * Whenever we have some high-level thing we want to implement, instead+ of creating a placeholder ticket, make a page on the project wiki at++ https://github.com/matterhorn-chat/matterhorn/wiki++ On this page we'll collaboratively hash out design ideas, collect+ context and research, and share approaches. These documents represent+ a "staging ground" for new ideas.++ * Once enough context has been gathered to support moving forward on+ the feature, create concrete tickets from the context. It's also+ possible we decide *not* to move forward, in which case the rationale+ for aborting can be clearly captured on the wiki. This way, external+ users can see why we decided not to implement something.++ * When external users create tickets for high-level features that+ cannot be implemented immediately but that we agree deserve+ consideration and need further investigation, close the tickets+ by referring to the newly-created context wiki page where we'll+ be hashing out the details. This means that we strive to ensure that+ open tickets are by definition always workable and fleshed-out.++ * This way, when external users stop by to ask about features, we can+ point them at those pages to make it easier to 1) share the developed+ context, 2) make it clear what is missing in case they want to help,+ and 3) keep a record of design decisions for posterity even after the+ feature is implemented.
README.md view
@@ -64,12 +64,20 @@ You can use built-in keybindings or `/cmd`-style commands to operate the client. To see available keybindings and commands, use the default-binding of `F1` or run the `/help` command.+binding of `F1` or run the `/help` command. Keybindings may include+modifiers such as Control (indicated with a `C-` prefix) or Meta+(indicated with a `M-` prefix). If your keyboard has an `Alt` key, that+will work as `Meta`. If it does not, you may be able to configure your+terminal to provide `Meta` via other means (e.g. iTerm2 on OS X can be+configured to make the left Option key work as Meta). To join a channel, use the `/join` command to choose from a list of available channels. To create a channel, use `/create-channel`. To leave a channel, use `/leave-channel`. +To create a private group chat amongst yourself and other users, use the+`/group-msg` command, e.g., `/group-msg user1 user2`.+ To see the members in the current channel, use the `/members` command. To send a message, type it into the editor and press Enter to send.@@ -91,7 +99,7 @@ `C-g` channel switching mode does a substring match of the input text on the channel and usernames; metacharacters `^` and `$` at the beginning or end of input, respectively, anchor the match in case of multiple-matches.+matches. The cursor in this mode is usable with `C-n` and `C-p`. To switch to the channel you were in prior to the current channel, use the default binding `M-s` (swap). The most recent channel is marked in
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 40000.1.0+version: 40400.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@@ -14,7 +14,12 @@ cabal-version: >= 1.18 tested-with: GHC == 7.10.3, GHC == 8.0.1 -extra-doc-files: CHANGELOG.md, README.md+extra-doc-files: CHANGELOG.md+ README.md+ PRACTICES.md+ scripts/cowsay+ scripts/figlet+ scripts/rot13 source-repository head type: git@@ -27,6 +32,8 @@ Command Connection Completion+ App+ Constants State State.Common State.Editing@@ -75,7 +82,7 @@ ScopedTypeVariables ghc-options: -Wall -threaded build-depends: base >=4.8 && <5- , mattermost-api == 40000.1.0+ , mattermost-api == 40400.0.0 , base-compat >= 0.9 && < 0.10 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.6@@ -86,8 +93,8 @@ , config-ini >= 0.1.2 && < 0.2 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4- , brick >= 0.23 && < 0.24- , vty >= 5.17 && < 5.18+ , brick >= 0.29 && < 0.30+ , vty >= 5.18 && < 5.19 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 1.9@@ -123,7 +130,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.10- , brick >= 0.23 && < 0.24+ , brick >= 0.29 && < 0.30 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5@@ -134,8 +141,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 40000.1.0- , mattermost-api-qc == 40000.1.0+ , mattermost-api == 40400.0.0+ , mattermost-api-qc == 40400.0.0 , microlens-platform >= 0.3 && < 0.4 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -153,5 +160,5 @@ , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3 , vector <= 0.12.0.1- , vty >= 5.17 && < 5.18+ , vty >= 5.18 && < 5.19 , xdg-basedir >= 0.2 && < 0.3
+ scripts/cowsay view
@@ -0,0 +1,7 @@+#!/bin/bash -e++# We want the fences so that the cowsay block gets rendered+# in Markdown as a code block. Otherwise, we just call cowsay.+echo '~~~~~~~~~~'+cowsay+echo '~~~~~~~~~~'
+ scripts/figlet view
@@ -0,0 +1,7 @@+#!/bin/bash -e++# We want the fences so that the cowsay block gets rendered+# in Markdown as a code block. Otherwise, we just call cowsay.+echo '~~~~~~~~~~'+figlet+echo '~~~~~~~~~~'
+ scripts/rot13 view
@@ -0,0 +1,4 @@+#!/bin/bash -e++# This should be a reasonably portable ROT-13-izer across Unixes+tr '[A-Za-z]' '[N-ZA-Mn-za-m]'
+ src/App.hs view
@@ -0,0 +1,65 @@+module App+ ( runMatterhorn+ )+where++import Prelude ()+import Prelude.Compat++import Brick+import Brick.BChan+import qualified Control.Concurrent.STM as STM+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform+import System.IO (IOMode(WriteMode), openFile, hClose)+import Text.Aspell (stopAspell)++import Config+import Options+import State.Setup+import State.Setup.Threads (startAsyncWorkerThread)+import Events+import Draw+import Types++app :: App ChatState MHEvent Name+app = App+ { appDraw = draw+ , appChooseCursor = showFirstCursor+ , appHandleEvent = onEvent+ , appStartEvent = return+ , appAttrMap = (^.csResources.crTheme)+ }++runMatterhorn :: Options -> Config -> IO ChatState+runMatterhorn opts config = do+ eventChan <- newBChan 25+ writeBChan eventChan RefreshWebsocketEvent++ requestChan <- STM.atomically STM.newTChan++ startAsyncWorkerThread config requestChan eventChan++ logFile <- case optLogLocation opts of+ Just path -> Just `fmap` openFile path WriteMode+ Nothing -> return Nothing++ st <- setupState logFile config requestChan eventChan++ let mkVty = do+ vty <- Vty.mkVty Vty.defaultConfig+ let output = Vty.outputIface vty+ Vty.setMode output Vty.BracketedPaste True+ return vty++ finalSt <- customMain mkVty (Just eventChan) app st++ case finalSt^.csEditState.cedSpellChecker of+ Nothing -> return ()+ Just (s, _) -> stopAspell s++ case logFile of+ Nothing -> return ()+ Just h -> hClose h++ return finalSt
src/Command.hs view
@@ -18,7 +18,6 @@ import State import State.Common-import State.Editing import State.PostListOverlay import Types import HelpTopics@@ -70,6 +69,9 @@ , Cmd "add-user" "Add a user to the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> addUserToCurrentChannel uname+ , Cmd "remove-user" "Remove a user from the current channel"+ (TokenArg "username" NoArg) $ \ (uname, ()) ->+ removeUserFromCurrentChannel uname , Cmd "focus" "Focus on a named channel" (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name@@ -86,6 +88,8 @@ Just topic -> showHelpScreen topic , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> listScripts+ , Cmd "group-msg" "Create a group chat"+ (LineArg "user1 user2 ...") createGroupChannel , Cmd "sh" "Run a prewritten shell script" (TokenArg "script" (LineArg "message")) $ \ (script, text) -> findAndRunScript script text@@ -99,6 +103,9 @@ , Cmd "flags" "Open up a pane of flagged posts" NoArg $ \ () -> enterFlaggedPostListMode++ , Cmd "search" "Search for posts with given terms" (LineArg "terms") $+ enterSearchResultPostListMode ] execMMCommand :: T.Text -> T.Text -> MH ()
src/Config.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE RecordWildCards #-}-+{-# LANGUAGE TupleSections #-} module Config ( Config(..) , PasswordSource(..)@@ -17,6 +17,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T import Data.Monoid ((<>))+import System.Directory (makeAbsolute) import System.Process (readProcess) import IOUtil@@ -33,13 +34,19 @@ configHost <- fieldMbOf "host" stringField configTeam <- fieldMbOf "team" stringField configPort <- fieldDefOf "port" number (configPort defaultConfig)+ configChannelListWidth <- fieldDefOf "channelListWidth" number+ (configChannelListWidth defaultConfig) configTimeFormat <- fieldMbOf "timeFormat" stringField configDateFormat <- fieldMbOf "dateFormat" stringField configTheme <- fieldMbOf "theme" stringField+ configThemeCustomizationFile <- fieldMbOf "themeCustomizationFile" stringField configAspellDictionary <- fieldMbOf "aspellDictionary" stringField configURLOpenCommand <- fieldMbOf "urlOpenCommand" stringField+ configURLOpenCommandInteractive <- fieldFlagDef "urlOpenCommandIsInteractive" False configSmartBacktick <- fieldFlagDef "smartbacktick" (configSmartBacktick defaultConfig)+ configShowOlderEdits <- fieldFlagDef "showOlderEdits"+ (configShowOlderEdits defaultConfig) configShowBackground <- fieldDefOf "showBackgroundActivity" backgroundField (configShowBackground defaultConfig) configShowMessagePreview <- fieldFlagDef "showMessagePreview"@@ -53,6 +60,8 @@ pure Nothing configUnsafeUseHTTP <- fieldFlagDef "unsafeUseUnauthenticatedConnection" False++ let configAbsPath = Nothing return Config { .. } backgroundField :: T.Text -> Either String BackgroundInfo@@ -86,7 +95,8 @@ defaultConfig :: Config defaultConfig =- Config { configUser = Nothing+ Config { configAbsPath = Nothing+ , configUser = Nothing , configHost = Nothing , configTeam = Nothing , configPort = defaultPort@@ -94,14 +104,18 @@ , configTimeFormat = Nothing , configDateFormat = Nothing , configTheme = Nothing+ , configThemeCustomizationFile = Nothing , configSmartBacktick = True , configURLOpenCommand = Nothing+ , configURLOpenCommandInteractive = False , configActivityBell = False , configShowBackground = Disabled , configShowMessagePreview = False , configEnableAspell = False , configAspellDictionary = Nothing , configUnsafeUseHTTP = False+ , configChannelListWidth = 20+ , configShowOlderEdits = True } findConfig :: Maybe FilePath -> IO (Either String Config)@@ -114,11 +128,12 @@ getConfig :: FilePath -> IO (Either String Config) getConfig fp = runExceptT $ do- t <- (convertIOException $ T.readFile fp) `catchE`- (\e -> throwE $ "Could not read " <> show fp <> ": " <> e)+ absPath <- convertIOException $ makeAbsolute fp+ t <- (convertIOException $ T.readFile absPath) `catchE`+ (\e -> throwE $ "Could not read " <> show absPath <> ": " <> e) case parseIniFile t fromIni of Left err -> do- throwE $ "Unable to parse " ++ fp ++ ":" ++ err+ throwE $ "Unable to parse " ++ absPath ++ ":" ++ err Right conf -> do actualPass <- case configPass conf of Just (PasswordCommand cmdString) -> do@@ -129,7 +144,9 @@ Just (PasswordString pass) -> return $ Just pass Nothing -> return Nothing - return conf { configPass = PasswordString <$> actualPass }+ return conf { configPass = PasswordString <$> actualPass+ , configAbsPath = Just absPath+ } -- | Returns the hostname, username, and password from the config. Only -- returns Just if all three have been provided. The idea is that if
src/Connection.hs view
@@ -16,8 +16,9 @@ connectWebsockets :: ChatState -> IO () connectWebsockets st = do- let shunt e = writeBChan (st^.csResources.crEventQueue) (WSEvent e)- let runWS = mmWithWebSocket (st^.csResources.crSession) shunt $ \ _ -> do+ let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg)+ shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e)+ runWS = mmWithWebSocket (st^.csResources.crSession) shunt $ \ _ -> do writeBChan (st^.csResources.crEventQueue) WebsocketConnect waitAndQuit st void $ forkIO $ runWS `catch` handleTimeout 1 st
+ src/Constants.hs view
@@ -0,0 +1,8 @@+module Constants+ ( pageAmount+ )+where++-- | The number of rows to consider a "page" when scrolling+pageAmount :: Int+pageAmount = 15
src/Draw/ChannelList.hs view
@@ -21,7 +21,6 @@ import Brick import Brick.Widgets.Border import qualified Data.HashMap.Strict as HM-import Data.List (sortBy, partition) import Data.Monoid ((<>)) import qualified Data.Text as T import Draw.Util@@ -53,8 +52,8 @@ , ChatState -> [ChannelListEntry] ) ] channelListGroups =- [ ("Channels", csChannelSelectChannelMatches, getOrdinaryChannels)- , ("Users", csChannelSelectUserMatches, getDmChannels)+ [ ("Channels", csChannelSelectState.channelMatches, getOrdinaryChannels)+ , ("Users", csChannelSelectState.userMatches, getDmChannels) ] -- | True if there is an active channel selection operation (i.e. in@@ -62,7 +61,7 @@ -- some channel selection text. hasActiveChannelSelection :: ChatState -> Bool hasActiveChannelSelection st =- st^.csMode == ChannelSelect && not (T.null (st^.csChannelSelectString))+ st^.csMode == ChannelSelect && not (T.null (st^.csChannelSelectState.channelSelectInput)) -- | This is the main function that is called from external code to -- render the ChannelList sidebar.@@ -71,8 +70,9 @@ let maybeViewport = if hasActiveChannelSelection st then id -- no viewport scrolling when actively selecting a channel else viewport ChannelList Vertical+ selMatch = st^.csChannelSelectState.selectedMatch renderedGroups = if hasActiveChannelSelection st- then renderChannelGroup renderChannelSelectListEntry <$> selectedGroupEntries+ then renderChannelGroup (renderChannelSelectListEntry selMatch) <$> selectedGroupEntries else renderChannelGroup renderChannelListEntry <$> plainGroupEntries plainGroupEntries (n, _m, f) = (n, f st) selectedGroupEntries (n, m, f) = (n, foldr (addSelectedChannel m) [] $ f st)@@ -135,10 +135,16 @@ -- | Render an individual entry when in Channel Select mode, -- highlighting the matching portion, or completely suppressing the -- entry if it doesn't match.-renderChannelSelectListEntry :: SelectedChannelListEntry -> Widget Name-renderChannelSelectListEntry (SCLE entry match) =+renderChannelSelectListEntry :: T.Text -> SelectedChannelListEntry -> Widget Name+renderChannelSelectListEntry selMatch (SCLE entry match) = let ChannelSelectMatch preMatch inMatch postMatch = match- in decorateRecent entry $ padRight Max $+ fullName = channelNameFromMatch match+ maybeSelect = if fullName == selMatch+ then withDefAttr currentChannelNameAttr+ else id+ in maybeSelect $+ decorateRecent entry $+ padRight Max $ hBox [ txt $ entrySigil entry , txt preMatch , forceAttr channelSelectMatchAttr $ txt inMatch@@ -189,24 +195,3 @@ Just cId -> maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount) Nothing -> 0 ]--sortedUserList :: ChatState -> [UserInfo]-sortedUserList st = sortBy cmp yes <> sortBy cmp no- where- cmp = compareUserInfo uiName- dmHasUnread u =- case st^.csNames.cnToChanId.at(u^.uiName) of- Nothing -> False- Just cId- | (st^.csCurrentChannelId) == cId -> False- | otherwise -> hasUnread st cId- (yes, no) = partition dmHasUnread (userList st)--compareUserInfo :: (Ord a) => Lens' UserInfo a -> UserInfo -> UserInfo -> Ordering-compareUserInfo field u1 u2- | u1^.uiStatus == Offline && u2^.uiStatus /= Offline =- GT- | u1^.uiStatus /= Offline && u2^.uiStatus == Offline =- LT- | otherwise =- (u1^.field) `compare` (u2^.field)
src/Draw/Main.hs view
@@ -56,10 +56,6 @@ import Draw.Messages import Draw.Util --channelListWidth :: Int-channelListWidth = 20- previewFromInput :: T.Text -> T.Text -> Maybe Message previewFromInput _ s | s == T.singleton cursorSentinel = Nothing previewFromInput uname s =@@ -253,7 +249,7 @@ Replying msg _ -> let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply in hBox [ replyArrow- , addEllipsis $ renderMessage st msgWithoutParent True uSet cSet False+ , addEllipsis $ renderMessage st Nothing False msgWithoutParent True uSet cSet False ] _ -> emptyWidget @@ -330,7 +326,7 @@ cached (ChannelMessages cId) $ vBox $ (withDefAttr loadMoreAttr $ hCenter $ str "<< Press C-b to load more messages >>") :- (F.toList $ renderSingleMessage st uSet cSet <$> channelMessages)+ (F.toList $ renderSingleMessage st editCutoff uSet cSet <$> channelMessages) MessageSelect -> renderMessagesWithSelect (st^.csMessageSelect) channelMessages MessageSelectDeleteConfirm ->@@ -355,12 +351,14 @@ in case s of Nothing -> renderLastMessages before Just m ->- unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st uSet cSet)+ unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st Nothing uSet cSet) + cutoff = getNewMessageCutoff cId st+ editCutoff = getEditedMessageCutoff cId st channelMessages = insertTransitions (getDateFormat st) (st ^. timeZone)- (getNewMessageCutoff cId st)+ cutoff (getMessageListing cId st) renderLastMessages :: RetrogradeMessages -> Widget Name@@ -383,7 +381,7 @@ False -> do r <- withReaderT relaxHeight $ render $ padRight Max $- renderSingleMessage st uSet cSet msg+ renderSingleMessage st editCutoff uSet cSet msg return $ r^.imageL cId = st^.csCurrentChannelId@@ -438,13 +436,14 @@ renderChannelSelect :: ChatState -> Widget Name renderChannelSelect st =- withDefAttr channelSelectPromptAttr $- (txt "Switch to channel [use ^ and $ to anchor]: ") <+>- (showCursor ChannelSelectString (Location (T.length $ st^.csChannelSelectString, 0)) $- txt $- (if T.null $ st^.csChannelSelectString- then " "- else st^.csChannelSelectString))+ let cstr = st^.csChannelSelectState.channelSelectInput+ in withDefAttr channelSelectPromptAttr $+ (txt "Switch to channel [use ^ and $ to anchor]: ") <+>+ (showCursor ChannelSelectString (Location (T.length cstr, 0)) $+ txt $+ (if T.null cstr+ then " "+ else cstr)) drawMain :: ChatState -> [Widget Name] drawMain st = [mainInterface st]@@ -532,7 +531,7 @@ Nothing -> noPreview Just pm -> if T.null curStr then noPreview- else renderMessage st pm True uSet cSet True+ else renderMessage st Nothing False pm True uSet cSet True in (maybePreviewViewport msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]") @@ -565,6 +564,7 @@ , userInputArea uSet cSet st ] where+ channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration mainDisplay = case st^.csMode of UrlSelect -> renderUrlList st _ -> maybeSubdue $ renderCurrentChannelDisplay uSet cSet st
src/Draw/Messages.hs view
@@ -24,13 +24,19 @@ maxMessageHeight :: Int maxMessageHeight = 200 -renderSingleMessage :: ChatState -> UserSet -> ChannelSet -> Message -> Widget Name-renderSingleMessage st uSet cSet =- renderChatMessage st uSet cSet (withBrackets . renderTime st)+-- | renderSingleMessage is the main message drawing function.+--+-- The `ind` argument specifies an "indicator boundary". Showing+-- various indicators (e.g. "edited") is not typically done for+-- messages that are older than this boundary value.+renderSingleMessage :: ChatState -> Maybe UTCTime -> UserSet -> ChannelSet -> Message -> Widget Name+renderSingleMessage st ind uSet cSet =+ renderChatMessage st ind uSet cSet (withBrackets . renderTime st) -renderChatMessage :: ChatState -> UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name-renderChatMessage st uSet cSet renderTimeFunc msg =- let m = renderMessage st msg True uSet cSet True+renderChatMessage :: ChatState -> Maybe UTCTime -> UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name+renderChatMessage st ind uSet cSet renderTimeFunc msg =+ let showOlderEdits = configShowOlderEdits $ st^.csResources.crConfiguration+ m = renderMessage st ind showOlderEdits msg True uSet cSet True msgAtch = if Seq.null (msg^.mAttachments) then Nothing else Just $ withDefAttr clientMessageAttr $ vBox
src/Draw/PostListOverlay.hs view
@@ -69,7 +69,11 @@ padRight (Pad 1) messageListContents where -- The 'window title' of the overlay contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of- PostListFlagged -> "Flagged posts"+ PostListFlagged -> "Flagged posts"+ PostListSearch terms searching -> "Search results" <> if searching+ then ": " <> terms+ else " (" <> (T.pack . show . length) (st^.csPostListOverlay.postListPosts) <> "): " <> terms+ -- User and channel set, for use in message rendering uSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName) cSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName)@@ -87,12 +91,16 @@ hCenter $ withDefAttr clientEmphAttr $ str $ case contents of- PostListFlagged -> "You have no flagged messages."+ PostListFlagged -> "You have no flagged messages."+ PostListSearch _ searching ->+ if searching+ then "Searching ..."+ else "No search results found" | otherwise = vBox renderedMessageList -- The render-message function we're using renderMessageForOverlay msg =- let renderedMsg = renderSingleMessage st uSet cSet msg+ let renderedMsg = renderSingleMessage st Nothing uSet cSet msg in case msg^.mOriginalPost of -- We should factor out some of the channel name logic at -- some point, but we can do that later
src/Draw/ShowHelp.hs view
@@ -4,11 +4,14 @@ import Prelude.Compat import Brick+import Brick.Themes (themeDescriptions) import Brick.Widgets.Border import Brick.Widgets.Center (hCenter, centerLayer)+import Brick.Widgets.List (listSelectedFocusedAttr) import Lens.Micro.Platform-import Data.List (sortBy)+import Data.List (sortBy, intercalate, sort) import Data.Ord (comparing)+import qualified Data.Map as M import qualified Data.Text as T import Data.Monoid ((<>)) import qualified Graphics.Vty as Vty@@ -38,6 +41,7 @@ case helpTopicScreen topic of MainHelp -> const mainHelp ScriptHelp -> const scriptHelp+ ThemeHelp -> const themeHelp mainHelp :: Widget Name mainHelp = commandHelp@@ -115,6 +119,91 @@ , "Matterhorn command " ] , [ "> *> /sh rot13 Hello, world!*\n" ] ]++themeHelp :: Widget a+themeHelp = overrideAttr codeAttr helpEmphAttr $ vBox+ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Themes"+ , padTop (Pad 1) $ hCenter $ renderText "Matterhorn provides these built-in color themes:"+ , padTop (Pad 1) $ vBox $ hCenter <$> withDefAttr helpEmphAttr <$>+ txt <$> internalThemeName <$> internalThemes+ , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $+ "These themes can be selected with the */theme* command. To automatically " <>+ "select a theme at startup, set the *theme* configuration file option to one " <>+ "of the themes listed above."+ , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Customizing the Theme"+ , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $+ "Theme customization is also supported. To customize the selected theme, " <>+ "create a theme customization file and set the `themeCustomizationFile` " <>+ "configuration option to the path to the customization file. If the path " <>+ "to the file is relative, Matterhorn will look for it in the same directory " <>+ "as the Matterhorn configuration file.\n" <>+ " \n" <>+ "Theme customization files are INI-style files that can customize any " <>+ "foreground color, background color, or style of any aspect of the " <>+ "Matterhorn user interface. Here is an example:\n" <>+ "```\n" <>+ "[default]\n" <>+ "default.fg = blue\n" <>+ "default.bg = black\n" <>+ "\n" <>+ "[other]\n" <>+ attrNameToConfig codeAttr <> ".fg = magenta\n" <>+ attrNameToConfig codeAttr <> ".style = bold\n" <>+ attrNameToConfig clientEmphAttr <> ".fg = cyan\n" <>+ attrNameToConfig clientEmphAttr <> ".style = [bold, underline]\n" <>+ attrNameToConfig listSelectedFocusedAttr <> ".fg = brightGreen\n" <>+ "```\n" <>+ "In the example above, the theme's default foreground and background colors " <>+ "are both customized to *blue* and *black*, respectively. The *default* section " <>+ "contains only customizations for the *default* attribute. All other customizations " <>+ "go in the *other* section. We can also set the style for attributes; we can either " <>+ "set just one style (as with the bold setting above) or multiple styles at once " <>+ "(as in the bold/underline example).\n\n" <>+ "Available colors are:\n" <>+ " * black\n" <>+ " * red\n" <>+ " * green\n" <>+ " * yellow\n" <>+ " * blue\n" <>+ " * magenta\n" <>+ " * cyan\n" <>+ " * white\n" <>+ " * brightBlack\n" <>+ " * brightRed\n" <>+ " * brightGreen\n" <>+ " * brightYellow\n" <>+ " * brightBlue\n" <>+ " * brightMagenta\n" <>+ " * brightCyan\n" <>+ " * brightWhite\n" <>+ " \n" <>+ "Available styles are:\n" <>+ " * standout\n" <>+ " * underline\n" <>+ " * reverseVideo\n" <>+ " * blink\n" <>+ " * dim\n" <>+ " * bold\n"+ , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Theme Attributes"+ , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $+ "This section lists all possible theme attributes for use in customization " <>+ "files along with a description of how each one is used in Matterhorn. Each " <>+ "option listed can be set in the *other* section of the customization file. " <>+ "Each provides three customization settings:\n" <>+ " * *<option>.fg = <color>*\n" <>+ " * *<option>.bg = <color>*\n" <>+ " * *<option>.style = <style>* or *<option>.style = [<style>, ...]*\n"++ , padTop (Pad 1) $ hCenter $ hLimit 72 $ renderText $+ let names = sort $+ (\(n, msg) -> (attrNameToConfig n, msg)) <$>+ (M.toList $ themeDescriptions themeDocs)+ mkEntry (opt, msg) = "*" <> opt <> "*\n" <> msg <> "\n"+ in T.concat $ mkEntry <$> names+ ]++attrNameToConfig :: AttrName -> T.Text+attrNameToConfig = T.pack . intercalate "." . attrNameComponents withMargins :: (Int, Int) -> Widget a -> Widget a withMargins (hMargin, vMargin) w =
src/Events.hs view
@@ -5,7 +5,7 @@ import Prelude.Compat import Brick-import Control.Monad (forM_)+import Control.Monad (forM_, when) import Control.Monad.IO.Class (liftIO) import qualified Data.Set as Set import qualified Data.Text as T@@ -21,7 +21,6 @@ import State import State.Common import Types-import Types.Channels (ccInfo, cdMentionCount) import Events.ShowHelp import Events.Main@@ -62,6 +61,11 @@ T.pack (show e) <> "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues" postErrorMessage msg+onAppEvent (WebsocketParseError e) = do+ let msg = "A websocket message could not be parsed:\n " <>+ T.pack e <>+ "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues"+ postErrorMessage msg onVtyEvent :: Vty.Event -> MH () onVtyEvent e = do@@ -90,133 +94,119 @@ handleWSEvent :: WebsocketEvent -> MH () handleWSEvent we = do- myId <- use (csMe.userIdL)- myTeamId <- use (csMyTeam.teamIdL)- case weEvent we of- WMPosted -> case wepPost (weData we) of- Just p -> do- -- If the message is a header change, also update the channel- -- metadata.- myUserId <- use (csMe.userIdL)- case wepMentions (weData we) of- Just lst- | myUserId `Set.member` lst ->- csChannel(postChannelId p).ccInfo.cdMentionCount += 1- _ -> return ()- addMessageToState p >>= postProcessMessageAdd- Nothing -> return ()-- WMPostEdited -> case wepPost (weData we) of- Just p -> editMessage p- Nothing -> return ()-- WMPostDeleted -> case wepPost (weData we) of- Just p -> deleteMessage p- Nothing -> return ()-- WMStatusChange -> case wepStatus (weData we) of- Just status -> case wepUserId (weData we) of- Just uId -> updateStatus uId status- Nothing -> return ()- Nothing -> return ()-- WMUserAdded -> case webChannelId (weBroadcast we) of- Just cId -> if wepUserId (weData we) == Just myId &&- wepTeamId (weData we) == Just myTeamId- then handleChannelInvite cId- else return ()- Nothing -> return ()-- WMUserUpdated -> -- XXX- return ()-- WMNewUser -> do- let Just newUserId = wepUserId $ weData we- handleNewUser newUserId+ myId <- use (csMe.userIdL)+ myTeamId <- use (csMyTeam.teamIdL)+ case weEvent we of+ WMPosted+ | Just p <- wepPost (weData we) -> do+ -- If the message is a header change, also update the+ -- channel metadata.+ myUserId <- use (csMe.userIdL)+ let wasMentioned = case wepMentions (weData we) of+ Just lst -> myUserId `Set.member` lst+ _ -> False+ addMessageToState (RecentPost p wasMentioned) >>= postProcessMessageAdd+ | otherwise -> return () - WMUserRemoved -> -- XXX- return ()+ WMPostEdited+ | Just p <- wepPost (weData we) -> editMessage p+ | otherwise -> return () - WMChannelDeleted -> -- XXX- return ()+ WMPostDeleted+ | Just p <- wepPost (weData we) -> deleteMessage p+ | otherwise -> return () - WMDirectAdded -> -- XXX- return ()+ WMStatusChange+ | Just status <- wepStatus (weData we)+ , Just uId <- wepUserId (weData we) ->+ updateStatus uId status+ | otherwise -> return () - WMChannelCreated -> -- XXX- return ()+ WMUserAdded+ | Just cId <- webChannelId (weBroadcast we) ->+ when (wepUserId (weData we) == Just myId &&+ wepTeamId (weData we) == Just myTeamId) $+ handleChannelInvite cId+ | otherwise -> return () - WMGroupAdded -> -- XXX- return ()+ WMNewUser+ | Just uId <- wepUserId $ weData we -> handleNewUser uId+ | otherwise -> return () - WMEmojiAdded -> -- XXX- return ()+ WMUserRemoved+ | Just cId <- wepChannelId (weData we) ->+ when (webUserId (weBroadcast we) == Just myId) $+ removeChannelFromState cId+ | otherwise -> return () - WMLeaveTeam -> -- XXX: How do we deal with this one?- return ()+ WMChannelDeleted+ | Just cId <- wepChannelId (weData we) ->+ when (webTeamId (weBroadcast we) == Just myTeamId) $+ removeChannelFromState cId+ | otherwise -> return () - -- An 'ephemeral message' is just Mattermost's version- -- of our 'client message'. This can be a little bit- -- wacky, e.g. if the user types '/shortcuts' in the- -- browser, we'll get an ephemeral message even in- -- MatterHorn with the browser shortcuts, but it's- -- probably a good idea to handle these messages anyway.- WMEphemeralMessage -> case wepPost (weData we) of- Just p -> do- postInfoMessage (p^.postMessageL)- Nothing -> return ()+ WMDirectAdded+ | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId+ | otherwise -> return () - -- The only preference we observe right now is flagging- WMPreferenceChanged- | Just pref <- wepPreferences (weData we)- , Just fps <- mapM preferenceToFlaggedPost pref ->- forM_ fps $ \f ->- updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)- | otherwise -> return ()- WMPreferenceDeleted- | Just pref <- wepPreferences (weData we)- , Just fps <- mapM preferenceToFlaggedPost pref ->- forM_ fps $ \f ->- updateMessageFlag (flaggedPostId f) False- | otherwise -> return ()+ -- An 'ephemeral message' is just Mattermost's version of our+ -- 'client message'. This can be a little bit wacky, e.g.+ -- if the user types '/shortcuts' in the browser, we'll get+ -- an ephemeral message even in MatterHorn with the browser+ -- shortcuts, but it's probably a good idea to handle these+ -- messages anyway.+ WMEphemeralMessage+ | Just p <- wepPost $ weData we -> postInfoMessage $ p^.postMessageL+ | otherwise -> return () - -- This happens whenever a user connects to the server- -- I think all the information we need (about being- -- online or away or what-have-you) gets represented- -- in StatusChanged messages, so we can ignore it.- WMHello -> return ()+ WMPreferenceChanged+ | Just prefs <- wepPreferences (weData we) ->+ mapM_ applyPreferenceChange prefs+ | otherwise -> return () - -- right now we don't show typing notifications. maybe- -- we should? i dunno.- WMTyping -> return ()+ WMPreferenceDeleted+ | Just pref <- wepPreferences (weData we)+ , Just fps <- mapM preferenceToFlaggedPost pref ->+ forM_ fps $ \f ->+ updateMessageFlag (flaggedPostId f) False+ | otherwise -> return () - -- Do we need to do anything with this?- WMUpdateTeam -> return ()+ WMReactionAdded+ | Just r <- wepReaction (weData we)+ , Just cId <- webChannelId (weBroadcast we) -> addReactions cId [r]+ | otherwise -> return () - WMReactionAdded -> case wepReaction (weData we) of- Just r -> case webChannelId (weBroadcast we) of- Just cId -> addReactions cId [r]- Nothing -> return ()- Nothing -> return ()+ WMReactionRemoved+ | Just r <- wepReaction (weData we)+ , Just cId <- webChannelId (weBroadcast we) -> removeReaction r cId+ | otherwise -> return () - WMReactionRemoved -> case wepReaction (weData we) of- Just r -> case webChannelId (weBroadcast we) of- Just cId -> removeReaction r cId- Nothing -> return ()- Nothing -> return ()+ WMChannelViewed+ | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById False cId+ | otherwise -> return () - WMAddedToTeam -> return () -- XXX: we need to handle this+ WMChannelUpdated+ | Just cId <- webChannelId $ weBroadcast we -> refreshChannelById False cId+ | otherwise -> return () - WMWebRTC -> return ()+ WMGroupAdded+ | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId+ | otherwise -> return () - WMAuthenticationChallenge -> return ()+ -- We are pretty sure we should do something about these:+ WMAddedToTeam -> return () - WMChannelViewed ->- case webChannelId $ weBroadcast we of- Just cId -> refreshChannelById False cId- Nothing -> return ()+ -- We aren't sure whether there is anything we should do about+ -- these yet:+ WMUpdateTeam -> return ()+ WMUserUpdated -> return ()+ WMLeaveTeam -> return () - WMChannelUpdated ->- case webChannelId $ weBroadcast we of- Just cId -> refreshChannelById False cId- Nothing -> return ()+ -- We deliberately ignore these events:+ WMChannelCreated -> return ()+ WMEmojiAdded -> return ()+ WMWebRTC -> return ()+ WMTyping -> return ()+ WMHello -> return ()+ WMAuthenticationChallenge -> return ()+ WMUserRoleUpdated -> return ()
src/Events/ChannelSelect.hs view
@@ -3,9 +3,8 @@ import Prelude () import Prelude.Compat -import Data.Monoid ((<>))+import Control.Monad (when) import qualified Data.Text as T-import qualified Data.HashMap.Strict as HM import qualified Graphics.Vty as Vty import Lens.Micro.Platform @@ -16,33 +15,23 @@ onEventChannelSelect e | Just kb <- lookupKeybinding e channelSelectKeybindings = kbAction kb onEventChannelSelect (Vty.EvKey Vty.KBS []) = do- csChannelSelectString %= (\s -> if T.null s then s else T.init s)+ csChannelSelectState.channelSelectInput %= (\s -> if T.null s then s else T.init s) updateChannelSelectMatches onEventChannelSelect (Vty.EvKey (Vty.KChar c) []) | c /= '\t' = do- csChannelSelectString %= (flip T.snoc c)+ csChannelSelectState.channelSelectInput %= (flip T.snoc c) updateChannelSelectMatches onEventChannelSelect _ = return () channelSelectKeybindings :: [Keybinding] channelSelectKeybindings =- [ KB "Select matching channel"+ [ KB "Switch to selected channel" (Vty.EvKey Vty.KEnter []) $ do- -- If there is only one channel selection match, switch to- -- it- st <- use id- let allMatches = (HM.elems $ st^.csChannelSelectChannelMatches) <>- (HM.elems $ st^.csChannelSelectUserMatches)- matchingName = (==) (st^.csChannelSelectString) . channelNameFromMatch- exactMatches = filter matchingName allMatches- case (allMatches, exactMatches) of- ([single], _) -> do- csMode .= Main- changeChannel (channelNameFromMatch single)- (_, [exact]) -> do- csMode .= Main- changeChannel (channelNameFromMatch exact)- _ -> return ()+ selMatch <- use (csChannelSelectState.selectedMatch) + csMode .= Main+ when (selMatch /= "") $ do+ changeChannel selMatch+ , KB "Cancel channel selection" (Vty.EvKey Vty.KEsc []) $ do csMode .= Main@@ -50,4 +39,12 @@ , KB "Cancel channel selection" (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ do csMode .= Main++ , KB "Select next match"+ (Vty.EvKey (Vty.KChar 'n') [Vty.MCtrl]) $ do+ channelSelectNext++ , KB "Select previous match"+ (Vty.EvKey (Vty.KChar 'p') [Vty.MCtrl]) $ do+ channelSelectPrevious ]
src/Events/Main.hs view
@@ -16,7 +16,8 @@ import Lens.Micro.Platform import Types-import Types.Channels (ccInfo, cdType, clearNewMessageIndicator)+import Types.Channels (ccInfo, cdType, clearNewMessageIndicator, clearEditedThreshold)+import Types.Users (uiDeleted, findUserById) import State import State.PostListOverlay (enterFlaggedPostListMode) import State.Editing@@ -24,6 +25,7 @@ import Completion import InputHistory import HelpTopics (mainHelpTopic)+import Constants import Network.Mattermost (Type(..)) @@ -131,9 +133,10 @@ (Vty.EvKey (Vty.KChar 'o') [Vty.MCtrl]) $ startUrlSelect - , KB "Clear the current channel's unread message indicator"+ , KB "Clear the current channel's unread / edited indicators" (Vty.EvKey (Vty.KChar 'l') [Vty.MMeta]) $- csCurrentChannel %= clearNewMessageIndicator+ csCurrentChannel %= (clearNewMessageIndicator .+ clearEditedThreshold) , KB "Toggle multi-line message compose mode" (Vty.EvKey (Vty.KChar 'e') [Vty.MMeta]) $@@ -180,6 +183,8 @@ tabComplete :: Completion.Direction -> MH () tabComplete dir = do st <- use id+ knownUsers <- use csUsers+ let completableChannels = catMaybes (flip map (st^.csNames.cnChans) $ \cname -> do -- Only permit completion of channel names for non-Group channels cId <- st^.csNames.cnToChanId.at cname@@ -189,10 +194,21 @@ _ -> Just cname ) + completableUsers = catMaybes (flip map (st^.csNames.cnUsers) $ \uname -> do+ -- Only permit completion of user names for non-deleted users+ uId <- st^.csNames.cnToUserId.at uname+ case findUserById uId knownUsers of+ Nothing -> Nothing+ Just u ->+ if u^.uiDeleted+ then Nothing+ else Just uname+ )+ priorities = [] :: [T.Text]-- XXX: add recent completions to this- completions = Set.fromList (st^.csNames.cnUsers +++ completions = Set.fromList (completableUsers ++ completableChannels ++- map (T.singleton userSigil <>) (st^.csNames.cnUsers) +++ map (T.singleton userSigil <>) completableUsers ++ map (T.singleton normalChannelSigil <>) completableChannels ++ map ("/" <>) (commandName <$> commandList))
src/Events/ShowHelp.hs view
@@ -8,7 +8,7 @@ import Lens.Micro.Platform import Types-import State+import Constants onEventShowHelp :: Vty.Event -> MH () onEventShowHelp e | Just kb <- lookupKeybinding e helpKeybindings =
src/HelpTopics.hs view
@@ -2,6 +2,7 @@ module HelpTopics ( helpTopics , lookupHelpTopic+ , themeHelpTopic , mainHelpTopic )@@ -19,6 +20,7 @@ helpTopics = [ mainHelpTopic , scriptHelpTopic+ , themeHelpTopic ] mainHelpTopic :: HelpTopic@@ -28,6 +30,10 @@ scriptHelpTopic :: HelpTopic scriptHelpTopic = HelpTopic "scripts" "Help on available scripts" ScriptHelp ScriptHelpText++themeHelpTopic :: HelpTopic+themeHelpTopic =+ HelpTopic "themes" "Help on color themes" ThemeHelp ThemeHelpText lookupHelpTopic :: T.Text -> Maybe HelpTopic lookupHelpTopic topic =
src/Main.hs view
@@ -1,101 +1,28 @@-{-# LANGUAGE RecordWildCards #-}- module Main where import Prelude () import Prelude.Compat -import Brick-import Brick.BChan-import Control.Concurrent (forkIO)-import qualified Control.Concurrent.STM as STM-import Control.Exception (try)-import Control.Monad (forever, void) import Data.Monoid ((<>))-import qualified Graphics.Vty as Vty import Lens.Micro.Platform import System.Exit (exitFailure)-import System.IO (IOMode(WriteMode), openFile, hClose)-import Text.Aspell (stopAspell) import Config import Options-import State.Setup-import Events-import Draw import Types import InputHistory+import App main :: IO () main = do- opts <- grabOptions- configResult <- findConfig (optConfLocation opts)- config <- case configResult of- Left err -> do- putStrLn $ "Error loading config: " <> err- exitFailure- Right c -> return c-- eventChan <- newBChan 25- writeBChan eventChan RefreshWebsocketEvent-- requestChan <- STM.atomically STM.newTChan- void $ forkIO $ forever $ do- startWork <-- case configShowBackground config of- Disabled -> return $ return ()- Active -> do chk <- STM.atomically $ STM.tryPeekTChan requestChan- case chk of- Nothing -> do writeBChan eventChan BGIdle- return $ writeBChan eventChan $ BGBusy Nothing- _ -> return $ return ()- ActiveCount -> do- chk <- STM.atomically $ do- chanCopy <- STM.cloneTChan requestChan- let cntMsgs = do m <- STM.tryReadTChan chanCopy- case m of- Nothing -> return 0- Just _ -> (1 +) <$> cntMsgs- cntMsgs- case chk of- 0 -> do writeBChan eventChan BGIdle- return (writeBChan eventChan $ BGBusy (Just 1))- _ -> do writeBChan eventChan $ BGBusy (Just chk)- return $ return ()- req <- STM.atomically $ STM.readTChan requestChan- startWork- res <- try req- case res of- Left e -> writeBChan eventChan (AsyncErrEvent e)- Right upd -> writeBChan eventChan (RespEvent upd)-- logFile <- case optLogLocation opts of- Just path -> Just `fmap` openFile path WriteMode- Nothing -> return Nothing- st <- setupState logFile config requestChan eventChan-- let mkVty = do- vty <- Vty.mkVty Vty.defaultConfig- let output = Vty.outputIface vty- Vty.setMode output Vty.BracketedPaste True- return vty-- finalSt <- customMain mkVty (Just eventChan) app st-- case finalSt^.csEditState.cedSpellChecker of- Nothing -> return ()- Just (s, _) -> stopAspell s+ opts <- grabOptions+ configResult <- findConfig (optConfLocation opts)+ config <- case configResult of+ Left err -> do+ putStrLn $ "Error loading config: " <> err+ exitFailure+ Right c -> return c - case logFile of- Nothing -> return ()- Just h -> hClose h- writeHistory (finalSt^.csEditState.cedInputHistory)+ finalSt <- runMatterhorn opts config -app :: App ChatState MHEvent Name-app = App- { appDraw = draw- , appChooseCursor = showFirstCursor- , appHandleEvent = onEvent- , appStartEvent = return- , appAttrMap = (^.csResources.crTheme)- }+ writeHistory (finalSt^.csEditState.cedInputHistory)
src/Markdown.hs view
@@ -34,6 +34,7 @@ import qualified Data.Text as T import qualified Data.Foldable as F import Data.Monoid (First(..), (<>))+import Data.Time.Clock (UTCTime) import Data.Sequence ( Seq , ViewL(..) , ViewR(..)@@ -49,6 +50,7 @@ import Lens.Micro.Platform ((^.)) import Control.Monad (join) +import Network.Mattermost.Lenses (postUpdateAtL, postCreateAtL) import Themes import Types (ChatState, getMessageForPostId, userSigil, normalChannelSigil) import Types.Posts@@ -64,8 +66,53 @@ , CP TopicChange ] -renderMessage :: ChatState -> Message -> Bool -> UserSet -> ChannelSet -> Bool -> Widget a-renderMessage st msg renderReplyParent uSet cSet indentBlocks =+-- The special string we use to indicate the placement of a styled+-- indication that a message has been edited.+editMarkingSentinel :: Text+editMarkingSentinel = "#__mh_edit"++-- The special string we use to indicate the placement of a styled+-- indication that a message has been edited recently.+editRecentlyMarkingSentinel :: Text+editRecentlyMarkingSentinel = "#__mh_edit_r"++-- The actual user-facing text that we render in place of the edit+-- marking sentinel.+editMarking :: Text+editMarking = "(edited)"++-- Add the edit sentinel to the end of the last block in the sequence.+-- If the last block is a paragraph, append it to that paragraph.+-- Otherwise, append a new block so it appears beneath the last+-- block-level element.+addEditSentinel :: Text -> Blocks -> Blocks+addEditSentinel s bs =+ case viewr bs of+ EmptyR -> bs+ (rest :> b) -> rest <> appendEditSentinel s b++appendEditSentinel :: Text -> Block -> Blocks+appendEditSentinel sentinel b =+ let s = C.Para (S.singleton m)+ m = C.Str sentinel+ in case b of+ C.Para is -> S.singleton $ C.Para (is |> C.Str " " |> m)+ _ -> S.fromList [b, s]++-- | renderMessage performs markdown rendering of the specified message.+--+-- The 'mEditThreshold' argument specifies a time boundary where+-- "edited" markers are not shown for any messages older than this+-- mark (under the presumption that they are distracting for really+-- old stuff). The mEditThreshold will be None if there is no+-- boundary known yet; the boundary is typically set to the "new"+-- message boundary.+--+-- The 'showOlderEdits' argument is a value read from the user's+-- configuration file that indicates that "edited" markers should be+-- shown for old messages (i.e., ignore the mEditThreshold value).+renderMessage :: ChatState -> Maybe UTCTime -> Bool -> Message -> Bool -> UserSet -> ChannelSet -> Bool -> Widget a+renderMessage st mEditThreshold showOlderEdits msg renderReplyParent uSet cSet indentBlocks = let msgUsr = case msg^.mUserName of Just u | msg^.mType `elem` omitUsernameTypes -> Nothing@@ -86,8 +133,25 @@ , B.txt ": " ] Nothing -> []- rmd = renderMarkdown uSet cSet (msg^.mText)- msgWidget = layout nameElems rmd . viewl $ msg^.mText++ -- Use the editing threshold to determine whether to append an+ -- editing indication to this message.+ maybeAugment bs = case msg^.mOriginalPost of+ Nothing -> bs+ Just p ->+ if p^.postUpdateAtL > p^.postCreateAtL+ then case mEditThreshold of+ Just cutoff | p^.postUpdateAtL >= cutoff ->+ addEditSentinel editRecentlyMarkingSentinel bs+ _ -> if showOlderEdits+ then addEditSentinel editMarkingSentinel bs+ else bs+ else bs++ augmentedText = maybeAugment $ msg^.mText+ rmd = renderMarkdown uSet cSet augmentedText+ msgWidget =+ (layout nameElems rmd . viewl) augmentedText withParent p = (replyArrow <+> p) B.<=> msgWidget in if not renderReplyParent then msgWidget@@ -97,7 +161,7 @@ case getMessageForPostId st parentId of Nothing -> withParent (B.str "[loading...]") Just pm ->- let parentMsg = renderMessage st pm False uSet cSet False+ let parentMsg = renderMessage st mEditThreshold False pm False uSet cSet False in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg) where@@ -191,7 +255,7 @@ B.withDefAttr clientHeaderAttr $ hBox [header n, B.txt " ", toInlineChunk is uPat cPat] toWidget uPat cPat (C.Blockquote is) =- B.padLeft (B.Pad 4) (vBox $ fmap (toWidget uPat cPat) is)+ addQuoting (vBox $ fmap (toWidget uPat cPat) is) toWidget uPat cPat (C.List _ l bs) = toList l bs uPat cPat toWidget _ _ (C.CodeBlock ci tx) = let f = maybe rawCodeBlockToWidget codeBlockToWidget mSyntax@@ -200,6 +264,22 @@ toWidget _ _ (C.HtmlBlock txt) = textWithCursor txt toWidget _ _ (C.HRule) = B.vLimit 1 (B.fill '*') +quoteChar :: Char+quoteChar = '>'++addQuoting :: B.Widget n -> B.Widget n+addQuoting w =+ B.Widget B.Fixed (B.vSize w) $ do+ ctx <- B.getContext+ childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w++ let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height+ height = V.imageHeight $ childResult^.B.imageL++ B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder+ , B.Widget B.Fixed B.Fixed $ return childResult+ ]+ codeBlockToWidget :: Sky.Syntax -> T.Text -> Widget a codeBlockToWidget syntax tx = let result = Sky.tokenize cfg syntax tx@@ -264,6 +344,8 @@ | TLineBreak | TLink Text | TRawHtml Text+ | TEditSentinel+ | TEditRecentlySentinel deriving (Show, Eq) data FragmentStyle@@ -272,15 +354,21 @@ | Strong | Code | User- | Link+ | Link Text | Emoji | Channel+ | Edited+ | EditedRecently deriving (Eq, Show) -- We convert it pretty mechanically: toFragments :: Inlines -> Seq Fragment toFragments = go Normal where go n c = case viewl c of+ C.Str t :< xs | t == editMarkingSentinel ->+ Fragment TEditSentinel Edited <| go n xs+ C.Str t :< xs | t == editRecentlyMarkingSentinel ->+ Fragment TEditRecentlySentinel EditedRecently <| go n xs C.Str t :< xs -> Fragment (TStr t) n <| go n xs C.Space :< xs ->@@ -291,8 +379,8 @@ Fragment TLineBreak n <| go n xs C.Link label url _ :< xs -> case F.toList label of- [C.Str s] | s == url -> Fragment (TLink url) Link <| go n xs- _ -> go Link label <> go n xs+ [C.Str s] | s == url -> Fragment (TLink url) (Link url) <| go n xs+ _ -> go (Link url) label <> go n xs C.RawHtml t :< xs -> Fragment (TRawHtml t) n <| go n xs C.Code t :< xs ->@@ -310,10 +398,10 @@ go Emph is <> go n xs C.Strong is :< xs -> go Strong is <> go n xs- C.Image altIs _ _ :< xs ->- Fragment (TStr ("[image" <> altInlinesString altIs <> "]")) Link <| go n xs+ C.Image altIs url _ :< xs ->+ Fragment (TStr ("[image" <> altInlinesString altIs <> "]")) (Link url) <| go n xs C.Entity t :< xs ->- Fragment (TStr t) Link <| go n xs+ Fragment (TStr t) (Link t) <| go n xs EmptyL -> S.empty --@@ -393,6 +481,8 @@ TStr t -> textWidth t TLink t -> textWidth t TRawHtml t -> textWidth t+ TEditSentinel -> textWidth editMarking+ TEditRecentlySentinel -> textWidth editMarking TSpace -> 1 TLineBreak -> 0 TSoftBreak -> 0@@ -402,6 +492,8 @@ TStr t -> t TLink t -> t TRawHtml t -> t+ TEditSentinel -> editMarking+ TEditRecentlySentinel -> editMarking TSpace -> " " _ -> "" @@ -415,9 +507,13 @@ let w = case s of Normal -> textWithCursor t Emph -> B.withDefAttr clientEmphAttr (textWithCursor t)+ Edited -> B.withDefAttr editedMarkingAttr $ B.txt t+ EditedRecently -> B.withDefAttr editedRecentlyMarkingAttr $ B.txt t Strong -> B.withDefAttr clientStrongAttr (textWithCursor t) Code -> B.withDefAttr codeAttr (textWithCursor t)- Link -> B.withDefAttr urlAttr (textWithCursor t)+ Link l ->+ B.modifyDefAttr (`V.withURL` l)+ (B.withDefAttr urlAttr (textWithCursor t)) Emoji -> B.withDefAttr emojiAttr (textWithCursor t) User -> B.withDefAttr (attrForUsername $ removeCursor t) (textWithCursor t)
src/Scripts.hs view
@@ -8,6 +8,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Data.Monoid ((<>))+import Control.Concurrent (takeMVar, newEmptyMVar) import qualified Control.Concurrent.STM as STM import System.Exit (ExitCode(..)) import Lens.Micro.Platform (use)@@ -38,7 +39,9 @@ runScript :: STM.TChan ProgramOutput -> FilePath -> T.Text -> IO (MH ()) runScript outputChan fp text = do- po <- runLoggedCommand True outputChan fp [] (Just $ T.unpack text)+ outputVar <- newEmptyMVar+ runLoggedCommand True outputChan fp [] (Just $ T.unpack text) (Just outputVar)+ po <- takeMVar outputVar return $ case programExitCode po of ExitSuccess -> do when (null $ programStderr po) $ do
src/State.hs view
@@ -1,16 +1,119 @@ {-# LANGUAGE LambdaCase #-}+module State+ (+ -- * Message flagging+ updateMessageFlag+ , flagMessage -module State where+ -- * Running external programs+ , runLoggedCommand + -- * Channel sidebar selection+ , prevChannel+ , nextChannel+ , recentChannel+ , nextUnreadChannel++ -- * Working with channels+ , createOrdinaryChannel+ , startJoinChannel+ , joinChannel+ , changeChannel+ , startLeaveCurrentChannel+ , leaveCurrentChannel+ , leaveChannel+ , removeChannelFromState+ , beginCurrentChannelDeleteConfirm+ , deleteCurrentChannel+ , loadMoreMessages+ , channelScrollToTop+ , channelScrollToBottom+ , channelScrollUp+ , channelScrollDown+ , channelPageUp+ , channelPageDown+ , isCurrentChannel+ , getNewMessageCutoff+ , getEditedMessageCutoff+ , setChannelTopic+ , fetchCurrentChannelMembers+ , refreshChannelById+ , handleChannelInvite+ , addUserToCurrentChannel+ , removeUserFromCurrentChannel+ , createGroupChannel++ -- * Channel history+ , channelHistoryForward+ , channelHistoryBackward++ -- * Working with messages+ , PostToAdd(..)+ , sendMessage+ , msgURLs+ , editMessage+ , deleteMessage+ , addMessageToState+ , postProcessMessageAdd++ -- * Working with users+ , handleNewUser+ , updateStatus++ -- * Startup/reconnect management+ , refreshChannelsAndUsers++ -- * Channel selection mode+ , beginChannelSelect+ , updateChannelSelectMatches+ , channelSelectNext+ , channelSelectPrevious++ -- * Server-side preferences+ , applyPreferenceChange++ -- * Message selection mode+ , beginMessageSelect+ , flagSelectedMessage+ , copyVerbatimToClipboard+ , openSelectedMessageURLs+ , beginConfirmDeleteSelectedMessage+ , messageSelectUp+ , messageSelectUpBy+ , messageSelectDown+ , messageSelectDownBy+ , deleteSelectedMessage+ , beginReplyCompose+ , beginUpdateMessage+ , getSelectedMessage+ , cancelReplyOrEdit+ , replyToLatestMessage++ -- * URL selection mode+ , startUrlSelect+ , stopUrlSelect+ , openSelectedURL++ -- * Help+ , showHelpScreen++ -- * Themes+ , listThemes+ , setTheme+ )+where+ import Prelude () import Prelude.Compat import Brick (invalidateCacheEntry)+import Brick.Themes (themeToAttrMap) import Brick.Widgets.Edit (getEditContents, editContentsL) import Brick.Widgets.List (list, listMoveTo, listSelectedElement) import Control.Applicative import Control.Exception (SomeException, try) import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (MVar, putMVar, forkIO) import qualified Control.Concurrent.STM as STM import Data.Char (isAlphaNum) import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd)@@ -19,9 +122,10 @@ import qualified Data.ByteString as BS import Data.Function (on) import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL)+import Data.Time.Clock (UTCTime) import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq-import Data.List (sort)+import Data.List (sort, findIndex) import Data.Maybe (maybeToList, isJust, catMaybes, isNothing) import Data.Monoid ((<>)) import qualified Data.Set as Set@@ -40,6 +144,8 @@ import System.FilePath import Network.Mattermost+import Network.Mattermost.Types (NotifyOption(..), GroupChannelPreference(..),+ preferenceToGroupChannelPreference) import Network.Mattermost.Lenses import Config@@ -53,17 +159,12 @@ import Themes import Zipper (Zipper) import qualified Zipper as Z+import Constants import Markdown (blockGetURLs, findVerbatimChunk) import State.Common import State.Setup.Threads (updateUserStatuses) --- * Hard-coded constants---- | The number of posts to include per page-pageAmount :: Int-pageAmount = 15- -- * Refreshing Channel Data -- | Refresh information about a specific channel. The channel@@ -74,17 +175,24 @@ let cId = getId chan curId <- use csCurrentChannelId - -- If this channel is unknown, register it first.- mChan <- preuse (csChannel(cId))- when (isNothing mChan) $- handleNewChannel False cwd+ -- If this is a group channel that the user has chosen to hide, ignore+ -- the refresh request.+ isHidden <- channelHiddenPreference cId+ case isHidden of+ True -> return ()+ False -> do+ -- If this channel is unknown, register it first.+ mChan <- preuse (csChannel(cId))+ when (isNothing mChan) $+ handleNewChannel False cwd - updateChannelInfo cId 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+ -- 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@@ -94,6 +202,76 @@ cwd <- mmGetChannel session myTeamId cId return $ refreshChannel refreshMessages cwd +createGroupChannel :: T.Text -> MH ()+createGroupChannel usernameList = do+ users <- use csUsers+ myTeamId <- use (csMyTeam.teamIdL)+ me <- use csMe++ let usernames = T.words usernameList+ findUserIds [] = return []+ findUserIds (n:ns) = do+ case findUserByName users n of+ Nothing -> do+ postErrorMessage $ "No such user: " <> n+ return []+ Just (uId, _) -> (uId:) <$> findUserIds ns++ results <- findUserIds usernames++ -- If we found all of the users mentioned, then create the group+ -- channel.+ when (length results == length usernames) $ do+ session <- use (csResources.crSession)+ doAsyncWith Preempt $ do+ chan <- mmCreateGroupChannel session results+ let pref = showGroupChannelPref (channelId chan) (me^.userIdL)+ -- It's possible that the channel already existed, in which+ -- case we want to request a preference change to show it.+ mmSetPreferences session (me^.userIdL) $ Seq.fromList [pref]+ cwd <- mmGetChannel session myTeamId (channelId chan)+ return $ do+ applyPreferenceChange pref+ handleNewChannel True cwd++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++applyPreferenceChange :: Preference -> MH ()+applyPreferenceChange pref+ | Just f <- preferenceToFlaggedPost pref =+ updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)+ | Just g <- preferenceToGroupChannelPreference pref = do+ -- First, go update the preferences with this change.+ updatePreference pref++ let cId = groupChannelId g+ mChan <- preuse $ csChannel cId++ case (mChan, groupChannelShow g) of+ (Just _, False) ->+ -- If it has been set to hidden and we are showing it,+ -- remove it from the state.+ removeChannelFromState cId+ (Nothing, True) ->+ -- If it has been set to showing and we are not showing+ -- it, ask for a load/refresh.+ refreshChannelById True 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)+ -- | Refresh information about all channels and users. This is usually -- triggered when a reconnect event for the WebSocket to the server -- occurs.@@ -107,21 +285,52 @@ 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+ when (not $ userDeleted 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+ lock <- use (csResources.crUserStatusLock)+ doAsyncWith Preempt $ updateUserStatuses lock session --- | Update the indicted Channel entry with the new data retrieved--- from the Mattermost server.+-- | Update the indicted Channel entry with the new data retrieved from+-- the Mattermost server. Also update the channel name if it changed. updateChannelInfo :: ChannelId -> ChannelWithData -> MH ()-updateChannelInfo cid cwd =+updateChannelInfo cid cwd@(ChannelWithData new _) = do+ mOldChannel <- preuse $ csChannel(cid)+ case mOldChannel of+ Nothing -> return ()+ Just old ->+ let oldName = old^.ccInfo.cdName+ newName = preferredChannelName new+ in if oldName == newName+ then return ()+ else do+ removeChannelName oldName+ addChannelName (channelType new) cid newName+ csChannel(cid).ccInfo %= channelInfoFromChannelWithData cwd +addChannelName :: Type -> ChannelId -> T.Text -> MH ()+addChannelName chType cid name = do+ csNames.cnToChanId.at(name) .= Just cid++ -- For direct channels the username is already in the user list so+ -- do nothing+ existingNames <- use $ csNames.cnChans+ when (chType /= Direct && (not $ name `elem` existingNames)) $+ csNames.cnChans %= (sort . (name:))++removeChannelName :: T.Text -> MH ()+removeChannelName name = do+ -- Flush cnToChanId+ csNames.cnToChanId.at name .= Nothing+ -- Flush cnChans+ csNames.cnChans %= filter (/= name)+ -- | If this channel has content, fetch any new content that has -- arrived after the existing content. updateMessages :: ChannelId -> MH ()@@ -292,10 +501,9 @@ deleteCurrentChannel :: MH () deleteCurrentChannel = do- leaveCurrentChannel csMode .= Main cId <- use csCurrentChannelId- doAsyncChannelMM Normal cId mmDeleteChannel endAsyncNOP+ leaveChannelIfPossible cId True isCurrentChannel :: ChatState -> ChannelId -> Bool isCurrentChannel st cId = st^.csCurrentChannelId == cId@@ -451,6 +659,35 @@ handleNewChannel False cwd asyncFetchScrollback Normal cId) +addUserToCurrentChannel :: T.Text -> MH ()+addUserToCurrentChannel uname = do+ -- First: is this a valid username?+ usrs <- use csUsers+ case findUserByName usrs uname of+ Just (uid, _) -> do+ cId <- use csCurrentChannelId+ session <- use (csResources.crSession)+ myTeamId <- use (csMyTeam.teamIdL)+ doAsyncWith Normal $ do+ tryMM (void $ mmChannelAddUser session myTeamId cId uid)+ (const $ return (return ()))+ _ -> do+ postErrorMessage ("No such user: " <> uname)++removeUserFromCurrentChannel :: T.Text -> MH ()+removeUserFromCurrentChannel uname = do+ -- First: is this a valid username?+ usrs <- use csUsers+ case findUserByName usrs uname of+ Just (uid, _) -> do+ cId <- use csCurrentChannelId+ session <- use (csResources.crSession)+ doAsyncWith Normal $ do+ tryMM (void $ mmChannelRemoveUser session cId uid)+ (const $ return (return ()))+ _ -> do+ postErrorMessage ("No such user: " <> uname)+ startLeaveCurrentChannel :: MH () startLeaveCurrentChannel = do cInfo <- use (csCurrentChannel.ccInfo)@@ -459,14 +696,65 @@ False -> postErrorMessage "The /leave command cannot be used with this channel." leaveCurrentChannel :: MH ()-leaveCurrentChannel = do- cId <- use csCurrentChannelId- withChannel cId $ \chan ->- when (canLeaveChannel (chan^.ccInfo)) $- doAsyncChannelMM Preempt cId- mmLeaveChannel- (\c () -> removeChannelFromState c)+leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel +leaveChannelIfPossible :: ChannelId -> Bool -> MH ()+leaveChannelIfPossible cId delete = do+ st <- use id+ me <- use csMe+ let isMe u = u^.userIdL == me^.userIdL++ case st ^? csChannel(cId).ccInfo of+ Nothing -> return ()+ Just cInfo -> case canLeaveChannel cInfo of+ False -> return ()+ True ->+ -- The server will reject an attempt to leave a private+ -- channel if we're the only member.+ doAsyncChannelMM Preempt cId+ fetchChannelMembers+ (\_ members -> do+ -- If the channel is private:+ -- * leave it if we aren't the last member.+ -- * delete it if we are.+ --+ -- Otherwise:+ -- * leave (or delete) the channel as specified+ -- by the delete argument.+ let func = case cInfo^.cdType of+ Private -> case all isMe members of+ True -> mmDeleteChannel+ False -> mmLeaveChannel+ Group ->+ \s _ _ ->+ mmSetPreferences s (me^.userIdL) $+ Seq.fromList [hideGroupChannelPref cId $ me^.userIdL]+ _ -> if delete+ then mmDeleteChannel+ else mmLeaveChannel++ doAsyncChannelMM Preempt cId func endAsyncNOP+ )++hideGroupChannelPref :: ChannelId -> UserId -> Preference+hideGroupChannelPref cId uId =+ Preference { preferenceCategory = PreferenceCategoryGroupChannelShow+ , preferenceValue = PreferenceValue "false"+ , preferenceName = PreferenceName $ idString cId+ , preferenceUserId = uId+ }++showGroupChannelPref :: ChannelId -> UserId -> Preference+showGroupChannelPref cId uId =+ Preference { preferenceCategory = PreferenceCategoryGroupChannelShow+ , preferenceValue = PreferenceValue "true"+ , preferenceName = PreferenceName $ idString cId+ , preferenceUserId = uId+ }++leaveChannel :: ChannelId -> MH ()+leaveChannel cId = leaveChannelIfPossible cId False+ removeChannelFromState :: ChannelId -> MH () removeChannelFromState cId = do withChannel cId $ \ chan -> do@@ -481,10 +769,8 @@ csEditState.cedLastChannelInput .at cId .= Nothing -- Update input history csEditState.cedInputHistory %= removeChannelHistory cId- -- Flush cnToChanId- csNames.cnToChanId .at cName .= Nothing- -- Flush cnChans- csNames.cnChans %= filter (/= cName)+ -- Remove channel name mappings+ removeChannelName cName -- Update msgMap csChannels %= filteredChannels ((/=) cId . fst) -- Remove from focus zipper@@ -494,18 +780,22 @@ fetchCurrentChannelMembers = do cId <- use csCurrentChannelId doAsyncChannelMM Preempt cId- (\s t c -> mmGetChannelMembers s t c 0 10000)- (\_ chanUserMap -> do+ fetchChannelMembers+ (\_ chanUsers -> do -- Construct a message listing them all and post it to the -- channel: let msgStr = "Channel members (" <> (T.pack $ show $ length chanUsers) <> "):\n" <> T.intercalate ", " usernames- userDeleted u = userDeleteAt u > userCreateAt u- chanUsers = filter (not . userDeleted) $ snd <$> HM.toList chanUserMap- usernames = sort $ userUsername <$> (F.toList chanUsers)+ usernames = sort $ userUsername <$> filteredUsers+ filteredUsers = filter (not . userDeleted) chanUsers postInfoMessage msgStr) +fetchChannelMembers :: Session -> TeamId -> ChannelId -> IO [User]+fetchChannelMembers s t c = do+ chanUserMap <- mmGetChannelMembers s t c 0 10000+ return $ snd <$> HM.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.@@ -514,7 +804,12 @@ chan <- use (csChannels.to (findChannelById cId)) -- Update new channel's viewed time, creating the channel if needed case chan of- Nothing -> handleChannelInvite cId+ Nothing ->+ -- It's possible for us to get spurious WMChannelViewed events+ -- from the server, e.g. for channels that have been deleted.+ -- So here we ignore the request since it's hard to detect it+ -- before this point.+ return () Just _ -> -- The server has been sent a viewed POST update, but there is -- no local information on what timestamp the server actually@@ -545,7 +840,7 @@ -- Update the old channel's previous viewed time (allows tracking of new messages) case prevId of Nothing -> return ()- Just p -> csChannels %= (channelByIdL p %~ clearNewMessageIndicator)+ Just p -> csChannels %= (channelByIdL p %~ (clearNewMessageIndicator . clearEditedThreshold)) updateViewed :: MH () updateViewed = do@@ -678,16 +973,17 @@ listThemes :: MH () listThemes = do- let mkThemeList _ = T.intercalate "\n\n" $- "Available built-in themes:" :- ((" " <>) <$> fst <$> themes)- postInfoMessage (mkThemeList themes)+ let themeList = T.intercalate "\n\n" $+ "Available built-in themes:" :+ ((" " <>) <$> internalThemeName <$> internalThemes)+ postInfoMessage themeList setTheme :: T.Text -> MH () setTheme name =- case lookup name themes of+ case lookupTheme name of Nothing -> listThemes- Just t -> csResources.crTheme .= t+ Just it -> csResources.crTheme .=+ (themeToAttrMap $ internalTheme it) channelPageUp :: MH () channelPageUp = do@@ -739,7 +1035,7 @@ addObtainedMessages _cId posts = postProcessMessageAdd =<< foldl mappend mempty <$>- mapM addMessageToState+ mapM (addMessageToState . OldPost) [ (posts^.postsPostsL) HM.! p | p <- F.toList (posts^.postsOrderL) ]@@ -837,89 +1133,98 @@ -- ^ 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+ -- Only add the channel to the state if it isn't already known.+ mChan <- preuse (csChannel(getId nc))+ case mChan of+ Just _ -> return ()+ Nothing -> do+ -- Create a new ClientChannel structure+ let cChannel = makeClientChannel nc &+ ccInfo %~ channelInfoFromChannelWithData (ChannelWithData nc cData) - -- 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+ st <- use id - -- 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+ -- 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 - case mName of- Nothing -> return ()- Just name -> do- csNames.cnToChanId.at(name) .= Just (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 - -- For direct channels the username is already in the user- -- list so do nothing- when (chType /= Direct) $- csNames.cnChans %= (sort . (name:))+ case mName of+ Nothing -> return ()+ Just name -> do+ addChannelName chType (getId nc) name - csChannels %= addChannel (getId nc) cChannel+ 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+ -- 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)+ -- 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+ myId <- use (csMe.userIdL) let isEditedMessage m = m^.mPostId == Just (new^.postIdL) msg = clientPostToMessage st (toClientPost new (new^.postParentIdL)) chan = csChannel (new^.postChannelIdL) chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg++ when (postUserId new /= Just myId) $+ chan %= adjustEditedThreshold new+ chan %= adjustUpdated new csPostMap.ix(postId new) .= msg asyncFetchReactionsForPost (postChannelId new) new@@ -978,24 +1283,57 @@ postOp NotifyUser = maybeRingBell postOp NotifyUserAndServer = updateViewed >> maybeRingBell +-- | When we add posts to the application state, we either get them+-- from the server during scrollback fetches (here called 'OldPost') or+-- we get them from websocket events when they are posted in real time+-- (here called 'RecentPost').+data PostToAdd =+ OldPost Post+ -- ^ A post from the server's history+ | RecentPost Post Bool+ -- ^ A message posted to the channel since the user connected, along+ -- with a flag indicating whether the post triggered any of the+ -- user's mentions. We need an extra flag because the server+ -- determines whether the post has any mentions, and that data is+ -- only available in websocket events (and then provided to this+ -- constructor).+ -- | Adds a possibly new message to the associated channel contents. -- Returns True if this is something that should potentially notify -- the user of a change to the channel (i.e., not a message we -- posted).-addMessageToState :: Post -> MH PostProcessMessageAdd-addMessageToState new = do+addMessageToState :: PostToAdd -> MH PostProcessMessageAdd+addMessageToState newPostData = do+ let (new, wasMentioned) = case newPostData of+ -- A post from scrollback history has no mention data, and+ -- that's okay: we only need to track mentions to tell the user+ -- that recent posts contained mentions.+ OldPost p -> (p, False)+ RecentPost p m -> (p, m)+ st <- use id case st ^? csChannel(postChannelId new) of Nothing -> do- -- When we join channels, sometimes we get the "user has- -- been added to channel" message here BEFORE we get the- -- websocket event that says we got added to a channel. This- -- means the message arriving here in addMessage can't be- -- added yet because we haven't fetched the channel metadata- -- in the websocket handler. So to be safe we just drop the- -- message here, but this is the only case of messages that we- -- /expect/ to drop for this reason. Hence the check for the- -- msgMap channel ID key presence above.+ session <- use (csResources.crSession)+ myTeamId <- use (csMyTeam.teamIdL)+ doAsyncWith Preempt $ do+ cwd@(ChannelWithData nc _) <- mmGetChannel session myTeamId (postChannelId new)++ let chType = nc^.channelTypeL+ pref = showGroupChannelPref (postChannelId new) (st^.csMe.userIdL)++ return $ do+ -- If the incoming message is for a group channel we+ -- don't know about, that's because it was previously+ -- hidden by the user. We need to show it, and to do+ -- that we need to update the server-side preference.+ -- (That, in turn, triggers a channel refresh.)+ if chType == Group+ then applyPreferenceChange pref+ else refreshChannel True cwd++ addMessageToState newPostData >>= postProcessMessageAdd+ return NoAction Just _ -> do let cp = toClientPost new (new^.postParentIdL)@@ -1015,7 +1353,10 @@ (adjustUpdated new) . (\c -> if currCId == cId then c- else updateNewMessageIndicator new c)+ else updateNewMessageIndicator new c) .+ (\c -> if wasMentioned+ then c & ccInfo.cdMentionCount %~ succ+ else c) ) asyncFetchReactionsForPost cId new asyncFetchAttachments new@@ -1048,15 +1389,19 @@ doAddMessage postedChanMessage =- withChannelOrDefault (postChannelId new) NoAction $ \_ -> do+ withChannelOrDefault (postChannelId new) NoAction $ \chan -> do currCId <- use csCurrentChannelId - let curChannelAction = if postChannelId new == currCId+ let notifyPref = notifyPreference (st^.csMe) chan+ curChannelAction = if postChannelId new == currCId then UpdateServerViewed else NoAction originUserAction = if fromMe then NoAction- else NotifyUser+ else if notifyPref == NotifyOptionAll ||+ (notifyPref == NotifyOptionMention && wasMentioned)+ then NotifyUser+ else NoAction return $ curChannelAction <> originUserAction -- If this message was written by a user we don't know about,@@ -1076,6 +1421,11 @@ cc <- st^?csChannel(cId) return $ cc^.ccInfo.cdNewMessageIndicator +getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe UTCTime+getEditedMessageCutoff cId st = do+ cc <- st^?csChannel(cId)+ cc^.ccInfo.cdEditedMessageThreshold+ fetchCurrentScrollback :: MH () fetchCurrentScrollback = do cId <- use csCurrentChannelId@@ -1164,23 +1514,80 @@ beginChannelSelect :: MH () beginChannelSelect = do- csMode .= ChannelSelect- csChannelSelectString .= ""- csChannelSelectChannelMatches .= mempty- csChannelSelectUserMatches .= mempty+ csMode .= ChannelSelect+ csChannelSelectState .= emptyChannelSelectState +-- Select the next match in channel selection mode.+channelSelectNext :: MH ()+channelSelectNext = updateSelectedMatch succ++-- Select the previous match in channel selection mode.+channelSelectPrevious :: MH ()+channelSelectPrevious = updateSelectedMatch pred++-- Update the channel selection mode match cursor. The argument function+-- determines how the new cursor position is computed from the old+-- one. The new cursor position is automatically wrapped around to the+-- beginning or end of the channel selection match list, so cursor+-- transformations do not have to do index validation. If the current+-- match (e.g. the sentinel "") is not found in the match list, this+-- sets the cursor position to the first match, if any.+updateSelectedMatch :: (Int -> Int) -> MH ()+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+ ]+ ]+ in case findIndex (== oldMatch) allMatches of+ Nothing -> if null allMatches+ then ""+ else allMatches !! 0+ Just i ->+ let newIndex = if tmpIndex < 0+ then length allMatches - 1+ else if tmpIndex >= length allMatches+ then 0+ else tmpIndex+ tmpIndex = nextIndex i+ in allMatches !! newIndex+ updateChannelSelectMatches :: MH () updateChannelSelectMatches = do -- Given the current channel select string, find all the channel and -- user matches and then update the match lists.- chanNameMatches <- use (csChannelSelectString.to channelNameMatch)+ chanNameMatches <- use (csChannelSelectState.channelSelectInput.to channelNameMatch) chanNames <- use (csNames.cnChans)- userNames <- use (to userList)+ uList <- use (to sortedUserList) let chanMatches = catMaybes (fmap chanNameMatches chanNames)- let userMatches = catMaybes (fmap chanNameMatches (fmap _uiName userNames))- let mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms]- csChannelSelectChannelMatches .= mkMap chanMatches- csChannelSelectUserMatches .= mkMap userMatches+ usernameMatches = catMaybes (fmap chanNameMatches (fmap _uiName uList))+ mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms]+ csChannelSelectState.channelMatches .= mkMap chanMatches+ csChannelSelectState.userMatches .= mkMap usernameMatches+ csChannelSelectState.selectedMatch %= \oldMatch ->+ -- If the previously selected match is still a possible match,+ -- leave it selected. Otherwise revert to the first available+ -- match.+ let newMatch = if oldMatch `elem` allMatches+ then oldMatch+ else firstAvailableMatch+ unames = channelNameFromMatch <$> usernameMatches+ allMatches = concat [ channelNameFromMatch <$> chanMatches+ , [ u^.uiName | u <- uList+ , u^.uiName `elem` unames+ ]+ ]+ firstAvailableMatch = if null allMatches+ then ""+ else head allMatches+ in newMatch channelNameMatch :: T.Text -> T.Text -> Maybe ChannelSelectMatch channelNameMatch patStr chanName =@@ -1294,49 +1701,90 @@ openURL :: LinkChoice -> MH Bool openURL link = do- cmd <- use (csResources.crConfiguration.to configURLOpenCommand)- case cmd of+ cfg <- use (csResources.crConfiguration)+ case configURLOpenCommand cfg of Nothing -> return False- Just urlOpenCommand ->+ Just urlOpenCommand -> do -- Is the URL referring to an attachment?- case link^.linkFileId of- Nothing -> do- openLink urlOpenCommand link- return True+ let act = case link^.linkFileId of+ Nothing -> prepareLink link+ Just fId -> prepareAttachment fId - Just fId -> do- openAttachment urlOpenCommand fId- return True+ -- Is the URL-opening command interactive? If so, pause+ -- Matterhorn and run the opener interactively. Otherwise+ -- run the opener asynchronously and continue running+ -- Matterhorn interactively.+ case configURLOpenCommandInteractive cfg of+ False -> do+ st <- use id+ outputChan <- use (csResources.crSubprocessLog)+ doAsyncWith Preempt $ do+ args <- act st+ runLoggedCommand False outputChan (T.unpack urlOpenCommand)+ args Nothing Nothing+ return $ return ()+ True -> do+ -- If there isn't a new message cutoff showing in+ -- the current channel, set one. This way, while the+ -- user is gone using their interactive URL opener,+ -- when they return, any messages that arrive in the+ -- current channel will be displayed as new.+ curChan <- use csCurrentChannel+ let msgs = curChan^.ccContents.cdMessages+ case findLatestUserMessage isEditable msgs of+ Nothing -> return ()+ Just m ->+ case m^.mOriginalPost of+ Nothing -> return ()+ Just p ->+ case curChan^.ccInfo.cdNewMessageIndicator of+ Hide ->+ csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))+ _ -> return () -openLink :: T.Text -> LinkChoice -> MH ()-openLink urlOpenCommand link = do- -- The link is a web link, not an attachment- outputChan <- use (csResources.crSubprocessLog)- doAsyncWith Preempt $ do- void $ runLoggedCommand False outputChan (T.unpack urlOpenCommand)- [T.unpack $ link^.linkURL] Nothing- return $ return ()+ mhSuspendAndResume $ \st -> do+ args <- act st+ void $ runInteractiveCommand (T.unpack urlOpenCommand) args+ return $ st & csMode .~ Main -openAttachment :: T.Text -> FileId -> MH ()-openAttachment urlOpenCommand fId = do+ return True++prepareLink :: LinkChoice -> ChatState -> IO [String]+prepareLink link _ = return [T.unpack $ link^.linkURL]++prepareAttachment :: FileId -> ChatState -> IO [String]+prepareAttachment fId st = do -- The link is for an attachment, so fetch it and then -- open the local copy.- sess <- use (csResources.crSession)- outputChan <- use (csResources.crSubprocessLog)- doAsyncWith Preempt $ do- info <- mmGetFileInfo sess fId- contents <- mmGetFile sess fId- cacheDir <- getUserCacheDir xdgName+ let sess = st^.csResources.crSession - let dir = cacheDir </> "files" </> T.unpack (idString fId)- fname = dir </> T.unpack (fileInfoName info)+ info <- mmGetFileInfo sess fId+ contents <- mmGetFile sess fId+ cacheDir <- getUserCacheDir xdgName - createDirectoryIfMissing True dir- BS.writeFile fname contents- void $ runLoggedCommand False outputChan (T.unpack urlOpenCommand) [fname] Nothing- return $ return ()+ let dir = cacheDir </> "files" </> T.unpack (idString fId)+ fname = dir </> T.unpack (fileInfoName info) + createDirectoryIfMissing True dir+ BS.writeFile fname contents+ return [fname]++runInteractiveCommand :: String+ -> [String]+ -> IO (Either String ExitCode)+runInteractiveCommand cmd args = do+ let opener = (proc cmd args) { std_in = Inherit+ , std_out = Inherit+ , std_err = Inherit+ }+ result <- try $ createProcess opener+ case result of+ Left (e::SomeException) -> return $ Left $ show e+ Right (_, _, _, ph) -> do+ ec <- waitForProcess ph+ return $ Right ec+ runLoggedCommand :: Bool -- ^ Whether stdout output is expected for this program -> STM.TChan ProgramOutput@@ -1347,8 +1795,10 @@ -- ^ Arguments -> Maybe String -- ^ The stdin to send, if any- -> IO ProgramOutput-runLoggedCommand stdoutOkay outputChan cmd args mInput = do+ -> Maybe (MVar ProgramOutput)+ -- ^ Where to put the program output when it is ready+ -> IO ()+runLoggedCommand stdoutOkay outputChan cmd args mInput mOutputVar = void $ forkIO $ do let stdIn = maybe NoStream (const CreatePipe) mInput opener = (proc cmd args) { std_in = stdIn , std_out = CreatePipe@@ -1359,7 +1809,7 @@ Left (e::SomeException) -> do let po = ProgramOutput cmd args "" stdoutOkay (show e) (ExitFailure 1) STM.atomically $ STM.writeTChan outputChan po- return po+ maybe (return ()) (flip putMVar po) mOutputVar Right (stdinResult, Just outh, Just errh, ph) -> do case stdinResult of Just inh -> do@@ -1373,7 +1823,7 @@ errResult <- hGetContents errh let po = ProgramOutput cmd args outResult stdoutOkay errResult ec STM.atomically $ STM.writeTChan outputChan po- return po+ maybe (return ()) (flip putMVar po) mOutputVar Right _ -> error $ "BUG: createProcess returned unexpected result, report this at " <> "https://github.com/matterhorn-chat/matterhorn"
src/State/Editing.hs view
@@ -9,7 +9,6 @@ import Brick.Widgets.Edit (applyEdit) import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Arrow-import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS import Data.Monoid ((<>))@@ -27,12 +26,8 @@ import qualified System.Process as Sys import Text.Aspell (AspellResponse(..), mistakeWord, askAspell) -import Network.Mattermost-import Network.Mattermost.Lenses- import Config import Types-import Types.Users import State.Common @@ -79,21 +74,6 @@ toggleMessagePreview :: MH () toggleMessagePreview = csShowMessagePreview %= not -addUserToCurrentChannel :: T.Text -> MH ()-addUserToCurrentChannel uname = do- -- First: is this a valid username?- usrs <- use csUsers- case findUserByName usrs uname of- Just (uid, _) -> do- cId <- use csCurrentChannelId- session <- use (csResources.crSession)- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Normal $ do- tryMM (void $ mmChannelAddUser session myTeamId cId uid)- (const $ return (return ()))- _ -> do- postErrorMessage ("No such user: " <> uname)- handlePaste :: BS.ByteString -> MH () handlePaste bytes = do let pasteStr = T.pack (UTF8.toString bytes)@@ -113,6 +93,18 @@ [ KB "Transpose the final two characters" (EvKey (KChar 't') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.transposeChars+ , KB "Go to the start of the current line"+ (EvKey (KChar 'a') [MCtrl]) $ do+ csEditState.cedEditor %= applyEdit Z.gotoBOL+ , KB "Go to the end of the current line"+ (EvKey (KChar 'e') [MCtrl]) $ do+ csEditState.cedEditor %= applyEdit Z.gotoEOL+ , KB "Delete the character at the cursor"+ (EvKey (KChar 'd') [MCtrl]) $ do+ csEditState.cedEditor %= applyEdit Z.deleteChar+ , KB "Delete from the cursor to the start of the current line"+ (EvKey (KChar 'u') [MCtrl]) $ do+ csEditState.cedEditor %= applyEdit Z.killToBOL , KB "Move one character to the right" (EvKey (KChar 'f') [MCtrl]) $ do csEditState.cedEditor %= applyEdit Z.moveRight
src/State/PostListOverlay.hs view
@@ -1,5 +1,6 @@ module State.PostListOverlay where +import Data.Text (Text) import Lens.Micro.Platform import Network.Mattermost import Network.Mattermost.Lenses@@ -35,6 +36,19 @@ return $ do messages <- messagesFromPosts posts enterPostListMode PostListFlagged messages++-- | Create a PostListOverlay with post search result messages from the+-- server.+enterSearchResultPostListMode :: Text -> MH ()+enterSearchResultPostListMode terms = do+ session <- use (csResources.crSession)+ tId <- teamId <$> use csMyTeam+ enterPostListMode (PostListSearch terms True) noMessages+ doAsyncWith Preempt $ do+ posts <- mmSearchPosts session tId terms False+ return $ do+ messages <- messagesFromPosts posts+ enterPostListMode (PostListSearch terms False) messages -- | Move the selection up in the PostListOverlay, which corresponds -- to finding a chronologically /newer/ message.
src/State/Setup.hs view
@@ -1,22 +1,28 @@ {-# LANGUAGE TypeFamilies #-}--module State.Setup where+module State.Setup+ ( setupState+ )+where import Prelude () import Prelude.Compat import Brick.BChan+import Brick.Themes (themeToAttrMap, loadCustomizations) import qualified Control.Concurrent.STM as STM-import Control.Concurrent.MVar (newEmptyMVar)+import Control.Concurrent.MVar (newEmptyMVar, putMVar) import Control.Exception (catch) import Control.Monad (forM, when)+import Data.Monoid ((<>)) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM-import Data.Maybe (listToMaybe, fromJust)+import Data.Maybe (listToMaybe, fromMaybe, fromJust, isNothing) import qualified Data.Sequence as Seq+import qualified Data.Text as T import Data.Time.LocalTime (getCurrentTimeZone) import Lens.Micro.Platform import System.Exit (exitFailure)+import System.FilePath ((</>), isRelative, dropFileName) import System.IO (Handle) import Network.Mattermost@@ -112,22 +118,48 @@ Just t -> return t quitCondition <- newEmptyMVar++ userStatusLock <- newEmptyMVar+ putMVar userStatusLock ()+ slc <- STM.atomically STM.newTChan + prefs <- mmGetMyPreferences session+ let themeName = case configTheme config of- Nothing -> defaultThemeName- Just t -> t- theme = case lookup themeName themes of- Nothing -> fromJust $ lookup defaultThemeName themes+ Nothing -> internalThemeName defaultTheme Just t -> t- cr = ChatResources session cd requestChan eventChan- slc theme quitCondition config mempty+ baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName)++ -- Did the configuration specify a theme customization file? If so,+ -- load it and customize the theme.+ custTheme <- case configThemeCustomizationFile config of+ Nothing -> return baseTheme+ Just path ->+ -- If we have no configuration path (i.e. we used the default+ -- config) then ignore theme customization.+ let pathStr = T.unpack path+ in if isRelative pathStr && isNothing (configAbsPath config)+ then return baseTheme+ else do+ let absPath = if isRelative pathStr+ then (dropFileName $ fromJust $ configAbsPath config) </> pathStr+ else pathStr+ result <- loadCustomizations absPath baseTheme+ case result of+ Left e -> do+ putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e+ exitFailure+ Right t -> return t++ let cr = ChatResources session cd requestChan eventChan+ slc (themeToAttrMap custTheme) quitCondition+ userStatusLock config mempty prefs+ initializeState cr myTeam myUser initializeState :: ChatResources -> Team -> User -> IO ChatState initializeState cr myTeam myUser = do- prefs <- mmGetMyPreferences (cr^.crSession)- let session = cr^.crSession requestChan = cr^.crRequestQueue myTeamId = getId myTeam@@ -156,7 +188,7 @@ -- Start background worker threads: -- * User status refresher- startUserRefreshThread session requestChan+ startUserRefreshThread (cr^.crUserStatusLock) session requestChan -- * Timezone change monitor startTimezoneMonitorThread tz requestChan -- * Subprocess logger@@ -172,5 +204,5 @@ & csChannels %~ flip (foldr (uncurry addChannel)) msgs & csNames .~ chanNames - loadFlaggedMessages prefs st+ loadFlaggedMessages (cr^.crPreferences) st return st
src/State/Setup/Threads.hs view
@@ -4,6 +4,7 @@ , startSubprocessLoggerThread , startTimezoneMonitorThread , maybeStartSpellChecker+ , startAsyncWorkerThread ) where @@ -11,11 +12,12 @@ import Prelude.Compat import Brick.BChan-import Control.Concurrent (threadDelay, forkIO)+import Control.Concurrent (threadDelay, forkIO, MVar, putMVar, tryTakeMVar) import qualified Control.Concurrent.STM as STM import Control.Concurrent.STM.Delay-import Control.Exception (SomeException, try)+import Control.Exception (SomeException, try, finally) import Control.Monad (forever, when, void)+import Data.List (isInfixOf) import qualified Data.Text as T import Data.Maybe (catMaybes) import Data.Monoid ((<>))@@ -34,22 +36,27 @@ import Types import Types.Users -updateUserStatuses :: Session -> IO (MH ())-updateUserStatuses session = do- statusMap <- mmGetStatuses session- return $ do- let setStatus u = u & uiStatus .~ (newsts u)- newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline- csUsers . mapped %= setStatus+updateUserStatuses :: MVar () -> Session -> IO (MH ())+updateUserStatuses lock session = do+ lockResult <- tryTakeMVar lock -startUserRefreshThread :: Session -> RequestChan -> IO ()-startUserRefreshThread session requestChan = void $ forkIO $ forever refresh+ case lockResult of+ Nothing -> return $ return ()+ Just () -> do+ statusMap <- mmGetStatuses session `finally` putMVar lock ()+ return $ do+ let setStatus u = u & uiStatus .~ (newsts u)+ newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline+ csUsers . mapped %= setStatus++startUserRefreshThread :: MVar () -> Session -> RequestChan -> IO ()+startUserRefreshThread lock session requestChan = void $ forkIO $ forever refresh where seconds = (* (1000 * 1000)) userRefreshInterval = 30 refresh = do STM.atomically $ STM.writeTChan requestChan $ do- rs <- try $ updateUserStatuses session+ rs <- try $ updateUserStatuses lock session case rs of Left (_ :: SomeException) -> return (return ()) Right upd -> return upd@@ -203,3 +210,49 @@ STM.writeTChan delayWorkerChan newDel return delayWakeupChan++-------------------------------------------------------------------+-- Async worker thread++startAsyncWorkerThread :: Config -> STM.TChan (IO (MH ())) -> BChan MHEvent -> IO ()+startAsyncWorkerThread c r e = void $ forkIO $ asyncWorker c r e++asyncWorker :: Config -> STM.TChan (IO (MH ())) -> BChan MHEvent -> IO ()+asyncWorker c r e = forever $ doAsyncWork c r e++doAsyncWork :: Config -> STM.TChan (IO (MH ())) -> BChan MHEvent -> IO ()+doAsyncWork config requestChan eventChan = do+ startWork <- case configShowBackground config of+ Disabled -> return $ return ()+ Active -> do chk <- STM.atomically $ STM.tryPeekTChan requestChan+ case chk of+ Nothing -> do writeBChan eventChan BGIdle+ return $ writeBChan eventChan $ BGBusy Nothing+ _ -> return $ return ()+ ActiveCount -> do+ chk <- STM.atomically $ do+ chanCopy <- STM.cloneTChan requestChan+ let cntMsgs = do m <- STM.tryReadTChan chanCopy+ case m of+ Nothing -> return 0+ Just _ -> (1 +) <$> cntMsgs+ cntMsgs+ case chk of+ 0 -> do writeBChan eventChan BGIdle+ return (writeBChan eventChan $ BGBusy (Just 1))+ _ -> do writeBChan eventChan $ BGBusy (Just chk)+ return $ return ()++ req <- STM.atomically $ STM.readTChan requestChan+ startWork+ res <- try req+ case res of+ Left e -> when (not $ shouldIgnore e) $+ writeBChan eventChan (AsyncErrEvent e)+ Right upd -> writeBChan eventChan (RespEvent upd)++-- Filter for exceptions that we don't want to report to the user,+-- probably because they are not actionable and/or contain no useful+-- information.+shouldIgnore :: SomeException -> Bool+shouldIgnore e = "resource vanished" `isInfixOf` show e
src/Themes.hs view
@@ -1,8 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} module Themes- ( defaultThemeName- , themes+ ( InternalTheme(..)++ , defaultTheme+ , internalThemes , attrNameForTokenType+ , lookupTheme+ , themeDocs -- * Attribute names , timeAttr@@ -38,6 +42,8 @@ , messageSelectAttr , messageSelectStatusAttr , misspellingAttr+ , editedMarkingAttr+ , editedRecentlyMarkingAttr -- * Username formatting , colorUsername@@ -46,20 +52,22 @@ import Prelude () import Prelude.Compat+import Data.List (find) +import qualified Data.Map as M import Data.Hashable (hash)+import Data.Maybe (isNothing) import Data.Monoid ((<>)) import Graphics.Vty import Brick+import Brick.Themes import Brick.Widgets.List import qualified Data.Text as T import qualified Skylighting as Sky+import Skylighting (TokenType(..)) import Types (userSigil) -defaultThemeName :: T.Text-defaultThemeName = darkColorThemeName- helpAttr :: AttrName helpAttr = "help" @@ -67,20 +75,26 @@ helpEmphAttr = "helpEmphasis" recentMarkerAttr :: AttrName-recentMarkerAttr = "recentMarker"+recentMarkerAttr = "recentChannelMarker" replyParentAttr :: AttrName-replyParentAttr = "replyParent"+replyParentAttr = "replyParentPreview" loadMoreAttr :: AttrName loadMoreAttr = "loadMoreMessages" urlListSelectedAttr :: AttrName-urlListSelectedAttr = "urlListSelectedAttr"+urlListSelectedAttr = "urlListCursor" messageSelectAttr :: AttrName-messageSelectAttr = "messageSelectAttr"+messageSelectAttr = "messageSelectCursor" +editedMarkingAttr :: AttrName+editedMarkingAttr = "editedMarking"++editedRecentlyMarkingAttr :: AttrName+editedRecentlyMarkingAttr = "editedRecentlyMarking"+ dialogAttr :: AttrName dialogAttr = "dialog" @@ -94,16 +108,10 @@ channelSelectPromptAttr = "channelSelectPrompt" completionAlternativeListAttr :: AttrName-completionAlternativeListAttr = "completionAlternativeList"+completionAlternativeListAttr = "tabCompletionAlternative" completionAlternativeCurrentAttr :: AttrName-completionAlternativeCurrentAttr = "completionAlternativeCurrent"--darkColorThemeName :: T.Text-darkColorThemeName = "builtin:dark"--lightColorThemeName :: T.Text-lightColorThemeName = "builtin:light"+completionAlternativeCurrentAttr = "tabCompletionCursor" timeAttr :: AttrName timeAttr = "time"@@ -112,19 +120,19 @@ channelHeaderAttr = "channelHeader" channelListHeaderAttr :: AttrName-channelListHeaderAttr = "channelListHeader"+channelListHeaderAttr = "channelListSectionHeader" currentChannelNameAttr :: AttrName currentChannelNameAttr = "currentChannelName" channelNameAttr :: AttrName-channelNameAttr = "channelNameAttr"+channelNameAttr = "channelName" unreadChannelAttr :: AttrName unreadChannelAttr = "unreadChannel" mentionsChannelAttr :: AttrName-mentionsChannelAttr = "mentionsChannel"+mentionsChannelAttr = "channelWithMentions" dateTransitionAttr :: AttrName dateTransitionAttr = "dateTransition"@@ -136,7 +144,7 @@ urlAttr = "url" codeAttr :: AttrName-codeAttr = "code"+codeAttr = "codeBlock" emailAttr :: AttrName emailAttr = "email"@@ -148,13 +156,13 @@ clientMessageAttr = "clientMessage" clientHeaderAttr :: AttrName-clientHeaderAttr = "clientHeader"+clientHeaderAttr = "markdownHeader" clientEmphAttr :: AttrName-clientEmphAttr = "clientEmph"+clientEmphAttr = "markdownEmph" clientStrongAttr :: AttrName-clientStrongAttr = "clientStrong"+clientStrongAttr = "markdownStrong" errorMessageAttr :: AttrName errorMessageAttr = "errorMessage"@@ -165,53 +173,85 @@ messageSelectStatusAttr :: AttrName messageSelectStatusAttr = "messageSelectStatus" -themes :: [(T.Text, AttrMap)]-themes =- [ (darkColorThemeName, darkColorTheme)- , (lightColorThemeName, lightColorTheme)+data InternalTheme =+ InternalTheme { internalThemeName :: T.Text+ , internalTheme :: Theme+ }++lookupTheme :: T.Text -> Maybe InternalTheme+lookupTheme n = find ((== n) . internalThemeName) internalThemes++internalThemes :: [InternalTheme]+internalThemes = validateInternalTheme <$>+ [ darkColorTheme+ , lightColorTheme ] -lightColorTheme :: AttrMap-lightColorTheme =- let sty = Sky.kate- in attrMap (black `on` white) $- [ (timeAttr, fg black)- , (channelHeaderAttr, fg black `withStyle` underline)- , (channelListHeaderAttr, fg cyan)- , (currentChannelNameAttr, black `on` yellow `withStyle` bold)- , (unreadChannelAttr, black `on` cyan `withStyle` bold)- , (mentionsChannelAttr, black `on` red `withStyle` bold)- , (urlAttr, fg brightYellow)- , (emailAttr, fg yellow)- , (codeAttr, fg magenta)- , (emojiAttr, fg yellow)- , (channelNameAttr, fg blue)- , (clientMessageAttr, fg black)- , (clientEmphAttr, fg black `withStyle` bold)- , (clientStrongAttr, fg black `withStyle` bold `withStyle` underline)- , (clientHeaderAttr, fg red `withStyle` bold)- , (dateTransitionAttr, fg green)- , (newMessageTransitionAttr, black `on` yellow)- , (errorMessageAttr, fg red)- , (helpAttr, black `on` cyan)- , (helpEmphAttr, fg white)- , (channelSelectMatchAttr, black `on` magenta)- , (channelSelectPromptAttr, fg black)- , (completionAlternativeListAttr, white `on` blue)- , (completionAlternativeCurrentAttr, black `on` yellow)- , (dialogAttr, black `on` cyan)- , (dialogEmphAttr, fg white)- , (listSelectedFocusedAttr, black `on` yellow)- , (recentMarkerAttr, fg black `withStyle` bold)- , (loadMoreAttr, black `on` cyan)- , (urlListSelectedAttr, black `on` yellow)- , (messageSelectAttr, black `on` yellow)- , (messageSelectStatusAttr, fg black)- , (misspellingAttr, fg red `withStyle` underline)- ] <>- ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <>- (themeEntriesForStyle sty)+validateInternalTheme :: InternalTheme -> InternalTheme+validateInternalTheme it =+ let un = undocumentedAttrNames (internalTheme it)+ in if not $ null un+ then error $ "Internal theme " <> show (T.unpack (internalThemeName it)) <>+ " references undocumented attribute names: " <> show un+ else it +undocumentedAttrNames :: Theme -> [AttrName]+undocumentedAttrNames t =+ let noDocs k = isNothing $ attrNameDescription themeDocs k+ in filter noDocs (M.keys $ themeDefaultMapping t)++defaultTheme :: InternalTheme+defaultTheme = darkColorTheme++lightColorTheme :: InternalTheme+lightColorTheme = InternalTheme name theme+ where+ theme = newTheme def lightAttrs+ name = "builtin:light"+ def = black `on` white++lightAttrs :: [(AttrName, Attr)]+lightAttrs =+ let sty = Sky.kate+ in [ (timeAttr, fg black)+ , (channelHeaderAttr, fg black `withStyle` underline)+ , (channelListHeaderAttr, fg cyan)+ , (currentChannelNameAttr, black `on` yellow `withStyle` bold)+ , (unreadChannelAttr, black `on` cyan `withStyle` bold)+ , (mentionsChannelAttr, black `on` red `withStyle` bold)+ , (urlAttr, fg brightYellow)+ , (emailAttr, fg yellow)+ , (codeAttr, fg magenta)+ , (emojiAttr, fg yellow)+ , (channelNameAttr, fg blue)+ , (clientMessageAttr, fg black)+ , (clientEmphAttr, fg black `withStyle` bold)+ , (clientStrongAttr, fg black `withStyle` bold `withStyle` underline)+ , (clientHeaderAttr, fg red `withStyle` bold)+ , (dateTransitionAttr, fg green)+ , (newMessageTransitionAttr, black `on` yellow)+ , (errorMessageAttr, fg red)+ , (helpAttr, black `on` cyan)+ , (helpEmphAttr, fg white)+ , (channelSelectMatchAttr, black `on` magenta)+ , (channelSelectPromptAttr, fg black)+ , (completionAlternativeListAttr, white `on` blue)+ , (completionAlternativeCurrentAttr, black `on` yellow)+ , (dialogAttr, black `on` cyan)+ , (dialogEmphAttr, fg white)+ , (listSelectedFocusedAttr, black `on` yellow)+ , (recentMarkerAttr, fg black `withStyle` bold)+ , (loadMoreAttr, black `on` cyan)+ , (urlListSelectedAttr, black `on` yellow)+ , (messageSelectAttr, black `on` yellow)+ , (messageSelectStatusAttr, fg black)+ , (misspellingAttr, fg red `withStyle` underline)+ , (editedMarkingAttr, fg yellow)+ , (editedRecentlyMarkingAttr, black `on` yellow)+ ] <>+ ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <>+ (themeEntriesForStyle sty)+ darkAttrs :: [(AttrName, Attr)] darkAttrs = let sty = Sky.espresso@@ -248,12 +288,18 @@ , (messageSelectAttr, black `on` yellow) , (messageSelectStatusAttr, fg white) , (misspellingAttr, fg red `withStyle` underline)+ , (editedMarkingAttr, fg yellow)+ , (editedRecentlyMarkingAttr, black `on` yellow) ] <> ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <> (themeEntriesForStyle sty) -darkColorTheme :: AttrMap-darkColorTheme = attrMap defAttr darkAttrs+darkColorTheme :: InternalTheme+darkColorTheme = InternalTheme name theme+ where+ theme = newTheme def darkAttrs+ name = "builtin:dark"+ def = defAttr usernameAttr :: Int -> AttrName usernameAttr i = "username" <> (attrName $ show i)@@ -291,9 +337,41 @@ baseHighlightedCodeBlockAttr :: AttrName baseHighlightedCodeBlockAttr = "highlightedCodeBlock" -attrNameForTokenType :: Sky.TokenType -> AttrName-attrNameForTokenType ty =- baseHighlightedCodeBlockAttr <> (attrName $ show ty)+attrNameForTokenType :: TokenType -> AttrName+attrNameForTokenType ty = baseHighlightedCodeBlockAttr <> (attrName s)+ where+ s = case ty of+ KeywordTok -> "keyword"+ DataTypeTok -> "dataType"+ DecValTok -> "declaration"+ BaseNTok -> "baseN"+ FloatTok -> "float"+ ConstantTok -> "constant"+ CharTok -> "char"+ SpecialCharTok -> "specialChar"+ StringTok -> "string"+ VerbatimStringTok -> "verbatimString"+ SpecialStringTok -> "specialString"+ ImportTok -> "import"+ CommentTok -> "comment"+ DocumentationTok -> "documentation"+ AnnotationTok -> "annotation"+ CommentVarTok -> "comment"+ OtherTok -> "other"+ FunctionTok -> "function"+ VariableTok -> "variable"+ ControlFlowTok -> "controlFlow"+ OperatorTok -> "operator"+ BuiltInTok -> "builtIn"+ ExtensionTok -> "extension"+ PreprocessorTok -> "preprocessor"+ AttributeTok -> "attribute"+ RegionMarkerTok -> "regionMarker"+ InformationTok -> "information"+ WarningTok -> "warning"+ AlertTok -> "alert"+ ErrorTok -> "error"+ NormalTok -> "normal" themeEntriesForStyle :: Sky.Style -> [(AttrName, Attr)] themeEntriesForStyle sty =@@ -321,3 +399,213 @@ if Sky.tokenUnderline tSty then flip withStyle underline else id in (attrNameForTokenType ty, a)++attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe T.Text+attrNameDescription td an = M.lookup an (themeDescriptions td)++themeDocs :: ThemeDocumentation+themeDocs = ThemeDocumentation $ M.fromList $+ [ ( timeAttr+ , "Timestamps on chat messages"+ )+ , ( channelHeaderAttr+ , "Channel headers displayed above chat message lists"+ )+ , ( channelListHeaderAttr+ , "The heading of the channel list sections"+ )+ , ( currentChannelNameAttr+ , "The currently selected channel in the channel list"+ )+ , ( unreadChannelAttr+ , "A channel in the channel list with unread messages"+ )+ , ( mentionsChannelAttr+ , "A channel in the channel list with unread mentions"+ )+ , ( urlAttr+ , "A URL in a chat message"+ )+ , ( codeAttr+ , "A code block in a chat message with no language indication"+ )+ , ( emailAttr+ , "An e-mail address in a chat message"+ )+ , ( emojiAttr+ , "A text emoji indication in a chat message"+ )+ , ( channelNameAttr+ , "A channel name in a chat message"+ )+ , ( clientMessageAttr+ , "A Matterhorn diagnostic or informative message"+ )+ , ( clientHeaderAttr+ , "Markdown heading"+ )+ , ( clientEmphAttr+ , "Markdown 'emphasized' text"+ )+ , ( clientStrongAttr+ , "Markdown 'strong' text"+ )+ , ( dateTransitionAttr+ , "Date transition lines between chat messages on different days"+ )+ , ( newMessageTransitionAttr+ , "The 'New Messages' line that appears above unread messages"+ )+ , ( errorMessageAttr+ , "Matterhorn error messages"+ )+ , ( helpAttr+ , "The help screen text"+ )+ , ( helpEmphAttr+ , "The help screen's emphasized text"+ )+ , ( channelSelectPromptAttr+ , "Channel selection: prompt"+ )+ , ( channelSelectMatchAttr+ , "Channel selection: the portion of a channel name that matches"+ )+ , ( completionAlternativeListAttr+ , "Tab completion alternatives"+ )+ , ( completionAlternativeCurrentAttr+ , "The currently-selected tab completion alternative"+ )+ , ( dialogAttr+ , "Dialog box text"+ )+ , ( dialogEmphAttr+ , "Dialog box emphasized text"+ )+ , ( recentMarkerAttr+ , "The marker indicating the channel last visited"+ )+ , ( replyParentAttr+ , "The first line of parent messages appearing above reply messages"+ )+ , ( loadMoreAttr+ , "The 'Load More' line that appears at the top of a chat message list"+ )+ , ( urlListSelectedAttr+ , "URL list: the selected URL"+ )+ , ( messageSelectAttr+ , "Message selection: the currently-selected message"+ )+ , ( messageSelectStatusAttr+ , "Message selection: the message selection actions"+ )+ , ( misspellingAttr+ , "A misspelled word in the chat message editor"+ )+ , ( editedMarkingAttr+ , "The 'edited' marking that appears on edited messages"+ )+ , ( editedRecentlyMarkingAttr+ , "The 'edited' marking that appears on newly-edited messages"+ )+ , ( attrNameForTokenType KeywordTok+ , "Syntax highlighting: Keyword"+ )+ , ( attrNameForTokenType DataTypeTok+ , "Syntax highlighting: DataType"+ )+ , ( attrNameForTokenType DecValTok+ , "Syntax highlighting: Declaration"+ )+ , ( attrNameForTokenType BaseNTok+ , "Syntax highlighting: BaseN"+ )+ , ( attrNameForTokenType FloatTok+ , "Syntax highlighting: Float"+ )+ , ( attrNameForTokenType ConstantTok+ , "Syntax highlighting: Constant"+ )+ , ( attrNameForTokenType CharTok+ , "Syntax highlighting: Char"+ )+ , ( attrNameForTokenType SpecialCharTok+ , "Syntax highlighting: Special Char"+ )+ , ( attrNameForTokenType StringTok+ , "Syntax highlighting: String"+ )+ , ( attrNameForTokenType VerbatimStringTok+ , "Syntax highlighting: Verbatim String"+ )+ , ( attrNameForTokenType SpecialStringTok+ , "Syntax highlighting: Special String"+ )+ , ( attrNameForTokenType ImportTok+ , "Syntax highlighting: Import"+ )+ , ( attrNameForTokenType CommentTok+ , "Syntax highlighting: Comment"+ )+ , ( attrNameForTokenType DocumentationTok+ , "Syntax highlighting: Documentation"+ )+ , ( attrNameForTokenType AnnotationTok+ , "Syntax highlighting: Annotation"+ )+ , ( attrNameForTokenType CommentVarTok+ , "Syntax highlighting: Comment"+ )+ , ( attrNameForTokenType OtherTok+ , "Syntax highlighting: Other"+ )+ , ( attrNameForTokenType FunctionTok+ , "Syntax highlighting: Function"+ )+ , ( attrNameForTokenType VariableTok+ , "Syntax highlighting: Variable"+ )+ , ( attrNameForTokenType ControlFlowTok+ , "Syntax highlighting: Control Flow"+ )+ , ( attrNameForTokenType OperatorTok+ , "Syntax highlighting: Operator"+ )+ , ( attrNameForTokenType BuiltInTok+ , "Syntax highlighting: Built-In"+ )+ , ( attrNameForTokenType ExtensionTok+ , "Syntax highlighting: Extension"+ )+ , ( attrNameForTokenType PreprocessorTok+ , "Syntax highlighting: Preprocessor"+ )+ , ( attrNameForTokenType AttributeTok+ , "Syntax highlighting: Attribute"+ )+ , ( attrNameForTokenType RegionMarkerTok+ , "Syntax highlighting: Region Marker"+ )+ , ( attrNameForTokenType InformationTok+ , "Syntax highlighting: Information"+ )+ , ( attrNameForTokenType WarningTok+ , "Syntax highlighting: Warning"+ )+ , ( attrNameForTokenType AlertTok+ , "Syntax highlighting: Alert"+ )+ , ( attrNameForTokenType ErrorTok+ , "Syntax highlighting: Error"+ )+ , ( attrNameForTokenType NormalTok+ , "Syntax highlighting: Normal text"+ )+ , ( listSelectedFocusedAttr+ , "The selected channel"+ )+ ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i)+ | i <- [0..(length usernameColors)-1]+ ]
src/Types.hs view
@@ -40,6 +40,13 @@ , linkName , linkFileId + , ChannelSelectState(..)+ , userMatches+ , channelMatches+ , channelSelectInput+ , selectedMatch+ , emptyChannelSelectState+ , ChatState , newState , csResources@@ -61,9 +68,7 @@ , csUsers , csChannel , csChannels- , csChannelSelectUserMatches- , csChannelSelectChannelMatches- , csChannelSelectString+ , csChannelSelectState , csMe , csEditState , timeZone@@ -88,12 +93,14 @@ , postListPosts , ChatResources(ChatResources)+ , crPreferences , crEventQueue , crTheme , crSession , crSubprocessLog , crRequestQueue , crQuitCondition+ , crUserStatusLock , crFlaggedPosts , crConn , crConfiguration@@ -122,7 +129,7 @@ , channelNameFromMatch , isMine , getUsernameForUserId- , getLastChannelPreference+ , sortedUserList , userSigil , normalChannelSigil@@ -149,7 +156,7 @@ import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (TimeZone) import qualified Data.HashMap.Strict as HM-import Data.List (sort)+import Data.List (sort, partition, sortBy) import Data.Maybe import Data.Monoid import Data.Set (Set)@@ -195,33 +202,23 @@ , configTimeFormat :: Maybe T.Text , configDateFormat :: Maybe T.Text , configTheme :: Maybe T.Text+ , configThemeCustomizationFile :: Maybe T.Text , configSmartBacktick :: Bool , configURLOpenCommand :: Maybe T.Text+ , configURLOpenCommandInteractive :: Bool , configActivityBell :: Bool , configShowBackground :: BackgroundInfo , configShowMessagePreview :: Bool , configEnableAspell :: Bool , configAspellDictionary :: Maybe T.Text , configUnsafeUseHTTP :: Bool+ , configChannelListWidth :: Int+ , configShowOlderEdits :: Bool+ , configAbsPath :: Maybe FilePath } 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 -- | The 'MMNames' record is for listing human-readable@@ -272,6 +269,7 @@ | HelpViewport | HelpText | ScriptHelpText+ | ThemeHelpText | ChannelSelectString | CompletionAlternatives | JoinChannelList@@ -369,8 +367,10 @@ , _crSubprocessLog :: STM.TChan ProgramOutput , _crTheme :: AttrMap , _crQuitCondition :: MVar ()+ , _crUserStatusLock :: MVar () , _crConfiguration :: Config , _crFlaggedPosts :: Set PostId+ , _crPreferences :: Seq.Seq Preference } -- | The 'ChatEditState' value contains the editor widget itself@@ -424,6 +424,7 @@ data HelpScreen = MainHelp | ScriptHelp+ | ThemeHelp deriving (Eq) -- | Help topics@@ -438,8 +439,8 @@ -- | Mode type for the current contents of the post list overlay data PostListContents = PostListFlagged--- | PostListPinned ChannelId--- | PostListSearch Text -- for the query+ | PostListSearch T.Text Bool -- for the query and search status+ -- | PostListPinned ChannelId deriving (Eq) -- | The 'Mode' represents the current dominant UI activity@@ -476,9 +477,7 @@ , _csEditState :: ChatEditState , _csMode :: Mode , _csShowMessagePreview :: Bool- , _csChannelSelectString :: T.Text- , _csChannelSelectChannelMatches :: ChannelSelectMap- , _csChannelSelectUserMatches :: ChannelSelectMap+ , _csChannelSelectState :: ChannelSelectState , _csRecentChannel :: Maybe ChannelId , _csUrlList :: List Name LinkChoice , _csConnectionStatus :: ConnectionStatus@@ -509,9 +508,7 @@ , _csEditState = emptyEditState hist sp , _csMode = Main , _csShowMessagePreview = configShowMessagePreview $ _crConfiguration rs- , _csChannelSelectString = ""- , _csChannelSelectChannelMatches = mempty- , _csChannelSelectUserMatches = mempty+ , _csChannelSelectState = emptyChannelSelectState , _csRecentChannel = Nothing , _csUrlList = list UrlList mempty 2 , _csConnectionStatus = Connected@@ -523,6 +520,21 @@ type ChannelSelectMap = HM.HashMap T.Text ChannelSelectMatch +data ChannelSelectState =+ ChannelSelectState { _channelSelectInput :: T.Text+ , _channelMatches :: ChannelSelectMap+ , _userMatches :: ChannelSelectMap+ , _selectedMatch :: T.Text+ }++emptyChannelSelectState :: ChannelSelectState+emptyChannelSelectState =+ ChannelSelectState { _channelSelectInput = ""+ , _channelMatches = mempty+ , _userMatches = mempty+ , _selectedMatch = ""+ }+ data MessageSelectState = MessageSelectState { selectMessagePostId :: Maybe PostId } @@ -591,21 +603,26 @@ instance St.MonadIO MH where liftIO = MH . St.liftIO --- | This represents any event that we might care about in the--- main application loop+-- | This represents events that we handle in the main application loop. data MHEvent- = WSEvent WebsocketEvent+ = WSEvent WebsocketEvent -- ^ For events that arise from the websocket- | RespEvent (MH ())+ | RespEvent (MH ()) -- ^ For the result values of async IO operations- | AsyncErrEvent SomeException+ | AsyncErrEvent SomeException -- ^ For errors that arise in the course of async IO operations- | RefreshWebsocketEvent+ | RefreshWebsocketEvent -- ^ Tell our main loop to refresh the websocket connection- | WebsocketDisconnect- | WebsocketConnect- | BGIdle -- ^ background worker is idle- | BGBusy (Maybe Int) -- ^ background worker is busy (with n requests)+ | WebsocketParseError String+ -- ^ We failed to parse an incoming websocket event+ | WebsocketDisconnect+ -- ^ The websocket connection went down.+ | WebsocketConnect+ -- ^ The websocket connection came up.+ | BGIdle+ -- ^ background worker is idle+ | BGBusy (Maybe Int)+ -- ^ background worker is busy (with n requests) -- ** Application State Lenses @@ -613,6 +630,7 @@ makeLenses ''ChatState makeLenses ''ChatEditState makeLenses ''PostListOverlayState+makeLenses ''ChannelSelectState resetSpellCheckTimer :: ChatEditState -> IO () resetSpellCheckTimer s =@@ -723,9 +741,31 @@ hasUnread st cId = maybe False id $ do chan <- findChannelById cId (st^.csChannels) lastViewTime <- chan^.ccInfo.cdViewed- return (chan^.ccInfo.cdUpdated > lastViewTime)+ return $ (chan^.ccInfo.cdUpdated > lastViewTime) ||+ (isJust $ chan^.ccInfo.cdEditedMessageThreshold) userList :: ChatState -> [UserInfo] userList st = filter showUser $ allUsers (st^.csUsers) where showUser u = not (isSelf u) && (u^.uiInTeam) isSelf u = (st^.csMe.userIdL) == (u^.uiId)++sortedUserList :: ChatState -> [UserInfo]+sortedUserList st = sortBy cmp yes <> sortBy cmp no+ where+ cmp = compareUserInfo uiName+ dmHasUnread u =+ case st^.csNames.cnToChanId.at(u^.uiName) of+ Nothing -> False+ Just cId+ | (st^.csCurrentChannelId) == cId -> False+ | otherwise -> hasUnread st cId+ (yes, no) = partition dmHasUnread (filter (not . _uiDeleted) $ userList st)++compareUserInfo :: (Ord a) => Lens' UserInfo a -> UserInfo -> UserInfo -> Ordering+compareUserInfo field u1 u2+ | u1^.uiStatus == Offline && u2^.uiStatus /= Offline =+ GT+ | u1^.uiStatus /= Offline && u2^.uiStatus == Offline =+ LT+ | otherwise =+ (u1^.field) `compare` (u2^.field)
src/Types/Channels.hs view
@@ -14,7 +14,7 @@ -- * Lenses created for accessing ClientChannel fields , ccContents, ccInfo -- * Lenses created for accessing ChannelInfo fields- , cdViewed, cdNewMessageIndicator, cdUpdated+ , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated , cdName, cdHeader, cdType, cdCurrentState , cdMentionCount -- * Lenses created for accessing ChannelContents fields@@ -35,8 +35,12 @@ , pendingChannelState , quiescentChannelState , clearNewMessageIndicator+ , clearEditedThreshold , adjustUpdated+ , adjustEditedThreshold , updateNewMessageIndicator+ -- * Notification settings+ , notifyPreference -- * Miscellaneous channel-related operations , canLeaveChannel , preferredChannelName@@ -53,6 +57,11 @@ , ChannelWithData(..) , Type(..) , Post+ , User(userNotifyProps)+ , ChannelNotifyProps+ , NotifyOption(..)+ , WithDefault(..)+ , emptyChannelNotifyProps ) import Types.Messages (Messages, noMessages) @@ -84,12 +93,14 @@ let updated = chan ^. channelLastPostAtL in ChannelInfo { _cdViewed = Nothing , _cdNewMessageIndicator = Hide+ , _cdEditedMessageThreshold = Nothing , _cdMentionCount = 0 , _cdUpdated = updated , _cdName = preferredChannelName chan , _cdHeader = chan^.channelHeaderL , _cdType = chan^.channelTypeL , _cdCurrentState = initialChannelState+ , _cdNotifyProps = emptyChannelNotifyProps } channelInfoFromChannelWithData :: ChannelWithData -> ChannelInfo -> ChannelInfo@@ -105,6 +116,7 @@ , _cdHeader = (chan^.channelHeaderL) , _cdType = (chan^.channelTypeL) , _cdMentionCount = chanData^.channelDataMentionCountL+ , _cdNotifyProps = chanData^.channelDataNotifyPropsL } -- | The 'ChannelContents' is a wrapper for a list of@@ -210,6 +222,8 @@ -- ^ The last time we looked at a channel , _cdNewMessageIndicator :: NewMessageIndicator -- ^ The state of the channel's new message indicator.+ , _cdEditedMessageThreshold :: Maybe UTCTime+ -- ^ The channel's edited message threshold. , _cdMentionCount :: Int -- ^ The current number of unread mentions , _cdUpdated :: UTCTime@@ -222,6 +236,8 @@ -- ^ The type of a channel: public, private, or DM , _cdCurrentState :: ChannelState -- ^ The current state of the channel+ , _cdNotifyProps :: ChannelNotifyProps+ -- ^ The user's notification settings for this channel } -- ** Channel-related Lenses@@ -230,6 +246,12 @@ makeLenses ''ChannelInfo makeLenses ''ClientChannel +notifyPreference :: User -> ClientChannel -> NotifyOption+notifyPreference u cc =+ case cc^.ccInfo.cdNotifyProps.channelNotifyPropsDesktopL of+ IsValue v -> v+ Default -> (userNotifyProps u)^.userNotifyPropsDesktopL+ -- ** Miscellaneous channel operations makeClientChannel :: Channel -> ClientChannel@@ -239,7 +261,7 @@ } canLeaveChannel :: ChannelInfo -> Bool-canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct, Group]+canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct] -- ** Manage the collection of all Channels @@ -297,11 +319,24 @@ clearNewMessageIndicator :: ClientChannel -> ClientChannel clearNewMessageIndicator c = c & ccInfo.cdNewMessageIndicator .~ Hide +-- | Clear the edit threshold for the specified channel+clearEditedThreshold :: ClientChannel -> ClientChannel+clearEditedThreshold c = c & ccInfo.cdEditedMessageThreshold .~ Nothing+ -- | Adjust updated time based on a message, ensuring that the updated -- time does not move backward. adjustUpdated :: Post -> ClientChannel -> ClientChannel adjustUpdated m = ccInfo.cdUpdated %~ max (maxPostTimestamp m)++adjustEditedThreshold :: Post -> ClientChannel -> ClientChannel+adjustEditedThreshold m c =+ if m^.postUpdateAtL <= m^.postCreateAtL+ then c+ else c & ccInfo.cdEditedMessageThreshold %~ (\mt -> case mt of+ Just t -> Just $ min (m^.postUpdateAtL) t+ Nothing -> Just $ m^.postUpdateAtL+ ) maxPostTimestamp :: Post -> UTCTime maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL)
src/Types/Users.hs view
@@ -8,6 +8,7 @@ , Users -- constructor remains internal -- * Lenses created for accessing UserInfo fields , uiName, uiId, uiStatus, uiInTeam, uiNickName, uiFirstName, uiLastName, uiEmail+ , uiDeleted -- * Various operations on UserInfo -- * Creating UserInfo objects , userInfoFromUser@@ -20,6 +21,7 @@ , modifyUserById , getDMChannelName , userIdForDMChannel+ , userDeleted ) where @@ -44,8 +46,13 @@ , _uiFirstName :: T.Text , _uiLastName :: T.Text , _uiEmail :: T.Text+ , _uiDeleted :: Bool } deriving (Eq, Show) +-- | Is this user deleted?+userDeleted :: User -> Bool+userDeleted u = userDeleteAt u > userCreateAt u+ -- | Create a 'UserInfo' value from a Mattermost 'User' value userInfoFromUser :: User -> Bool -> UserInfo userInfoFromUser up inTeam = UserInfo@@ -59,6 +66,7 @@ , _uiFirstName = userFirstName up , _uiLastName = userLastName up , _uiEmail = userEmail up+ , _uiDeleted = userDeleted up } -- | The 'UserStatus' value represents possible current status for