matterhorn 30802.1.0 → 31000.0.0
raw patch · 40 files changed
+3376/−1292 lines, 40 filesdep +aspell-pipedep +skylightingdep +stm-delaydep ~brickdep ~mattermost-apidep ~mattermost-api-qc
Dependencies added: aspell-pipe, skylighting, stm-delay, unix
Dependency ranges changed: brick, mattermost-api, mattermost-api-qc, process, vector
Files
- README.md +202/−0
- matterhorn.cabal +85/−68
- src/Command.hs +19/−79
- src/Config.hs +32/−7
- src/Draw.hs +3/−1
- src/Draw/ChannelList.hs +189/−0
- src/Draw/DeleteChannelConfirm.hs +1/−0
- src/Draw/LeaveChannelConfirm.hs +1/−0
- src/Draw/Main.hs +245/−253
- src/Draw/Messages.hs +120/−0
- src/Draw/PostListOverlay.hs +119/−0
- src/Draw/ShowHelp.hs +89/−70
- src/Draw/Util.hs +3/−1
- src/Events.hs +51/−8
- src/Events/ChannelScroll.hs +4/−0
- src/Events/ChannelSelect.hs +7/−2
- src/Events/Main.hs +14/−8
- src/Events/MessageSelect.hs +5/−0
- src/Events/PostListOverlay.hs +37/−0
- src/HelpTopics.hs +34/−0
- src/InputHistory.hs +6/−0
- src/Login.hs +111/−68
- src/Main.hs +6/−0
- src/Markdown.hs +63/−28
- src/Scripts.hs +75/−0
- src/State.hs +538/−279
- src/State/Common.hs +156/−78
- src/State/Editing.hs +48/−5
- src/State/PostListOverlay.hs +69/−0
- src/State/Setup.hs +129/−64
- src/TeamSelect.hs +1/−1
- src/Themes.hs +122/−67
- src/Types.hs +110/−181
- src/Types/Channels.hs +321/−0
- src/Types/Messages.hs +45/−10
- src/Types/Posts.hs +11/−11
- src/Types/Users.hs +138/−0
- test/Cheapskate_QCA.hs +47/−0
- test/Message_QCA.hs +117/−0
- test/test_messages.hs +3/−3
+ README.md view
@@ -0,0 +1,202 @@+[](https://travis-ci.org/matterhorn-chat/matterhorn)++++Matterhorn is a terminal client for the Mattermost chat system.++++# Quick Start++We provide pre-built binary releases for some platforms. Please see the+release list to download a binary release for your platform that matches+your server version:++https://github.com/matterhorn-chat/matterhorn/releases++To fetch a release and run Matterhorn, run the following commands (where+`VERSION` and `PLATFORM` match your setup):++ wget https://github.com/matterhorn-chat/matterhorn/releases/download/<VERSION>/matterhorn-<VERSION>-<PLATFORM>.tar.gz+ tar xf matterhorn-<VERSION>-<PLATFORM>.tar.gz+ cd matterhorn-<VERSION>-<PLATFORM>+ ./matterhorn++When you run Matterhorn you'll be prompted for your server information+and credentials. At present `matterhorn` supports only username/password+authentication.++Note: Version `ABBCC.X.Y` matches Mattermost server version `A.BB.CC`.+For example, if your Mattermost server version is `3.6.0` then you+would download matterhorn version `30600.2.4`. See [Our Versioning+Scheme](#our-versioning-scheme) for details.++# Configuring++For configuration options you have two choices:++* Interactive configuration entered on each program run+* Configuration via stored settings in a config file++The first option is useful when trying out the program because you can+get up and running without worrying about making a configuration. Once+you're ready to make your settings persistent, they can be added to+a configuration file. An example configuration file can be found at+`sample-config.ini`. Any settings omitted from the configuration will be+obtained interactively at startup.++When looking for configuration files, matterhorn will prefer+`config.ini` in the current working directory, but will look in the+typical XDG configuration directories (you'll probably want to use+`$HOME/.config/matterhorn/config.ini`) and as a last resort look for a+globally-accessible `/etc/matterhorn/config.ini`.++# Using the Client++The user interface has three main areas:++* Left: list of channels you're in, and list of users in your team and+ their statuses (`+` means online, `-` means away, and an absent sigil+ means offline)+* Right: messages in the current channel+* Bottom: editing area for writing, editing, and replying to messages++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.++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 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.+To send a multi-line message, toggle multi-line mode with the default+binding `M-e`. Markdown syntax is accepted.++To edit your current message in an external editor (`$EDITOR`), use the+default binding of `M-k`.++To preview the message you're about to send (e.g. to check on how your+Markdown syntax will be rendered), toggle preview mode with the default+binding `M-p`.++To change channels, use `/focus` or one of the default bindings `C-n`+(next channel), `C-p` (previous channel), `C-g` (fast channel switch).++To directly message another user, use `/focus` or `C-g`.++`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.++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+the channel list with a "`<`" indicator.++To switch to the next channel with unread messages, use the default+binding `M-a`.++To quickly show a list of URLs mentioned in the current channel and then+open one in your local browser, use the default binding of `C-o` and+configure the `urlOpenCommand` configuration setting.++To edit, delete, flag, or reply to a message, select a message with+the default binding of `C-s`. Use the default binding of `C-c` to+cancel these operations.++Messages that have been flagged can be viewed with either the `/flags`+command or `M-8`. This view allows you to select and unflag particular+messages, as well.++To enable spell-checking in the message editor, install Aspell and set+`enableAspell` to `True` in your configuration. To override Aspell's+choice of master dictionary, set the `aspellDictionary` option to the+name of the dictionary you'd like to use.++# Features++* Channel creation, deletion, and membership management commands+* Optimized channel-switching modes: `M-a`, `M-s`, and `C-g`+* Message posting, editing, replying, and deletion+* Markdown rendering+* Convenient URL-opening with local browser+* Secure password entry via external command (e.g. OSX keychain)+* Yank verbatim content from messages into the system clipboard+* Preview message rendering before sending+* Optional smart quoting for efficient Markdown entry+* Edit messages with `$EDITOR`+* Message editor with kill/yank buffer and readline-style keybindings+* Tab-completion of usernames, channel names, and commands+* Spell-checking via Aspell+* Syntax highlighting of fenced code blocks in messages (works best in+ 256-color terminals)+* Flagging and unflagging of posts, which are then viewable with `M-8`++# Spell Checking Support++Matterhorn uses `aspell` to perform spell-checking of your message+input. To use this feature:++ * Install `aspell` and ensure that your installation includes+ dictionaries corresponding to your `LANG` setting. To check this, ask+ `aspell` to check some input:+ ```+ $ echo stuff | aspell -a+ Error: No word lists can be found for the language "en".+ $ echo $LANG+ en_US+ ```+ If Aspell succeeds, the output will look like this:+ ```+ @(#) International Ispell Version 3.1.20 (but really Aspell 0.60.6.1)+ *+ ```+ * Set `enableAspell` to `True` in your `config.ini`+ * Enter any message input in the message editor in `matterhorn`. After+ a short delay after you stop typing, misspelled words will turn red.++# Building++`matterhorn` is built with the provided `install.sh` script, which+requires `git` and an appropriate `ghc`/`cabal` installation.+(Although the name suggests installtion, this will just do a build in+`dist-newstyle`.) This script will pull the appropriate repos and build+the application. This is required for building Matterhorn since clones+of some of our other dependencies may need to be locally available in+`deps/` in case important changes to those dependencies have not yet+been released.++# Our Versioning Scheme++Matterhorn version strings will be of the form `ABBCC.X.Y` where ABBCC+corresponds to the Mattermost server version supported by the release.+For example, if a release supports Mattermost server version 1.2.3, the+ABBCC portion of the `matterhorn` version will be `10203`. The `X.Y`+portion of the version corresponds to our own version namespace for the+package. If the server version changes, `X.Y` SHOULD be `0.0`. Otherwise+the first component should increment if the package undergoes major code+changes or functionality changes. The second component alone should+change only if the package undergoes security fixes or other bug fixes.++# Contributing++If you decide to contribute, that's great! Here are some guidelines you+should consider to make submitting patches easier for all concerned:++ - If you want to take on big things, let's have a design/vision+ discussion before you start coding. Create a GitHub issue and we can+ use that as the place to hash things out. We'll be interested to+ discuss any usability / UI, performance, or compatibility issues.+ - Please make changes consistent with the conventions already used in+ the codebase.++# Frequently Asked Questions++* Q: Does matterhorn support Gitlab authentication?+* A: No. But we would be happy to work with contributors who are+ interested in investigating what this would take and/or implementing+ it. See the Contributing section for details.
matterhorn.cabal view
@@ -1,19 +1,21 @@ name: matterhorn-version: 30802.1.0-synopsis: Terminal client for the MatterMost chat system-description: This is a terminal client for the MatterMost chat+version: 31000.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 features and information on getting started. license: BSD3 license-file: LICENSE-author: Getty Ritter <gdritter@galois.com>-maintainer: Getty Ritter <gdritter@galois.com>+author: matterhorn@galois.com+maintainer: matterhorn@galois.com copyright: ©2016-2017 AUTHORS.txt category: Chat build-type: Simple cabal-version: >= 1.12 tested-with: GHC == 7.10.3, GHC == 8.0.1 +extra-doc-files: README.md+ source-repository head type: git location: https://github.com/matterhorn-chat/matterhorn.git@@ -28,14 +30,18 @@ State State.Common State.Editing+ State.PostListOverlay State.Setup Zipper Themes Draw Draw.Main+ Draw.Messages+ Draw.ChannelList Draw.ShowHelp Draw.LeaveChannelConfirm Draw.DeleteChannelConfirm+ Draw.PostListOverlay Draw.JoinChannel Draw.Util InputHistory@@ -47,11 +53,16 @@ Events.JoinChannel Events.ChannelScroll Events.ChannelSelect+ Events.PostListOverlay Events.UrlSelect Events.LeaveChannelConfirm Events.DeleteChannelConfirm+ HelpTopics+ Scripts Types+ Types.Channels Types.Messages+ Types.Users Types.Posts FilePaths TeamSelect@@ -62,76 +73,82 @@ default-extensions: OverloadedStrings, ScopedTypeVariables ghc-options: -Wall -threaded- build-depends: base >=4.8 && <5- , mattermost-api >= 30802.1.0- , base-compat- , unordered-containers- , containers >= 0.5.7- , connection- , text- , bytestring- , stm- , config-ini >= 0.1.2- , process- , microlens-platform- , brick >= 0.17- , vty >= 5.15.1- , transformers- , text-zipper >= 0.10- , time >= 1.6- , xdg-basedir- , filepath- , directory- , vector < 0.12- , strict- , hashable- , cheapskate- , utf8-string- , temporary- , gitrev- , Hclip- , mtl+ build-depends: base >=4.8 && <5+ , mattermost-api == 31000.0.0+ , base-compat >= 0.9 && < 0.10+ , unordered-containers >= 0.2 && < 0.3+ , containers >= 0.5.7 && < 0.6+ , connection >= 0.2 && < 0.3+ , text >= 1.2 && < 1.3+ , bytestring >= 0.10 && < 0.11+ , stm >= 2.4 && < 2.5+ , config-ini >= 0.1.2 && < 0.2+ , process >= 1.4 && < 1.7+ , microlens-platform >= 0.3 && < 0.4+ , brick >= 0.19 && < 0.20+ , vty >= 5.15.1 && < 5.16+ , transformers >= 0.4 && < 0.6+ , text-zipper >= 0.10 && < 0.11+ , time >= 1.6 && < 1.8+ , xdg-basedir >= 0.2 && < 0.3+ , filepath >= 1.4 && < 1.5+ , directory >= 1.3 && < 1.4+ , vector < 0.13+ , strict >= 0.3 && < 0.4+ , hashable >= 1.2 && < 1.3+ , cheapskate >= 0.1 && < 0.2+ , utf8-string >= 1.0 && < 1.1+ , temporary >= 1.2 && < 1.3+ , gitrev >= 1.3 && < 1.4+ , Hclip >= 3.0 && < 3.1+ , mtl >= 2.2 && < 2.3+ , aspell-pipe >= 0.3 && < 0.4+ , stm-delay >= 0.1 && < 0.2+ , unix >= 2.7.1.0 && < 2.7.3.0+ , skylighting >= 0.3.3.1 && < 0.4 default-language: Haskell2010 test-suite test_messages type: exitcode-stdio-1.0 main-is: test_messages.hs+ other-modules: Cheapskate_QCA+ , Message_QCA default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables ghc-options: -Wall -fno-warn-orphans hs-source-dirs: src, test- build-depends: base >=4.7 && <5- , base-compat- , brick >= 0.17- , bytestring- , cheapskate- , checkers- , config-ini >= 0.1.2- , connection- , containers >= 0.5.7- , directory- , filepath- , hashable- , Hclip- , mattermost-api >= 30802.0.0- , mattermost-api-qc >= 30802.1.0- , microlens-platform- , mtl- , process- , quickcheck-text- , stm- , strict- , string-conversions- , tasty- , tasty-hunit- , tasty-quickcheck- , text- , text-zipper >= 0.10- , time >= 1.6- , transformers- , Unique- , unordered-containers- , vector < 0.12- , vty >= 5.15.1- , xdg-basedir+ build-depends: base >=4.7 && <5+ , base-compat >= 0.9 && < 0.10+ , brick >= 0.19 && < 0.20+ , bytestring >= 0.10 && < 0.11+ , cheapskate >= 0.1 && < 0.2+ , checkers >= 0.4 && < 0.5+ , config-ini >= 0.1.2 && < 0.2+ , connection >= 0.2 && < 0.3+ , containers >= 0.5.7 && < 0.6+ , directory >= 1.3 && < 1.4+ , filepath >= 1.4 && < 1.5+ , hashable >= 1.2 && < 1.3+ , Hclip >= 3.0 && < 3.1+ , mattermost-api == 31000.0.0+ , mattermost-api-qc == 31000.0.0+ , microlens-platform >= 0.3 && < 0.4+ , mtl >= 2.2 && < 2.3+ , process >= 1.4 && < 1.7+ , quickcheck-text >= 0.1 && < 0.2+ , stm >= 2.4 && < 2.5+ , strict >= 0.3 && < 0.4+ , string-conversions >= 0.4 && < 0.5+ , tasty >= 0.11 && < 0.12+ , tasty-hunit >= 0.9 && < 0.10+ , tasty-quickcheck >= 0.8 && < 0.9+ , text >= 1.2 && < 1.3+ , text-zipper >= 0.10 && < 0.11+ , time >= 1.6 && < 1.8+ , transformers >= 0.4 && < 0.6+ , Unique >= 0.4 && < 0.5+ , unordered-containers >= 0.2 && < 0.3+ , vector < 0.12+ , vty >= 5.15.1 && < 5.16+ , xdg-basedir >= 0.2 && < 0.3
src/Command.hs view
@@ -1,23 +1,21 @@ {-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-} module Command where import Prelude () import Prelude.Compat import Control.Monad (when)-import Control.Monad.IO.Class (liftIO) import Data.Monoid ((<>)) import qualified Data.Text as T-import System.Exit (ExitCode(..))-import System.Process (readProcessWithExitCode) -import FilePaths (Script(..), getAllScripts, locateScriptPath)-import Lens.Micro.Platform (use)- import State import State.Common import State.Editing+import State.PostListOverlay import Types+import HelpTopics+import Scripts printArgSpec :: CmdArgs a -> T.Text printArgSpec NoArg = ""@@ -61,9 +59,7 @@ setTheme themeName , Cmd "topic" "Set the current channel's topic" (LineArg "topic") $ \ p -> do- when (not $ T.null p) $ do- st <- use id- liftIO $ setChannelTopic st p+ when (not $ T.null p) $ setChannelTopic p , Cmd "add-user" "Add a user to the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> addUserToCurrentChannel uname@@ -71,35 +67,21 @@ (TokenArg "channel" NoArg) $ \ (name, ()) -> changeChannel name , Cmd "help" "Show this help screen" NoArg $ \ _ ->- showHelpScreen MainHelp+ showHelpScreen mainHelpTopic , Cmd "help" "Show help about a particular topic"- (TokenArg "topic" NoArg) $ \ (topic, ()) ->- case topic of- "main" -> showHelpScreen MainHelp- "scripts" -> showHelpScreen ScriptHelp- _ -> do- let msg = ("Unknown help topic: `" <> topic <> "`. " <>- "Available topics are:\n - main\n - scripts\n")- postErrorMessage msg+ (TokenArg "topic" NoArg) $ \ (topicName, ()) ->+ case lookupHelpTopic topicName of+ Nothing -> do+ let msg = ("Unknown help topic: `" <> topicName <> "`. " <>+ (T.unlines $ "Available topics are:" : knownTopics))+ knownTopics = (" - " <>) <$> helpTopicName <$> helpTopics+ postErrorMessage msg+ Just topic -> showHelpScreen topic , Cmd "sh" "List the available shell scripts" NoArg $ \ () -> listScripts , Cmd "sh" "Run a prewritten shell script"- (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do- fpMb <- liftIO $ locateScriptPath (T.unpack script)- case fpMb of- ScriptPath scriptPath -> do- doAsyncWith Preempt $ runScript scriptPath text- NonexecScriptPath scriptPath -> do- let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <>- "executed. Try running\n" <>- "```\n" <>- "$ chmod u+x " <> T.pack scriptPath <> "\n" <>- "```\n" <>- "to correct this error. " <> scriptHelpAddendum)- postErrorMessage msg- ScriptNotFound -> do- let msg = ("No script named " <> script <> " was found")- postErrorMessage msg+ (TokenArg "script" (LineArg "message")) $ \ (script, text) ->+ findAndRunScript script text , Cmd "me" "Send an emote message" (LineArg "message") $ \msg -> execMMCommand "me" msg@@ -107,52 +89,10 @@ , Cmd "shrug" "Send a message followed by a shrug emoticon" (LineArg "message") $ \msg -> execMMCommand "shrug" msg- ] -scriptHelpAddendum :: T.Text-scriptHelpAddendum =- "For more help with scripts, run the command\n" <>- "```\n/help scripts\n```\n"--runScript :: FilePath -> T.Text -> IO (MH ())-runScript fp text = do- (code, stdout, stderr) <- readProcessWithExitCode fp [] (T.unpack text)- case code of- ExitSuccess -> return $ do- mode <- use (csEditState.cedEditMode)- sendMessage mode (T.pack stdout)- ExitFailure _ -> return $ do- let msgText = "The script `" <> T.pack fp <> "` exited with a " <>- "non-zero exit code."- msgText' = if stderr == ""- then msgText- else msgText <> " It also produced the " <>- "following output on stderr:\n~~~~~\n" <>- T.pack stderr <> "~~~~~\n" <> scriptHelpAddendum- postErrorMessage msgText'--listScripts :: MH ()-listScripts = do- (execs, nonexecs) <- liftIO getAllScripts- let scripts = ("Available scripts are:\n" <>- mconcat [ " - " <> T.pack cmd <> "\n"- | cmd <- execs- ])- postInfoMessage scripts- case nonexecs of- [] -> return ()- _ -> do- let errMsg = ("Some non-executable script files are also " <>- "present. If you want to run these as scripts " <>- "in Matterhorn, mark them executable with \n" <>- "```\n" <>- "$ chmod u+x [script path]\n" <>- "```\n" <>- "\n" <>- mconcat [ " - " <> T.pack cmd <> "\n"- | cmd <- nonexecs- ] <> "\n" <> scriptHelpAddendum)- postErrorMessage errMsg+ , Cmd "flags" "Open up a pane of flagged posts" NoArg $ \ () ->+ enterFlaggedPostListMode+ ] dispatchCommand :: T.Text -> MH () dispatchCommand cmd =
src/Config.hs view
@@ -29,18 +29,21 @@ fromIni :: IniParser Config fromIni = do section "mattermost" $ do- configUser <- fieldMb "user"- configHost <- fieldMb "host"- configTeam <- fieldMb "team"+ configUser <- fieldMbOf "user" stringField+ configHost <- fieldMbOf "host" stringField+ configTeam <- fieldMbOf "team" stringField configPort <- fieldDefOf "port" number (configPort defaultConfig)- configTimeFormat <- fieldMb "timeFormat"- configDateFormat <- fieldMb "dateFormat"- configTheme <- fieldMb "theme"- configURLOpenCommand <- fieldMb "urlOpenCommand"+ configTimeFormat <- fieldMbOf "timeFormat" stringField+ configDateFormat <- fieldMbOf "dateFormat" stringField+ configTheme <- fieldMbOf "theme" stringField+ configAspellDictionary <- fieldMbOf "aspellDictionary" stringField+ configURLOpenCommand <- fieldMbOf "urlOpenCommand" stringField configSmartBacktick <- fieldFlagDef "smartbacktick" (configSmartBacktick defaultConfig) configShowMessagePreview <- fieldFlagDef "showMessagePreview" (configShowMessagePreview defaultConfig)+ configEnableAspell <- fieldFlagDef "enableAspell"+ (configEnableAspell defaultConfig) configActivityBell <- fieldFlagDef "activityBell" (configActivityBell defaultConfig) configPass <- (Just . PasswordCommand <$> field "passcmd") <|>@@ -48,6 +51,26 @@ pure Nothing return Config { .. } +stringField :: T.Text -> Either String T.Text+stringField t =+ case isQuoted t of+ True -> Right $ parseQuotedString t+ False -> Right t++parseQuotedString :: T.Text -> T.Text+parseQuotedString t =+ let body = T.drop 1 $ T.init t+ unescapeQuotes s | T.null s = s+ | "\\\"" `T.isPrefixOf` s = "\"" <> unescapeQuotes (T.drop 2 s)+ | otherwise = (T.singleton $ T.head s) <> unescapeQuotes (T.drop 1 s)+ in unescapeQuotes body++isQuoted :: T.Text -> Bool+isQuoted t =+ let quote = "\""+ in (quote `T.isPrefixOf` t) &&+ (quote `T.isSuffixOf` t)+ defaultConfig :: Config defaultConfig = Config { configUser = Nothing@@ -62,6 +85,8 @@ , configURLOpenCommand = Nothing , configActivityBell = False , configShowMessagePreview = False+ , configEnableAspell = False+ , configAspellDictionary = Nothing } findConfig :: Maybe FilePath -> IO (Either String Config)
src/Draw.hs view
@@ -10,6 +10,7 @@ import Draw.ShowHelp import Draw.LeaveChannelConfirm import Draw.DeleteChannelConfirm+import Draw.PostListOverlay import Draw.JoinChannel draw :: ChatState -> [Widget Name]@@ -18,10 +19,11 @@ Main -> drawMain st ChannelScroll -> drawMain st UrlSelect -> drawMain st- ShowHelp screen -> drawShowHelp screen st+ ShowHelp topic -> drawShowHelp topic st ChannelSelect -> drawMain st LeaveChannelConfirm -> drawLeaveChannelConfirm st JoinChannel -> drawJoinChannel st MessageSelect -> drawMain st MessageSelectDeleteConfirm -> drawMain st DeleteChannelConfirm -> drawDeleteChannelConfirm st+ PostListOverlay contents -> drawPostListOverlay contents st
+ src/Draw/ChannelList.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE MultiWayIf #-}++-- | This module provides the Drawing functionality for the+-- ChannelList sidebar. The sidebar is divided vertically into groups+-- and each group is rendered separately.+--+-- There are actually two UI modes handled by this code:+--+-- * Normal display of the channels, with various markers to+-- indicate the current channel, channels with unread messages,+-- user state (for Direct Message channels), etc.+--+-- * ChannelSelect display where the user is typing match characters+-- into a prompt at the ChannelList sidebar is showing only those+-- channels matching the entered text (and highlighting the+-- matching portion).++module Draw.ChannelList (renderChannelList) where++import Brick+import Brick.Widgets.Border+import qualified Data.HashMap.Strict as HM+import Data.Monoid ((<>))+import qualified Data.Text as T+import Draw.Util+import Lens.Micro.Platform+import State+import Themes+import Types+import Types.Users+import Types.Channels++type GroupName = T.Text++-- | Specify the different groups of channels to be displayed+-- vertically in the ChannelList sidebar. This list provides the+-- central control over what channels are displayed and how they are+-- grouped.+--+-- Each group is specified as a tuple of:+--+-- * the name of this group+--+-- * A lens to get the HashMap of matching selections when in+-- ChannelSelect mode (ignored for Normal mode).+--+-- * The function to retrieve the list of channels for this group+-- from the ChatState.+channelListGroups :: [ ( GroupName+ , Getting ChannelSelectMap ChatState ChannelSelectMap+ , ChatState -> [ChannelListEntry]+ ) ]+channelListGroups =+ [ ("Channels", csChannelSelectChannelMatches, getOrdinaryChannels)+ , ("Users", csChannelSelectUserMatches, getDmChannels)+ ]++-- | True if there is an active channel selection operation (i.e. in+-- ChannelSelect mode). This requires both the state change *and*+-- some channel selection text.+hasActiveChannelSelection :: ChatState -> Bool+hasActiveChannelSelection st =+ st^.csMode == ChannelSelect && not (T.null (st^.csChannelSelectString))++-- | This is the main function that is called from external code to+-- render the ChannelList sidebar.+renderChannelList :: ChatState -> Widget Name+renderChannelList st =+ let maybeViewport = if hasActiveChannelSelection st+ then id -- no viewport scrolling when actively selecting a channel+ else viewport ChannelList Vertical+ renderedGroups = if hasActiveChannelSelection st+ then renderChannelGroup renderChannelSelectListEntry <$> selectedGroupEntries+ else renderChannelGroup renderChannelListEntry <$> plainGroupEntries+ plainGroupEntries (n, _m, f) = (n, f st)+ selectedGroupEntries (n, m, f) = (n, foldr (addSelectedChannel m) [] $ f st)+ addSelectedChannel m e s = case HM.lookup (entryLabel e) (st^.m) of+ Just y -> SCLE e y : s+ Nothing -> s+ in maybeViewport $ vBox $ concat $ renderedGroups <$> channelListGroups++-- | Renders a specific group, given the name of the group and the+-- list of entries in that group (which are expected to be either+-- ChannelListEntry or SelectedChannelListEntry elements).+renderChannelGroup :: (a -> Widget Name) -> (GroupName, [a]) -> [Widget Name]+renderChannelGroup eRender (groupName, entries) =+ let header label = hBorderWithLabel $ withDefAttr channelListHeaderAttr $ txt label+ in header groupName : (eRender <$> entries)++-- | Internal record describing each channel entry and its associated+-- attributes. This is the object passed to the rendering function so+-- that it can determine how to render each channel.+data ChannelListEntry =+ ChannelListEntry { entrySigil :: T.Text+ , entryLabel :: T.Text+ , entryHasUnread :: Bool+ , entryMentions :: Int+ , entryIsRecent :: Bool+ , entryIsCurrent :: Bool+ , entryUserStatus :: Maybe UserStatus+ }++-- | Similar to the ChannelListEntry, but also holds information about+-- the matching channel select specification.+data SelectedChannelListEntry = SCLE ChannelListEntry ChannelSelectMatch++-- | Render an individual Channel List entry (in Normal mode) with+-- appropriate visual decorations.+renderChannelListEntry :: ChannelListEntry -> Widget Name+renderChannelListEntry entry =+ decorate $ decorateRecent entry $ decorateMentions $ padRight Max $+ entryWidget $ entrySigil entry <> entryLabel entry+ where+ decorate = if | entryIsCurrent entry ->+ visible . forceAttr currentChannelNameAttr+ | entryMentions entry > 0 ->+ forceAttr mentionsChannelAttr+ | entryHasUnread entry ->+ forceAttr unreadChannelAttr+ | otherwise -> id+ entryWidget = case entryUserStatus entry of+ Just Offline -> withDefAttr clientMessageAttr . txt+ Just _ -> colorUsername+ Nothing -> txt+ decorateMentions+ | entryMentions entry > 9 =+ (<+> str "(9+)")+ | entryMentions entry > 0 =+ (<+> str ("(" <> show (entryMentions entry) <> ")"))+ | otherwise = id+++-- | 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) =+ let ChannelSelectMatch preMatch inMatch postMatch = match+ in decorateRecent entry $ padRight Max $+ hBox [ txt $ entrySigil entry+ , txt preMatch+ , forceAttr channelSelectMatchAttr $ txt inMatch+ , txt postMatch+ ]++-- | If this channel is the most recently viewed channel (prior to the+-- currently viewed channel), add a decoration to denote that.+decorateRecent :: ChannelListEntry -> Widget n -> Widget n+decorateRecent entry = if entryIsRecent entry+ then (<+> (withDefAttr recentMarkerAttr $ str "<"))+ else id++-- | Extract the names and information about normal channels to be+-- displayed in the ChannelList sidebar.+getOrdinaryChannels :: ChatState -> [ChannelListEntry]+getOrdinaryChannels st =+ [ ChannelListEntry sigil n unread mentions recent current Nothing+ | n <- (st ^. csNames . cnChans)+ , let Just chan = st ^. csNames . cnToChanId . at n+ unread = hasUnread st chan+ recent = Just chan == st^.csRecentChannel+ current = isCurrentChannel st chan+ sigil = case st ^. csLastChannelInput . at chan of+ Nothing -> T.singleton normalChannelSigil+ Just ("", _) -> T.singleton normalChannelSigil+ _ -> "»"+ mentions = maybe 0 id (st^?csChannel(chan).ccInfo.cdMentionCount)+ ]++-- | Extract the names and information about Direct Message channels+-- to be displayed in the ChannelList sidebar.+getDmChannels :: ChatState -> [ChannelListEntry]+getDmChannels st =+ [ ChannelListEntry sigil uname unread mentions recent current (Just $ u^.uiStatus)+ | u <- sortedUserList st+ , let sigil =+ case do { cId <- m_chanId; st^.csLastChannelInput.at cId } of+ Nothing -> T.singleton $ userSigilFromInfo u+ Just ("", _) -> T.singleton $ userSigilFromInfo u+ _ -> "»" -- shows that user has a message in-progress+ uname = u^.uiName+ recent = maybe False ((== st^.csRecentChannel) . Just) m_chanId+ m_chanId = st^.csNames.cnToChanId.at (u^.uiName)+ unread = maybe False (hasUnread st) m_chanId+ current = maybe False (isCurrentChannel st) m_chanId+ mentions = case m_chanId of+ Just cId -> maybe 0 id (st^?csChannel(cId).ccInfo.cdMentionCount)+ Nothing -> 0+ ]
src/Draw/DeleteChannelConfirm.hs view
@@ -13,6 +13,7 @@ import Lens.Micro.Platform ((^.)) import Types+import Types.Channels ( ccInfo, cdName ) import Themes import Draw.Main
src/Draw/LeaveChannelConfirm.hs view
@@ -13,6 +13,7 @@ import Lens.Micro.Platform ((^.)) import Types+import Types.Channels ( ccInfo, cdName ) import Themes import Draw.Main
src/Draw/Main.hs view
@@ -20,18 +20,17 @@ import Data.Time.LocalTime ( TimeZone, utcToLocalTime , localTimeToUTC, localDay , LocalTime(..), midnight )-import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq+import qualified Data.Set as S import qualified Data.Foldable as F-import Data.HashMap.Strict ( HashMap ) import Data.List (intersperse)-import qualified Data.Map.Strict as Map-import Data.Maybe (listToMaybe, maybeToList, catMaybes, isJust)+import Data.Maybe (catMaybes, isJust) import Data.Monoid ((<>)) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Text.Zipper (cursorPosition, insertChar, getText, gotoEOL)+import Data.Char (isSpace, isPunctuation) import Lens.Micro.Platform import Network.Mattermost@@ -41,159 +40,25 @@ import Markdown import State-import State.Common import Themes import Types+import Types.Channels ( NewMessageIndicator(..)+ , ChannelState(..)+ , ccInfo, ccContents+ , cdCurrentState+ , cdName, cdType, cdHeader, cdMessages+ , findChannelById) import Types.Posts import Types.Messages+import Types.Users+import Draw.ChannelList (renderChannelList)+import Draw.Messages import Draw.Util -renderChatMessage :: UserSet -> ChannelSet -> (UTCTime -> Widget Name) -> Message -> Widget Name-renderChatMessage uSet cSet renderTimeFunc msg =- let m = renderMessage msg True uSet cSet- msgAtch = if Seq.null (msg^.mAttachments)- then emptyWidget- else withDefAttr clientMessageAttr $ vBox- [ txt (" [attached: `" <> a^.attachmentName <> "`]")- | a <- F.toList (msg^.mAttachments)- ]- msgReac = if Map.null (msg^.mReactions)- then emptyWidget- else let renderR e 1 = " [" <> e <> "]"- renderR e n- | n > 1 = " [" <> e <> " " <> T.pack (show n) <> "]"- | otherwise = ""- reacMsg = Map.foldMapWithKey renderR (msg^.mReactions)- in withDefAttr emojiAttr $ txt (" " <> reacMsg)- msgTxt =- case msg^.mUserName of- Just _- | msg^.mType == CP Join || msg^.mType == CP Leave ->- withDefAttr clientMessageAttr m- | otherwise -> m- Nothing ->- case msg^.mType of- C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m)- C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m)- C Error -> withDefAttr errorMessageAttr m- _ -> withDefAttr clientMessageAttr m- fullMsg = msgTxt <=> msgAtch <=> msgReac- maybeRenderTime w = renderTimeFunc (msg^.mDate) <+> txt " " <+> w- maybeRenderTimeWith f = case msg^.mType of- C DateTransition -> id- C NewMessagesTransition -> id- _ -> f- in maybeRenderTimeWith maybeRenderTime fullMsg channelListWidth :: Int channelListWidth = 20 -renderChannelList :: ChatState -> Widget Name-renderChannelList st = hLimit channelListWidth $ maybeViewport $- vBox $ concat $ renderChannelGroup st <$> channelGroups- where- -- Only render the channel list in a viewport if we're not in- -- channel select mode, since we don't want or need the viewport- -- state to be affected by channel select input.- maybeViewport = if st^.csMode == ChannelSelect- then id- else viewport ChannelList Vertical- channelGroups = [ ( "Channels"- , getOrdinaryChannels st- , st^.csChannelSelectChannelMatches- )- , ( "Users"- , getDmChannels st- , st^.csChannelSelectUserMatches- )- ]--renderChannelGroup :: ChatState- -> (T.Text, [ChannelListEntry], HM.HashMap T.Text ChannelSelectMatch)- -> [Widget Name]-renderChannelGroup st (groupName, entries, csMatches) =- let header label = hBorderWithLabel $ withDefAttr channelListHeaderAttr $ txt label- in header groupName : (renderChannelListEntry st csMatches <$> entries)--data ChannelListEntry =- ChannelListEntry { entryChannelName :: T.Text- , entrySigil :: T.Text- , entryLabel :: T.Text- , entryMakeWidget :: T.Text -> Widget Name- , entryHasUnread :: Bool- , entryIsRecent :: Bool- }--renderChannelListEntry :: ChatState- -> HM.HashMap T.Text ChannelSelectMatch- -> ChannelListEntry- -> Widget Name-renderChannelListEntry st csMatches entry =- decorate $ decorateRecent $ padRight Max $- entryMakeWidget entry $ entrySigil entry <> entryLabel entry- where- decorate = if | matches -> const $- let Just (ChannelSelectMatch preMatch inMatch postMatch) =- HM.lookup (entryLabel entry) csMatches- in (txt $ entrySigil entry)- <+> txt preMatch- <+> (forceAttr channelSelectMatchAttr $ txt inMatch)- <+> txt postMatch- | isChanSelect &&- (not $ T.null $ st^.csChannelSelectString) -> const emptyWidget- | current ->- if isChanSelect- then forceAttr currentChannelNameAttr- else visible . forceAttr currentChannelNameAttr- | entryHasUnread entry ->- forceAttr unreadChannelAttr- | otherwise -> id-- decorateRecent = if entryIsRecent entry- then (<+> (withDefAttr recentMarkerAttr $ str "<"))- else id-- matches = isChanSelect && (HM.member (entryLabel entry) csMatches) &&- (not $ T.null $ st^.csChannelSelectString)-- isChanSelect = st^.csMode == ChannelSelect- current = entryChannelName entry == currentChannelName- currentChannelName = st^.csCurrentChannel.ccInfo.cdName--getOrdinaryChannels :: ChatState -> [ChannelListEntry]-getOrdinaryChannels st =- [ ChannelListEntry n sigil n txt unread recent- | n <- (st ^. csNames . cnChans)- , let Just chan = st ^. csNames . cnToChanId . at n- unread = hasUnread st chan- recent = Just chan == st^.csRecentChannel- sigil = case st ^. csLastChannelInput . at chan of- Nothing -> T.singleton normalChannelSigil- Just ("", _) -> T.singleton normalChannelSigil- _ -> "»"- ]--getDmChannels :: ChatState -> [ChannelListEntry]-getDmChannels st =- [ ChannelListEntry cname sigil uname colorUsername' unread recent- | u <- sortedUserList st- , let colorUsername' =- if | u^.uiStatus == Offline ->- withDefAttr clientMessageAttr . txt- | otherwise ->- colorUsername- sigil =- case do { cId <- m_chanId; st^.csLastChannelInput.at cId } of- Nothing -> T.singleton $ userSigilFromInfo u- Just ("", _) -> T.singleton $ userSigilFromInfo u- _ -> "»"- uname = u^.uiName- cname = getDMChannelName (st^.csMe^.userIdL) (u^.uiId)- recent = maybe False ((== st^.csRecentChannel) . Just) m_chanId- m_chanId = st^.csNames.cnToChanId.at (u^.uiName)- unread = maybe False (hasUnread st) m_chanId- ]- previewFromInput :: T.Text -> T.Text -> Maybe Message previewFromInput _ s | s == T.singleton cursorSentinel = Nothing previewFromInput uname s =@@ -222,30 +87,172 @@ , _mPostId = Nothing , _mReactions = mempty , _mOriginalPost = Nothing+ , _mFlagged = False+ , _mChannelId = Nothing } +-- | Tokens in spell check highlighting.+data Token =+ Ignore T.Text+ -- ^ This bit of text is to be ignored for the purposes of+ -- spell-checking.+ | Check T.Text+ -- ^ This bit of text should be checked against the spell checker's+ -- misspelling list.+ deriving (Show)++drawEditorContents :: UserSet -> ChannelSet -> ChatState -> [T.Text] -> Widget Name+drawEditorContents uSet cSet st =+ let noHighlight = txt . T.unlines+ in case st^.csEditState.cedSpellChecker of+ Nothing -> noHighlight+ Just _ ->+ case S.null (st^.csEditState.cedMisspellings) of+ True -> noHighlight+ False -> doHighlightMisspellings uSet cSet (st^.csEditState.cedMisspellings)++-- | This function takes a set of misspellings from the spell+-- checker, the editor lines, and builds a rendering of the text with+-- misspellings highlighted.+--+-- This function processes each line of text from the editor as follows:+--+-- * Tokenize the line based on our rules for what constitutes+-- whitespace. We do this because we need to check "words" in the+-- user's input against the list of misspellings returned by the spell+-- checker. But to do this we need to ignore the same things that+-- Aspell ignores, and it ignores whitespace and lots of puncutation.+-- We also do this because once we have identified the misspellings+-- present in the input, we need to reconstruct the user's input and+-- that means preserving whitespace so that the input looks as it was+-- originally typed.+--+-- * Once we have a list of tokens -- the whitespace tokens to be+-- preserved but ignored and the tokens to be checked -- we check+-- each non-whitespace token for presence in the list of misspellings+-- reported by the checker.+--+-- * Having indicated which tokens correspond to misspelled words, we+-- then need to coallesce adjacent tokens that are of the same+-- "misspelling status", i.e., two neighboring tokens (of whitespace+-- or check type) need to be coallesced if they both correspond to+-- text that is a misspelling or if they both are NOT a misspelling.+-- We do this so that the final Brick widget is optimal in that it+-- uses a minimal number of box cells to display substrings that have+-- the same attribute.+--+-- * Finally we build a widget out of these coallesced tokens and apply+-- the misspellingAttr attribute to the misspelled tokens.+--+-- Note that since we have to come to our own conclusion about which+-- words are worth checking in the checker's output, sometimes our+-- algorithm will differ from aspell in what is considered "part of a+-- word" and what isn't. In particular, Aspell is smart about sometimes+-- noticing that "'" is an apostrophe and at other times that it is+-- a single quote as part of a quoted string. As a result there will+-- be cases where Markdown formatting characters interact poorly+-- with Aspell's checking to result in misspellings that are *not*+-- highlighted.+--+-- One way to deal with this would be to *not* parse the user's input+-- as done here, complete with all its Markdown metacharacters, but to+-- instead 1) parse the input as Markdown, 2) traverse the Markdown AST+-- and extract the words from the relevant subtrees, and 3) spell-check+-- those words. The reason we don't do it that way in the first place is+-- because 1) the user's input might not be valid markdown and 2) even+-- if we did that, we'd still have to do this tokenization operation to+-- annotate misspellings and reconstruct the user's raw input.+doHighlightMisspellings :: UserSet -> ChannelSet -> S.Set T.Text -> [T.Text] -> Widget Name+doHighlightMisspellings uSet cSet misspellings contents =+ -- Traverse the input, gathering non-whitespace into tokens and+ -- checking if they appear in the misspelling collection+ let whitelist = S.union uSet cSet++ handleLine t | t == "" = txt " "+ handleLine t =+ -- For annotated tokens, coallesce tokens of the same type+ -- and add attributes for misspellings.+ let mkW (Left tok) =+ let s = getTokenText tok+ in if T.null s+ then emptyWidget+ else withDefAttr misspellingAttr $ txt $ getTokenText tok+ mkW (Right tok) =+ let s = getTokenText tok+ in if T.null s+ then emptyWidget+ else txt s++ go :: Either Token Token -> [Either Token Token] -> [Either Token Token]+ go lst [] = [lst]+ go lst (tok:toks) =+ case (lst, tok) of+ (Left a, Left b) -> go (Left $ combineTokens a b) toks+ (Right a, Right b) -> go (Right $ combineTokens a b) toks+ _ -> lst : go tok toks++ in hBox $ mkW <$> (go (Right $ Ignore "") $ annotatedTokens t)++ combineTokens (Ignore a) (Ignore b) = Ignore $ a <> b+ combineTokens (Check a) (Check b) = Check $ a <> b+ combineTokens (Ignore a) (Check b) = Check $ a <> b+ combineTokens (Check a) (Ignore b) = Check $ a <> b++ getTokenText (Ignore a) = a+ getTokenText (Check a) = a++ annotatedTokens t =+ -- For every token, check on whether it is a misspelling.+ -- The result is Either Token Token where the Left is a+ -- misspelling and the Right is not.+ checkMisspelling <$> tokenize t (Ignore "")++ checkMisspelling t@(Ignore _) = Right t+ checkMisspelling t@(Check s) =+ if s `S.member` whitelist+ then Right t+ else if s `S.member` misspellings+ then Left t+ else Right t++ ignoreChar c = isSpace c || isPunctuation c || c == '`'++ tokenize t curTok+ | T.null t = [curTok]+ | ignoreChar $ T.head t =+ case curTok of+ Ignore s -> tokenize (T.tail t) (Ignore $ s <> (T.singleton $ T.head t))+ Check s -> Check s : tokenize (T.tail t) (Ignore $ T.singleton $ T.head t)+ | otherwise =+ case curTok of+ Ignore s -> Ignore s : tokenize (T.tail t) (Check $ T.singleton $ T.head t)+ Check s -> tokenize (T.tail t) (Check $ s <> (T.singleton $ T.head t))++ in vBox $ handleLine <$> contents+ renderUserCommandBox :: UserSet -> ChannelSet -> ChatState -> Widget Name renderUserCommandBox uSet cSet st = let prompt = txt $ case st^.csEditState.cedEditMode of Replying _ _ -> "reply> " Editing _ -> "edit> " NewPost -> "> "- inputBox = renderEditor True (st^.csCmdLine)+ inputBox = renderEditor (drawEditorContents uSet cSet st) True (st^.csCmdLine) curContents = getEditContents $ st^.csCmdLine multilineContent = length curContents > 1 multilineHints =- (borderElem bsHorizontal) <+>- (str $ "[" <> (show $ (+1) $ fst $ cursorPosition $- st^.csCmdLine.editContentsL) <>- "/" <> (show $ length curContents) <> "]") <+>- (hBorderWithLabel $ withDefAttr clientEmphAttr $- (str "In multi-line mode. Press M-e to finish."))+ hBox [ borderElem bsHorizontal+ , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $+ st^.csCmdLine.editContentsL) <>+ "/" <> (show $ length curContents) <> "]"+ , hBorderWithLabel $ withDefAttr clientEmphAttr $+ str "In multi-line mode. Press M-e to finish."+ ] replyDisplay = case st^.csEditState.cedEditMode of Replying msg _ -> let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply in hBox [ replyArrow- , addEllipsis $ renderMessage msgWithoutParent True uSet cSet+ , addEllipsis $ renderMessage st msgWithoutParent True uSet cSet ] _ -> emptyWidget @@ -255,23 +262,18 @@ then "line" else "lines" numLines = length curContents- in vLimit 1 $- prompt <+> if multilineContent- then ((withDefAttr clientEmphAttr $- str $ "[" <> show numLines <> " " <> linesStr <>- "; Enter: send, M-e: edit, Backspace: cancel] ")) <+>- (txt $ head curContents) <+>- (showCursor MessageInput (Location (0,0)) $ str " ")- else inputBox+ in vLimit 1 $ hBox $+ prompt : if multilineContent+ then [ withDefAttr clientEmphAttr $+ str $ "[" <> show numLines <> " " <> linesStr <>+ "; Enter: send, M-e: edit, Backspace: cancel] "+ , txt $ head curContents+ , showCursor MessageInput (Location (0,0)) $ str " "+ ]+ else [inputBox] True -> vLimit 5 inputBox <=> multilineHints in replyDisplay <=> commandBox -maxMessageHeight :: Int-maxMessageHeight = 200--renderSingleMessage :: ChatState -> UserSet -> ChannelSet -> Message -> Widget Name-renderSingleMessage st uSet cSet = renderChatMessage uSet cSet (withBrackets . renderTime st)- renderCurrentChannelDisplay :: UserSet -> ChannelSet -> ChatState -> Widget Name renderCurrentChannelDisplay uSet cSet st = (header <+> conn) <=> messages where@@ -283,27 +285,39 @@ case T.null topicStr of True -> case chnType of Direct ->- case findUserByDMChannelName (st^.usrMap)+ case findUserByDMChannelName (st^.csUsers) chnName (st^.csMe^.userIdL) of Nothing -> txt $ mkChannelName (chan^.ccInfo)- Just u -> colorUsername $ mkDMChannelName u+ Just u -> userHeader u _ -> txt $ mkChannelName (chan^.ccInfo) False -> renderText $ mkChannelName (chan^.ccInfo) <> " - " <> topicStr- messages = body <+> txt " "+ userHeader u = let p1 = (colorUsername $ mkDMChannelName u)+ p2 = txt $ T.intercalate " " $ filter (not . T.null) parts+ parts = [ " is"+ , u^.uiFirstName+ , nick+ , u^.uiLastName+ , "<" <> u^.uiEmail <> ">"+ ]+ quote n = "\"" <> n <> "\""+ nick = maybe "" quote $ u^.uiNickName+ in p1 <+> p2+ messages = padTop Max $ padRight (Pad 1) body - body = chatText <=> case chan^.ccInfo.cdCurrentState of- ChanUnloaded -> withDefAttr clientMessageAttr $- txt "[Loading channel...]"- ChanLoadPending -> withDefAttr clientMessageAttr $- txt "[Loading channel...]"- ChanRefreshing -> withDefAttr clientMessageAttr $- txt "[Refreshing channel...]"- _ -> emptyWidget+ body = chatText+ <=> case chan^.ccInfo.cdCurrentState.to stateMessage of+ Nothing -> emptyWidget+ Just msg -> withDefAttr clientMessageAttr $ txt msg chatText = case st^.csMode of ChannelScroll ->+ -- n.b., In this mode, the output is cached and scrolled+ -- via the viewport. This means that newly received+ -- messages are *not* displayed, but this preserves the+ -- stability of the scrolling, which provides a better+ -- user experience. viewport (ChannelMessages cId) Vertical $ cached (ChannelMessages cId) $ vBox $ (withDefAttr loadMoreAttr $ hCenter $@@ -332,39 +346,8 @@ let (s, (before, after)) = splitMessages selPostId msgs in case s of Nothing -> renderLastMessages before- Just m -> unsafeMessageSelectList before after m-- unsafeMessageSelectList before after curMsg = Widget Greedy Greedy $ do- ctx <- getContext-- -- Render the message associated with the current post ID.- curMsgResult <- withReaderT relaxHeight $ render $- forceAttr messageSelectAttr $- padRight Max $ renderSingleMessage st uSet cSet curMsg-- let targetHeight = ctx^.availHeightL- upperHeight = targetHeight `div` 2- lowerHeight = targetHeight - upperHeight-- lowerRender = render1HLimit Vty.vertJoin targetHeight- upperRender = render1HLimit (flip Vty.vertJoin) targetHeight-- lowerHalf <- foldM lowerRender Vty.emptyImage after- upperHalf <- foldM upperRender Vty.emptyImage before-- let curHeight = Vty.imageHeight $ curMsgResult^.imageL- uncropped = upperHalf Vty.<-> curMsgResult^.imageL Vty.<-> lowerHalf- img = if Vty.imageHeight lowerHalf < (lowerHeight - curHeight)- then Vty.cropTop targetHeight uncropped- else if Vty.imageHeight upperHalf < upperHeight- then Vty.cropBottom targetHeight uncropped- else Vty.cropTop upperHeight upperHalf Vty.<->- curMsgResult^.imageL Vty.<->- (if curHeight < lowerHeight- then Vty.cropBottom (lowerHeight - curHeight) lowerHalf- else Vty.cropBottom lowerHeight lowerHalf)-- return $ emptyResult & imageL .~ img+ Just m ->+ unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st uSet cSet) channelMessages = insertTransitions (getDateFormat st)@@ -383,11 +366,10 @@ relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL)) - render1HLimit fjoin lim img msg = if Vty.imageHeight img >= lim- then return img- else fjoin img <$> render1 msg+ render1HLimit fjoin lim img msg+ | Vty.imageHeight img >= lim = return img+ | otherwise = fjoin img <$> render1 msg - render1 :: Message -> RenderM Name Vty.Image render1 msg = case msg^.mDeleted of True -> return Vty.emptyImage False -> do@@ -402,52 +384,58 @@ chnType = chan^.ccInfo.cdType topicStr = chan^.ccInfo.cdHeader ++-- | When displaying channel contents, it may be convenient to display+-- information about the current state of the channel.+stateMessage :: ChannelState -> Maybe T.Text+stateMessage ChanGettingInfo = Just "[Fetching channel information...]"+stateMessage ChanUnloaded = Just "[Channel content pending...]"+stateMessage ChanGettingPosts = Just "[Fetching channel content...]"+stateMessage ChanInitialSelect = Just "[channel initial content pending...]"+stateMessage ChanLoaded = Nothing+ getMessageListing :: ChannelId -> ChatState -> Messages getMessageListing cId st =- st ^. msgMap . ix cId . ccContents . cdMessages+ st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages -insertTransitions :: Text -> TimeZone -> Maybe UTCTime -> Messages -> Messages+insertTransitions :: Text -> TimeZone -> Maybe NewMessageIndicator -> Messages -> Messages insertTransitions datefmt tz cutoff ms = foldr addMessage ms transitions where transitions = newMessagesT <> dateT+ anyNondeletedNewMessages t =+ isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms) newMessagesT = case cutoff of- Nothing -> []- Just t -> [newMessagesMsg $ justBefore t]+ Nothing -> []+ Just Hide -> []+ Just (NewPostsAfterServerTime t)+ | anyNondeletedNewMessages t -> [newMessagesMsg $ justAfter t]+ | otherwise -> []+ Just (NewPostsStartingAt t)+ | anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t]+ | otherwise -> []+ dateT = fmap dateMsg dateRange dateRange = let dr = foldr checkDateChange [] ms in if length dr > 1 then tail dr else []- checkDateChange m [] = [dayStart $ m^.mDate]- checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate)+ checkDateChange m [] | m^.mDeleted = []+ | otherwise = [dayStart $ m^.mDate]+ checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate) || m^.mDeleted then dl else dayStart (m^.mDate) : dl dayOf = localDay . utcToLocalTime tz dayStart dt = localTimeToUTC tz $ LocalTime (dayOf dt) $ midnight justBefore (UTCTime d t) = UTCTime d $ pred t- dateMsg d = Message (getBlocks (T.pack $ formatTime defaultTimeLocale- (T.unpack datefmt)- (utcToLocalTime tz d)))- Nothing d (C DateTransition) False False- Seq.empty NotAReply Nothing mempty Nothing- newMessagesMsg d = Message (getBlocks (T.pack "New Messages"))- Nothing d (C NewMessagesTransition)- False False Seq.empty NotAReply- Nothing mempty Nothing---findUserByDMChannelName :: HashMap UserId UserInfo- -> T.Text -- ^ the dm channel name- -> UserId -- ^ me- -> Maybe UserInfo -- ^ you-findUserByDMChannelName userMap dmchan me = listToMaybe- [ user- | u <- HM.keys userMap- , getDMChannelName me u == dmchan- , user <- maybeToList (HM.lookup u userMap)- ]+ justAfter (UTCTime d t) = UTCTime d $ succ t+ dateMsg d = newMessageOfType (T.pack $ formatTime defaultTimeLocale+ (T.unpack datefmt)+ (utcToLocalTime tz d))+ (C DateTransition) d+ newMessagesMsg d = newMessageOfType (T.pack "New Messages")+ (C NewMessagesTransition) d renderChannelSelect :: ChatState -> Widget Name renderChannelSelect st = withDefAttr channelSelectPromptAttr $- (txt "Switch to channel: ") <+>+ (txt "Switch to channel [use ^ and $ to anchor]: ") <+> (showCursor ChannelSelectString (Location (T.length $ st^.csChannelSelectString, 0)) $ txt $ (if T.null $ st^.csChannelSelectString@@ -476,6 +464,8 @@ , (\m -> isMine st m && isDeletable m, "d", "delete") , (const hasURLs, "o", openUrlsMsg) , (const hasVerb, "y", "yank")+ , (\m -> not (m^.mFlagged), "f", "flag")+ , (\m -> m^.mFlagged , "f", "unflag") ] Just postMsg = getSelectedMessage st @@ -538,7 +528,7 @@ Nothing -> noPreview Just pm -> if T.null curStr then noPreview- else renderMessage pm True uSet cSet+ else renderMessage st pm True uSet cSet in (maybePreviewViewport msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]") @@ -565,22 +555,24 @@ mainInterface :: ChatState -> Widget Name mainInterface st =- (renderChannelList st <+> vBorder <+> mainDisplay)- <=> bottomBorder- <=> inputPreview uSet cSet st- <=> userInputArea uSet cSet st+ vBox [ hBox [hLimit channelListWidth (renderChannelList st), vBorder, mainDisplay]+ , bottomBorder+ , inputPreview uSet cSet st+ , userInputArea uSet cSet st+ ] where mainDisplay = case st^.csMode of UrlSelect -> renderUrlList st _ -> maybeSubdue $ renderCurrentChannelDisplay uSet cSet st- uSet = Set.fromList (map _uiName (HM.elems (st^.usrMap)))- cSet = Set.fromList (_cdName <$> _ccInfo <$> (HM.elems $ st^.msgMap))+ uSet = Set.fromList (st^..csUsers.to allUsers.folded.uiName)+ cSet = Set.fromList (st^..csChannels.folded.ccInfo.cdName) bottomBorder = case st^.csMode of MessageSelect -> messageSelectBottomBar st _ -> case st^.csCurrentCompletion of Just _ | length (st^.csEditState.cedCompletionAlternatives) > 1 -> completionAlternatives st- _ -> maybeSubdue $ hLimit channelListWidth hBorder <+> borderElem bsIntersectB <+> hBorder+ _ -> maybeSubdue $ hBox+ [hLimit channelListWidth hBorder, borderElem bsIntersectB, hBorder] maybeSubdue = if st^.csMode == ChannelSelect then forceAttr ""
+ src/Draw/Messages.hs view
@@ -0,0 +1,120 @@+module Draw.Messages where++import Brick+import Brick.Widgets.Border+import Control.Monad (foldM)+import Control.Monad.Trans.Reader (withReaderT)+import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map+import Data.Maybe (catMaybes)+import Data.Monoid ((<>))+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import Data.Time.Clock (UTCTime(..))+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform++import Draw.Util+import Markdown+import Themes+import Types+import Types.Posts+import Types.Messages++maxMessageHeight :: Int+maxMessageHeight = 200++renderSingleMessage :: ChatState -> UserSet -> ChannelSet -> Message -> Widget Name+renderSingleMessage st uSet cSet =+ renderChatMessage st 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+ msgAtch = if Seq.null (msg^.mAttachments)+ then Nothing+ else Just $ withDefAttr clientMessageAttr $ vBox+ [ txt (" [attached: `" <> a^.attachmentName <> "`]")+ | a <- F.toList (msg^.mAttachments)+ ]+ msgReac = if Map.null (msg^.mReactions)+ then Nothing+ else let renderR e 1 = " [" <> e <> "]"+ renderR e n+ | n > 1 = " [" <> e <> " " <> T.pack (show n) <> "]"+ | otherwise = ""+ reacMsg = Map.foldMapWithKey renderR (msg^.mReactions)+ in Just $ withDefAttr emojiAttr $ txt (" " <> reacMsg)+ msgTxt =+ case msg^.mUserName of+ Just _+ | msg^.mType == CP Join || msg^.mType == CP Leave ->+ withDefAttr clientMessageAttr m+ | otherwise -> m+ Nothing ->+ case msg^.mType of+ C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m)+ C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m)+ C Error -> withDefAttr errorMessageAttr m+ _ -> withDefAttr clientMessageAttr m+ fullMsg = hBox $ msgTxt : catMaybes [msgAtch, msgReac]+ maybeRenderTime w = hBox [renderTimeFunc (msg^.mDate), txt " ", w]+ maybeRenderTimeWith f = case msg^.mType of+ C DateTransition -> id+ C NewMessagesTransition -> id+ _ -> f+ in maybeRenderTimeWith maybeRenderTime fullMsg++-- | Render a selected message with focus, including the messages+-- before and the messages after it. The foldable parameters exist+-- because (depending on the situation) we might use either of the+-- message list types for the 'before' and 'after' (i.e. the+-- chronological or retrograde message sequences).+unsafeRenderMessageSelection ::+ (Foldable f, Foldable g) =>+ (Message, (f Message, g Message)) ->+ (Message -> Widget Name) ->+ Widget Name+unsafeRenderMessageSelection (curMsg, (before, after)) doMsgRender =+ Widget Greedy Greedy $ do+ let relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))++ render1HLimit fjoin lim img msg+ | Vty.imageHeight img >= lim = return img+ | otherwise = fjoin img <$> render1 msg++ render1 msg = case msg^.mDeleted of+ True -> return Vty.emptyImage+ False -> do+ r <- withReaderT relaxHeight $+ render $ padRight Max $+ doMsgRender msg+ return $ r^.imageL++ ctx <- getContext+ curMsgResult <- withReaderT relaxHeight $ render $+ forceAttr messageSelectAttr $+ padRight Max $ doMsgRender curMsg++ let targetHeight = ctx^.availHeightL+ upperHeight = targetHeight `div` 2+ lowerHeight = targetHeight - upperHeight++ lowerRender = render1HLimit Vty.vertJoin targetHeight+ upperRender = render1HLimit (flip Vty.vertJoin) targetHeight++ lowerHalf <- foldM lowerRender Vty.emptyImage after+ upperHalf <- foldM upperRender Vty.emptyImage before++ let curHeight = Vty.imageHeight $ curMsgResult^.imageL+ uncropped = upperHalf Vty.<-> curMsgResult^.imageL Vty.<-> lowerHalf+ img = if Vty.imageHeight lowerHalf < (lowerHeight - curHeight)+ then Vty.cropTop targetHeight uncropped+ else if Vty.imageHeight upperHalf < upperHeight+ then Vty.cropBottom targetHeight uncropped+ else Vty.cropTop upperHeight upperHalf Vty.<->+ curMsgResult^.imageL Vty.<->+ (if curHeight < lowerHeight+ then Vty.cropBottom (lowerHeight - curHeight) lowerHalf+ else Vty.cropBottom lowerHeight lowerHalf)+ return $ emptyResult & imageL .~ img
+ src/Draw/PostListOverlay.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE OverloadedStrings #-}++module Draw.PostListOverlay where++import Prelude ()+import Prelude.Compat++import Control.Monad.Trans.Reader (withReaderT)+import qualified Data.Foldable as F+import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Time.Format ( formatTime+ , defaultTimeLocale )+import Data.Time.LocalTime ( TimeZone, utcToLocalTime+ , localTimeToUTC, localDay+ , LocalTime(..), TimeOfDay(..) )+import qualified Data.Set as Set+import Lens.Micro.Platform+import Network.Mattermost+import Network.Mattermost.Lenses++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center++import Themes+import Types+import Types.Channels+import Types.Posts+import Types.Messages+import Types.Users+import Draw.Main+import Draw.Messages+import Draw.Util++hLimitWithPadding :: Int -> Widget n -> Widget n+hLimitWithPadding pad contents = Widget+ { hSize = Fixed+ , vSize = (vSize contents)+ , render =+ withReaderT (& availWidthL %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents+ }++drawPostListOverlay :: PostListContents -> ChatState -> [Widget Name]+drawPostListOverlay contents st =+ drawPostsBox contents st : (forceAttr "invalid" <$> drawMain st)++insertDateHeaders :: T.Text -> TimeZone -> Messages -> Messages+insertDateHeaders datefmt tz ms = foldr addMessage ms dateT+ where dateT = fmap dateMsg dateRange+ dateRange = foldr checkDateChange [] ms+ checkDateChange m [] = [dayStart $ m^.mDate]+ checkDateChange m dl = if dayOf (head dl) == dayOf (m^.mDate)+ then dl+ else dayStart (m^.mDate) : dl+ dayOf = localDay . utcToLocalTime tz+ dayStart dt = localTimeToUTC tz $ LocalTime (dayOf dt) $ TimeOfDay 23 59 59+ dateMsg d = newMessageOfType+ (T.pack $ formatTime defaultTimeLocale+ (T.unpack datefmt)+ (utcToLocalTime tz d))+ (C DateTransition) d++-- | Draw a PostListOverlay as a floating overlay on top of whatever+-- is rendered beneath it+drawPostsBox :: PostListContents -> ChatState -> Widget Name+drawPostsBox contents st =+ centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $+ padRight (Pad 1) messageListContents+ where -- The 'window title' of the overlay+ contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of+ PostListFlagged -> "Flagged posts"+ -- 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)++ messages = insertDateHeaders+ (getDateFormat st)+ (st^.timeZone)+ (st^.csPostListOverlay.postListPosts)++ -- The overall contents, with a sensible default even if there+ -- are no messages+ messageListContents+ | null (st^.csPostListOverlay.postListPosts) =+ padTopBottom 1 $+ hCenter $+ withDefAttr clientEmphAttr $+ str $ case contents of+ PostListFlagged -> "You have no flagged messages."+ | otherwise = vBox renderedMessageList++ -- The render-message function we're using+ renderMessageForOverlay msg =+ let renderedMsg = renderSingleMessage st 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+ Just post+ | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) ->+ case chan^.ccInfo.cdType of+ Direct+ | Just u <- findUserByDMChannelName (st^.csUsers)+ (chan^.ccInfo.cdName)+ (st^.csMe.userIdL) ->+ (forceAttr channelNameAttr (txt (T.singleton '@' <> u^.uiName)) <=>+ (str " " <+> renderedMsg))+ _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to mkChannelName)) <=>+ (str " " <+> renderedMsg))+ _ | CP _ <- msg^.mType -> str "[BUG: unknown channel]"+ | otherwise -> renderedMsg++ -- The full message list, rendered with the current selection+ renderedMessageList =+ let (s, (before, after)) = splitMessages (st^.csPostListOverlay.postListSelected) messages+ in case s of+ Nothing -> map renderMessageForOverlay (reverse (F.toList messages))+ Just curMsg ->+ [unsafeRenderMessageSelection (curMsg, (after, before)) renderMessageForOverlay]
src/Draw/ShowHelp.hs view
@@ -23,16 +23,99 @@ import Events.UrlSelect import Events.Main import Events.MessageSelect+import Events.PostListOverlay import State.Editing (editingKeybindings) import Markdown (renderText) import Options (mhVersion)+import HelpTopics (helpTopics) -drawShowHelp :: HelpScreen -> ChatState -> [Widget Name]-drawShowHelp screen = const [helpBox name widget]- where (name, widget) = case screen of- MainHelp -> (HelpText, mainHelp)- ScriptHelp -> (ScriptHelpText, scriptHelp)+drawShowHelp :: HelpTopic -> ChatState -> [Widget Name]+drawShowHelp topic st =+ [helpBox (helpTopicViewportName topic) $ helpTopicDraw topic st] +helpTopicDraw :: HelpTopic -> ChatState -> Widget Name+helpTopicDraw topic =+ case helpTopicScreen topic of+ MainHelp -> const mainHelp+ ScriptHelp -> const scriptHelp++mainHelp :: Widget Name+mainHelp = commandHelp+ where+ commandHelp = vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ str mhVersion+ , hCenter $ withDefAttr helpEmphAttr $ str mmApiVersion+ , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Help Topics"+ , drawHelpTopics+ , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands"+ , mkCommandHelpText $ sortBy (comparing commandName) commandList+ ] <>+ (mkKeybindingHelp <$> keybindSections)++ mkCommandHelpText :: [Cmd] -> Widget Name+ mkCommandHelpText cs =+ let helpInfo = [ (info, desc)+ | Cmd cmd desc args _ <- cs+ , let argSpec = printArgSpec args+ info = T.cons '/' cmd <> " " <> argSpec+ ]+ commandNameWidth = 4 + (maximum $ T.length <$> fst <$> helpInfo)+ in hCenter $+ vBox [ (withDefAttr helpEmphAttr $ txt $ padTo commandNameWidth info) <+> renderText desc+ | (info, desc) <- helpInfo+ ]++drawHelpTopics :: Widget Name+drawHelpTopics =+ let allHelpTopics = drawTopic <$> helpTopics+ topicNameWidth = 4 + (maximum $ T.length <$> helpTopicName <$> helpTopics)+ drawTopic t = (withDefAttr helpEmphAttr $ txt (padTo topicNameWidth $ helpTopicName t)) <+>+ txt (helpTopicDescription t)+ in (padBottom (Pad 1) $+ hCenter $ renderText "These topics can be used with the `/help` command:") <=>+ (hCenter $ vBox allHelpTopics)++scriptHelp :: Widget Name+scriptHelp = vBox+ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Scripts"+ , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox scriptHelpText+ ]+ where scriptHelpText = map (padTop (Pad 1) . renderText . mconcat)+ [ [ "Matterhorn has a special feature that allows you to use "+ , "prewritten shell scripts to preprocess messages. "+ , "For example, this can allow you to run various filters over "+ , "your written text, do certain kinds of automated formatting, "+ , "or just automatically cowsay-ify a message.\n" ]+ , [ "These scripts can be any kind of executable file, "+ , "as long as the file lives in "+ , "*~/.config/matterhorn/scripts* (unless you've explicitly "+ , "moved your XDG configuration directory elsewhere). "+ , "Those executables are given no arguments "+ , "on the command line and are passed your typed message on "+ , "*stdin*; whatever they produce on *stdout* is sent "+ , "as a message. If the script exits successfully, then everything "+ , "that appeared on *stderr* is discarded; if it instead exits with "+ , "a failing exit code, your message is *not* sent, and you are "+ , "presented with whatever was printed on stderr as a "+ , "local error message.\n" ]+ , [ "To run a script, simply type\n" ]+ , [ "> *> /sh [script-name] [my-message]*\n" ]+ , [ "And the script named *[script-name]* will be invoked with "+ , "the text of *[my-message]*. If the script does not exist, "+ , "or if it exists but is not marked as executable, you'll be "+ , "presented with an appropriate error message.\n" ]+ , [ "For example, if you want to use a basic script to "+ , "automatically ROT13 your message, you can write a shell "+ , "script using the standard Unix *tr* utility, like this:\n" ]+ , [ "> *#!/bin/bash -e*\n"+ , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*\n\n" ]+ , [ "Move this script to *~/.config/matterhorn/scripts/rot13* "+ , "and be sure it's executable with\n" ]+ , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*\n\n" ]+ , [ "after which you can send ROT13 messages with the "+ , "Matterhorn command " ]+ , [ "> *> /sh rot13 Hello, world!*\n" ]+ ]+ withMargins :: (Int, Int) -> Widget a -> Widget a withMargins (hMargin, vMargin) w = Widget (hSize w) (vSize w) $ do@@ -50,6 +133,7 @@ , ("Channel Scroll Mode", channelScrollKeybindings) , ("Message Select Mode", messageSelectKeybindings) , ("Text Editing", editingKeybindings)+ , ("Flagged Messages", postListOverlayKeybindings) ] helpBox :: Name -> Widget Name -> Widget Name@@ -61,29 +145,6 @@ where quitMessage = padTop (Pad 1) $ hCenter $ txt "Press Esc to exit the help screen." -mainHelp :: Widget Name-mainHelp = commandHelp- where- commandHelp = vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ str mhVersion- , hCenter $ withDefAttr helpEmphAttr $ str mmApiVersion- , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands"- , mkCommandHelpText $ sortBy (comparing commandName) commandList- ] <>- (mkKeybindingHelp <$> keybindSections)-- mkCommandHelpText :: [Cmd] -> Widget Name- mkCommandHelpText cs =- let helpInfo = [ (info, desc)- | Cmd cmd desc args _ <- cs- , let argSpec = printArgSpec args- info = T.cons '/' cmd <> " " <> argSpec- ]- commandNameWidth = 4 + (maximum $ T.length <$> fst <$> helpInfo)- in hCenter $- vBox [ (withDefAttr helpEmphAttr $ txt $ padTo commandNameWidth info) <+> renderText desc- | (info, desc) <- helpInfo- ]- kbColumnWidth :: Int kbColumnWidth = 12 @@ -136,45 +197,3 @@ padTo :: Int -> T.Text -> T.Text padTo n s = s <> T.replicate (n - T.length s) " "--scriptHelp :: Widget Name-scriptHelp = vBox- [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Using Scripts"- , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox scriptHelpText- ]- where scriptHelpText = map (padTop (Pad 1) . renderText . mconcat)- [ [ "Matterhorn has a special feature that allows you to use "- , "prewritten shell scripts to preprocess messages. "- , "For example, this can allow you to run various filters over "- , "your written text, do certain kinds of automated formatting, "- , "or just automatically cowsay-ify a message.\n" ]- , [ "These scripts can be any kind of executable file, "- , "as long as the file lives in "- , "*~/.config/matterhorn/scripts* (unless you've explicitly "- , "moved your XDG configuration directory elsewhere). "- , "Those executables are given no arguments "- , "on the command line and are passed your typed message on "- , "*stdin*; whatever they produce on *stdout* is sent "- , "as a message. If the script exits successfully, then everything "- , "that appeared on *stderr* is discarded; if it instead exits with "- , "a failing exit code, your message is *not* sent, and you are "- , "presented with whatever was printed on stderr as a "- , "local error message.\n" ]- , [ "To run a script, simply type\n" ]- , [ "> *> /sh [script-name] [my-message]*\n" ]- , [ "And the script named *[script-name]* will be invoked with "- , "the text of *[my-message]*. If the script does not exist, "- , "or if it exists but is not marked as executable, you'll be "- , "presented with an appropriate error message.\n" ]- , [ "For example, if you want to use a basic script to "- , "automatically ROT13 your message, you can write a shell "- , "script using the standard Unix *tr* utility, like this:\n" ]- , [ "> *#!/bin/bash -e*\n"- , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*\n\n" ]- , [ "Move this script to *~/.config/matterhorn/scripts/rot13* "- , "and be sure it's executable with\n" ]- , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*\n\n" ]- , [ "after which you can send ROT13 messages with the "- , "Matterhorn command " ]- , [ "> *> /sh rot13 Hello, world!*\n" ]- ]
src/Draw/Util.hs view
@@ -12,6 +12,8 @@ import Network.Mattermost import Types+import Types.Channels+import Types.Users import Themes defaultTimeFormat :: T.Text@@ -40,7 +42,7 @@ else withDefAttr timeAttr (txt timeStr) withBrackets :: Widget a -> Widget a-withBrackets w = str "[" <+> w <+> str "]"+withBrackets w = hBox [str "[", w, str "]"] userSigilFromInfo :: UserInfo -> Char userSigilFromInfo u = case u^.uiStatus of
src/Events.hs view
@@ -5,7 +5,9 @@ import Prelude.Compat import Brick+import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO)+import qualified Data.Set as Set import qualified Data.Text as T import Data.Monoid ((<>)) import qualified Graphics.Vty as Vty@@ -19,6 +21,7 @@ import State import State.Common import Types+import Types.Channels (ccInfo, cdHeader, cdMentionCount) import Events.ShowHelp import Events.Main@@ -29,6 +32,7 @@ import Events.DeleteChannelConfirm import Events.UrlSelect import Events.MessageSelect+import Events.PostListOverlay onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState) onEvent st ev = runMHEvent st $ case ev of@@ -47,7 +51,7 @@ csConnectionStatus .= Disconnected onAppEvent WebsocketConnect = do csConnectionStatus .= Connected- refreshLoadedChannels+ refreshChannels onAppEvent (WSEvent we) = handleWSEvent we onAppEvent (RespEvent f) = f@@ -80,6 +84,7 @@ MessageSelect -> onEventMessageSelect e MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e DeleteChannelConfirm -> onEventDeleteChannelConfirm e+ PostListOverlay _ -> onEventPostListOverlay e handleWSEvent :: WebsocketEvent -> MH () handleWSEvent we = do@@ -90,47 +95,66 @@ Just p -> do -- If the message is a header change, also update the channel -- metadata.+ myUserId <- use (csMe.userIdL) case postPropsNewHeader (p^.postPropsL) of- Just newHeader | postType p == SystemHeaderChange ->+ Just newHeader | postType p == PostTypeHeaderChange -> csChannel(postChannelId p).ccInfo.cdHeader .= newHeader _ -> return ()- addMessageToState p+ 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+ WMUserRemoved -> -- XXX return ()+ WMChannelDeleted -> -- XXX return ()+ WMDirectAdded -> -- XXX return ()+ WMChannelCreated -> -- XXX return ()+ WMGroupAdded -> -- XXX return ()+ WMLeaveTeam -> -- XXX: How do we deal with this one? return ()- -- An 'ephemeral message' is just MatterMost's version++ -- 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@@ -140,29 +164,48 @@ Just p -> do postInfoMessage (p^.postMessageL) Nothing -> return ()- -- Right now, we don't use any server preferences in- -- our client, but that might change- WMPreferenceChanged -> 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 ()+ -- 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 ()+ -- right now we don't show typing notifications. maybe -- we should? i dunno. WMTyping -> return ()+ -- Do we need to do anything with this? WMUpdateTeam -> return ()+ WMReactionAdded -> case wepReaction (weData we) of Just r -> case webChannelId (weBroadcast we) of- Just cId -> addReaction r cId+ Just cId -> addReactions cId [r] Nothing -> return () Nothing -> return ()+ WMReactionRemoved -> case wepReaction (weData we) of Just r -> case webChannelId (weBroadcast we) of Just cId -> removeReaction r cId Nothing -> return () Nothing -> return ()+ WMAddedToTeam -> return () -- XXX: we need to handle this+ WMWebRTC -> return ()+ WMAuthenticationChallenge -> return ()
src/Events/ChannelScroll.hs view
@@ -25,6 +25,10 @@ , KB "Cancel scrolling and return to channel view" (Vty.EvKey Vty.KEsc []) $ csMode .= Main+ , KB "Scroll to top" (Vty.EvKey Vty.KHome [])+ channelScrollToTop+ , KB "Scroll to bottom" (Vty.EvKey Vty.KEnd [])+ channelScrollToBottom ] onEventChannelScroll :: Vty.Event -> MH ()
src/Events/ChannelSelect.hs view
@@ -32,10 +32,15 @@ st <- use id let allMatches = (HM.elems $ st^.csChannelSelectChannelMatches) <> (HM.elems $ st^.csChannelSelectUserMatches)- case allMatches of- [single] -> do+ 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 () , KB "Cancel channel selection"
src/Events/Main.hs view
@@ -16,11 +16,14 @@ import Lens.Micro.Platform import Types+import Types.Channels (ccInfo, cdType, clearNewMessageIndicator) import State+import State.PostListOverlay (enterFlaggedPostListMode) import State.Editing import Command import Completion import InputHistory+import HelpTopics (mainHelpTopic) import Network.Mattermost (Type(..)) @@ -33,7 +36,7 @@ mainKeybindings = [ KB "Show this help screen" (Vty.EvKey (Vty.KFun 1) []) $- showHelpScreen MainHelp+ showHelpScreen mainHelpTopic , KB "Select a message to edit/reply/delete" (Vty.EvKey (Vty.KChar 's') [Vty.MCtrl]) $@@ -129,9 +132,8 @@ startUrlSelect , KB "Clear the current channel's unread message indicator"- (Vty.EvKey (Vty.KChar 'l') [Vty.MMeta]) $ do- cId <- use csCurrentChannelId- clearNewMessageCutoff cId+ (Vty.EvKey (Vty.KChar 'l') [Vty.MMeta]) $+ csCurrentChannel %= clearNewMessageIndicator , KB "Toggle multi-line message compose mode" (Vty.EvKey (Vty.KChar 'e') [Vty.MMeta]) $@@ -144,6 +146,10 @@ , KB "Cancel message reply or update" (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $ cancelReplyOrEdit++ , KB "View currently flagged posts"+ (Vty.EvKey (Vty.KChar '8') [Vty.MMeta]) $+ enterFlaggedPostListMode ] handleInputSubmission :: MH ()@@ -174,10 +180,10 @@ 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- let cInfo = st^.csChannel(cId).ccInfo- case cInfo^.cdType /= Group of- True -> Just cname- False -> Nothing+ let cType = st^?csChannel(cId).ccInfo.cdType+ case cType of+ Just Group -> Nothing+ _ -> Just cname ) priorities = [] :: [T.Text]-- XXX: add recent completions to this
src/Events/MessageSelect.hs view
@@ -78,4 +78,9 @@ , KB "Copy a verbatim section to the clipboard" (Vty.EvKey (Vty.KChar 'y') []) $ copyVerbatimToClipboard++ , KB "Flag the selected message"+ (Vty.EvKey (Vty.KChar 'f') []) $+ flagSelectedMessage+ ]
+ src/Events/PostListOverlay.hs view
@@ -0,0 +1,37 @@+module Events.PostListOverlay where++import qualified Graphics.Vty as Vty++import Types+import State.PostListOverlay++onEventPostListOverlay :: Vty.Event -> MH ()+onEventPostListOverlay e+ | Just kb <- lookupKeybinding e postListOverlayKeybindings =+ kbAction kb+onEventPostListOverlay _ = return ()++-- | The keybindings we want to use while viewing a post list overlay+postListOverlayKeybindings :: [Keybinding]+postListOverlayKeybindings =+ [ KB "Exit post browsing" (Vty.EvKey Vty.KEsc []) $+ exitPostListMode++ , KB "Exit post browsing" (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) $+ exitPostListMode++ , KB "Select the previous message" (Vty.EvKey (Vty.KChar 'k') []) $+ postListSelectUp++ , KB "Select the previous message" (Vty.EvKey Vty.KUp []) $+ postListSelectUp++ , KB "Select the next message" (Vty.EvKey (Vty.KChar 'j') []) $+ postListSelectDown++ , KB "Select the next message" (Vty.EvKey Vty.KDown []) $+ postListSelectDown++ , KB "Toggle the selected message flag" (Vty.EvKey (Vty.KChar 'f') []) $+ postListUnflagSelected+ ]
+ src/HelpTopics.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE OverloadedStrings #-}+module HelpTopics+ ( helpTopics+ , lookupHelpTopic++ , mainHelpTopic+ )+where++import Prelude ()+import Prelude.Compat++import qualified Data.Text as T+import Data.Maybe (listToMaybe)++import Types++helpTopics :: [HelpTopic]+helpTopics =+ [ mainHelpTopic+ , scriptHelpTopic+ ]++mainHelpTopic :: HelpTopic+mainHelpTopic =+ HelpTopic "main" "This help page" MainHelp HelpText++scriptHelpTopic :: HelpTopic+scriptHelpTopic =+ HelpTopic "scripts" "Help on available scripts" ScriptHelp ScriptHelpText++lookupHelpTopic :: T.Text -> Maybe HelpTopic+lookupHelpTopic topic =+ listToMaybe $ filter ((== topic) . helpTopicName) helpTopics
src/InputHistory.hs view
@@ -20,6 +20,8 @@ import qualified System.IO.Strict as S import qualified Data.Vector as V import Data.Text ( Text )+import qualified System.Posix.Files as P+import qualified System.Posix.Types as P import IOUtil import FilePaths@@ -38,6 +40,9 @@ removeChannelHistory :: ChannelId -> InputHistory -> InputHistory removeChannelHistory cId ih = ih & historyEntries.at cId .~ Nothing +historyFileMode :: P.FileMode+historyFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode+ writeHistory :: InputHistory -> IO () writeHistory ih = do historyFile <- historyFilePath@@ -45,6 +50,7 @@ let entries = (\(cId, z) -> (cId, V.toList z)) <$> (HM.toList $ ih^.historyEntries) writeFile historyFile $ show entries+ P.setFileMode historyFile historyFileMode readHistory :: IO (Either String InputHistory) readHistory = runExceptT $ do
src/Login.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-} module Login ( interactiveGatherCredentials ) where@@ -11,8 +13,11 @@ import Brick.Widgets.Center import Brick.Widgets.Border import Control.Monad.IO.Class (liftIO)+import Data.Char (isNumber) import Data.Maybe (isNothing)+import Data.Monoid ((<>)) import Text.Read (readMaybe)+import Lens.Micro.Platform import qualified Data.Text as T import Graphics.Vty hiding (Config) import System.Exit (exitSuccess)@@ -26,27 +31,48 @@ data Name = Hostname | Port | Username | Password deriving (Ord, Eq, Show) data State =- State { hostnameEdit :: Editor T.Text Name- , portEdit :: Editor T.Text Name- , usernameEdit :: Editor T.Text Name- , passwordEdit :: Editor T.Text Name- , focus :: Name- , previousError :: Maybe AuthenticationException+ State { _hostnameEdit :: Editor T.Text Name+ , _portEdit :: Editor T.Text Name+ , _usernameEdit :: Editor T.Text Name+ , _passwordEdit :: Editor T.Text Name+ , _focus :: Name+ , _previousError :: Maybe AuthenticationException } +makeLenses ''State+ toPassword :: [T.Text] -> Widget a toPassword s = txt $ T.replicate (T.length $ T.concat s) "*" +validHostname :: State -> Bool+validHostname st =+ all (flip notElem (":/"::String)) $ T.unpack $ T.concat $ getEditContents $ st^.hostnameEdit++validPort :: State -> Bool+validPort st =+ all isNumber $ T.unpack $ T.concat $ getEditContents $ st^.portEdit+ interactiveGatherCredentials :: Config -> Maybe AuthenticationException -> IO ConnectionInfo interactiveGatherCredentials config authError = do- let state = State { hostnameEdit = editor Hostname (txt . T.concat) (Just 1) hStr- , portEdit = editor Port (txt . T.concat) (Just 1) (T.pack $ show $ configPort config)- , usernameEdit = editor Username (txt . T.concat) (Just 1) uStr- , passwordEdit = editor Password toPassword (Just 1) pStr- , focus = initialFocus- , previousError = authError+ let state = newState config authError+ finalSt <- defaultMain app state+ let finalH = T.concat $ getEditContents $ finalSt^.hostnameEdit+ finalPort = read $ T.unpack $ T.concat $ getEditContents $ finalSt^.portEdit+ finalU = T.concat $ getEditContents $ finalSt^.usernameEdit+ finalPass = T.concat $ getEditContents $ finalSt^.passwordEdit+ return $ ConnectionInfo finalH finalPort finalU finalPass++newState :: Config -> Maybe AuthenticationException -> State+newState config authError = state+ where+ state = State { _hostnameEdit = editor Hostname (Just 1) hStr+ , _portEdit = editor Port (Just 1) (T.pack $ show $ configPort config)+ , _usernameEdit = editor Username (Just 1) uStr+ , _passwordEdit = editor Password (Just 1) pStr+ , _focus = initialFocus+ , _previousError = authError } hStr = maybe "" id $ configHost config uStr = maybe "" id $ configUser config@@ -57,12 +83,6 @@ | T.null uStr -> Username | T.null pStr -> Password | otherwise -> Hostname- finalSt <- defaultMain app state- let finalH = T.concat $ getEditContents $ hostnameEdit finalSt- finalPort = read $ T.unpack $ T.concat $ getEditContents $ portEdit finalSt- finalU = T.concat $ getEditContents $ usernameEdit finalSt- finalPass = T.concat $ getEditContents $ passwordEdit finalSt- return $ ConnectionInfo finalH finalPort finalU finalPass app :: App State e Name app = App@@ -90,66 +110,89 @@ errorMessageDisplay :: State -> Widget Name errorMessageDisplay st = do- case previousError st of+ case st^.previousError of Nothing -> emptyWidget- -- XXX- Just e -> txt " " <=>- (withDefAttr errorAttr $- hCenter (str "Error: " <+> renderAuthError e))+ Just e ->+ hCenter $ hLimit uiWidth $+ padTop (Pad 1) $ renderError $ renderText $+ "Error: " <> renderAuthError e -renderAuthError :: AuthenticationException -> Widget Name-renderAuthError (ConnectError _) = txt "Could not connect to server"-renderAuthError (ResolveError _) = txt "Could not resolve server hostname"-renderAuthError (OtherAuthError e) = str $ show e-renderAuthError (LoginError (LoginFailureException msg)) = str msg+renderAuthError :: AuthenticationException -> T.Text+renderAuthError (ConnectError _) =+ "Could not connect to server"+renderAuthError (ResolveError _) =+ "Could not resolve server hostname"+renderAuthError (OtherAuthError e) =+ T.pack $ show e+renderAuthError (LoginError (LoginFailureException msg)) =+ T.pack msg +renderError :: Widget a -> Widget a+renderError = withDefAttr errorAttr++uiWidth :: Int+uiWidth = 50+ credentialsForm :: State -> Widget Name credentialsForm st =- hCenter $ hLimit 50 $ vLimit 15 $+ hCenter $ hLimit uiWidth $ vLimit 15 $ border $- vBox [ renderText "Please enter your MatterMost credentials to log in."- , txt " "- , txt "Hostname:" <+> renderEditor (focus st == Hostname) (hostnameEdit st)- , txt " "- , txt "Port: " <+> renderEditor (focus st == Port) (portEdit st)- , txt " "- , txt "Username:" <+> renderEditor (focus st == Username) (usernameEdit st)- , txt " "- , txt "Password:" <+> renderEditor (focus st == Password) (passwordEdit st)- , txt " "- , renderText "Press Enter to log in or Esc to exit."+ vBox [ renderText "Please enter your Mattermost credentials to log in."+ , padTop (Pad 1) $+ txt "Hostname: " <+> renderEditor (txt . T.concat) (st^.focus == Hostname) (st^.hostnameEdit)+ , if validHostname st+ then txt " "+ else hCenter $ renderError $ txt "Invalid hostname"+ , txt "Port: " <+> renderEditor (txt . T.concat) (st^.focus == Port) (st^.portEdit)+ , if validPort st+ then txt " "+ else hCenter $ renderError $ txt "Invalid port"+ , txt "Username: " <+> renderEditor (txt . T.concat) (st^.focus == Username) (st^.usernameEdit)+ , padTop (Pad 1) $+ txt "Password: " <+> renderEditor toPassword (st^.focus == Password) (st^.passwordEdit)+ , padTop (Pad 1) $+ hCenter $ renderText "Press Enter to log in or Esc to exit." ] onEvent :: State -> BrickEvent Name e -> EventM Name (Next State) onEvent _ (VtyEvent (EvKey KEsc [])) = liftIO exitSuccess onEvent st (VtyEvent (EvKey (KChar '\t') [])) =- continue $ st { focus = if | focus st == Hostname -> Port- | focus st == Port -> Username- | focus st == Username -> Password- | focus st == Password -> Hostname- }+ continue $ st & focus %~ nextFocus onEvent st (VtyEvent (EvKey KEnter [])) =- -- check for valid (non-empty) contents- let h = T.concat $ getEditContents $ hostnameEdit st- u = T.concat $ getEditContents $ usernameEdit st- p = T.concat $ getEditContents $ passwordEdit st- port :: Maybe Int- port = readMaybe (T.unpack $ T.concat $ getEditContents $ portEdit st)- in case T.null h || T.null u || T.null p || isNothing port of- True -> continue st- False -> halt st-onEvent st (VtyEvent e) =- case focus st of- Hostname -> do- e' <- handleEditorEvent e (hostnameEdit st)- continue $ st { hostnameEdit = e' }- Port -> do- e' <- handleEditorEvent e (portEdit st)- continue $ st { portEdit = e' }- Username -> do- e' <- handleEditorEvent e (usernameEdit st)- continue $ st { usernameEdit = e' }- Password -> do- e' <- handleEditorEvent e (passwordEdit st)- continue $ st { passwordEdit = e' }+ if badState st then continue st else halt st+onEvent st (VtyEvent e) = do+ let target :: Lens' State (Editor T.Text Name)+ target = getFocusedEditor st+ continue =<< handleEventLensed st target handleEditorEvent e onEvent st _ = continue st++nextFocus :: Name -> Name+nextFocus Hostname = Port+nextFocus Port = Username+nextFocus Username = Password+nextFocus Password = Hostname++getFocusedEditor :: State -> Lens' State (Editor T.Text Name)+getFocusedEditor st =+ case st^.focus of+ Hostname -> hostnameEdit+ Port -> portEdit+ Username -> usernameEdit+ Password -> passwordEdit++badState :: State -> Bool+badState st = bad+ where+ -- check for valid (non-empty) contents+ h = T.concat $ getEditContents $ st^.hostnameEdit+ u = T.concat $ getEditContents $ st^.usernameEdit+ p = T.concat $ getEditContents $ st^.passwordEdit+ port :: Maybe Int+ port = readMaybe (T.unpack $ T.concat $ getEditContents $ st^.portEdit)+ bad = or [ T.null h+ , T.null u+ , T.null p+ , isNothing port+ , (not $ validHostname st)+ , (not $ validPort st)+ ]
src/Main.hs view
@@ -16,6 +16,7 @@ import Lens.Micro.Platform import System.Exit (exitFailure) import System.IO (IOMode(WriteMode), openFile, hClose)+import Text.Aspell (stopAspell) import Config import Options@@ -58,6 +59,11 @@ 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
src/Markdown.hs view
@@ -40,13 +40,14 @@ , viewl , viewr) import qualified Data.Sequence as S+import qualified Skylighting as Sky import Data.Set (Set) import qualified Data.Set as Set import qualified Graphics.Vty as V import Lens.Micro.Platform ((^.)) import Themes-import Types (userSigil, normalChannelSigil)+import Types (ChatState, getMessageForPostId, userSigil, normalChannelSigil) import Types.Posts import Types.Messages @@ -60,14 +61,8 @@ , CP TopicChange ] -getReplyToMessage :: Message -> Maybe Message-getReplyToMessage m =- case m^.mInReplyToMsg of- ParentLoaded _ parent -> Just parent- _ -> Nothing--renderMessage :: Message -> Bool -> UserSet -> ChannelSet -> Widget a-renderMessage msg renderReplyParent uSet cSet =+renderMessage :: ChatState -> Message -> Bool -> UserSet -> ChannelSet -> Widget a+renderMessage st msg renderReplyParent uSet cSet = let msgUsr = case msg^.mUserName of Just u | msg^.mType `elem` omitUsernameTypes -> Nothing@@ -75,19 +70,33 @@ Nothing -> Nothing mine = case msgUsr of Just un- | msg^.mType == CP Emote -> B.txt "*" <+> colorUsername un- <+> B.txt " " <+> renderMarkdown uSet cSet (msg^.mText)- | otherwise -> colorUsername un <+> B.txt ": " <+> renderMarkdown uSet cSet (msg^.mText)+ | msg^.mType == CP Emote ->+ hBox [ B.txt "*", colorUsername un+ , B.txt " "+ , renderMarkdown uSet cSet (msg^.mText)+ ]+ | msg^.mFlagged ->+ hBox [ colorUsername un+ , B.txt "[!]: "+ , renderMarkdown uSet cSet (msg^.mText)+ ]+ | otherwise ->+ hBox [ colorUsername un+ , B.txt ": "+ , renderMarkdown uSet cSet (msg^.mText)+ ] Nothing -> renderMarkdown uSet cSet (msg^.mText)- parent = if not renderReplyParent- then Nothing- else getReplyToMessage msg- in case parent of- Nothing -> mine- Just m -> let parentMsg = renderMessage m False uSet cSet- in (replyArrow <+>- (addEllipsis $ B.forceAttr replyParentAttr parentMsg))- B.<=> mine+ withParent p = (replyArrow <+> p) B.<=> mine+ in if not renderReplyParent+ then mine+ else case msg^.mInReplyToMsg of+ NotAReply -> mine+ InReplyTo parentId ->+ case getMessageForPostId st parentId of+ Nothing -> withParent (B.str "[loading...]")+ Just pm ->+ let parentMsg = renderMessage st pm False uSet cSet+ in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg) addEllipsis :: Widget a -> Widget a addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do@@ -153,20 +162,44 @@ instance ToWidget Block where toWidget uPat cPat (C.Para is) = toInlineChunk is uPat cPat toWidget uPat cPat (C.Header n is) =- B.withDefAttr clientHeaderAttr- (header n <+> B.txt " " <+> toInlineChunk is uPat cPat)+ 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) toWidget uPat cPat (C.List _ l bs) = toList l bs uPat cPat- toWidget _ _ (C.CodeBlock _ tx) =+ toWidget _ _ (C.CodeBlock ci tx) =+ let f = maybe rawCodeBlockToWidget codeBlockToWidget mSyntax+ mSyntax = Sky.lookupSyntax (C.codeLang ci) Sky.defaultSyntaxMap+ in f tx+ toWidget _ _ (C.HtmlBlock txt) = textWithCursor txt+ toWidget _ _ (C.HRule) = B.vLimit 1 (B.fill '*')++codeBlockToWidget :: Sky.Syntax -> T.Text -> Widget a+codeBlockToWidget syntax tx =+ let result = Sky.tokenize cfg syntax tx+ cfg = Sky.TokenizerConfig Sky.defaultSyntaxMap False+ in case result of+ Left _ -> rawCodeBlockToWidget tx+ Right tokLines ->+ let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)+ in padding <+> (B.vBox $ renderTokenLine <$> tokLines)++renderTokenLine :: Sky.SourceLine -> Widget a+renderTokenLine [] = B.str " "+renderTokenLine toks = B.hBox $ renderToken <$> toks++renderToken :: Sky.Token -> Widget a+renderToken (ty, tx) =+ B.withDefAttr (attrNameForTokenType ty) $ textWithCursor tx++rawCodeBlockToWidget :: T.Text -> Widget a+rawCodeBlockToWidget tx = B.withDefAttr codeAttr $ let padding = B.padLeftRight 1 (B.vLimit (length theLines) B.vBorder) theLines = expandEmpty <$> T.lines tx expandEmpty "" = " " expandEmpty s = s in padding <+> (B.vBox $ textWithCursor <$> theLines)- toWidget _ _ (C.HtmlBlock txt) = textWithCursor txt- toWidget _ _ (C.HRule) = B.vLimit 1 (B.fill '*') toInlineChunk :: Inlines -> UserSet -> ChannelSet -> Widget a toInlineChunk is uSet cSet = B.Widget B.Fixed B.Fixed $ do@@ -182,8 +215,10 @@ | b <- bs | i <- is ] where is = case lt of C.Bullet _ -> repeat ("• ")- C.Numbered _ _ -> [ T.pack (show (n :: Int)) <> ". "- | n <- [1..] ]+ C.Numbered C.PeriodFollowing s ->+ [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]+ C.Numbered C.ParenFollowing s ->+ [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ] -- We want to do word-wrapping, but for that we want a linear -- sequence of chunks we can break up. The typical Markdown
+ src/Scripts.hs view
@@ -0,0 +1,75 @@+module Scripts+ ( findAndRunScript+ , listScripts+ )+where++import Control.Monad (when)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Data.Monoid ((<>))+import qualified Control.Concurrent.STM as STM+import System.Exit (ExitCode(..))+import Lens.Micro.Platform (use)++import Types+import State (sendMessage, runLoggedCommand)+import State.Common+import FilePaths (Script(..), getAllScripts, locateScriptPath)++findAndRunScript :: T.Text -> T.Text -> MH ()+findAndRunScript scriptName input = do+ fpMb <- liftIO $ locateScriptPath (T.unpack scriptName)+ outputChan <- use (csResources.crSubprocessLog)+ case fpMb of+ ScriptPath scriptPath -> do+ doAsyncWith Preempt $ runScript outputChan scriptPath input+ NonexecScriptPath scriptPath -> do+ let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <>+ "executed. Try running\n" <>+ "```\n" <>+ "$ chmod u+x " <> T.pack scriptPath <> "\n" <>+ "```\n" <>+ "to correct this error. " <> scriptHelpAddendum)+ postErrorMessage msg+ ScriptNotFound -> do+ let msg = ("No script named " <> scriptName <> " was found")+ postErrorMessage msg++runScript :: STM.TChan ProgramOutput -> FilePath -> T.Text -> IO (MH ())+runScript outputChan fp text = do+ po <- runLoggedCommand True outputChan fp [] (Just $ T.unpack text)+ return $ case programExitCode po of+ ExitSuccess -> do+ when (null $ programStderr po) $ do+ mode <- use (csEditState.cedEditMode)+ sendMessage mode (T.pack $ programStdout po)+ ExitFailure _ -> return ()++listScripts :: MH ()+listScripts = do+ (execs, nonexecs) <- liftIO getAllScripts+ let scripts = ("Available scripts are:\n" <>+ mconcat [ " - " <> T.pack cmd <> "\n"+ | cmd <- execs+ ])+ postInfoMessage scripts+ case nonexecs of+ [] -> return ()+ _ -> do+ let errMsg = ("Some non-executable script files are also " <>+ "present. If you want to run these as scripts " <>+ "in Matterhorn, mark them executable with \n" <>+ "```\n" <>+ "$ chmod u+x [script path]\n" <>+ "```\n" <>+ "\n" <>+ mconcat [ " - " <> T.pack cmd <> "\n"+ | cmd <- nonexecs+ ] <> "\n" <> scriptHelpAddendum)+ postErrorMessage errMsg++scriptHelpAddendum :: T.Text+scriptHelpAddendum =+ "For more help with scripts, run the command\n" <>+ "```\n/help scripts\n```\n"
src/State.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+ module State where import Prelude ()@@ -14,17 +13,17 @@ import Control.Monad.IO.Class (liftIO) import qualified Control.Concurrent.STM as STM import Data.Char (isAlphaNum)-import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy)+import Brick.Main (getVtyHandle, viewportScroll, vScrollToBeginning, vScrollBy, vScrollToEnd) import Brick.Widgets.Edit (applyEdit)-import Control.Monad (when, void)+import Control.Monad (when, unless, void) import qualified Data.ByteString as BS+import Data.Function (on) import Data.Text.Zipper (textZipper, clearZipper, insertMany, gotoEOL) import qualified Data.HashMap.Strict as HM import qualified Data.Sequence as Seq import Data.List (sort) import Data.Maybe (maybeToList, isJust, catMaybes, isNothing) import Data.Monoid ((<>))-import Data.Time.Clock (UTCTime, getCurrentTime) import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Vector as V@@ -35,9 +34,9 @@ import System.Exit (ExitCode(..)) import System.Process (proc, std_in, std_out, std_err, StdStream(..), createProcess, waitForProcess)-import System.IO (hGetContents)-import System.Directory ( createDirectoryIfMissing )-import System.Environment.XDG.BaseDir ( getUserCacheDir )+import System.IO (hGetContents, hFlush, hPutStrLn)+import System.Directory (createDirectoryIfMissing)+import System.Environment.XDG.BaseDir (getUserCacheDir) import System.FilePath import Network.Mattermost@@ -47,8 +46,10 @@ import Config import FilePaths import Types+import Types.Channels import Types.Posts import Types.Messages+import Types.Users import InputHistory import Themes import Zipper (Zipper)@@ -65,46 +66,112 @@ -- * Refreshing Channel Data --- | Get all the new messages for a given channel. In addition, load the--- channel metadata and update that, too.+-- | Refresh information about a specific channel. The channel+-- metadata is refreshed, and if this is a loaded channel, the+-- scrollback is updated as well. refreshChannel :: ChannelId -> MH ()-refreshChannel chan = do- msgs <- use (csChannel(chan).ccContents.cdMessages)- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Normal $- case getLatestPostId msgs of- Just pId -> do- -- Get the latest channel metadata.- cwd <- mmGetChannel session myTeamId chan+refreshChannel cId = do+ curId <- use csCurrentChannelId+ let priority = if curId == cId then Preempt else Normal+ asPending doAsyncChannelMM priority (Just cId) mmGetChannel postRefreshChannel+ where postRefreshChannel cId' cwd = do+ updateChannelInfo cId' cwd+ -- If this is an active channel, also update the Messages to+ -- retrieve any that might have been missed.+ updateMessages cId' - -- Load posts since the last post in this channel. Note that- -- postsOrder from mattermost-api is most recent first.- posts <- mmGetPostsAfter session myTeamId chan pId 0 100- return $ do- mapM_ addMessageToState [ (posts^.postsPostsL) HM.! p- | p <- F.toList (posts^.postsOrderL)- ]- let newChanInfo ci = channelInfoFromChannelWithData cwd ci- & cdCurrentState .~ ChanLoaded+-- | Refresh information about all channels. This is usually+-- triggered when a reconnect event for the WebSocket to the server+-- occurs.+refreshChannels :: MH ()+refreshChannels = do+ cIds <- use (csChannels.to (filteredChannelIds (const True)))+ sequence_ $ refreshChannel <$> cIds - csChannel(chan).ccInfo %= newChanInfo- _ -> return (return ())+-- | Update the indicted Channel entry with the new data retrieved+-- from the Mattermost server.+updateChannelInfo :: ChannelId -> ChannelWithData -> MH ()+updateChannelInfo cid cwd =+ csChannel(cid).ccInfo %= channelInfoFromChannelWithData cwd --- | Find all the loaded channels and refresh their state, setting the--- state as dirty until we get a response-refreshLoadedChannels :: MH ()-refreshLoadedChannels = do- msgs <- use msgMap- sequence_- [ refreshChannel cId- | (cId, chan) <- HM.toList msgs- , chan^.ccInfo.cdCurrentState == ChanLoaded- ]- let upd ChanLoaded = ChanRefreshing- upd chanState = chanState- msgMap.each.ccInfo.cdCurrentState %= upd+-- | If this channel has content, fetch any new content that has+-- arrived after the existing content.+updateMessages :: ChannelId -> MH ()+updateMessages cId =+ withChannel cId $ \chan -> do+ when (chan^.ccInfo.cdCurrentState.to (`elem` [ChanLoaded, ChanInitialSelect])) $ do+ curId <- use csCurrentChannelId+ let priority = if curId == cId then Preempt else Normal+ asyncFetchScrollback priority cId +-- | Fetch scrollback for a channel in the background. This may be+-- called to fetch messages in a number of situations, including:+--+-- 1. WebSocket connect at init, no messages available+--+-- 2. WebSocket reconnect after losing connectivity for a period+--+-- 3. Channel selected by user+--+-- a. No current messages fetched yet+--+-- b. Messages may have been provided unsolicited via the+-- WebSocket.+--+-- 4. User got invited to the channel (by another user).+--+-- For most cases, fetching the most recent set of messages is+-- appropriate, but for case 2, messages from the most recent forward+-- should be retrieved. However, be careful not to confuse case 2+-- with case 3b.+asyncFetchScrollback :: AsyncPriority -> ChannelId -> MH ()+asyncFetchScrollback prio cId = do+ withChannel cId $ \chan -> do+ let last_pId = getLatestPostId (chan^.ccContents.cdMessages)+ newCutoff = chan^.ccInfo.cdNewMessageIndicator+ asPending doAsyncChannelMM prio (Just cId)+ (let fc = case last_pId of+ Nothing -> F1 -- or F4+ Just pId ->+ case findMessage pId (chan^.ccContents.cdMessages) of+ Nothing -> F4 -- This should never happen since+ -- we just assigned pId.+ Just m ->+ case newCutoff of+ Hide ->+ -- No cutoff has been set, so we+ -- just ask for the most recent+ -- messages.+ F2 pId+ NewPostsAfterServerTime ct ->+ -- If the most recent message is+ -- after the cutoff, meaning there+ -- might be intervening messages+ -- that we missed.+ if m^.mDate > ct+ then F3b pId+ else F3a+ NewPostsStartingAt ct ->+ -- If the most recent message is+ -- after the cutoff, meaning there+ -- might be intervening messages+ -- that we missed.+ if m^.mDate >= ct+ then F3b pId+ else F3a+ op = case fc of+ F1 -> ___2 mmGetPosts+ F2 pId -> ___3 mmGetPostsAfter pId+ F3a -> ___2 mmGetPosts+ F3b pId -> ___3 mmGetPostsBefore pId+ F4 -> ___2 mmGetPosts+ in op 0 numScrollbackPosts+ )+ addObtainedMessages++data FetchCase = F1 | F2 PostId | F3a | F3b PostId | F4 deriving (Eq,Show)++ -- * Message selection mode beginMessageSelect :: MH ()@@ -178,37 +245,94 @@ selectedMessage <- use (to getSelectedMessage) st <- use id case selectedMessage of- Just msg | isMine st msg && isDeletable msg -> do- cId <- use csCurrentChannelId- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Preempt $ do- let Just p = msg^.mOriginalPost- mmDeletePost session myTeamId cId (postId p)- return $ do- csEditState.cedEditMode .= NewPost- csMode .= Main+ Just msg | isMine st msg && isDeletable msg ->+ case msg^.mOriginalPost of+ Just p ->+ doAsyncChannelMM Preempt Nothing+ (___1 mmDeletePost (postId p))+ (\_ _ -> do csEditState.cedEditMode .= NewPost+ csMode .= Main)+ Nothing -> return () _ -> return () beginCurrentChannelDeleteConfirm :: MH () beginCurrentChannelDeleteConfirm = do cId <- use csCurrentChannelId- chType <- use (csChannel(cId).ccInfo.cdType)- if chType /= Direct- then csMode .= DeleteChannelConfirm- else postErrorMessage "The /delete-channel command cannot be used with direct message channels."+ withChannel cId $ \chan -> do+ let chType = chan^.ccInfo.cdType+ if chType /= Direct+ then csMode .= DeleteChannelConfirm+ else postErrorMessage "The /delete-channel command cannot be used with direct message channels." deleteCurrentChannel :: MH () deleteCurrentChannel = do- cId <- use csCurrentChannelId- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Preempt $ do- mmDeleteChannel session myTeamId cId- return $ do- csMode .= Main- leaveCurrentChannel+ leaveCurrentChannel+ csMode .= Main+ doAsyncChannelMM Normal Nothing mmDeleteChannel endAsyncNOP +isCurrentChannel :: ChatState -> ChannelId -> Bool+isCurrentChannel st cId = st^.csCurrentChannelId == cId++-- | Update the UI to reflect the flagged/unflagged state of a+-- message. This __does not__ talk to the Mattermost server, but+-- rather is the function we call when the Mattermost server notifies+-- us of flagged or unflagged messages.+updateMessageFlag :: PostId -> Bool -> MH ()+updateMessageFlag pId f = do+ if f+ then csResources.crFlaggedPosts %= Set.insert pId+ else csResources.crFlaggedPosts %= Set.delete pId+ msgMb <- use (csPostMap.at(pId))+ case msgMb of+ Just msg+ | Just cId <- msg^.mChannelId -> do+ let isTargetMessage m = m^.mPostId == Just pId+ csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f+ csPostMap.ix(pId).mFlagged .= f+ -- We also want to update the post overlay if this happens while+ -- we're we're observing it+ mode <- use csMode+ case mode of+ PostListOverlay PostListFlagged+ | f ->+ csPostListOverlay.postListPosts %=+ addMessage (msg & mFlagged .~ True)+ -- deleting here is tricky, because it means that we need to+ -- move the focus somewhere: we'll try moving it _up_ unless+ -- we can't, in which case we'll try moving it down.+ | otherwise -> do+ selId <- use (csPostListOverlay.postListSelected)+ posts <- use (csPostListOverlay.postListPosts)+ let nextId = case getNextPostId selId posts of+ Nothing -> getPrevPostId selId posts+ Just x -> Just x+ csPostListOverlay.postListSelected .= nextId+ csPostListOverlay.postListPosts %=+ filterMessages (((/=) `on` _mPostId) msg)+ _ -> return ()+ _ -> return ()++-- | Tell the server that we have flagged or unflagged a message.+flagMessage :: PostId -> Bool -> MH ()+flagMessage pId f = do+ session <- use csSession+ myId <- use (csMe.userIdL)+ doAsyncWith Normal $ do+ let doFlag = if f then mmFlagPost else mmUnflagPost+ doFlag session myId pId+ return $ return ()++-- | Tell the server that the message we currently have selected+-- should have its flagged state toggled.+flagSelectedMessage :: MH ()+flagSelectedMessage = do+ selected <- use (to getSelectedMessage)+ case selected of+ Just msg+ | Just pId <- msg^.mPostId ->+ flagMessage pId (not (msg^.mFlagged))+ _ -> return ()+ beginUpdateMessage :: MH () beginUpdateMessage = do selected <- use (to getSelectedMessage)@@ -286,14 +410,8 @@ joinChannel :: Channel -> MH () joinChannel chan = do- let cId = getId chan- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Preempt $ do- void $ mmJoinChannel session myTeamId cId- return (return ())- csMode .= Main+ doAsyncChannelMM Preempt (Just $ getId chan) mmJoinChannel endAsyncNOP -- | When another user adds us to a channel, we need to fetch the -- channel info for that channel.@@ -314,25 +432,25 @@ True -> csMode .= LeaveChannelConfirm False -> postErrorMessage "The /leave command cannot be used with this channel." -canLeaveChannel :: ChannelInfo -> Bool-canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct, Group]- leaveCurrentChannel :: MH () leaveCurrentChannel = do cId <- use csCurrentChannelId- cInfo <- use (csCurrentChannel.ccInfo)- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)-- when (canLeaveChannel cInfo) $ doAsyncWith Preempt $ do- mmLeaveChannel session myTeamId cId- return (removeChannelFromState cId)+ withChannel cId $ \chan ->+ when (canLeaveChannel (chan^.ccInfo)) $+ doAsyncChannelMM Preempt (Just cId)+ mmLeaveChannel+ removeChannelFromState -removeChannelFromState :: ChannelId -> MH ()-removeChannelFromState cId = do- cName <- use (csChannel(cId).ccInfo.cdName)- chType <- use (csChannel(cId).ccInfo.cdType)- when (chType /= Direct) $ do+removeChannelFromState :: ChannelId -> a -> MH ()+removeChannelFromState cId _ = do+ withChannel cId $ \ chan -> do+ let cName = chan^.ccInfo.cdName+ chType = chan^.ccInfo.cdType+ when (chType /= Direct) $ do+ origFocus <- use csCurrentChannelId+ when (origFocus == cId) $ do+ st <- use id+ setFocusWith (getNextNonDMChannel st Z.right) csEditState.cedInputHistoryPosition .at cId .= Nothing csEditState.cedLastChannelInput .at cId .= Nothing -- Update input history@@ -342,57 +460,98 @@ -- Flush cnChans csNames.cnChans %= filter (/= cName) -- Update msgMap- msgMap .at cId .= Nothing+ csChannels %= filteredChannels ((/=) cId . fst) -- Remove from focus zipper csFocus %= Z.filterZipper (/= cId) fetchCurrentChannelMembers :: MH ()-fetchCurrentChannelMembers = do- cId <- use csCurrentChannelId- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Preempt $ do- chanUserMap <- mmGetChannelMembers session myTeamId cId 0 10000-- -- Construct a message listing them all and post it to the- -- channel:- let msgStr = "Channel members (" <> (T.pack $ show $ length chanUsers) <> "):\n" <>- T.intercalate ", " usernames- chanUsers = snd <$> HM.toList chanUserMap- usernames = sort $ userUsername <$> (F.toList chanUsers)-- return $ postInfoMessage msgStr---- * Channel Updates and Notifications+fetchCurrentChannelMembers =+ doAsyncChannelMM Preempt Nothing+ (___2 mmGetChannelMembers 0 10000)+ (\_ chanUserMap -> do+ -- Construct a message listing them all and post it to the+ -- channel:+ let msgStr = "Channel members (" <> (T.pack $ show $ length chanUsers) <> "):\n" <>+ T.intercalate ", " usernames+ chanUsers = snd <$> HM.toList chanUserMap+ usernames = sort $ userUsername <$> (F.toList chanUsers) -hasUnread :: ChatState -> ChannelId -> Bool-hasUnread st cId = maybe False id $ do- chan <- st^.msgMap.at(cId)- u <- chan^.ccInfo.cdViewed- let v = chan^.ccInfo.cdUpdated- return (v > u)+ postInfoMessage msgStr) -setLastViewedFor :: ChannelId -> MH ()-setLastViewedFor cId = do- now <- getNow- msgs <- use msgMap- if cId `HM.member` msgs- then csChannel(cId).ccInfo.cdViewed .= Just now- else handleChannelInvite cId+-- | Called on async completion when the currently viewed channel has+-- been updated (i.e., just switched to this channel) to update local+-- state.+setLastViewedFor :: Maybe ChannelId -> ChannelId -> () -> MH ()+setLastViewedFor prevId cId _ = do+ chan <- use (csChannels.to (findChannelById cId))+ -- Update new channel's viewed time, creating the channel if needed+ case chan of+ Nothing -> handleChannelInvite cId+ Just _ ->+ -- The server has been sent a viewed POST update, but there is+ -- no local information on what timestamp the server actually+ -- recorded. There are a couple of options for setting the+ -- local value of the viewed time:+ --+ -- 1. Attempting to locally construct a value, which would+ -- involve scanning all (User) messages in the channel to+ -- find the maximum of the created date, the modified date,+ -- or the deleted date, and assuming that maximum mostly+ -- matched the server's viewed time.+ --+ -- 2. Issuing a channel metadata request to get the server's+ -- new concept of the viewed time.+ --+ -- 3. Having the "chan/viewed" POST that was just issued+ -- return a value from the server. See+ -- https://github.com/mattermost/platform/issues/6803.+ --+ -- Method 3 would be the best and most lightweight. Until that+ -- is available, Method 2 will be used. The downside to Method+ -- 2 is additional client-server messaging, and a delay in+ -- updating the client data, but it's also immune to any new or+ -- removed Message date fields, or anything else that would+ -- contribute to the viewed/updated times on the server.+ doAsyncChannelMM Preempt (Just cId) mmGetChannel+ (\pcid cwd -> csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd)+ -- Update the old channel's previous viewed time (allows tracking of new messages)+ case prevId of+ Nothing -> return ()+ Just p -> csChannels %= (channelByIdL p %~ clearNewMessageIndicator) updateViewed :: MH () updateViewed = do- st <- use id- liftIO (updateViewedIO st)+ csCurrentChannel.ccInfo.cdMentionCount .= 0+ updateViewedChan =<< use csCurrentChannelId +-- | When a new channel has been selected for viewing, this will+-- notify the server of the change, and also update the local channel+-- state to set the last-viewed time for the previous channel and+-- update the viewed time to now for the newly selected channel.+updateViewedChan :: ChannelId -> MH ()+updateViewedChan cId = use csConnectionStatus >>= \case+ Connected -> do+ -- Only do this if we're connected to avoid triggering noisy exceptions.+ pId <- use csRecentChannel+ doAsyncChannelMM Preempt (Just cId)+ (___1 mmViewChannel pId)+ (setLastViewedFor pId)+ Disconnected ->+ -- Cannot update server; make no local updates to avoid+ -- getting out-of-sync with the server. Assumes that this+ -- is a temporary break in connectivity and that after the+ -- connection is restored, the user's normal activities will+ -- update state as appropriate. If connectivity is+ -- permanently lost, managing this state is irrelevant.+ return ()+ resetHistoryPosition :: MH () resetHistoryPosition = do cId <- use csCurrentChannelId csInputHistoryPosition.at cId .= Just Nothing updateStatus :: UserId -> T.Text -> MH ()-updateStatus uId t =- usrMap.ix(uId).uiStatus .= statusFromText t+updateStatus uId t = csUsers %= modifyUserById uId (uiStatus .~ statusFromText t) clearEditor :: MH () clearEditor = csCmdLine %= applyEdit clearZipper@@ -443,7 +602,6 @@ cId <- use csCurrentChannelId csRecentChannel .= Just cId saveCurrentEdit- clearNewMessageCutoff cId nextChannel :: MH () nextChannel = do@@ -471,16 +629,24 @@ -> (Zipper ChannelId -> Zipper ChannelId) -> (Zipper ChannelId -> Zipper ChannelId) getNextNonDMChannel st shift z =- if (st^?msgMap.ix(Z.focus z).ccInfo.cdType) == Just Direct+ if fType z == Direct then z else go (shift z) where go z'- | (st^?msgMap.ix(Z.focus z').ccInfo.cdType) /= Just Direct = z'+ | fType z' /= Direct = z' | otherwise = go (shift z')+ fType onz = st^.(csChannels.to+ (findChannelById (Z.focus onz))) ^?! _Just.ccInfo.cdType getNextUnreadChannel :: ChatState -> (Zipper ChannelId -> Zipper ChannelId)-getNextUnreadChannel st = Z.findRight (hasUnread st)+getNextUnreadChannel st =+ -- The next channel with unread messages must also be a channel+ -- other than the current one, since the zipper may be on a channel+ -- that has unread messages and will stay that way until we leave+ -- it- so we need to skip that channel when doing the zipper search+ -- for the next candidate channel.+ Z.findRight (\cId -> hasUnread st cId && (cId /= st^.csCurrentChannelId)) listThemes :: MH () listThemes = do@@ -505,29 +671,45 @@ cId <- use csCurrentChannelId mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount -asyncFetchMoreMessages :: ChatState -> ChannelId -> IO ()-asyncFetchMoreMessages st cId =- doAsyncWithIO Preempt st $ do- let offset = length $ st^.csChannel(cId).ccContents.cdMessages- numToFetch = 10- posts <- mmGetPosts (st^.csSession) (st^.csMyTeam.teamIdL) cId (offset - 1) numToFetch- return $ do- cc <- fromPosts posts- ccId <- use csCurrentChannelId- mh $ invalidateCacheEntry (ChannelMessages ccId)- mapM_ (\m ->- csChannel(ccId).ccContents.cdMessages %= (addMessage m))- (cc^.cdMessages)+channelScrollToTop :: MH ()+channelScrollToTop = do+ cId <- use csCurrentChannelId+ mh $ vScrollToBeginning (viewportScroll (ChannelMessages cId)) +channelScrollToBottom :: MH ()+channelScrollToBottom = do+ cId <- use csCurrentChannelId+ mh $ vScrollToEnd (viewportScroll (ChannelMessages cId))++-- | Fetches additional message history for the current channel. This+-- is generally called when in ChannelScroll mode, in which state the+-- output is cached and seen via a scrolling viewport; new messages+-- received in this mode are not normally shown, but this explicit+-- user-driven fetch should be displayed, so this also invalidates the+-- cache.+asyncFetchMoreMessages :: MH ()+asyncFetchMoreMessages = do+ cId <- use csCurrentChannelId+ withChannel cId $ \chan ->+ let offset = length $ chan^.ccContents.cdMessages+ in asPending doAsyncChannelMM Preempt (Just cId)+ (___2 mmGetPosts offset pageAmount)+ (\c p -> do addObtainedMessages c p+ mh $ invalidateCacheEntry (ChannelMessages cId))++addObtainedMessages :: ChannelId -> Posts -> MH ()+addObtainedMessages _cId posts =+ postProcessMessageAdd =<<+ foldl mappend mempty <$>+ mapM addMessageToState+ [ (posts^.postsPostsL) HM.! p+ | p <- F.toList (posts^.postsOrderL)+ ]+ loadMoreMessages :: MH () loadMoreMessages = do mode <- use csMode- cId <- use csCurrentChannelId- st <- use id- case mode of- ChannelScroll -> do- liftIO $ asyncFetchMoreMessages st cId- _ -> return ()+ when (mode == ChannelScroll) asyncFetchMoreMessages channelByName :: ChatState -> T.Text -> Maybe ChannelId channelByName st n@@ -600,19 +782,7 @@ handleNewChannel name switch nc = do -- time to do a lot of state updating: -- create a new ClientChannel structure- now <- getNow- let cChannel = ClientChannel- { _ccContents = emptyChannelContents- , _ccInfo = ChannelInfo- { _cdViewed = Nothing- , _cdUpdated = now- , _cdName = preferredChannelName nc- , _cdHeader = nc^.channelHeaderL- , _cdType = nc^.channelTypeL- , _cdCurrentState = ChanLoaded- , _cdNewMessageCutoff = Nothing- }- }+ let cChannel = makeClientChannel nc -- add it to the message map, and to the map so we can look it up by -- user name csNames.cnToChanId.at(name) .= Just (getId nc)@@ -621,7 +791,7 @@ -- do nothing when (chType /= Direct) $ csNames.cnChans %= (sort . (name:))- msgMap.at(getId nc) .= Just 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@@ -633,28 +803,26 @@ editMessage :: Post -> MH () editMessage new = do- now <- getNow st <- use id- let chan = csChannel (postChannelId new)- isEditedMessage m = m^.mPostId == Just (new^.postIdL)+ 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- chan . ccInfo . cdUpdated .= now+ chan %= adjustUpdated new csPostMap.ix(postId new) .= msg cId <- use csCurrentChannelId- when (postChannelId new == cId) $- updateViewed+ when (postChannelId new == cId) updateViewed deleteMessage :: Post -> MH () deleteMessage new = do- now <- getNow- let isDeletedMessage m = m^.mPostId == Just (new^.postIdL)- chan = csChannel (postChannelId new)+ let isDeletedMessage m = m^.mPostId == Just (new^.postIdL) ||+ isReplyTo (new^.postIdL) m+ chan :: Traversal' ChatState ClientChannel+ chan = csChannel (new^.postChannelIdL) chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)- chan.ccInfo.cdUpdated .= now+ chan %= adjustUpdated new cId <- use csCurrentChannelId- when (postChannelId new == cId) $- updateViewed+ when (postChannelId new == cId) updateViewed maybeRingBell :: MH () maybeRingBell = do@@ -664,12 +832,48 @@ Just vty <- mh getVtyHandle liftIO $ ringTerminalBell $ outputIface vty -addMessageToState :: Post -> MH ()+-- | PostProcessMessageAdd is an internal value that informs the main+-- code whether the user should be notified (e.g., ring the bell) or+-- the server should be updated (e.g., that the channel has been+-- viewed). This is a monoid so that it can be folded over when there+-- are multiple inbound posts to be processed.+data PostProcessMessageAdd = NoAction+ | NotifyUser+ | UpdateServerViewed+ | NotifyUserAndServer++instance Monoid PostProcessMessageAdd where+ mempty = NoAction+ mappend NotifyUserAndServer _ = NotifyUserAndServer+ mappend _ NotifyUserAndServer = NotifyUserAndServer+ mappend NotifyUser UpdateServerViewed = NotifyUserAndServer+ mappend UpdateServerViewed NotifyUser = NotifyUserAndServer+ mappend x NoAction = x+ mappend _ x = x++-- | postProcessMessageAdd performs the actual actions indicated by+-- the corresponding input value.+postProcessMessageAdd :: PostProcessMessageAdd -> MH ()+postProcessMessageAdd ppma = do+ postOp ppma+ cState <- use (csCurrentChannel.ccInfo.cdCurrentState)+ when (cState == ChanInitialSelect) $+ csCurrentChannel.ccInfo.cdCurrentState .= ChanLoaded+ where+ postOp NoAction = return ()+ postOp UpdateServerViewed = updateViewed+ postOp NotifyUser = maybeRingBell+ postOp NotifyUserAndServer = updateViewed >> maybeRingBell++-- | 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 st <- use id- asyncFetchAttachments new- case st^.msgMap.at (postChannelId new) of- Nothing ->+ 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@@ -679,72 +883,85 @@ -- 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.- return ()+ return NoAction Just _ -> do- now <- getNow let cp = toClientPost new (new^.postParentIdL) fromMe = (cp^.cpUser == (Just $ getId (st^.csMe))) && (isNothing $ cp^.cpUserOverride)- updateTime = if fromMe then id else const now cId = postChannelId new doAddMessage = do- s <- use id- let chan = msgMap . ix cId- msg' = clientPostToMessage s (toClientPost new (new^.postParentIdL))- csPostMap.ix(postId new) .= msg'- chan.ccContents.cdMessages %= (addMessage msg')- chan.ccInfo.cdUpdated %= updateTime- when (not fromMe) $ maybeRingBell- ccId <- use csCurrentChannelId- if postChannelId new == ccId- then updateViewed- else setNewMessageCutoff cId msg'+ currCId <- use csCurrentChannelId+ s <- use id -- use *latest* state+ flags <- use (csResources.crFlaggedPosts)+ let msg' = clientPostToMessage s cp+ & mFlagged .~ ((cp^.cpPostId) `Set.member` flags)+ csPostMap.at(postId new) .= Just msg'+ csChannels %= modifyChannelById cId+ ((ccContents.cdMessages %~ addMessage msg') .+ (adjustUpdated new) .+ (\c -> if currCId == cId+ then c+ else updateNewMessageIndicator new c)+ )+ asyncFetchReactionsForPost cId new+ asyncFetchAttachments new+ postedChanMessage - doHandleNewMessage = do+ doHandleAddedMessage = do -- If the message is in reply to another message, -- try to find it in the scrollback for the post's -- channel. If the message isn't there, fetch it. If -- we have to fetch it, don't post this message to the -- channel until we have fetched the parent.- case getMessageForPostId st <$> cp^.cpInReplyToPost of- Just (ParentNotLoaded parentId) -> do- doAsyncWith Normal $ do- let theTeamId = st^.csMyTeam.teamIdL- p <- mmGetPost (st^.csSession) theTeamId cId parentId- let postMap = HM.fromList [ ( pId- , clientPostToMessage st (toClientPost x (x^.postParentIdL))- )- | (pId, x) <- HM.toList (p^.postsPostsL)- ]- return $ do- csPostMap %= HM.union postMap- doAddMessage- _ -> doAddMessage+ case cp^.cpInReplyToPost of+ Just parentId ->+ case getMessageForPostId st parentId of+ Nothing -> do+ doAsyncChannelMM Preempt (Just cId)+ (___1 mmGetPost parentId)+ (\_ p ->+ let postMap = HM.fromList [ ( pId+ , clientPostToMessage st+ (toClientPost x (x^.postParentIdL))+ )+ | (pId, x) <- HM.toList (p^.postsPostsL)+ ]+ in csPostMap %= HM.union postMap+ )+ _ -> return ()+ _ -> return () + doAddMessage++ postedChanMessage =+ withChannelOrDefault (postChannelId new) NoAction $ \_ -> do+ currCId <- use csCurrentChannelId++ let curChannelAction = if postChannelId new == currCId+ then UpdateServerViewed+ else NoAction+ originUserAction = if fromMe+ then NoAction+ else NotifyUser+ return $ curChannelAction <> originUserAction+ -- If this message was written by a user we don't know about, -- fetch the user's information before posting the message. case cp^.cpUser of- Nothing -> doHandleNewMessage+ Nothing -> doHandleAddedMessage Just uId ->- case st^.usrMap.at uId of- Just _ -> doHandleNewMessage+ case st^.csUsers.to (findUserById uId) of+ Just _ -> doHandleAddedMessage Nothing -> do handleNewUser uId- doAsyncWith Normal $ return doHandleNewMessage--setNewMessageCutoff :: ChannelId -> Message -> MH ()-setNewMessageCutoff cId msg =- csChannel(cId).ccInfo.cdNewMessageCutoff %= (<|> Just (msg^.mDate))--clearNewMessageCutoff :: ChannelId -> MH ()-clearNewMessageCutoff cId =- csChannel(cId).ccInfo.cdNewMessageCutoff .= Nothing+ doAsyncWith Normal $ return (doHandleAddedMessage >> return ())+ postedChanMessage -getNewMessageCutoff :: ChannelId -> ChatState -> Maybe UTCTime+getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator getNewMessageCutoff cId st = do- cc <- st^.msgMap.at cId- cc^.ccInfo.cdNewMessageCutoff+ cc <- st^?csChannel(cId)+ return $ cc^.ccInfo.cdNewMessageIndicator execMMCommand :: T.Text -> T.Text -> MH () execMMCommand name rest = do@@ -767,14 +984,21 @@ fetchCurrentScrollback :: MH () fetchCurrentScrollback = do cId <- use csCurrentChannelId- currentState <- preuse (msgMap.ix(cId).ccInfo.cdCurrentState)- didQueue <- case maybe False (== ChanUnloaded) currentState of- True -> do- asyncFetchScrollback Preempt cId- return True- False -> return False- csChannel(cId).ccInfo.cdCurrentState %=- if didQueue then const ChanLoadPending else id+ withChannel cId $ \ chan -> do+ unless (chan^.ccInfo.cdCurrentState `elem` [ChanLoaded, ChanInitialSelect]) $ do+ -- Upgrades the channel state to "Loaded" to indicate that+ -- content is now present (this is the main point where channel+ -- state is switched from metadata-only to with-content), then+ -- initiates an operation to read the content (which will change+ -- the state to a pending for loaded. If there was an async+ -- background task pending (esp. if this channel was selected+ -- just after startup and startup fetching is still underway),+ -- this will potentially schedule a duplicate, but that will not+ -- be harmful since quiescent channel states only increase to+ -- "higher" states.+ when (chan^.ccInfo.cdCurrentState /= ChanInitialSelect) $+ csChannel(cId).ccInfo.cdCurrentState .= ChanLoaded+ asyncFetchScrollback Preempt cId mkChannelZipperList :: MMNames -> [ChannelId] mkChannelZipperList chanNames =@@ -784,13 +1008,10 @@ | i <- chanNames ^. cnUsers , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] -setChannelTopic :: ChatState -> T.Text -> IO ()-setChannelTopic st msg = do- let chanId = st^.csCurrentChannelId- theTeamId = st^.csMyTeam.teamIdL- doAsyncWithIO Normal st $ do- void $ mmSetChannelHeader (st^.csSession) theTeamId chanId msg- return $ msgMap.at chanId.each.ccInfo.cdHeader .= msg+setChannelTopic :: T.Text -> MH ()+setChannelTopic msg = doAsyncChannelMM Normal Nothing+ (___1 mmSetChannelHeader msg)+ (\cId _ -> csChannel(cId).ccInfo.cdHeader .= msg) channelHistoryForward :: MH () channelHistoryForward = do@@ -839,10 +1060,10 @@ csCmdLine.editContentsL .= (mv $ textZipper eLines Nothing) csInputHistoryPosition.at cId .= (Just $ Just newI) -showHelpScreen :: HelpScreen -> MH ()-showHelpScreen screen = do+showHelpScreen :: HelpTopic -> MH ()+showHelpScreen topic = do mh $ vScrollToBeginning (viewportScroll HelpViewport)- csMode .= ShowHelp screen+ csMode .= ShowHelp topic beginChannelSelect :: MH () beginChannelSelect = do@@ -857,7 +1078,7 @@ -- user matches and then update the match lists. chanNameMatches <- use (csChannelSelectString.to channelNameMatch) chanNames <- use (csNames.cnChans)- userNames <- use (to sortedUserList)+ userNames <- use (to userList) let chanMatches = catMaybes (fmap chanNameMatches chanNames) let userMatches = catMaybes (fmap chanNameMatches (fmap _uiName userNames)) let mkMap ms = HM.fromList [(channelNameFromMatch m, m) | m <- ms]@@ -923,7 +1144,7 @@ findUrls :: ClientChannel -> [LinkChoice] findUrls chan = let msgs = chan^.ccContents.cdMessages- in removeDuplicates $ concat $ F.toList $ F.toList <$> Seq.reverse <$> msgURLs <$> msgs+ in removeDuplicates $ concat $ F.toList $ F.toList <$> msgURLs <$> msgs removeDuplicates :: [LinkChoice] -> [LinkChoice] removeDuplicates = snd . go Set.empty@@ -970,42 +1191,81 @@ Nothing -> return False Just urlOpenCommand ->+ -- Is the URL referring to an attachment? case _linkFileId link of Nothing -> do- runLoggedCommand (T.unpack urlOpenCommand) [T.unpack $ link^.linkURL]- return True+ openLink urlOpenCommand link+ return True+ Just fId -> do- sess <- use csSession- doAsyncWith Normal $ do- info <- mmGetFileInfo sess fId- contents <- mmGetFile sess fId- cacheDir <- getUserCacheDir xdgName- let dir = cacheDir </> "files" </> T.unpack (idString fId)- fname = dir </> T.unpack (fileInfoName info)- createDirectoryIfMissing True dir- BS.writeFile fname contents- return $! runLoggedCommand (T.unpack urlOpenCommand) [fname]- return True+ openAttachment urlOpenCommand fId+ return True -runLoggedCommand :: String -> [String] -> MH ()-runLoggedCommand cmd args = do- st <- use id- liftIO $ do- let opener = (proc cmd args) { std_in = NoStream+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 ()++openAttachment :: T.Text -> FileId -> MH ()+openAttachment urlOpenCommand fId = do+ -- The link is for an attachment, so fetch it and then+ -- open the local copy.+ sess <- use csSession+ outputChan <- use (csResources.crSubprocessLog)+ doAsyncWith Preempt $ do+ info <- mmGetFileInfo sess fId+ contents <- mmGetFile sess fId+ cacheDir <- getUserCacheDir xdgName++ let dir = cacheDir </> "files" </> T.unpack (idString fId)+ fname = dir </> T.unpack (fileInfoName info)++ createDirectoryIfMissing True dir+ BS.writeFile fname contents+ void $ runLoggedCommand False outputChan (T.unpack urlOpenCommand) [fname] Nothing+ return $ return ()++runLoggedCommand :: Bool+ -- ^ Whether stdout output is expected for this program+ -> STM.TChan ProgramOutput+ -- ^ The output channel to send the output to+ -> String+ -- ^ The program name+ -> [String]+ -- ^ Arguments+ -> Maybe String+ -- ^ The stdin to send, if any+ -> IO ProgramOutput+runLoggedCommand stdoutOkay outputChan cmd args mInput = do+ let stdIn = maybe NoStream (const CreatePipe) mInput+ opener = (proc cmd args) { std_in = stdIn , std_out = CreatePipe , std_err = CreatePipe } result <- try $ createProcess opener case result of Left (e::SomeException) -> do- let po = ProgramOutput cmd args "" (show e) (ExitFailure 1)- STM.atomically $ STM.writeTChan (st^.csResources.crSubprocessLog) po- Right (Nothing, Just outh, Just errh, ph) -> do+ let po = ProgramOutput cmd args "" stdoutOkay (show e) (ExitFailure 1)+ STM.atomically $ STM.writeTChan outputChan po+ return po+ Right (stdinResult, Just outh, Just errh, ph) -> do+ case stdinResult of+ Just inh -> do+ let Just input = mInput+ hPutStrLn inh input+ hFlush inh+ Nothing -> return ()+ ec <- waitForProcess ph outResult <- hGetContents outh errResult <- hGetContents errh- let po = ProgramOutput cmd args outResult errResult ec- STM.atomically $ STM.writeTChan (st^.csResources.crSubprocessLog) po+ let po = ProgramOutput cmd args outResult stdoutOkay errResult ec+ STM.atomically $ STM.writeTChan outputChan po+ return po Right _ -> error $ "BUG: createProcess returned unexpected result, report this at " <> "https://github.com/matterhorn-chat/matterhorn"@@ -1056,25 +1316,24 @@ } void $ mmPost (st^.csSession) theTeamId modifiedPost Editing p -> do- now <- getCurrentTime let modifiedPost = p { postMessage = msg , postPendingPostId = Nothing- , postUpdateAt = now } void $ mmUpdatePost (st^.csSession) theTeamId modifiedPost handleNewUser :: UserId -> MH ()-handleNewUser newUserId = do- -- Fetch the new user record.- st <- use id- doAsyncWith Normal $ do- newUser <- mmGetUser (st^.csSession) newUserId- -- Also re-load the team members so we can tell whether the new- -- user is in the current user's team.- teamUsers <- mmGetProfiles (st^.csSession) (st^.csMyTeam.teamIdL) 0 10000- let uInfo = userInfoFromUser newUser (HM.member newUserId teamUsers)-- return $ do- -- Update the name map and the list of known users- usrMap . at newUserId .= Just uInfo- csNames . cnUsers %= (sort . ((newUser^.userUsernameL):))+handleNewUser newUserId = doAsyncMM Normal getUserInfo updateUserState+ where getUserInfo session team =+ do nUser <- mmGetUser session newUserId+ -- Also re-load the team members so we can tell+ -- whether the new user is in the current user's+ -- team.+ teamUsers <- mmGetProfiles session team 0 10000+ let usrInfo = userInfoFromUser nUser (HM.member newUserId teamUsers)+ return (nUser, usrInfo)+ updateUserState :: (User, UserInfo) -> MH ()+ updateUserState (newUser, uInfo) =+ -- Update the name map and the list of known users+ do csUsers %= addUser newUserId uInfo+ csNames . cnUsers %= (sort . ((newUser^.userUsernameL):))+ csNames . cnToUserId . at (newUser^.userUsernameL) .= Just newUserId
src/State/Common.hs view
@@ -8,10 +8,10 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM-import Data.List (sort) import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) import qualified Data.Sequence as Seq+import qualified Data.Set as Set import qualified Data.Text as T import Data.Time.Clock (getCurrentTime) import Lens.Micro.Platform@@ -22,10 +22,11 @@ import Network.Mattermost.Exceptions import Types+import Types.Channels import Types.Posts import Types.Messages --- * MatterMost API+-- * Mattermost API -- | Try to run a computation, posting an informative error -- message if it fails with a 'MattermostServerError'.@@ -42,6 +43,54 @@ -- * Background Computation +-- $background_computation+--+-- The main context for Matterhorn is the EventM context provided by+-- the 'Brick' library. This context is normally waiting for user+-- input (or terminal resizing, etc.) which gets turned into an+-- MHEvent and the 'onEvent' event handler is called to process that+-- event, after which the display is redrawn as necessary and brick+-- awaits the next input.+--+-- However, it is often convenient to communicate with the Mattermost+-- server in the background, so that large numbers of+-- synchronously-blocking events (e.g. on startup) or refreshes can+-- occur whenever needed and without negatively impacting the UI+-- updates or responsiveness. This is handled by a 'forkIO' context+-- that waits on an STM channel for work to do, performs the work, and+-- then sends brick an MHEvent containing the completion or failure+-- information for that work.+--+-- The /doAsyncWith/ family of functions here facilitates that+-- asynchronous functionality. This is typically used in the+-- following fashion:+--+-- > doSomething :: MH ()+-- > doSomething = do+-- > got <- something+-- > doAsyncWith Normal $ do+-- > r <- mmFetchR ....+-- > return $ do+-- > csSomething.here %= processed r+--+-- The second argument is an IO monad operation (because 'forkIO' runs+-- in the IO Monad context), but it returns an MH monad operation.+-- The IO monad has access to the closure of 'doSomething' (e.g. the+-- 'got' value), but it should be aware that the state of the MH monad+-- may have been changed by the time the IO monad runs in the+-- background, so the closure is a snapshot of information at the time+-- the 'doAsyncWith' was called.+--+-- Similarly, the returned MH monad operation is *not* run in the+-- context of the 'forkIO' background, but it is instead passed via an+-- MHEvent back to the main brick thread, where it is executed in an+-- EventM handler's MH monad context. This operation therefore has+-- access to the combined closure of the pre- 'doAsyncWith' code and+-- the closure of the IO operation. It is important that the final MH+-- monad operation should *re-obtain* state information from the MH+-- monad instead of using or setting the state obtained prior to the+-- 'doAsyncWith' call.+ -- | Priority setting for asynchronous work items. Preempt means that -- the queued item will be the next work item begun (i.e. it goes to the -- front of the queue); normal means it will go last in the queue.@@ -76,6 +125,82 @@ let queue = st^.csResources.crRequestQueue STM.atomically $ putChan queue $ thunk +-- | Performs an asynchronous IO operation. On completion, the final+-- argument a completion function is executed in an MH () context in+-- the main (brick) thread.+doAsyncMM :: AsyncPriority -- ^ the priority for this async operation+ -> (Session -> TeamId -> IO a) -- ^ the async MM channel-based IO operation+ -> (a -> MH ()) -- ^ function to process the results in+ -- brick event handling context+ -> MH ()+doAsyncMM prio mmOp thunk = do+ session <- use csSession+ myTeamId <- use (csMyTeam.teamIdL)+ doAsyncWith prio $ do+ r <- mmOp session myTeamId+ return $ thunk r++-- | Helper type for a function to perform an asynchronous MM+-- operation on a channel and then invoke an MH completion event.+type DoAsyncChannelMM a+ = AsyncPriority -- ^ the priority for this async operation+ -> Maybe ChannelId -- ^ defaults to the "current" channel if Nothing+ -> (Session -> TeamId -> ChannelId -> IO a) -- ^ the asynchronous Mattermost+ -- channel-based IO operation+ -> (ChannelId -> a -> MH ()) -- ^ function to process the results in brick+ -- event handling context+ -> MH ()++-- | Performs an asynchronous IO operation on a specific channel. On+-- completion, the final argument a completion function is executed in+-- an MH () context in the main (brick) thread.+--+-- If no channel ID is provided on input, the current channel is used;+-- the completion function is always called with the channel ID upon+-- which the operation was performed.+doAsyncChannelMM :: DoAsyncChannelMM a+doAsyncChannelMM prio m_cId mmOp thunk = do+ ccId <- use csCurrentChannelId+ let cId = maybe ccId id m_cId+ doAsyncMM prio (\s t -> mmOp s t cId) (\r -> thunk cId r)++-- | Prefix function for calling doAsyncChannelMM that will set the+-- channel state to "pending" until the async operation completes. If+-- the channel state is already in the pending state when this+-- function is called, no operations are performed (i.e., this request+-- is treated as a duplicate).+asPending :: DoAsyncChannelMM a -> DoAsyncChannelMM a+asPending asyncOp prio m_cId mmOp thunk = do+ ccId <- use csCurrentChannelId+ let cId = maybe ccId id m_cId+ withChannel cId $ \chan ->+ let origState = chan^.ccInfo.cdCurrentState+ (pendState, setDone) = pendingChannelState origState+ in if pendState == origState+ then return () -- this operation already pending; do not duplicate+ else do+ csChannel(cId).ccInfo.cdCurrentState .= pendState+ asyncOp prio m_cId mmOp $ \_ r ->+ do csChannel(cId).ccInfo.cdCurrentState %= setDone+ thunk cId r++-- | Helper to skip the first 3 arguments of a 4 argument function+___1 :: (a -> b -> c -> d -> e) -> d -> (a -> b -> c -> e)+___1 f a = \s t c -> f s t c a++-- | Helper to skip the first 3 arguments of a 5 argument function+___2 :: (a -> b -> c -> d -> e -> g) -> d -> e -> (a -> b -> c -> g)+___2 f a b = \s t c -> f s t c a b++-- | Helper to skip the first 3 arguments of a 5 argument function+___3 :: (a -> b -> c -> d -> e -> g -> h) -> d -> e -> g -> (a -> b -> c -> h)+___3 f a b d = \s t c -> f s t c a b d++-- | Use this convenience function if no operation needs to be+-- performed in the MH state after an async operation completes.+endAsyncNOP :: ChannelId -> a -> MH ()+endAsyncNOP _ _ = return ()+ -- * Client Messages -- | Create 'ChannelContents' from a 'Posts' value@@ -86,27 +211,27 @@ asyncFetchAttachments return (ChannelContents msgs) -getDMChannelName :: UserId -> UserId -> T.Text-getDMChannelName me you = cname- where- [loUser, hiUser] = sort $ idString <$> [ you, me ]- cname = loUser <> "__" <> hiUser- messagesFromPosts :: Posts -> MH Messages-messagesFromPosts p = do -- (msgs, st')+messagesFromPosts p = do st <- use id+ flags <- use (csResources.crFlaggedPosts) csPostMap %= HM.union (postMap st) st' <- use id- let msgs = postsToMessages (clientPostToMessage st') (clientPost <$> ps)+ let msgs = postsToMessages (maybeFlag flags . clientPostToMessage st') (clientPost <$> ps) postsToMessages f = foldr (addMessage . f) noMessages return msgs where postMap :: ChatState -> HM.HashMap PostId Message- postMap st = HM.fromList [ ( pId- , clientPostToMessage st (toClientPost x Nothing)- )- | (pId, x) <- HM.toList (p^.postsPostsL)- ]+ postMap st = HM.fromList+ [ ( pId+ , clientPostToMessage st (toClientPost x Nothing)+ )+ | (pId, x) <- HM.toList (p^.postsPostsL)+ ]+ maybeFlag flagSet msg+ | Just pId <- msg^.mPostId, pId `Set.member` flagSet+ = msg & mFlagged .~ True+ | otherwise = msg -- n.b. postsOrder is most recent first ps = findPost <$> (Seq.reverse $ postsOrder p) clientPost :: Post -> ClientPost@@ -150,7 +275,8 @@ addClientMessage :: ClientMessage -> MH () addClientMessage msg = do cid <- use csCurrentChannelId- msgMap.ix cid.ccContents.cdMessages %= (addMessage $ clientMessageToMessage msg)+ let addCMsg = ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg)+ csChannels %= modifyChannelById cid addCMsg -- | Add a new 'ClientMessage' representing an error message to -- the current channel's message list@@ -168,82 +294,34 @@ postErrorMessageIO :: T.Text -> ChatState -> IO ChatState postErrorMessageIO err st = do- now <- liftIO getCurrentTime- let msg = ClientMessage err now Error- cId = st ^. csCurrentChannelId- return $ st & msgMap.ix cId.ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg)+ msg <- newClientMessage Error err+ let cId = st ^. csCurrentChannelId+ addEMsg = ccContents.cdMessages %~ (addMessage $ clientMessageToMessage msg)+ return $ st & csChannels %~ modifyChannelById cId addEMsg numScrollbackPosts :: Int numScrollbackPosts = 100 --- | Fetch scrollback for a channel in the background-asyncFetchScrollback :: AsyncPriority -> ChannelId -> MH ()-asyncFetchScrollback prio cId = do- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- Just viewTime <- preuse (msgMap.ix cId.ccInfo.cdViewed)- doAsyncWith prio $ do- posts <- mmGetPosts session myTeamId cId 0 numScrollbackPosts- return $ do- mapM_ (asyncFetchReactionsForPost cId) (posts^.postsPostsL)- contents <- fromPosts posts- -- We need to set the new message cutoff only if there are- -- actually messages that came in after our last view time.- let setCutoff = if hasNew- then const $ Just $ minimum (_mDate <$> newMessages)- else id- hasNew = not $ null newMessages- newMessages = case viewTime of- Nothing -> mempty- Just vt -> messagesAfter vt $ contents^.cdMessages- csChannel(cId).ccContents .= contents- csChannel(cId).ccInfo.cdCurrentState .= ChanLoaded- csChannel(cId).ccInfo.cdNewMessageCutoff %= setCutoff- asyncFetchReactionsForPost :: ChannelId -> Post -> MH () asyncFetchReactionsForPost cId p | not (p^.postHasReactionsL) = return ()- | otherwise = do- session <- use csSession- myTeamId <- use (csMyTeam.teamIdL)- doAsyncWith Normal $ do- reactions <- mmGetReactionsForPost session myTeamId cId (p^.postIdL)- return $ do- let insert r = Map.insertWith (+) (r^.reactionEmojiNameL) 1- insertAll m = foldr insert m reactions- upd m | m^.mPostId == Just (p^.postIdL) =- m & mReactions %~ insertAll- | otherwise = m- csChannel(cId).ccContents.cdMessages %= fmap upd+ | otherwise = doAsyncChannelMM Normal (Just cId)+ (___1 mmGetReactionsForPost (p^.postIdL))+ addReactions -addReaction :: Reaction -> ChannelId -> MH ()-addReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd- where upd m | m^.mPostId == Just (r^.reactionPostIdL) =- m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) 1)- | otherwise = m+addReactions :: ChannelId -> [Reaction] -> MH ()+addReactions cId rs = csChannel(cId).ccContents.cdMessages %= fmap upd+ where upd msg = msg & mReactions %~ insertAll (msg^.mPostId)+ insert pId r+ | pId == Just (r^.reactionPostIdL) = Map.insertWith (+) (r^.reactionEmojiNameL) 1+ | otherwise = id+ insertAll pId msg = foldr (insert pId) msg rs removeReaction :: Reaction -> ChannelId -> MH () removeReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd where upd m | m^.mPostId == Just (r^.reactionPostIdL) = m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1)) | otherwise = m--updateViewedIO :: ChatState -> IO ()-updateViewedIO st = do- -- Only do this if we're connected to avoid triggering noisy exceptions.- case st^.csConnectionStatus of- Connected -> do- now <- getCurrentTime- let cId = st^.csCurrentChannelId- pId = st^.csRecentChannel- doAsyncWithIO Preempt st $ do- mmViewChannel- (st^.csSession)- (getId (st^.csMyTeam))- cId- pId- return (csChannel(cId).ccInfo.cdViewed .= Just now)- Disconnected -> return () copyToClipboard :: T.Text -> MH () copyToClipboard txt = do
src/State/Editing.hs view
@@ -12,8 +12,8 @@ import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString as BS-import qualified Data.HashMap.Strict as HM import Data.Monoid ((<>))+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Zipper as Z@@ -25,12 +25,14 @@ import qualified System.IO as Sys import qualified System.IO.Temp as Sys 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 @@ -80,10 +82,9 @@ addUserToCurrentChannel :: T.Text -> MH () addUserToCurrentChannel uname = do -- First: is this a valid username?- usrs <- use usrMap- let results = filter ((== uname) . _uiName . snd) $ HM.toList usrs- case results of- [(uid, _)] -> do+ usrs <- use csUsers+ case findUserByName usrs uname of+ Just (uid, _) -> do cId <- use csCurrentChannelId session <- use csSession myTeamId <- use (csMyTeam.teamIdL)@@ -133,6 +134,12 @@ , KB "Delete the word to the right of the cursor" (EvKey (KChar 'd') [MMeta]) $ do csCmdLine %= applyEdit Z.deleteWord+ , KB "Move the cursor to the beginning of the input"+ (EvKey KHome []) $ do+ csCmdLine %= applyEdit gotoHome+ , KB "Move the cursor to the end of the input"+ (EvKey KEnd []) $ do+ csCmdLine %= applyEdit gotoEnd , KB "Kill the line to the right of the current position and copy it" (EvKey (KChar 'k') [MCtrl]) $ do z <- use (csCmdLine.editContentsL)@@ -196,6 +203,30 @@ csCurrentCompletion .= Nothing + liftIO $ st^.csEditState.cedResetSpellCheckTimer++-- Kick off an async request to the spell checker for the current editor+-- contents.+requestSpellCheck :: MH ()+requestSpellCheck = do+ st <- use id+ case st^.csEditState.cedSpellChecker of+ Nothing -> return ()+ Just checker -> do+ -- Get the editor contents.+ contents <- getEditContents <$> use csCmdLine+ doAsyncWith Normal $ do+ -- For each line in the editor, submit an aspell request.+ let query = concat <$> mapM (askAspell checker) contents+ postMistakes :: [AspellResponse] -> MH ()+ postMistakes responses = do+ let getMistakes AllCorrect = []+ getMistakes (Mistakes ms) = mistakeWord <$> ms+ allMistakes = S.fromList $ concat $ getMistakes <$> responses+ csEditState.cedMisspellings .= allMistakes++ tryMM query (return . postMistakes)+ editorEmpty :: Editor T.Text a -> Bool editorEmpty e = cursorIsAtEnd e && cursorIsAtBeginning e@@ -226,3 +257,15 @@ curLine = Z.currentLine z z = e^.editContentsL in (T.singleton ch) `T.isPrefixOf` T.drop col curLine++gotoHome :: Z.TextZipper T.Text -> Z.TextZipper T.Text+gotoHome = Z.moveCursor (0, 0)++gotoEnd :: Z.TextZipper T.Text -> Z.TextZipper T.Text+gotoEnd z =+ let zLines = Z.getText z+ numLines = length zLines+ lastLineLength = T.length $ last zLines+ in if numLines > 0+ then Z.moveCursor (numLines - 1, lastLineLength) z+ else z
+ src/State/PostListOverlay.hs view
@@ -0,0 +1,69 @@+module State.PostListOverlay where++import Lens.Micro.Platform+import Network.Mattermost+import Network.Mattermost.Lenses++import State+import State.Common+import Types+import Types.Messages++-- | Create a PostListOverlay with the given content description and+-- with a specified list of messages.+enterPostListMode :: PostListContents -> Messages -> MH ()+enterPostListMode contents msgs = do+ csPostListOverlay.postListPosts .= msgs+ csPostListOverlay.postListSelected .= getLatestPostId msgs+ csMode .= PostListOverlay contents++-- | Clear out the state of a PostListOverlay+exitPostListMode :: MH ()+exitPostListMode = do+ csPostListOverlay.postListPosts .= mempty+ csPostListOverlay.postListSelected .= Nothing+ csMode .= Main++-- | Create a PostListOverlay with flagged messages from the+-- server.+enterFlaggedPostListMode :: MH ()+enterFlaggedPostListMode = do+ session <- use csSession+ uId <- use (csMe.userIdL)+ doAsyncWith Preempt $ do+ posts <- mmGetFlaggedPosts session uId+ return $ do+ messages <- messagesFromPosts posts+ enterPostListMode PostListFlagged messages++-- | Move the selection up in the PostListOverlay, which corresponds+-- to finding a chronologically /newer/ message.+postListSelectUp :: MH ()+postListSelectUp = do+ msgId <- use (csPostListOverlay.postListSelected)+ posts <- use (csPostListOverlay.postListPosts)+ let nextId = (getNextPostId msgId posts)+ case nextId of+ Nothing -> return ()+ Just _ ->+ csPostListOverlay.postListSelected .= nextId++-- | Move the selection down in the PostListOverlay, which corresponds+-- to finding a chronologically /old/ message.+postListSelectDown :: MH ()+postListSelectDown = do+ msgId <- use (csPostListOverlay.postListSelected)+ posts <- use (csPostListOverlay.postListPosts)+ let prevId = (getPrevPostId msgId posts)+ case prevId of+ Nothing -> return ()+ Just _ ->+ csPostListOverlay.postListSelected .= prevId++-- | Unflag the post currently selected in the PostListOverlay, if any+postListUnflagSelected :: MH ()+postListUnflagSelected = do+ msgId <- use (csPostListOverlay.postListSelected)+ case msgId of+ Nothing -> return ()+ Just pId -> flagMessage pId False
src/State/Setup.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE TypeFamilies #-}+ module State.Setup where import Prelude ()@@ -7,15 +9,15 @@ import Brick.Widgets.List (list) import Control.Concurrent (threadDelay, forkIO) import qualified Control.Concurrent.STM as STM+import Control.Concurrent.STM.Delay import Control.Concurrent.MVar (newEmptyMVar) import Control.Exception (SomeException, catch, try) import Control.Monad (forM, forever, when, void)-import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HM import Data.List (sort)-import Data.Maybe (listToMaybe, maybeToList, fromJust)+import Data.Maybe (listToMaybe, maybeToList, fromJust, catMaybes) import Data.Monoid ((<>)) import qualified Data.Sequence as Seq import Data.Time.LocalTime ( TimeZone(..), getCurrentTimeZone )@@ -24,6 +26,7 @@ import System.IO (Handle, hPutStrLn, hFlush) import System.IO.Temp (openTempFile) import System.Directory (getTemporaryDirectory)+import Text.Aspell (Aspell, AspellOption(..), startAspell) import Network.Mattermost import Network.Mattermost.Lenses@@ -32,21 +35,24 @@ import Config import InputHistory import Login+import State (updateMessageFlag) import State.Common+import State.Editing (requestSpellCheck) import TeamSelect import Themes import Types+import Types.Channels+import Types.Users import Zipper (Zipper) import qualified Zipper as Z -fetchUserStatuses :: Session -> IO (MH ())-fetchUserStatuses session = do+updateUserStatuses :: Session -> IO (MH ())+updateUserStatuses session = do statusMap <- mmGetStatuses session return $ do- let updateUser u = u & uiStatus .~ (case HM.lookup (u^.uiId) statusMap of- Nothing -> Offline- Just t -> statusFromText t)- usrMap.each %= updateUser+ let setStatus u = u & uiStatus .~ (newsts u)+ newsts u = (statusMap^.at(u^.uiId) & _Just %~ statusFromText) ^. non Offline+ csUsers . mapped %= setStatus userRefresh :: Session -> RequestChan -> IO () userRefresh session requestChan = void $ forkIO $ forever refresh@@ -54,7 +60,7 @@ let seconds = (* (1000 * 1000)) threadDelay (seconds 30) STM.atomically $ STM.writeTChan requestChan $ do- rs <- try $ fetchUserStatuses session+ rs <- try $ updateUserStatuses session case rs of Left (_ :: SomeException) -> return (return ()) Right upd -> return upd@@ -62,14 +68,14 @@ startSubprocessLogger :: STM.TChan ProgramOutput -> RequestChan -> IO () startSubprocessLogger logChan requestChan = do let logMonitor mPair = do- ProgramOutput progName args out err ec <-+ ProgramOutput progName args out stdoutOkay err ec <- STM.atomically $ STM.readTChan logChan -- If either stdout or stderr is non-empty or there was an exit -- failure, log it and notify the user. let emptyOutput s = null s || s == "\n" - case ec == ExitSuccess && emptyOutput out && emptyOutput err of+ case ec == ExitSuccess && (emptyOutput out || stdoutOkay) && emptyOutput err of -- the "good" case, no output and exit sucess True -> logMonitor mPair False -> do@@ -93,9 +99,9 @@ STM.atomically $ STM.writeTChan requestChan $ do return $ do- let msg = T.pack $ "Program " <> show progName <>- " produced unexpected output; see " <>- logPath <> " for details."+ let msg = T.pack $+ "An error occurred when running " <> show progName <>+ "; see " <> logPath <> " for details." postErrorMessage msg logMonitor (Just (logPath, logHandle))@@ -148,18 +154,20 @@ -> Team -> TimeZone -> InputHistory+ -> Maybe Aspell+ -> IO () -> ChatState-newState rs i u m tz hist = ChatState+newState rs i u m tz hist sp resetTimer = ChatState { _csResources = rs , _csFocus = i , _csMe = u , _csMyTeam = m , _csNames = emptyMMNames- , _msgMap = HM.empty+ , _csChannels = noChannels , _csPostMap = HM.empty- , _usrMap = HM.empty+ , _csUsers = noUsers , _timeZone = tz- , _csEditState = emptyEditState hist+ , _csEditState = emptyEditState hist sp resetTimer , _csMode = Main , _csShowMessagePreview = configShowMessagePreview $ rs^.crConfiguration , _csChannelSelectString = ""@@ -170,8 +178,17 @@ , _csConnectionStatus = Connected , _csJoinChannelList = Nothing , _csMessageSelect = MessageSelectState Nothing+ , _csPostListOverlay = PostListOverlayState mempty Nothing } +loadFlaggedMessages :: ChatState -> IO ()+loadFlaggedMessages st = doAsyncWithIO Normal st $ do+ prefs <- mmGetMyPreferences (st^.csResources.crSession)+ return $ sequence_ [ updateMessageFlag (flaggedPostId fp) True+ | Just fp <- F.toList (fmap preferenceToFlaggedPost prefs)+ , flaggedPostStatus fp+ ]+ setupState :: Maybe Handle -> Config -> RequestChan -> BChan MHEvent -> IO ChatState setupState logFile config requestChan eventChan = do -- If we don't have enough credentials, ask for them.@@ -188,8 +205,6 @@ initConnectionData (ciHostname cInfo) (fromIntegral (ciPort cInfo)) - putStrLn "Authenticating..."- let login = Login { username = ciUsername cInfo , password = ciPassword cInfo }@@ -253,6 +268,7 @@ , _crQuitCondition = quitCondition , _crConfiguration = config , _crSubprocessLog = slc+ , _crFlaggedPosts = mempty } initializeState cr myTeam myUser @@ -266,31 +282,25 @@ initializeState :: ChatResources -> Team -> User -> IO ChatState initializeState cr myTeam myUser = do- let ChatResources session _ requestChan _ _ _ _ _ = cr+ let ChatResources session _ requestChan _ _ _ _ _ _ = cr let myTeamId = getId myTeam - STM.atomically $ STM.writeTChan requestChan $ fetchUserStatuses session+ STM.atomically $ STM.writeTChan requestChan $ updateUserStatuses session userRefresh session requestChan - putStrLn $ "Loading channels for team " <> show (teamName myTeam) <> "..." chans <- mmGetChannels session myTeamId - msgs <- fmap (HM.fromList . F.toList) $ forM (F.toList chans) $ \c -> do- let cChannel = ClientChannel- { _ccContents = emptyChannelContents- , _ccInfo = initialChannelInfo c & cdCurrentState .~ state- }-+ msgs <- forM (F.toList chans) $ \c -> do+ let cChannel = makeClientChannel c & ccInfo.cdCurrentState .~ state state = if c^.channelNameL == "town-square"- then ChanLoadPending- else ChanUnloaded-+ then ChanInitialSelect+ else initialChannelState return (getId c, cChannel) teamUsers <- mmGetProfiles session myTeamId 0 10000 users <- loadAllUsers session- let mkUser u = userInfoFromUser u (HM.member (u^.userIdL) teamUsers)+ let mkUser u = (u^.userIdL, userInfoFromUser u (HM.member (u^.userIdL) teamUsers)) tz <- getCurrentTimeZone hist <- do result <- readHistory@@ -302,6 +312,18 @@ startSubprocessLogger (cr^.crSubprocessLog) requestChan + -- Start the spell check timer thread.+ let spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms+ resetSCChan <- startSpellCheckerThread (cr^.crEventQueue) spellCheckerTimeout+ let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan ()++ sp <- case configEnableAspell $ cr^.crConfiguration of+ False -> return Nothing+ True ->+ let aspellOpts = catMaybes [ UseDictionary <$> (configAspellDictionary $ cr^.crConfiguration)+ ]+ in either (const Nothing) Just <$> startAspell aspellOpts+ let chanNames = mkChanNames myUser users chans Just townSqId = chanNames ^. cnToChanId . at "town-square" chanIds = [ (chanNames ^. cnToChanId) HM.! i@@ -310,39 +332,82 @@ | i <- chanNames ^. cnUsers , c <- maybeToList (HM.lookup i (chanNames ^. cnToChanId)) ] chanZip = Z.findRight (== townSqId) (Z.fromList chanIds)- st = newState cr chanZip myUser myTeam tz hist- & usrMap .~ fmap mkUser users- & msgMap .~ msgs+ st = newState cr chanZip myUser myTeam tz hist sp resetSCTimer+ & csUsers %~ flip (foldr (uncurry addUser)) (fmap mkUser users)+ & csChannels %~ flip (foldr (uncurry addChannel)) msgs & csNames .~ chanNames - -- Fetch town-square asynchronously, but put it in the queue early.- case F.find ((== townSqId) . getId) chans of- Nothing -> return ()- Just c -> doAsyncWithIO Preempt st $ do- cwd <- liftIO $ mmGetChannel session myTeamId (getId c)- return $ do- csChannel(getId c).ccInfo %= channelInfoFromChannelWithData cwd- liftIO $ updateViewedIO st- asyncFetchScrollback Preempt (getId c)+ loadFlaggedMessages st+ return st - -- It's important to queue up these channel metadata fetches first so- -- that by the time the scrollback requests are processed, we have the- -- latest metadata.- --- -- First we queue up fetches for non-DM channels:- F.forM_ chans $ \c ->- when (getId c /= townSqId && c^.channelTypeL /= Direct) $- doAsyncWithIO Normal st $ do- cwd <- liftIO $ mmGetChannel session myTeamId (getId c)- return $ do- csChannel(getId c).ccInfo %= channelInfoFromChannelWithData cwd+-- Start the background spell checker delay thread.+--+-- The purpose of this thread is to postpone the spell checker query+-- while the user is actively typing and only wait until they have+-- stopped typing before bothering with a query. This is to avoid spell+-- checker queries when the editor contents are changing rapidly.+-- Avoiding such queries reduces system load and redraw frequency.+--+-- We do this by starting a thread whose job is to wait for the event+-- loop to tell it to schedule a spell check. Spell checks are scheduled+-- by writing to the channel returned by this function. The scheduler+-- thread reads from that channel and then works with another worker+-- thread as follows:+--+-- A wakeup of the main spell checker thread causes it to determine+-- whether the worker thread is already waiting on a timer. When that+-- timer goes off, a spell check will be requested. If there is already+-- an active timer that has not yet expired, the timer's expiration is+-- extended. This is the case where typing is occurring and we want to+-- continue postponing the spell check. If there is not an active timer+-- or the active timer has expired, we create a new timer and send it to+-- the worker thread for waiting.+--+-- The worker thread works by reading a timer from its queue, waiting+-- until the timer expires, and then injecting an event into the main+-- event loop to request a spell check.+startSpellCheckerThread :: BChan MHEvent+ -- ^ The main event loop's event channel.+ -> Int+ -- ^ The number of microseconds to wait before+ -- requesting a spell check.+ -> IO (STM.TChan ())+startSpellCheckerThread eventChan spellCheckTimeout = do+ delayWakeupChan <- STM.atomically STM.newTChan+ delayWorkerChan <- STM.atomically STM.newTChan+ delVar <- STM.atomically $ STM.newTVar Nothing - -- Then we queue up fetches for DM channels:- F.forM_ chans $ \c ->- when (c^.channelTypeL == Direct) $- doAsyncWithIO Normal st $ do- cwd <- liftIO $ mmGetChannel session myTeamId (getId c)- return $ do- csChannel(getId c).ccInfo %= channelInfoFromChannelWithData cwd+ -- The delay worker actually waits on the delay to expire and then+ -- requests a spell check.+ void $ forkIO $ forever $ do+ STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan+ writeBChan eventChan (RespEvent requestSpellCheck) - return st+ -- The delay manager waits for requests to start a delay timer and+ -- signals the worker to begin waiting.+ void $ forkIO $ forever $ do+ () <- STM.atomically $ STM.readTChan delayWakeupChan++ oldDel <- STM.atomically $ STM.readTVar delVar+ mNewDel <- case oldDel of+ Nothing -> Just <$> newDelay spellCheckTimeout+ Just del -> do+ -- It's possible that between this check for expiration and+ -- the updateDelay below, the timer will expire -- at which+ -- point this will mean that we won't extend the timer as+ -- originally desired. But that's alright, because future+ -- keystroke will trigger another timer anyway.+ expired <- tryWaitDelayIO del+ case expired of+ True -> Just <$> newDelay spellCheckTimeout+ False -> do+ updateDelay del spellCheckTimeout+ return Nothing++ case mNewDel of+ Nothing -> return ()+ Just newDel -> STM.atomically $ do+ STM.writeTVar delVar $ Just newDel+ STM.writeTChan delayWorkerChan newDel++ return delayWakeupChan
src/TeamSelect.hs view
@@ -49,7 +49,7 @@ teamSelect :: State -> Widget () teamSelect st = center $ hLimit 50 $ vLimit 15 $- vBox [ hCenter $ txt "Welcome to MatterMost. Please select a team:"+ vBox [ hCenter $ txt "Welcome to Mattermost. Please select a team:" , txt " " , border theList , txt " "
src/Themes.hs view
@@ -2,6 +2,7 @@ module Themes ( defaultThemeName , themes+ , attrNameForTokenType -- * Attribute names , timeAttr@@ -9,6 +10,7 @@ , channelListHeaderAttr , currentChannelNameAttr , unreadChannelAttr+ , mentionsChannelAttr , urlAttr , codeAttr , emailAttr@@ -35,6 +37,7 @@ , urlListSelectedAttr , messageSelectAttr , messageSelectStatusAttr+ , misspellingAttr -- * Username formatting , colorUsername@@ -50,6 +53,7 @@ import Brick import Brick.Widgets.List import qualified Data.Text as T+import qualified Skylighting as Sky import Types (userSigil) @@ -119,6 +123,9 @@ unreadChannelAttr :: AttrName unreadChannelAttr = "unreadChannel" +mentionsChannelAttr :: AttrName+mentionsChannelAttr = "mentionsChannel"+ dateTransitionAttr :: AttrName dateTransitionAttr = "dateTransition" @@ -152,6 +159,9 @@ errorMessageAttr :: AttrName errorMessageAttr = "errorMessage" +misspellingAttr :: AttrName+misspellingAttr = "misspelling"+ messageSelectStatusAttr :: AttrName messageSelectStatusAttr = "messageSelectStatus" @@ -162,76 +172,85 @@ ] lightColorTheme :: AttrMap-lightColorTheme = 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)- , (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)- ] <>- ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors)+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) darkAttrs :: [(AttrName, Attr)] darkAttrs =- [ (timeAttr, fg white)- , (channelHeaderAttr, fg white `withStyle` underline)- , (channelListHeaderAttr, fg cyan)- , (currentChannelNameAttr, black `on` yellow `withStyle` bold)- , (unreadChannelAttr, black `on` cyan `withStyle` bold)- , (urlAttr, fg yellow)- , (emailAttr, fg yellow)- , (codeAttr, fg magenta)- , (emojiAttr, fg yellow)- , (channelNameAttr, fg cyan)- , (clientMessageAttr, fg white)- , (clientEmphAttr, fg white `withStyle` bold)- , (clientStrongAttr, fg white `withStyle` bold `withStyle` underline)- , (clientHeaderAttr, fg red `withStyle` bold)- , (dateTransitionAttr, fg green)- , (newMessageTransitionAttr, fg yellow `withStyle` bold)- , (errorMessageAttr, fg red)- , (helpAttr, black `on` cyan)- , (helpEmphAttr, fg white)- , (channelSelectMatchAttr, black `on` magenta)- , (channelSelectPromptAttr, fg white)- , (completionAlternativeListAttr, white `on` blue)- , (completionAlternativeCurrentAttr, black `on` yellow)- , (dialogAttr, black `on` cyan)- , (dialogEmphAttr, fg white)- , (listSelectedFocusedAttr, black `on` yellow)- , (recentMarkerAttr, fg yellow `withStyle` bold)- , (loadMoreAttr, black `on` cyan)- , (urlListSelectedAttr, black `on` yellow)- , (messageSelectAttr, black `on` yellow)- , (messageSelectStatusAttr, fg white)- ] <>- ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors)+ let sty = Sky.espresso+ in [ (timeAttr, fg white)+ , (channelHeaderAttr, fg white `withStyle` underline)+ , (channelListHeaderAttr, fg cyan)+ , (currentChannelNameAttr, black `on` yellow `withStyle` bold)+ , (unreadChannelAttr, black `on` cyan `withStyle` bold)+ , (mentionsChannelAttr, black `on` brightMagenta `withStyle` bold)+ , (urlAttr, fg yellow)+ , (emailAttr, fg yellow)+ , (codeAttr, fg magenta)+ , (emojiAttr, fg yellow)+ , (channelNameAttr, fg cyan)+ , (clientMessageAttr, fg white)+ , (clientEmphAttr, fg white `withStyle` bold)+ , (clientStrongAttr, fg white `withStyle` bold `withStyle` underline)+ , (clientHeaderAttr, fg red `withStyle` bold)+ , (dateTransitionAttr, fg green)+ , (newMessageTransitionAttr, fg yellow `withStyle` bold)+ , (errorMessageAttr, fg red)+ , (helpAttr, black `on` cyan)+ , (helpEmphAttr, fg white)+ , (channelSelectMatchAttr, black `on` magenta)+ , (channelSelectPromptAttr, fg white)+ , (completionAlternativeListAttr, white `on` blue)+ , (completionAlternativeCurrentAttr, black `on` yellow)+ , (dialogAttr, black `on` cyan)+ , (dialogEmphAttr, fg white)+ , (listSelectedFocusedAttr, black `on` yellow)+ , (recentMarkerAttr, fg yellow `withStyle` bold)+ , (loadMoreAttr, black `on` cyan)+ , (urlListSelectedAttr, black `on` yellow)+ , (messageSelectAttr, black `on` yellow)+ , (messageSelectStatusAttr, fg white)+ , (misspellingAttr, fg red `withStyle` underline)+ ] <>+ ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..] usernameColors) <>+ (themeEntriesForStyle sty) darkColorTheme :: AttrMap darkColorTheme = attrMap defAttr darkAttrs@@ -266,3 +285,39 @@ , fg brightMagenta , fg brightCyan ]++-- Functions for dealing with Skylighting styles++baseHighlightedCodeBlockAttr :: AttrName+baseHighlightedCodeBlockAttr = "highlightedCodeBlock"++attrNameForTokenType :: Sky.TokenType -> AttrName+attrNameForTokenType ty =+ baseHighlightedCodeBlockAttr <> (attrName $ show ty)++themeEntriesForStyle :: Sky.Style -> [(AttrName, Attr)]+themeEntriesForStyle sty =+ mkTokenTypeEntry <$> Sky.tokenStyles sty++baseAttrFromPair :: (Maybe Sky.Color, Maybe Sky.Color) -> Attr+baseAttrFromPair (mf, mb) =+ case (mf, mb) of+ (Nothing, Nothing) -> defAttr+ (Just f, Nothing) -> fg (tokenColorToVtyColor f)+ (Nothing, Just b) -> bg (tokenColorToVtyColor b)+ (Just f, Just b) -> (tokenColorToVtyColor f) `on`+ (tokenColorToVtyColor b)++tokenColorToVtyColor :: Sky.Color -> Color+tokenColorToVtyColor (Sky.RGB r g b) = rgbColor r g b++mkTokenTypeEntry :: (Sky.TokenType, Sky.TokenStyle) -> (AttrName, Attr)+mkTokenTypeEntry (ty, tSty) =+ let a = setStyle baseAttr+ baseAttr = baseAttrFromPair (Sky.tokenColor tSty, Sky.tokenBackground tSty)+ setStyle =+ if Sky.tokenBold tSty then flip withStyle bold else id .+ if Sky.tokenItalic tSty then flip withStyle standout else id .+ if Sky.tokenUnderline tSty then flip withStyle underline else id++ in (attrNameForTokenType ty, a)
src/Types.hs view
@@ -10,7 +10,7 @@ import Prelude () import Prelude.Compat -import Brick (EventM, txt, Next)+import Brick (EventM, Next) import qualified Brick import Brick.BChan import Brick.AttrMap (AttrMap)@@ -20,16 +20,19 @@ import Control.Concurrent.MVar (MVar) import Control.Exception (SomeException) import qualified Control.Monad.State as St+import qualified Data.Set as S import Data.HashMap.Strict (HashMap)-import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Time.Clock (UTCTime) import Data.Time.LocalTime (TimeZone) import qualified Data.HashMap.Strict as HM-import Data.List (partition, sort)+import Data.List (partition, sortBy) import Data.Maybe import Data.Monoid+import Data.Set (Set) import qualified Graphics.Vty as Vty-import Lens.Micro.Platform (at, makeLenses, lens, (&), (^.), (^?), (%~), (.~),- ix, to, SimpleGetter)+import Lens.Micro.Platform ( at, makeLenses, lens, (&), (^.), (%~), (.~), (^?!)+ , to, SimpleGetter, _Just+ , Traversal', preuse ) import Network.Mattermost import Network.Mattermost.Exceptions import Network.Mattermost.Lenses@@ -37,14 +40,16 @@ import Network.Connection (HostNotResolved, HostCannotConnect) import qualified Data.Text as T import System.Exit (ExitCode)+import Text.Aspell (Aspell) import Zipper (Zipper, focusL) import InputHistory +import Types.Channels import Types.Posts import Types.Messages-+import Types.Users -- * Configuration @@ -70,6 +75,8 @@ , configURLOpenCommand :: Maybe T.Text , configActivityBell :: Bool , configShowMessagePreview :: Bool+ , configEnableAspell :: Bool+ , configAspellDictionary :: Maybe T.Text } deriving (Eq, Show) -- * 'MMNames' structures@@ -122,7 +129,7 @@ deriving (Show) -- | Our 'ConnectionInfo' contains exactly as much information as is--- necessary to start a connection with a MatterMost server+-- necessary to start a connection with a Mattermost server data ConnectionInfo = ConnectionInfo { ciHostname :: T.Text , ciPort :: Int@@ -151,17 +158,6 @@ makeLenses ''LinkChoice --- * Channel representations---- | A 'ClientChannel' contains both the message--- listing and the metadata about a channel-data ClientChannel = ClientChannel- { _ccContents :: ChannelContents- -- ^ A list of 'Message's in the channel- , _ccInfo :: ChannelInfo- -- ^ The 'ChannelInfo' for the channel- }- -- Sigils normalChannelSigil :: Char normalChannelSigil = '~'@@ -169,78 +165,6 @@ userSigil :: Char userSigil = '@' --- Get a channel's name, depending on its type-preferredChannelName :: Channel -> T.Text-preferredChannelName ch- | channelType ch == Group = channelDisplayName ch- | otherwise = channelName ch--initialChannelInfo :: Channel -> ChannelInfo-initialChannelInfo chan =- let updated = chan ^. channelLastPostAtL- in ChannelInfo { _cdViewed = Nothing- , _cdUpdated = updated- , _cdName = preferredChannelName chan- , _cdHeader = chan^.channelHeaderL- , _cdType = chan^.channelTypeL- , _cdCurrentState = ChanUnloaded- , _cdNewMessageCutoff = Nothing- }--channelInfoFromChannelWithData :: ChannelWithData -> ChannelInfo -> ChannelInfo-channelInfoFromChannelWithData (ChannelWithData chan chanData) ci =- let viewed = chanData ^. channelDataLastViewedAtL- updated = chan ^. channelLastPostAtL- in ci { _cdViewed = Just viewed- , _cdUpdated = updated- , _cdName = preferredChannelName chan- , _cdHeader = (chan^.channelHeaderL)- , _cdType = (chan^.channelTypeL)- }---- | The 'ChannelContents' is a wrapper for a list of--- 'Message' values-data ChannelContents = ChannelContents- { _cdMessages :: Messages- }---- | An initial empty 'ChannelContents' value-emptyChannelContents :: ChannelContents-emptyChannelContents = ChannelContents- { _cdMessages = noMessages- }---- | The 'ChannelState' represents our internal state--- of the channel with respect to our knowledge (or--- lack thereof) about the server's information--- about the channel.-data ChannelState- = ChanUnloaded- | ChanLoaded- | ChanLoadPending- | ChanRefreshing- deriving (Eq, Show)---- | The 'ChannelInfo' record represents metadata--- about a channel-data ChannelInfo = ChannelInfo- { _cdViewed :: Maybe UTCTime- -- ^ The last time we looked at a channel- , _cdUpdated :: UTCTime- -- ^ The last time a message showed up in the channel- , _cdName :: T.Text- -- ^ The name of the channel- , _cdHeader :: T.Text- -- ^ The header text of a channel- , _cdType :: Type- -- ^ The type of a channel: public, private, or DM- , _cdCurrentState :: ChannelState- -- ^ The current state of the channel- , _cdNewMessageCutoff :: Maybe UTCTime- -- ^ The last time we looked at the new messages in- -- this channel, if ever- }- -- ** Channel-matching types data ChannelSelectMatch =@@ -259,67 +183,13 @@ data MatchType = Prefix | Suffix | Infix | Equal deriving (Eq, Show) --- ** Channel-related Lenses--makeLenses ''ChannelContents-makeLenses ''ChannelInfo-makeLenses ''ClientChannel---- * 'UserInfo' Values---- | A 'UserInfo' value represents everything we need to know at--- runtime about a user-data UserInfo = UserInfo- { _uiName :: T.Text- , _uiId :: UserId- , _uiStatus :: UserStatus- , _uiInTeam :: Bool- } deriving (Eq, Show)---- | Create a 'UserInfo' value from a Mattermost 'User' value-userInfoFromUser :: User -> Bool -> UserInfo-userInfoFromUser up inTeam = UserInfo- { _uiName = userUsername up- , _uiId = userId up- , _uiStatus = Offline- , _uiInTeam = inTeam- }---- | The 'UserStatus' value represents possible current status for--- a user-data UserStatus- = Online- | Away- | Offline- | Other T.Text- deriving (Eq, Show)--statusFromText :: T.Text -> UserStatus-statusFromText t = case t of- "online" -> Online- "offline" -> Offline- "away" -> Away- _ -> Other t---- ** 'UserInfo' lenses--makeLenses ''UserInfo--instance Ord UserInfo where- u1 `compare` u2- | u1^.uiStatus == Offline && u2^.uiStatus /= Offline =- GT- | u1^.uiStatus /= Offline && u2^.uiStatus == Offline =- LT- | otherwise =- (u1^.uiName) `compare` (u2^.uiName)- -- * Application State Values data ProgramOutput = ProgramOutput { program :: FilePath , programArgs :: [String] , programStdout :: String+ , programStdoutExpected :: Bool , programStderr :: String , programExitCode :: ExitCode }@@ -339,6 +209,7 @@ , _crTheme :: AttrMap , _crQuitCondition :: MVar () , _crConfiguration :: Config+ , _crFlaggedPosts :: Set PostId } -- | The 'ChatEditState' value contains the editor widget itself@@ -355,6 +226,9 @@ , _cedCurrentAlternative :: T.Text , _cedCompletionAlternatives :: [T.Text] , _cedYankBuffer :: T.Text+ , _cedSpellChecker :: Maybe Aspell+ , _cedResetSpellCheckTimer :: IO ()+ , _cedMisspellings :: S.Set T.Text } data EditMode =@@ -365,9 +239,9 @@ -- | We can initialize a new 'ChatEditState' value with just an -- edit history, which we save locally.-emptyEditState :: InputHistory -> ChatEditState-emptyEditState hist = ChatEditState- { _cedEditor = editor MessageInput (txt . T.unlines) Nothing ""+emptyEditState :: InputHistory -> Maybe Aspell -> IO () -> ChatEditState+emptyEditState hist sp resetTimer = ChatEditState+ { _cedEditor = editor MessageInput Nothing "" , _cedMultiline = False , _cedInputHistory = hist , _cedInputHistoryPosition = mempty@@ -377,6 +251,9 @@ , _cedCurrentAlternative = "" , _cedEditMode = NewPost , _cedYankBuffer = ""+ , _cedSpellChecker = sp+ , _cedMisspellings = mempty+ , _cedResetSpellCheckTimer = resetTimer } -- | A 'RequestChan' is a queue of operations we have to perform@@ -390,10 +267,26 @@ | ScriptHelp deriving (Eq) +-- | Help topics+data HelpTopic =+ HelpTopic { helpTopicName :: T.Text+ , helpTopicDescription :: T.Text+ , helpTopicScreen :: HelpScreen+ , helpTopicViewportName :: Name+ }+ deriving (Eq)++-- | Mode type for the current contents of the post list overlay+data PostListContents+ = PostListFlagged+-- | PostListPinned ChannelId+-- | PostListSearch Text -- for the query+ deriving (Eq)+ -- | The 'Mode' represents the current dominant UI activity data Mode = Main- | ShowHelp HelpScreen+ | ShowHelp HelpTopic | ChannelSelect | UrlSelect | LeaveChannelConfirm@@ -402,6 +295,7 @@ | ChannelScroll | MessageSelect | MessageSelectDeleteConfirm+ | PostListOverlay PostListContents deriving (Eq) -- | We're either connected or we're not.@@ -416,26 +310,34 @@ , _csNames :: MMNames , _csMe :: User , _csMyTeam :: Team- , _msgMap :: HashMap ChannelId ClientChannel+ , _csChannels :: ClientChannels , _csPostMap :: HashMap PostId Message- , _usrMap :: HashMap UserId UserInfo+ , _csUsers :: Users , _timeZone :: TimeZone , _csEditState :: ChatEditState , _csMode :: Mode , _csShowMessagePreview :: Bool , _csChannelSelectString :: T.Text- , _csChannelSelectChannelMatches :: HashMap T.Text ChannelSelectMatch- , _csChannelSelectUserMatches :: HashMap T.Text ChannelSelectMatch+ , _csChannelSelectChannelMatches :: ChannelSelectMap+ , _csChannelSelectUserMatches :: ChannelSelectMap , _csRecentChannel :: Maybe ChannelId , _csUrlList :: List Name LinkChoice , _csConnectionStatus :: ConnectionStatus , _csJoinChannelList :: Maybe (List Name Channel) , _csMessageSelect :: MessageSelectState+ , _csPostListOverlay :: PostListOverlayState } +type ChannelSelectMap = HM.HashMap T.Text ChannelSelectMatch+ data MessageSelectState = MessageSelectState { selectMessagePostId :: Maybe PostId } +data PostListOverlayState = PostListOverlayState+ { _postListPosts :: Messages+ , _postListSelected :: Maybe PostId+ }+ -- * MH Monad -- | A value of type 'MH' @a@ represents a computation that can@@ -480,9 +382,6 @@ (st, _) <- St.get St.put (st, Brick.halt) -getNow :: MH UTCTime-getNow = St.liftIO getCurrentTime- instance Functor MH where fmap f (MH x) = MH (fmap f x) @@ -524,6 +423,7 @@ makeLenses ''ChatResources makeLenses ''ChatState makeLenses ''ChatEditState+makeLenses ''PostListOverlayState -- ** Utility Lenses csCurrentChannelId :: Lens' ChatState ChannelId@@ -531,18 +431,31 @@ csCurrentChannel :: Lens' ChatState ClientChannel csCurrentChannel =- lens (\ st -> (st^.msgMap) HM.! (st^.csCurrentChannelId))- (\ st n -> st & msgMap %~ HM.insert (st^.csCurrentChannelId) n)+ lens (\ st -> findChannelById (st^.csCurrentChannelId) (st^.csChannels) ^?! _Just)+ (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId) n) -csChannel :: ChannelId -> Lens' ChatState ClientChannel+csChannel :: ChannelId -> Traversal' ChatState ClientChannel csChannel cId =- lens (\ st -> (st^.msgMap) HM.! cId)- (\ st n -> st & msgMap %~ HM.insert cId n)+ csChannels . channelByIdL cId +csChannel' :: ChannelId -> Lens' ChatState (Maybe ClientChannel)+csChannel' cId =+ csChannels . maybeChannelByIdL cId++withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH ()+withChannel cId = withChannelOrDefault cId ()++withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a+withChannelOrDefault cId deflt mote = do+ chan <- preuse (csChannel(cId))+ case chan of+ Nothing -> return deflt+ Just c -> mote c+ csUser :: UserId -> Lens' ChatState UserInfo csUser uId =- lens (\ st -> (st^.usrMap) HM.! uId)- (\ st n -> st & usrMap %~ HM.insert uId n)+ lens (\ st -> findUserById uId (st^.csUsers) ^?! _Just)+ (\ st n -> st & csUsers %~ addUser uId n) -- ** Interim lenses for backwards compat @@ -572,14 +485,11 @@ -- ** 'ChatState' Helper Functions -getMessageForPostId :: ChatState -> PostId -> ReplyState-getMessageForPostId st pId =- case st^.csPostMap.at(pId) of- Nothing -> ParentNotLoaded pId- Just m -> ParentLoaded pId m+getMessageForPostId :: ChatState -> PostId -> Maybe Message+getMessageForPostId st pId = st^.csPostMap.at(pId) getUsernameForUserId :: ChatState -> UserId -> Maybe T.Text-getUsernameForUserId st uId = st^.usrMap ^? ix uId.uiName+getUsernameForUserId st uId = _uiName <$> findUserById uId (st^.csUsers) clientPostToMessage :: ChatState -> ClientPost -> Message clientPostToMessage st cp = Message@@ -596,10 +506,12 @@ , _mInReplyToMsg = case cp^.cpInReplyToPost of Nothing -> NotAReply- Just pId -> getMessageForPostId st pId+ Just pId -> InReplyTo pId , _mPostId = Just $ cp^.cpPostId , _mReactions = _cpReactions cp , _mOriginalPost = Just $ cp^.cpOriginalPost+ , _mFlagged = False+ , _mChannelId = Just $ cp^.cpChannelId } -- * Slash Commands@@ -642,19 +554,36 @@ lookupKeybinding :: Vty.Event -> [Keybinding] -> Maybe Keybinding lookupKeybinding e kbs = listToMaybe $ filter ((== e) . kbEvent) kbs +-- * Channel Updates and Notifications++hasUnread :: ChatState -> ChannelId -> Bool+hasUnread st cId = maybe False id $ do+ chan <- findChannelById cId (st^.csChannels)+ lastViewTime <- chan^.ccInfo.cdViewed+ return (chan^.ccInfo.cdUpdated > lastViewTime)+ sortedUserList :: ChatState -> [UserInfo]-sortedUserList st = sort yes ++ sort no- where userList = filter showUser (HM.elems(st^.usrMap))- showUser u = not (isSelf u) && (u^.uiInTeam)- isSelf u = (st^.csMe.userIdL) == (u^.uiId)- hasUnread u =+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 ->- let info = st^.csChannel(cId).ccInfo- in case info^.cdViewed of- Nothing -> False- Just v -> info^.cdUpdated > v- (yes, no) = partition hasUnread userList+ | 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)++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)
+ src/Types/Channels.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RankNTypes #-}++module Types.Channels+ ( ClientChannel(..)+ , ChannelContents(..)+ , ChannelInfo(..)+ , ChannelState(..)+ , ClientChannels -- constructor remains internal+ , NewMessageIndicator(..)+ -- * Lenses created for accessing ClientChannel fields+ , ccContents, ccInfo+ -- * Lenses created for accessing ChannelInfo fields+ , cdViewed, cdNewMessageIndicator, cdUpdated+ , cdName, cdHeader, cdType, cdCurrentState+ , cdMentionCount+ -- * Lenses created for accessing ChannelContents fields+ , cdMessages+ -- * Creating ClientChannel objects+ , makeClientChannel+ -- * Managing ClientChannel collections+ , noChannels, addChannel, findChannelById, modifyChannelById+ , channelByIdL, maybeChannelByIdL+ , filteredChannelIds+ , filteredChannels+ -- * Creating ChannelInfo objects+ , channelInfoFromChannelWithData+ -- * Channel State management+ , initialChannelState+ , loadingChannelContentState+ , isPendingState+ , pendingChannelState+ , quiescentChannelState+ , clearNewMessageIndicator+ , adjustUpdated+ , updateNewMessageIndicator+ -- * Miscellaneous channel-related operations+ , canLeaveChannel+ , preferredChannelName+ )+where++import qualified Data.HashMap.Strict as HM+import qualified Data.Text as T+import Data.Time.Clock (UTCTime)+import Lens.Micro.Platform+import Network.Mattermost.Lenses hiding (Lens')+import Network.Mattermost.Types ( Channel(..), ChannelId+ , ChannelWithData(..)+ , Type(..)+ , Post+ )+import Types.Messages (Messages, noMessages)++-- * Channel representations++-- | A 'ClientChannel' contains both the message+-- listing and the metadata about a channel+data ClientChannel = ClientChannel+ { _ccContents :: ChannelContents+ -- ^ A list of 'Message's in the channel+ , _ccInfo :: ChannelInfo+ -- ^ The 'ChannelInfo' for the channel+ }++-- Get a channel's name, depending on its type+preferredChannelName :: Channel -> T.Text+preferredChannelName ch+ | channelType ch == Group = channelDisplayName ch+ | otherwise = channelName ch++data NewMessageIndicator =+ Hide+ | NewPostsAfterServerTime UTCTime+ | NewPostsStartingAt UTCTime+ deriving (Eq, Show)++initialChannelInfo :: Channel -> ChannelInfo+initialChannelInfo chan =+ let updated = chan ^. channelLastPostAtL+ in ChannelInfo { _cdViewed = Nothing+ , _cdNewMessageIndicator = Hide+ , _cdMentionCount = 0+ , _cdUpdated = updated+ , _cdName = preferredChannelName chan+ , _cdHeader = chan^.channelHeaderL+ , _cdType = chan^.channelTypeL+ , _cdCurrentState = initialChannelState+ }++channelInfoFromChannelWithData :: ChannelWithData -> ChannelInfo -> ChannelInfo+channelInfoFromChannelWithData (ChannelWithData chan chanData) ci =+ let viewed = chanData ^. channelDataLastViewedAtL+ updated = chan ^. channelLastPostAtL+ in ci { _cdViewed = Just viewed+ , _cdNewMessageIndicator = case _cdNewMessageIndicator ci of+ Hide -> if updated > viewed then NewPostsAfterServerTime viewed else Hide+ v -> v+ , _cdUpdated = updated+ , _cdName = preferredChannelName chan+ , _cdHeader = (chan^.channelHeaderL)+ , _cdType = (chan^.channelTypeL)+ , _cdMentionCount = chanData^.channelDataMentionCountL+ }++-- | The 'ChannelContents' is a wrapper for a list of+-- 'Message' values+data ChannelContents = ChannelContents+ { _cdMessages :: Messages+ }++-- | An initial empty 'ChannelContents' value+emptyChannelContents :: ChannelContents+emptyChannelContents = ChannelContents+ { _cdMessages = noMessages+ }++------------------------------------------------------------------------++-- * Channel State management++-- | The 'ChannelState' represents our internal state+-- of the channel with respect to our knowledge (or+-- lack thereof) about the server's information+-- about the channel.+data ChannelState+ = ChanGettingInfo -- ^ (Re-) fetching for an unloaded channel+ | ChanUnloaded -- ^ Only have channel metadata+ | ChanGettingPosts -- ^ (Re-) fetching for a loaded channel+ | ChanInitialSelect -- ^ Initially selected channel, but not contents yet+ | ChanLoaded -- ^ Have channel metadata and contents+ deriving (Eq, Show)++-- The ChannelState may be affected by background operations (see+-- asyncIO), so state transitions may be suggested by the completion+-- of those asynchronous operations but they should be reconciled with+-- any other asynchronous (or foreground) state updates.+--+-- To facilitate this, the ChannelState is a member of Ord and Enum,+-- with the intention that states generally transition to higher state+-- values (indicating more knowledge/completeness) and not downwards,+-- allowing the use of `max` and `pred` and `succ` below for managing+-- state changes. The `Ord` and `Enum` membership is merely for local+-- convenience: all state management should be handled by the methods+-- below so more detailed methods can be used instead of the Ord and+-- Enum instances without impact to external code.++-- | Specifies the initial state for created ClientChannel objects.+initialChannelState :: ChannelState+initialChannelState = ChanUnloaded++-- | The state to use to indicate that channel content (i.e.,+-- messages) are being loaded (possibly asynchronously). In contrast+-- to the `pendingChannelState` function, this function is used when+-- the channel is transitioning from only having the metadata+-- information to having full content information.+loadingChannelContentState :: ChannelState+loadingChannelContentState = ChanGettingPosts++-- | The pendingChannelState specifies the new ChannelState to+-- represent an active fetch of information for a channel, given the+-- channel's current state. This is used when the existing+-- information is being refreshed. The return is a tuple of the new+-- state and a function to call after the async operation has finished+-- with the ChannelState at that time and which will return the new+-- state that should be set on that completion.+pendingChannelState :: ChannelState -> (ChannelState,+ (ChannelState -> ChannelState))+pendingChannelState ChanGettingInfo = (ChanGettingInfo, id)+pendingChannelState ChanGettingPosts = (ChanGettingPosts, id)+pendingChannelState ChanUnloaded = (ChanGettingInfo, quiescentChannelState ChanUnloaded)+pendingChannelState ChanLoaded = (ChanGettingPosts, quiescentChannelState ChanLoaded)+pendingChannelState ChanInitialSelect = (ChanGettingPosts, quiescentChannelState ChanInitialSelect)++-- | The completionChannelState specifies the new ChannelState upon+-- completion of an activity. The activity is represented by the+-- first argument, which is the pendingState. The channel may have+-- been updated in the interim by other activities as well, so the+-- currentState is also provided. This function determines the proper+-- new state of the channel based on the action and current state. In+-- the event that multiple update operations are performed at the same+-- time, the state should always reach higher resting states.+quiescentChannelState :: ChannelState -> ChannelState -> ChannelState+quiescentChannelState targetState currentState =+ if isPendingState targetState+ then currentState+ else case (currentState, targetState) of+ (ChanLoaded, ChanUnloaded) -> ChanLoaded+ (ChanGettingPosts, ChanUnloaded) -> ChanGettingPosts+ (ChanInitialSelect, ChanUnloaded) -> ChanInitialSelect+ (_, t) -> t++-- | Returns true if the channel's state is one where there is a+-- pending asynchronous update already scheduled.+isPendingState :: ChannelState -> Bool+isPendingState cstate = cstate `elem` [ ChanGettingPosts+ , ChanGettingInfo+ ]++------------------------------------------------------------------------++-- | The 'ChannelInfo' record represents metadata+-- about a channel+data ChannelInfo = ChannelInfo+ { _cdViewed :: Maybe UTCTime+ -- ^ The last time we looked at a channel+ , _cdNewMessageIndicator :: NewMessageIndicator+ -- ^ The state of the channel's new message indicator.+ , _cdMentionCount :: Int+ -- ^ The current number of unread mentions+ , _cdUpdated :: UTCTime+ -- ^ The last time a message showed up in the channel+ , _cdName :: T.Text+ -- ^ The name of the channel+ , _cdHeader :: T.Text+ -- ^ The header text of a channel+ , _cdType :: Type+ -- ^ The type of a channel: public, private, or DM+ , _cdCurrentState :: ChannelState+ -- ^ The current state of the channel+ }++-- ** Channel-related Lenses++makeLenses ''ChannelContents+makeLenses ''ChannelInfo+makeLenses ''ClientChannel++-- ** Miscellaneous channel operations++makeClientChannel :: Channel -> ClientChannel+makeClientChannel nc = ClientChannel+ { _ccContents = emptyChannelContents+ , _ccInfo = initialChannelInfo nc+ }++canLeaveChannel :: ChannelInfo -> Bool+canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct, Group]++-- ** Manage the collection of all Channels++-- | Define a binary kinded type to allow derivation of functor.+newtype AllMyChannels a = AllChannels { _ofChans :: HM.HashMap ChannelId a }+ deriving (Functor, Foldable, Traversable)++-- | Define the exported typename which universally binds the+-- collection to the ChannelInfo type.+type ClientChannels = AllMyChannels ClientChannel++makeLenses ''AllMyChannels++-- | Initial collection of Channels with no members+noChannels :: ClientChannels+noChannels = AllChannels HM.empty++-- | Add a channel to the existing collection.+addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels+addChannel cId cinfo = AllChannels . HM.insert cId cinfo . _ofChans++-- | Get the ChannelInfo information given the ChannelId+findChannelById :: ChannelId -> ClientChannels -> Maybe ClientChannel+findChannelById cId = HM.lookup cId . _ofChans++-- | Extract a specific user from the collection and perform an+-- endomorphism operation on it, then put it back into the collection.+modifyChannelById :: ChannelId -> (ClientChannel -> ClientChannel)+ -> ClientChannels -> ClientChannels+modifyChannelById cId f = ofChans.ix(cId) %~ f++-- | A 'Traversal' that will give us the 'ClientChannel' in a+-- 'ClientChannels' structure if it exists+channelByIdL :: ChannelId -> Traversal' ClientChannels ClientChannel+channelByIdL cId = ofChans . ix cId++-- | A 'Lens' that will give us the 'ClientChannel' in a+-- 'ClientChannels' wrapped in a 'Maybe'+maybeChannelByIdL :: ChannelId -> Lens' ClientChannels (Maybe ClientChannel)+maybeChannelByIdL cId = ofChans . at cId++-- | Apply a filter to each ClientChannel and return a list of the+-- ChannelId values for which the filter matched.+filteredChannelIds :: (ClientChannel -> Bool) -> ClientChannels -> [ChannelId]+filteredChannelIds f cc = fst <$> filter (f . snd) (HM.toList (cc^.ofChans))++-- | Filter the ClientChannel collection, keeping only those for which+-- the provided filter test function returns True.+filteredChannels :: ((ChannelId, ClientChannel) -> Bool)+ -> ClientChannels -> ClientChannels+filteredChannels f cc =+ AllChannels . HM.fromList . filter f $ cc^.ofChans.to HM.toList++-- | Clear the new message indicator for the specified channel+clearNewMessageIndicator :: ClientChannel -> ClientChannel+clearNewMessageIndicator c = c & ccInfo.cdNewMessageIndicator .~ Hide++-- | 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)++maxPostTimestamp :: Post -> UTCTime+maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL)++updateNewMessageIndicator :: Post -> ClientChannel -> ClientChannel+updateNewMessageIndicator m =+ ccInfo.cdNewMessageIndicator %~+ (\old ->+ case old of+ Hide ->+ NewPostsStartingAt $ m^.postCreateAtL+ NewPostsStartingAt ts ->+ NewPostsStartingAt $ min (m^.postCreateAtL) ts+ NewPostsAfterServerTime ts ->+ if m^.postCreateAtL <= ts+ then NewPostsStartingAt $ m^.postCreateAtL+ else NewPostsAfterServerTime ts+ )
src/Types/Messages.hs view
@@ -7,13 +7,14 @@ module Types.Messages ( Message(..)- , isDeletable, isReplyable, isEditable+ , isDeletable, isReplyable, isEditable, isReplyTo , mText, mUserName, mDate, mType, mPending, mDeleted- , mAttachments, mInReplyToMsg, mPostId, mReactions- , mOriginalPost+ , mAttachments, mInReplyToMsg, mPostId, mReactions, mFlagged+ , mOriginalPost, mChannelId , MessageType(..) , ReplyState(..) , clientMessageToMessage+ , newMessageOfType , Messages , ChronologicalMessages , RetrogradeMessages@@ -21,6 +22,7 @@ , noMessages , splitMessages , findMessage+ , filterMessages , getNextPostId , getPrevPostId , getLatestPostId@@ -39,7 +41,7 @@ import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Lens.Micro.Platform-import Network.Mattermost+import Network.Mattermost.Types (ChannelId, PostId, Post) import Types.Posts -- * Messages@@ -58,6 +60,8 @@ , _mPostId :: Maybe PostId , _mReactions :: Map.Map T.Text Int , _mOriginalPost :: Maybe Post+ , _mFlagged :: Bool+ , _mChannelId :: Maybe ChannelId } deriving (Show) isDeletable :: Message -> Bool@@ -69,20 +73,25 @@ isEditable :: Message -> Bool isEditable m = _mType m `elem` [CP NormalPost, CP Emote] +isReplyTo :: PostId -> Message -> Bool+isReplyTo expectedParentId m =+ case _mInReplyToMsg m of+ NotAReply -> False+ InReplyTo actualParentId -> actualParentId == expectedParentId+ -- | A 'Message' is the representation we use for storage and -- rendering, so it must be able to represent either a -- post from Mattermost or an internal message. This represents -- the union of both kinds of post types. data MessageType = C ClientMessageType- | CP PostType+ | CP ClientPostType deriving (Eq, Show) -- | The 'ReplyState' of a message represents whether a message -- is a reply, and if so, to what message data ReplyState = NotAReply- | ParentLoaded PostId Message- | ParentNotLoaded PostId+ | InReplyTo PostId deriving (Show) -- | Convert a 'ClientMessage' to a 'Message'@@ -99,8 +108,27 @@ , _mPostId = Nothing , _mReactions = Map.empty , _mOriginalPost = Nothing+ , _mFlagged = False+ , _mChannelId = Nothing } +newMessageOfType :: T.Text -> MessageType -> UTCTime -> Message+newMessageOfType text typ d = Message+ { _mText = getBlocks text+ , _mUserName = Nothing+ , _mDate = d+ , _mType = typ+ , _mPending = False+ , _mDeleted = False+ , _mAttachments = Seq.empty+ , _mInReplyToMsg = NotAReply+ , _mPostId = Nothing+ , _mReactions = Map.empty+ , _mOriginalPost = Nothing+ , _mFlagged = False+ , _mChannelId = Nothing+ }+ -- ** 'Message' Lenses makeLenses ''Message@@ -149,6 +177,13 @@ -- ** Common operations on Messages +filterMessages ::+ SeqDirection seq =>+ (Message -> Bool) ->+ DirectionalSeq seq Message ->+ DirectionalSeq seq Message+filterMessages p = onDirectedSeq (Seq.filter p)+ class MessageOps a where addMessage :: Message -> a -> a @@ -253,9 +288,9 @@ where valid m = not (m^.mDeleted) && isJust (m^.mPostId) -- | Find the most recent message that is a message posted by a user--- that matches the (if any), skipping local client messages and any--- user event that is not a message (i.e. find a normal message or an--- emote).+-- that matches the test (if any), skipping local client messages and+-- any user event that is not a message (i.e. find a normal message or+-- an emote). findLatestUserMessage :: (Message -> Bool) -> Messages -> Maybe Message findLatestUserMessage f msgs = case getLatestPostId msgs of
src/Types/Posts.hs view
@@ -47,7 +47,7 @@ , _cpUser :: Maybe UserId , _cpUserOverride :: Maybe T.Text , _cpDate :: UTCTime- , _cpType :: PostType+ , _cpType :: ClientPostType , _cpPending :: Bool , _cpDeleted :: Bool , _cpAttachments :: Seq.Seq Attachment@@ -68,7 +68,7 @@ -- | A Mattermost 'Post' value can represent either a normal -- chat message or one of several special events.-data PostType =+data ClientPostType = NormalPost | Emote | Join@@ -83,7 +83,7 @@ getBlocks s = bs where C.Doc _ bs = C.markdown C.def s -- | Determine the internal 'PostType' based on a 'Post'-postClientPostType :: Post -> PostType+postClientPostType :: Post -> ClientPostType postClientPostType cp = if | postIsEmote cp -> Emote | postIsJoin cp -> Join@@ -93,7 +93,7 @@ -- | Find out whether a 'Post' represents a topic change postIsTopicChange :: Post -> Bool-postIsTopicChange p = postType p == SystemHeaderChange+postIsTopicChange p = postType p == PostTypeHeaderChange -- | Find out whether a 'Post' is from a @/me@ command postIsEmote :: Post -> Bool@@ -105,14 +105,16 @@ -- | Find out whether a 'Post' is a user joining a channel postIsJoin :: Post -> Bool-postIsJoin p = "has joined the channel" `T.isInfixOf` postMessage p+postIsJoin p =+ p^.postTypeL == PostTypeJoinChannel -- | Find out whether a 'Post' is a user leaving a channel postIsLeave :: Post -> Bool-postIsLeave p = "has left the channel" `T.isInfixOf` postMessage p+postIsLeave p =+ p^.postTypeL == PostTypeLeaveChannel -- | Undo the automatic formatting of posts generated by @/me@-commands-unEmote :: PostType -> T.Text -> T.Text+unEmote :: ClientPostType -> T.Text -> T.Text unEmote Emote t = if "*" `T.isPrefixOf` t && "*" `T.isSuffixOf` t then T.init $ T.tail t else t@@ -125,9 +127,7 @@ { _cpText = (getBlocks $ unEmote (postClientPostType p) $ postMessage p) <> getAttachmentText p , _cpUser = postUserId p- , _cpUserOverride = case p^.postPropsL.postPropsOverrideIconUrlL of- Just _ -> Nothing- _ -> p^.postPropsL.postPropsOverrideUsernameL+ , _cpUserOverride = p^.postPropsL.postPropsOverrideUsernameL , _cpDate = postCreateAt p , _cpType = postClientPostType p , _cpPending = False@@ -148,7 +148,7 @@ Nothing -> Seq.empty Just attachments -> fmap (C.Blockquote . render) attachments- where render att = getBlocks (att^.ppaTextL)+ where render att = getBlocks (att^.ppaTextL) <> getBlocks (att^.ppaFallbackL) -- ** 'ClientPost' Lenses
+ src/Types/Users.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}++module Types.Users+ ( UserInfo(..)+ , UserStatus(..)+ , Users -- constructor remains internal+ -- * Lenses created for accessing UserInfo fields+ , uiName, uiId, uiStatus, uiInTeam, uiNickName, uiFirstName, uiLastName, uiEmail+ -- * Various operations on UserInfo+ -- * Creating UserInfo objects+ , userInfoFromUser+ -- * Miscellaneous+ , statusFromText+ , findUserById+ , findUserByName+ , findUserByDMChannelName+ , noUsers, addUser, allUsers+ , modifyUserById+ , getDMChannelName+ )+where++import qualified Data.HashMap.Strict as HM+import Data.List (sort)+import Data.Maybe (listToMaybe, maybeToList)+import Data.Monoid ((<>))+import qualified Data.Text as T+import Lens.Micro.Platform+import Network.Mattermost.Types (UserId, User(..), idString)++-- * 'UserInfo' Values++-- | A 'UserInfo' value represents everything we need to know at+-- runtime about a user+data UserInfo = UserInfo+ { _uiName :: T.Text+ , _uiId :: UserId+ , _uiStatus :: UserStatus+ , _uiInTeam :: Bool+ , _uiNickName :: Maybe T.Text+ , _uiFirstName :: T.Text+ , _uiLastName :: T.Text+ , _uiEmail :: T.Text+ } deriving (Eq, Show)++-- | Create a 'UserInfo' value from a Mattermost 'User' value+userInfoFromUser :: User -> Bool -> UserInfo+userInfoFromUser up inTeam = UserInfo+ { _uiName = userUsername up+ , _uiId = userId up+ , _uiStatus = Offline+ , _uiInTeam = inTeam+ , _uiNickName = if T.null (userNickname up)+ then Nothing+ else Just $ userNickname up+ , _uiFirstName = userFirstName up+ , _uiLastName = userLastName up+ , _uiEmail = userEmail up+ }++-- | The 'UserStatus' value represents possible current status for+-- a user+data UserStatus+ = Online+ | Away+ | Offline+ | Other T.Text+ deriving (Eq, Show)++statusFromText :: T.Text -> UserStatus+statusFromText t = case t of+ "online" -> Online+ "offline" -> Offline+ "away" -> Away+ _ -> Other t++-- ** 'UserInfo' lenses++makeLenses ''UserInfo++-- ** Manage the collection of all Users++-- | Define a binary kinded type to allow derivation of functor.+newtype AllMyUsers a = AllUsers { _ofUsers :: HM.HashMap UserId a }+ deriving Functor++-- | Define the exported typename which universally binds the+-- collection to the UserInfo type.+type Users = AllMyUsers UserInfo++makeLenses ''AllMyUsers++-- | Initial collection of Users with no members+noUsers :: Users+noUsers = AllUsers HM.empty++-- | Add a member to the existing collection of Users+addUser :: UserId -> UserInfo -> Users -> Users+addUser uId userinfo = AllUsers . HM.insert uId userinfo . _ofUsers++-- | Get a list of all known users+allUsers :: Users -> [UserInfo]+allUsers = HM.elems . _ofUsers++-- | Get the User information given the UserId+findUserById :: UserId -> Users -> Maybe UserInfo+findUserById uId = HM.lookup uId . _ofUsers++-- | Get the User information given the user's name. This is an exact+-- match on the username field, not necessarly the presented name.+findUserByName :: Users -> T.Text -> Maybe (UserId, UserInfo)+findUserByName allusers name =+ case filter ((== name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of+ (usr : []) -> Just usr+ _ -> Nothing++-- | Extract a specific user from the collection and perform an+-- endomorphism operation on it, then put it back into the collection.+modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users+modifyUserById uId f = ofUsers.ix(uId) %~ f++getDMChannelName :: UserId -> UserId -> T.Text+getDMChannelName me you = cname+ where+ [loUser, hiUser] = sort $ idString <$> [ you, me ]+ cname = loUser <> "__" <> hiUser++findUserByDMChannelName :: Users+ -> T.Text -- ^ the dm channel name+ -> UserId -- ^ me+ -> Maybe UserInfo -- ^ you+findUserByDMChannelName users dmchan me = listToMaybe+ [ user+ | u <- HM.keys $ _ofUsers users+ , getDMChannelName me u == dmchan+ , user <- maybeToList (HM.lookup u $ _ofUsers users)+ ]
+ test/Cheapskate_QCA.hs view
@@ -0,0 +1,47 @@+module Cheapskate_QCA where++import Cheapskate.Types+import qualified Data.Sequence as Seq ()+import Network.Mattermost.QuickCheck (genText, genSeq)+import Test.Tasty.QuickCheck++genBlocks :: Gen Blocks+genBlocks = genSeq genBlock++genBlock :: Gen Block+genBlock = oneof [ Para <$> genInlines+ , Header <$> arbitrary <*> genInlines+ , Blockquote <$> genBlocks+ , List <$> arbitrary <*> genListType <*> listOf (genBlocks)+ , CodeBlock <$> genCodeAttr <*> genText+ , HtmlBlock <$> genText+ , return HRule+ ]++genInlines :: Gen Inlines+genInlines = genSeq genInline++genInline :: Gen Inline+genInline = oneof [ Str <$> genText+ , return Space+ , return SoftBreak+ , return LineBreak+ , Emph <$> genInlines+ , Strong <$> genInlines+ , Code <$> genText+ , Link <$> genInlines <*> genText <*> genText+ , Image <$> genInlines <*> genText <*> genText+ , Entity <$> genText+ , RawHtml <$> genText+ ]++genListType :: Gen ListType+genListType = oneof [ Bullet <$> arbitrary+ , Numbered <$> genNumWrapper <*> arbitrary+ ]++genNumWrapper :: Gen NumWrapper+genNumWrapper = elements [ PeriodFollowing, ParenFollowing ]++genCodeAttr :: Gen CodeAttr+genCodeAttr = CodeAttr <$> genText <*> genText
+ test/Message_QCA.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Message_QCA where++import Cheapskate_QCA+import Data.Map hiding (foldr)+import Network.Mattermost.QuickCheck+import Network.Mattermost.Types+import Test.Tasty.QuickCheck+import Types.Messages+import Types.Posts++genMap :: Ord key => Gen key -> Gen value -> Gen (Map key value)+genMap gk gv = let kv = (,) <$> gk <*> gv in fromList <$> listOf kv++genMessage :: Gen Message+genMessage = Message+ <$> genBlocks+ <*> genMaybe genText+ <*> genTime+ <*> genMessageType+ <*> arbitrary+ <*> arbitrary+ <*> genSeq genAttachment+ <*> genReplyState+ <*> genMaybe genPostId+ <*> genMap genText arbitrary+ <*> genMaybe genPost+ <*> arbitrary+ <*> (Just <$> genChannelId)++-- Some tests specifically want deleted or non-deleted messages, so+-- make an easy way to specify these.+newtype Message__DeletedPost = Message__DeletedPost { delMsg :: Message }+ deriving Show++genMessage__DeletedPost :: Gen Message__DeletedPost+genMessage__DeletedPost = Message__DeletedPost+ <$> (Message+ <$> genBlocks+ <*> genMaybe genText+ <*> genTime+ <*> genMessageType+ <*> arbitrary+ <*> return True -- mDeleted+ <*> genSeq genAttachment+ <*> genReplyState+ <*> (Just <$> genPostId) -- must have been Posted if deleted+ <*> genMap genText arbitrary+ <*> genMaybe genPost+ <*> arbitrary+ <*> (Just <$> genChannelId))++newtype Message__Posted = Message__Posted { postMsg :: Message }+ deriving Show++genMessage__Posted :: Gen Message__Posted+genMessage__Posted = Message__Posted+ <$> (Message+ <$> genBlocks+ <*> genMaybe genText+ <*> genTime+ <*> genMessageType+ <*> arbitrary+ <*> return False -- mDeleted+ <*> genSeq genAttachment+ <*> genReplyState+ <*> (Just <$> genPostId)+ <*> genMap genText arbitrary+ <*> genMaybe genPost+ <*> arbitrary+ <*> (Just <$> genChannelId))+++genMessageType :: Gen MessageType+genMessageType = oneof [ C <$> genClientMessageType+ , CP <$> genClientPostType+ ]++genClientMessageType :: Gen ClientMessageType+genClientMessageType = elements [ Informative+ , Error+ , DateTransition+ , NewMessagesTransition+ ]++genClientPostType :: Gen ClientPostType+genClientPostType = elements [ NormalPost+ , Emote+ , Join+ , Leave+ , TopicChange+ ]++genReplyState :: Gen ReplyState+genReplyState = oneof [ return NotAReply+ , InReplyTo <$> genPostId+ ]++genAttachment :: Gen Attachment+genAttachment = Attachment+ <$> genText+ <*> genText+ <*> genFileId+++instance Arbitrary Message where arbitrary = genMessage+instance Arbitrary Message__DeletedPost where arbitrary = genMessage__DeletedPost+instance Arbitrary Message__Posted where arbitrary = genMessage__Posted+instance Arbitrary PostId where arbitrary = genPostId++instance Arbitrary Messages where+ arbitrary = sized $ \s -> foldr addMessage noMessages <$> vectorOf s arbitrary++instance Arbitrary RetrogradeMessages where+ arbitrary = reverseMessages <$> arbitrary
test/test_messages.hs view
@@ -45,15 +45,15 @@ test_m1 :: IO Message test_m1 = do t1 <- getCurrentTime- return $ Message Seq.empty Nothing t1 (CP NormalPost) False False Seq.empty NotAReply Nothing Map.empty Nothing+ return $ Message Seq.empty Nothing t1 (CP NormalPost) False False Seq.empty NotAReply Nothing Map.empty Nothing False Nothing test_m2 :: IO Message test_m2 = do t2 <- getCurrentTime- return $ Message Seq.empty Nothing t2 (CP Emote) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m2") Map.empty Nothing+ return $ Message Seq.empty Nothing t2 (CP Emote) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m2") Map.empty Nothing False Nothing test_m3 :: IO Message test_m3 = do t3 <- getCurrentTime- return $ Message Seq.empty Nothing t3 (CP NormalPost) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m3") Map.empty Nothing+ return $ Message Seq.empty Nothing t3 (CP NormalPost) False False Seq.empty NotAReply (Just $ fromId $ Id $ T.pack "m3") Map.empty Nothing False Nothing setDateOrderMessages :: [Message] -> [Message] setDateOrderMessages = snd . foldl setTimeAndInsert (startTime, [])