matterhorn 50200.1.1 → 50200.2.0
raw patch · 45 files changed
+1527/−719 lines, 45 filesdep ~aesondep ~brickdep ~containers
Dependency ranges changed: aeson, brick, containers, mattermost-api, mattermost-api-qc, stm, tasty, vector
Files
- CHANGELOG.md +77/−0
- PRACTICES.md +89/−3
- README.md +64/−18
- matterhorn.cabal +19/−19
- src/App.hs +16/−0
- src/Command.hs +23/−3
- src/Command.hs-boot +9/−0
- src/Config.hs +41/−28
- src/Draw.hs +0/−1
- src/Draw/Autocomplete.hs +13/−8
- src/Draw/ChannelList.hs +10/−5
- src/Draw/Main.hs +36/−34
- src/Draw/Messages.hs +5/−8
- src/Draw/ShowHelp.hs +65/−23
- src/Events.hs +0/−2
- src/Events/ChannelScroll.hs +0/−48
- src/Events/Keybindings.hs +1/−0
- src/Events/Main.hs +16/−54
- src/Events/MessageSelect.hs +7/−0
- src/Events/PostListOverlay.hs +1/−0
- src/KeyMap.hs +0/−2
- src/Main.hs +14/−2
- src/Markdown.hs +13/−13
- src/Options.hs +19/−8
- src/Prelude/MH.hs +31/−1
- src/Scripts.hs +2/−1
- src/State/Autocomplete.hs +1/−1
- src/State/ChannelScroll.hs +0/−54
- src/State/Channels.hs +70/−63
- src/State/Editing.hs +87/−5
- src/State/MessageSelect.hs +49/−6
- src/State/Messages.hs +321/−61
- src/State/PostListOverlay.hs +85/−28
- src/State/Reactions.hs +7/−2
- src/State/Setup.hs +1/−1
- src/State/UserListOverlay.hs +2/−2
- src/Types.hs +51/−130
- src/Types/Channels.hs +46/−6
- src/Types/DirectionalSeq.hs +6/−2
- src/Types/KeyEvents.hs +3/−0
- src/Types/Messages.hs +136/−64
- src/Types/Posts.hs +8/−3
- src/Types/UserNames.hs +70/−0
- src/Types/Users.hs +4/−1
- test/test_messages.hs +9/−9
CHANGELOG.md view
@@ -1,3 +1,80 @@+50200.2.0+=========++New features:+ * Channel scrolling mode has been merged with message select mode.+ There are no longer two separate modes that the user must switched+ between for fetching additional messages and operating on displayed+ messages.+ * As part of this change, gaps in the local client history where+ the server may contain additional messages are displayed as+ special entries in the message history, along with specific key+ commands that can be used to fetch additional messages at that+ point.+ * The `/msg` command now takes optional user and message arguments to+ make it faster and easier to initiate discussions with specific+ users: `/msg [@user [message]]`. This resolves enhancement issue+ #471.+ * If smart editing is enabled and a triple backtick is typed at the+ start of a line, input automatically switches to multi-line mode.+ Fixes issue #467.+ * Status is now tracked on a per-channel basis. Previously some+ things (like incomplete message entries) were global, and others+ were simply reset when moving away from and back to a channel. In+ this version, much of this state is automatically saved and+ restored on a per-channel basis:+ * Incomplete message (editor) entries.+ * Multi-line mode for incomplete message entries.+ * Input history scrollback position.+ * Incomplete message reply-to or editing-previous-post status.+ This resolves enhancement issue #445.+ * Adds the `/user` command as an alias for the `/msg` command.+ * Channel auto-completion mode indication of the user's membership in+ the channel is more clearly indicated.+ * A new configuration item (`directChannelExpirationDays`) is added.+ In release 50200.1.0, the channel sidebar management was updated to+ automatically remove direct channels if there had been no activity+ for 7 days. This configuration item allows overriding that time+ period, (thanks, Brent Carmer).+ * A new configuration item (`cpuUsagePolicy`) is added. Valid values+ are `single` and `multiple` which determines how many of the+ available processors Matterhorn will make use of. The default is+ `multiple`. This resolves enhancement issue #484.+ * Additional information on managing attachments (relative to issue #485).++New command-line options:+ * `-k`: print the active keybindings in plain text format. The output+ includes customized bindings in the current configuration, or the+ defaults if `-i` is used.+ * `-K`: print the active keybindings in Markdown format. The output+ includes customized bindings in the current configuration, or the+ defaults if `-i` is used.++Documentation updates:+ * The FAQ is updated to help users with terminals that don't support+ hyperlinks (thanks, Bob Arezina).+ * Updated the Design notes and development Practices documentation+ for Matterhorn.+ * Matterhorn releases now include the default keybindings in a Markdown+ document, `keybindings.md`.++Bug fixes:+ * Updated to mattermost-api 50200.1.2 which includes a bugfix for a+ server "UploadResponse" with a null `client_ids` field. This+ manifested as an error report when attempting to post a message+ with an attachment to a general channel.+ * Misc process and maintenance changes to re-enable and update the+ Travis builds (fully passing now).++Dependency updates:+ * Added support for building with GHC 8.6 (thanks, Adam Wick).++50200.1.2+=========++Bug fixes:+ * Permit user creation timestamp to be optional in server responses+ (#483) 50200.1.1 =========
PRACTICES.md view
@@ -13,11 +13,70 @@ * We want to manage inevitable software evolution, and * We want to reduce waste through good team coordination. -General--------+Design Philosophy+----------------- -Branches should be `-Wall` clean prior to merging.+We aim to take care of the following concerns when adding new features: + * We want Matterhorn to be responsive.+ * We want Matterhorn to use available system resources when possible.+ * We want Matterhorn's system resource usage to be user-constrainable.+ * We want Matterhorn to default to using only as much system resources+ as necessary.+ * We want to avoid exposing or leaking Haskell internals (such as RTS+ options) to the end user. Instead, we want to use our own idioms.+ * We want configuration to be as clear, simple, and future-proof as+ possible. (Avoid: confusing, complex, error-prone, future-brittle.)++Commit Hygiene+--------------++Before committing or merging, strive for a `-Wall`-clean build.++Each commit should ideally make one logical, self-contained change. For+example, by this reasoning a commit should add one new feature, fix one+bug, or do one incremental refactoring step. A single commit maintains+a successful build and working software whenever possible. Commits that+break things that are intended to be fixed at a much later date should+be avoided if possible. When unavoidable they should be indicated very+clearly by their commit message.++Commits should also be concise so that if something has to be reverted+or updated it's easy to focus on the origin of the change in its+minimum form. Commits should not be squashed (no mega-commits, please).++A commit should have a commit message describing the purpose of the+change, the salient code elements to bring to the reader's attention,+any motivations or context for the change, any caveats, and any+intentions about the future. A good commit message template is:++```+<scope>: <concise one-line high-level description>++<paragraph describing in greater detail all of the above>+```++where `scope` is the name of a module, file, function, etc. that plays+the most central role in the change.++We want commit messages to be a good reference for someone (maybe you!)+wanting to understand a code change (maybe your own!) in the future.+Capturing reasoning and other context makes the commit history useful in+this way.++One way to support this workflow is to always use hunk prompting with+git:++```+$ git add -p+```++and only add hunks relevant to your logical change and split large hunks+into small ones with the `s` choice to ensure that incidental unrelated+changes don't make it into the commit. You should only ever use `git+add <file>` if you are *absolutely sure* the entire file belongs in the+commit.+ Aesthetics ---------- @@ -94,6 +153,33 @@ directly to `master` and merged back into `develop`. This ensures that bug fixes are not held up by other development work in case a bugfix release is desired.++Compatibility+-------------++Matterhorn is primarily distributed to users as binaries that have+been built for that purpose; the primary compatibility support goal is+the set of operating systems binaries are built for.++From an operating system perspective, the "current stable release"+versions of those operating systems are the primary targets. We+support many of the more popular operating systems, including: CentOS,+Fedoria, Ubuntu, and MacOS.++Those wishing to use Matterhorn on a different operating system (that+is not compatible with one of the pre-built binaries) or work with the+code directly by building from source will need to obtain the source+directly and follow the build instructions described in the README+document. The GHC compiler version documented in the build+instructions is the primary supported version.++Continuous Integration (CI) systems (e.g. Travis and/or Hydra) are+used for determining the viability of builds for different GHC+compiler versions, and in some cases on different operating systems.+The general intent is to support 3 GHC compiler versions (the current+and the two most previous versions) to allow flexibility for developer+configurations, but we cannot commit to supporting any version other+than the one documented in the README. Issue Tracking --------------
README.md view
@@ -29,8 +29,12 @@ https://github.com/matterhorn-chat/matterhorn/releases To run Matterhorn, unpack the binary release archive and run the-`matterhorn` binary within.+`matterhorn` binary within. Help is available via the `--help` or+`-h` flag. + $ matterhorn --help+ $ matterhorn+ When you run Matterhorn you'll be prompted for your server information and credentials. At present `matterhorn` supports only username/password authentication.@@ -71,16 +75,26 @@ * 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. Keybindings may include-modifiers such as Control (indicated with a `C-` prefix) or Meta-(indicated with a `M-` prefix). If your keyboard has an `Alt` key, that-will work as `Meta`. If it does not, you may be able to configure your-terminal to provide `Meta` via other means (e.g. iTerm2 on OS X can be-configured to make the left Option key work as Meta). Keybindings can-be customized in the configuration file; see `/help keybindings` for-details.+the client. Keybinding information may be obtained in a number of ways: +* The `/help` command within Matterhorn.+* The `F1` key within Matterhorn.+* Running matterhorn with the `-k` argument for text keybindings+* Running matterhorn with the `-K` argument for [Markdown keybindings](keybindings.md)++ Note: The latter two commands do not start the client but simply+ print to stdout and exit. The bindings shown include any user+ overrides from the config files; use the `-i` flag to skip loading+ the local config files and see the Matterhorn default keybindings.++Keybindings may include modifiers such as Control (indicated with a+`C-` prefix) or Meta (indicated with a `M-` prefix). If your keyboard+has an `Alt` key, that will work as `Meta`. If it does not, you may be+able to configure your terminal to provide `Meta` via other means+(e.g. iTerm2 on OS X can be configured to make the left Option key+work as Meta). Keybindings can be customized in the configuration+file; see `/help keybindings` for details.+ 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`.@@ -213,15 +227,43 @@ # 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.+corresponds to the lowest Mattermost server version expected to be+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`. There may be later versions of the+Mattermost server that are supported (e.g. Matterhorn 50200.X.Y+supports Mattermost server versions 5.2 through at least 5.8). +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.++# Our Design Philosophy++Overall, we strive to build a terminal client that provides the same+basic feature set as the web client. This is reflected in the state+of the client, our issue backlog, and the content of our wiki feature+design discussions.++We intend to add web client features to Matterhorn to the extent that+they can be added sensibly in a terminal setting. Our goal is to do+so in a way that minimizes surprise to web client users migrating to+Matterhorn while also providing the best terminal user experience that+we can think of. That might entail adding the web client features but+changing their designs to ones better suited for terminal use or it+might mean omitting aspects of web client features that rely heavily on+mouse- or DOM-related UI idioms. It might also entail adding web client+features but deviating slightly on specific behaviors.++If you are used to a web client feature and don't see it in Matterhorn,+that's probably because we just haven't gotten to it yet. We would+be happy to hear from people wanting to contribute! If you can't+contribute, search existing issues to see if we already have an issue+for it, or create a new issue and let us know!+ # Contributing If you decide to contribute, that's great! Here are some guidelines you@@ -253,3 +295,7 @@ * http://www.nerdyweekly.com/posts/enable-italic-text-vim-tmux-gnome-terminal/ * https://medium.com/@dubistkomisch/how-to-actually-get-italics-and-true-colour-to-work-in-iterm-tmux-vim-9ebe55ebc2be * https://github.com/tmux/tmux/blob/2.1/FAQ#L355-L383+ +* Q: I am seeing malformed characters when I run matterhorn in my terminal. What could be causing this?+* A: Some terminal emulators cannot handle the extra escaping that occurs when the URL hyperlinking mode+ is enabled. Try setting `hyperlinkUrls = False` in your `config.ini` file.
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.1.1+version: 50200.2.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@@ -8,11 +8,11 @@ license-file: LICENSE author: matterhorn@galois.com maintainer: matterhorn@galois.com-copyright: ©2016-2018 AUTHORS.txt+copyright: ©2016-2019 AUTHORS.txt category: Chat build-type: Simple cabal-version: >= 1.18-tested-with: GHC == 7.10.3, GHC == 8.0.1+tested-with: GHC == 7.10.3, GHC == 8.0.1, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.3 data-files: syntax/*.xml syntax/language.dtd@@ -43,7 +43,6 @@ State.Attachments State.Autocomplete State.Channels- State.ChannelScroll State.ChannelSelect State.Common State.Editing@@ -87,7 +86,6 @@ Events.MessageSelect Events.Main Events.JoinChannel- Events.ChannelScroll Events.ChannelSelect Events.PostListOverlay Events.UrlSelect@@ -108,6 +106,7 @@ Types.KeyEvents Types.Messages Types.Users+ Types.UserNames Types.Posts FilePaths TeamSelect@@ -119,22 +118,22 @@ default-extensions: OverloadedStrings, ScopedTypeVariables, NoImplicitPrelude- ghc-options: -Wall -threaded -with-rtsopts=-I0+ ghc-options: -Wall -threaded -with-rtsopts=-I0 -Wcompat build-depends: base >=4.8 && <5- , mattermost-api == 50200.1.0+ , mattermost-api == 50200.1.2 , base-compat >= 0.9 && < 0.11 , unordered-containers >= 0.2 && < 0.3- , containers >= 0.5.7 && < 0.6+ , containers >= 0.5.7 && < 0.7 , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.19 , connection >= 0.2 && < 0.3 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11- , stm >= 2.4 && < 2.5+ , stm >= 2.4 && < 2.6 , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7 , microlens-platform >= 0.3 && < 0.4- , brick >= 0.43 && < 0.44+ , brick >= 0.46 && < 0.47 , brick-skylighting >= 0.2 && < 0.4 , vty >= 5.23.1 && < 5.26 , word-wrap >= 0.4.0 && < 0.5@@ -159,7 +158,7 @@ , skylighting-core >= 0.7 && < 0.8 , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2- , aeson >= 1.2.3.0 && < 1.4+ , aeson >= 1.2.3.0 && < 1.5 , async >= 2.2 && < 2.3 , uuid >= 1.3 && < 1.4 , random >= 1.1 && < 1.2@@ -173,37 +172,38 @@ , TimeUtils , Types.Messages , Types.Posts+ , Types.UserNames , Types.Common , Types.DirectionalSeq , Prelude.MH default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables- ghc-options: -Wall -fno-warn-orphans+ ghc-options: -Wall -fno-warn-orphans -Wcompat hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.11- , brick >= 0.43 && < 0.44+ , brick >= 0.46 && < 0.47 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.5 , config-ini >= 0.2.2.0 && < 0.3 , connection >= 0.2 && < 0.3- , containers >= 0.5.7 && < 0.6+ , containers >= 0.5.7 && < 0.7 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.3 , Hclip >= 3.0 && < 3.1- , mattermost-api == 50200.1.0- , mattermost-api-qc == 50200.1.0+ , mattermost-api == 50200.1.2+ , mattermost-api-qc == 50200.1.2 , 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+ , stm >= 2.4 && < 2.6 , strict >= 0.3 && < 0.4 , string-conversions >= 0.4 && < 0.5- , tasty >= 0.11 && < 1.2+ , tasty >= 0.11 && < 1.3 , tasty-hunit >= 0.9 && < 0.12 , tasty-quickcheck >= 0.8 && < 0.12 , text >= 1.2 && < 1.3@@ -214,7 +214,7 @@ , transformers >= 0.4 && < 0.6 , Unique >= 0.4 && < 0.5 , unordered-containers >= 0.2 && < 0.3- , vector <= 0.12.0.1+ , vector < 0.13 , vty >= 5.23.1 && < 5.26 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19
src/App.hs view
@@ -11,6 +11,7 @@ import Control.Monad.Trans.Except ( runExceptT ) import qualified Graphics.Vty as Vty import Text.Aspell ( stopAspell )+import GHC.Conc (getNumProcessors, setNumCapabilities) import Network.Mattermost @@ -38,8 +39,23 @@ , appAttrMap = (^.csResources.crTheme) } +applicationMaxCPUs :: Int+applicationMaxCPUs = 2++setupCpuUsage :: Config -> IO ()+setupCpuUsage config = do+ actualNumCpus <- getNumProcessors++ let requestedCPUs = case configCpuUsagePolicy config of+ SingleCPU -> 1+ MultipleCPUs -> min applicationMaxCPUs actualNumCpus++ setNumCapabilities requestedCPUs+ runMatterhorn :: Options -> Config -> IO ChatState runMatterhorn opts config = do+ setupCpuUsage config+ st <- setupState (optLogLocation opts) config let mkVty = do
src/Command.hs view
@@ -25,12 +25,14 @@ import HelpTopics import Scripts import State.Help+import State.Editing import State.Channels import State.ChannelSelect import State.Logging import State.PostListOverlay import State.Themes import State.UserListOverlay+import State.Users import Types @@ -86,8 +88,8 @@ beginCurrentChannelDeleteConfirm , Cmd "hide" "Hide the current DM or group channel from the channel list"- NoArg $ \ () ->- hideCurrentDMChannel+ NoArg $ \ () -> do+ hideDMChannel =<< use csCurrentChannelId , Cmd "reconnect" "Force a reconnection attempt to the server" NoArg $ \ () ->@@ -121,10 +123,22 @@ NoArg $ \ () -> enterChannelInviteUserList - , Cmd "msg" "Chat with a user privately"+ , Cmd "msg" "Search for a user to enter a private chat" NoArg $ \ () -> enterDMSearchUserList + , Cmd "msg" "Chat with the specified user"+ (TokenArg "user" NoArg) $ \ (name, ()) ->+ changeChannelByName name++ , Cmd "msg" "Go to a user's channel and send the specified message"+ (TokenArg "user" $ LineArg "message") $ \ (name, msg) -> do+ withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do+ case foundUser of+ Just user -> createOrFocusDMChannel user $ Just $ \cId ->+ handleInputSubmission cId msg+ Nothing -> mhError $ NoSuchUser name+ , Cmd "log-start" "Begin logging to the specified path" (TokenArg "path" NoArg) $ \ (path, ()) -> startLogging $ T.unpack path@@ -148,6 +162,12 @@ , Cmd "remove-user" "Remove a user from the current channel" (TokenArg "username" NoArg) $ \ (uname, ()) -> removeUserFromCurrentChannel uname++ , Cmd "user" "Show users to initiate a private DM chat channel"+ -- n.b. this is identical to "msg", but is provided as an+ -- alternative mental model for useability.+ NoArg $ \ () ->+ enterDMSearchUserList , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ -> toggleMessagePreview
+ src/Command.hs-boot view
@@ -0,0 +1,9 @@+module Command where++import Data.Text ( Text )++import Types ( MH, Cmd, CmdArgs )++commandList :: [Cmd]+printArgSpec :: CmdArgs a -> Text+dispatchCommand :: Text -> MH ()
src/Config.hs view
@@ -71,6 +71,8 @@ configPort <- fieldDefOf "port" number (configPort defaultConfig) configChannelListWidth <- fieldDefOf "channelListWidth" number (configChannelListWidth defaultConfig)+ configCpuUsagePolicy <- fieldDefOf "cpuUsagePolicy" cpuUsagePolicy+ (configCpuUsagePolicy defaultConfig) configLogMaxBufferSize <- fieldDefOf "logMaxBufferSize" number (configLogMaxBufferSize defaultConfig) configTimeFormat <- fieldMbOf "timeFormat" stringField@@ -105,6 +107,8 @@ pure Nothing configUnsafeUseHTTP <- fieldFlagDef "unsafeUseUnauthenticatedConnection" False+ configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number+ (configDirectChannelExpirationDays defaultConfig) let configAbsPath = Nothing configUserKeys = mempty@@ -129,6 +133,13 @@ _ -> Left ("Invalid value " <> show t <> "; must be one of: Disabled, Active, ActiveCount") +cpuUsagePolicy :: Text -> Either String CPUUsagePolicy+cpuUsagePolicy t =+ case T.toLower t of+ "single" -> return SingleCPU+ "multiple" -> return MultipleCPUs+ _ -> Left $ "Invalid CPU usage policy value: " <> show t+ stringField :: Text -> Either String Text stringField t = case isQuoted t of@@ -151,34 +162,36 @@ defaultConfig :: Config defaultConfig =- Config { configAbsPath = Nothing- , configUser = Nothing- , configHost = Nothing- , configTeam = Nothing- , configPort = defaultPort- , configPass = Nothing- , configTimeFormat = Nothing- , configDateFormat = Nothing- , configTheme = Nothing- , configThemeCustomizationFile = Nothing- , configSmartBacktick = True- , configURLOpenCommand = Nothing- , configURLOpenCommandInteractive = False- , configActivityNotifyCommand = Nothing- , configActivityBell = False- , configShowBackground = Disabled- , configShowMessagePreview = False- , configShowChannelList = True- , configEnableAspell = False- , configAspellDictionary = Nothing- , configUnsafeUseHTTP = False- , configChannelListWidth = 20- , configLogMaxBufferSize = 200- , configShowOlderEdits = True- , configUserKeys = mempty- , configShowTypingIndicator = False- , configHyperlinkingMode = True- , configSyntaxDirs = []+ Config { configAbsPath = Nothing+ , configUser = Nothing+ , configHost = Nothing+ , configTeam = Nothing+ , configPort = defaultPort+ , configPass = Nothing+ , configTimeFormat = Nothing+ , configDateFormat = Nothing+ , configTheme = Nothing+ , configThemeCustomizationFile = Nothing+ , configSmartBacktick = True+ , configURLOpenCommand = Nothing+ , configURLOpenCommandInteractive = False+ , configActivityNotifyCommand = Nothing+ , configActivityBell = False+ , configShowBackground = Disabled+ , configShowMessagePreview = False+ , configShowChannelList = True+ , configEnableAspell = False+ , configAspellDictionary = Nothing+ , configUnsafeUseHTTP = False+ , configChannelListWidth = 20+ , configLogMaxBufferSize = 200+ , configShowOlderEdits = True+ , configUserKeys = mempty+ , configShowTypingIndicator = False+ , configHyperlinkingMode = True+ , configSyntaxDirs = []+ , configDirectChannelExpirationDays = 7+ , configCpuUsagePolicy = MultipleCPUs } findConfig :: Maybe FilePath -> IO (Either String Config)
src/Draw.hs view
@@ -20,7 +20,6 @@ draw st = case appMode st of Main -> drawMain st- ChannelScroll -> drawMain st UrlSelect -> drawMain st ShowHelp topic -> drawShowHelp topic st ChannelSelect -> drawMain st
src/Draw/Autocomplete.hs view
@@ -44,7 +44,8 @@ " match" <> if numResults == 1 then "" else "es" selElem = snd <$> listSelectedElement matchList- footer = case renderAutocompleteFooterFor =<< selElem of+ curChan = st^.csCurrentChannel+ footer = case renderAutocompleteFooterFor curChan =<< selElem of Just w -> hBorderWithLabel w _ -> hBorder @@ -53,7 +54,7 @@ else Widget Greedy Greedy $ do ctx <- getContext let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight- editorOffset = if st^.csEditState.cedMultiline+ editorOffset = if st^.csEditState.cedEphemeral.eesMultiline then multilineHeightLimit else 0 render $ translateBy (Location (0, rowOffset)) $@@ -63,18 +64,22 @@ , footer ] -renderAutocompleteFooterFor :: AutocompleteAlternative -> Maybe (Widget Name)-renderAutocompleteFooterFor (UserCompletion _ False) =+renderAutocompleteFooterFor :: ClientChannel -> AutocompleteAlternative -> Maybe (Widget Name)+renderAutocompleteFooterFor ch (UserCompletion _ False) = Just $ hBox [ txt $ "(" , withDefAttr clientEmphAttr (txt userNotInChannelMarker)- , txt ": not in this channel)"+ , txt ": not a member of "+ , withDefAttr channelNameAttr (txt $ normalChannelSigil <> ch^.ccInfo.cdName)+ , txt ")" ]-renderAutocompleteFooterFor (ChannelCompletion False _) =+renderAutocompleteFooterFor _ (ChannelCompletion False ch) = Just $ hBox [ txt $ "(" , withDefAttr clientEmphAttr (txt userNotInChannelMarker)- , txt ": not in this channel)"+ , txt ": you are not a member of "+ , withDefAttr channelNameAttr (txt $ normalChannelSigil <> sanitizeUserText (channelName ch))+ , txt ")" ]-renderAutocompleteFooterFor _ = Nothing+renderAutocompleteFooterFor _ _ = Nothing renderAutocompleteAlternative :: Bool -> AutocompleteAlternative -> Widget Name renderAutocompleteAlternative sel (UserCompletion u inChan) =
src/Draw/ChannelList.hs view
@@ -25,7 +25,7 @@ import Brick.Widgets.Border import Brick.Widgets.Center (hCenter) import qualified Data.Text as T-import Lens.Micro.Platform (at, non)+import Lens.Micro.Platform (non) import qualified Network.Mattermost.Types as MM @@ -117,10 +117,15 @@ else u^.uiName in (uname, Just $ T.singleton $ userSigilFromInfo u, True, Just $ u^.uiStatus) sigilWithSpace = sigil <> if addSpace then " " else ""- sigil = case st^.csEditState.cedLastChannelInput.at cId of- Nothing -> fromMaybe "" normalSigil- Just ("", _) -> fromMaybe "" normalSigil- _ -> "»"+ prevEditSigil = "»"+ sigil = if current+ then fromMaybe "" normalSigil+ else case chan^.ccEditState.eesInputHistoryPosition of+ Just _ -> prevEditSigil+ Nothing ->+ case chan^.ccEditState.eesLastInput of+ ("", _) -> fromMaybe "" normalSigil+ _ -> prevEditSigil mentions = chan^.ccInfo.cdMentionCount -- | Render an individual Channel List entry (in Normal mode) with
src/Draw/Main.hs view
@@ -49,12 +49,12 @@ -- If it starts with a slash but not /me, this has no preview -- representation let isCommand = "/" `T.isPrefixOf` s- isEmote = "/me " `T.isPrefixOf` s- content = if isEmote+ isEmoteCmd = "/me " `T.isPrefixOf` s+ content = if isEmoteCmd then T.stripStart $ T.drop 3 s else s- msgTy = fromMaybe (if isEmote then CP Emote else CP NormalPost) overrideTy- in if isCommand && not isEmote+ msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy+ in if isCommand && not isEmoteCmd then Nothing else Just $ Message { _mText = getBlocks content , _mMarkdownSource = content@@ -256,7 +256,7 @@ ] _ -> emptyWidget - commandBox = case st^.csEditState.cedMultiline of+ commandBox = case st^.csEditState.cedEphemeral.eesMultiline of False -> let linesStr = "line" <> if numLines == 1 then "" else "s" numLines = length curContents@@ -325,17 +325,6 @@ body = chatText chatText = case appMode st 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 $- str "<< Press C-b to load more messages >>") :- (toList $ renderSingleMessage st hs editCutoff <$> channelMessages) MessageSelect -> renderMessagesWithSelect (st^.csMessageSelect) channelMessages MessageSelectDeleteConfirm ->@@ -405,7 +394,7 @@ st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown) where isShown m | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True- | otherwise = m^.mType /= CP Join && m^.mType /= CP Leave+ | otherwise = not $ isJoinLeave m insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT@@ -474,34 +463,48 @@ | KB { kbBindingInfo = Just e' , kbEvent = b } <- keymap- , e' == e ]- options = [ ( const True+ , e' == e+ ]+ options = [ ( not . isGap , ev YankWholeMessageEvent- , "yank-all" )+ , "yank-all"+ ) , ( \m -> isFlaggable m && not (m^.mFlagged) , ev FlagMessageEvent- , "flag" )+ , "flag"+ ) , ( \m -> isFlaggable m && m^.mFlagged , ev FlagMessageEvent- , "unflag" )+ , "unflag"+ ) , ( isReplyable , ev ReplyMessageEvent- , "reply" )- , ( const True+ , "reply"+ )+ , ( not . isGap , ev ViewMessageEvent- , "view" )+ , "view"+ )+ , ( isGap+ , ev FillGapEvent+ , "load messages"+ ) , ( \m -> isMine st m && isEditable m , ev EditMessageEvent- , "edit" )+ , "edit"+ ) , ( \m -> isMine st m && isDeletable m , ev DeleteMessageEvent- , "delete" )+ , "delete"+ ) , ( const hasURLs , ev OpenMessageURLEvent- , openUrlsMsg )+ , openUrlsMsg+ ) , ( const hasVerb , ev YankMessageEvent- , "yank-code" )+ , "yank-code"+ ) ] Just postMsg = getSelectedMessage st @@ -574,10 +577,6 @@ , withDefAttr clientEmphAttr $ txt "Escape" , txt " to cancel." ]- ChannelScroll -> hCenter $ hBox [ txt "Press "- , withDefAttr clientEmphAttr $ txt "Escape"- , txt " to stop scrolling and resume chatting."- ] MessageSelectDeleteConfirm -> renderDeleteConfirm _ -> renderUserCommandBox st hs @@ -617,7 +616,10 @@ else hBox [ borderElem bsHorizontal , withDefAttr clientMessageAttr $ txt $ "(" <> (T.pack $ show count) <> " attachment" <>- (if count == 1 then "" else "s") <> ")"+ (if count == 1 then "" else "s") <> "; "+ , withDefAttr clientEmphAttr $+ txt $ ppBinding (getFirstDefaultBinding ShowAttachmentListEvent)+ , txt " to manage)" ] showTypingUsers = case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of
src/Draw/Messages.hs view
@@ -77,22 +77,19 @@ in Just $ withDefAttr emojiAttr $ txt (" " <> reacMsg) msgTxt = case msg^.mUser of- NoUser ->+ NoUser+ | isGap msg -> withDefAttr gapMessageAttr m+ | otherwise -> case msg^.mType of C DateTransition -> withDefAttr dateTransitionAttr (hBorderWithLabel m) C NewMessagesTransition -> withDefAttr newMessageTransitionAttr (hBorderWithLabel m) C Error -> withDefAttr errorMessageAttr m- C UnknownGap -> withDefAttr gapMessageAttr m _ -> withDefAttr clientMessageAttr m- _ | msg^.mType == CP Join || msg^.mType == CP Leave ->- withDefAttr clientMessageAttr m+ _ | isJoinLeave msg -> withDefAttr clientMessageAttr m | otherwise -> m fullMsg = vBox $ 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+ maybeRenderTimeWith f = if isTransition msg then id else f in maybeRenderTimeWith maybeRenderTime fullMsg -- | Render a selected message with focus, including the messages
src/Draw/ShowHelp.hs view
@@ -1,4 +1,9 @@-module Draw.ShowHelp (drawShowHelp) where+module Draw.ShowHelp+ ( drawShowHelp+ , keybindingMarkdownTable+ , keybindingTextTable+ )+where import Prelude () import Prelude.MH@@ -15,7 +20,6 @@ import Network.Mattermost.Version ( mmApiVersion ) import Command-import Events.ChannelScroll import Events.ChannelSelect import Events.Keybindings import Events.Main@@ -125,16 +129,38 @@ , [ "> *> /sh rot13 Hello, world!*\n" ] ] +keybindingMarkdownTable :: KeyConfig -> Text+keybindingMarkdownTable kc = keybindSectionStrings+ where keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc+ sectionText = mkKeybindEventSectionHelp keybindEventHelpMarkdown T.unlines mkHeading+ mkHeading n =+ "\n# " <> n <>+ "\n| Keybinding | Description |" <>+ "\n| ---------- | ----------- |"++keybindingTextTable :: KeyConfig -> Text+keybindingTextTable kc = keybindSectionStrings+ where keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc+ sectionText = mkKeybindEventSectionHelp (keybindEventHelpText keybindingWidth) T.unlines mkHeading+ keybindingWidth = 20+ mkHeading n =+ "\n" <> n <>+ "\n" <> (T.replicate (T.length n) "=")+ keybindingHelp :: KeyConfig -> Widget Name-keybindingHelp kc = vBox $+keybindingHelp kc = hCenter $ hLimit 100 $ vBox $ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Configurable Keybindings"- , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox keybindingHelpText- ] ++ map mkKeybindEventSectionHelp (keybindSections kc)+ , padTop (Pad 1) $ hCenter $ vBox keybindingHelpText+ ] ++ keybindSectionWidgets ++ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybinding Syntax"- , padTop (Pad 1) $ hCenter $ hLimit 100 $ vBox validKeys+ , padTop (Pad 1) $ hCenter $ vBox validKeys ]- where keybindingHelpText = map (padTop (Pad 1) . renderText . mconcat)+ where keybindSectionWidgets = catMaybes $ sectionWidget <$> keybindSections kc+ sectionWidget = mkKeybindEventSectionHelp keybindEventHelpWidget vBox mkSectionHeading+ mkSectionHeading = hCenter . padTop (Pad 1) . withDefAttr helpEmphAttr . txt++ keybindingHelpText = map (padTop (Pad 1) . renderText . mconcat) [ [ "Many of the keybindings used in Matterhorn can be " , "modified from within Matterhorn's **config.ini** file. " , "To do this, include a section called **[KEYBINDINGS]** "@@ -341,11 +367,10 @@ keybindSections :: KeyConfig -> [(Text, [Keybinding])] keybindSections kc =- [ ("This Help Page", helpKeybindings kc)+ [ ("Help Page", helpKeybindings kc) , ("Main Interface", mainKeybindings kc) , ("Channel Select Mode", channelSelectKeybindings kc) , ("URL Select Mode", urlSelectKeybindings kc)- , ("Channel Scroll Mode", channelScrollKeybindings kc) , ("Message Select Mode", messageSelectKeybindings kc) , ("Text Editing", editingKeybindings) , ("Flagged Messages", postListOverlayKeybindings kc)@@ -377,25 +402,42 @@ (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $ ppBinding $ eventToBinding ev) <+> (vLimit 1 $ hLimit kbDescColumnWidth $ renderText desc <+> fill ' ') --mkKeybindEventSectionHelp :: (Text, [Keybinding]) -> Widget Name-mkKeybindEventSectionHelp (sectionName, kbs) =+mkKeybindEventSectionHelp :: ((Text, Text, [Text]) -> a)+ -> ([a] -> a)+ -> (Text -> a)+ -> (Text, [Keybinding])+ -> Maybe a+mkKeybindEventSectionHelp mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) = let lst = sortWith (fmap keyEventName . kbBindingInfo . head) $ groupWith kbBindingInfo kbs in if all (all (isNothing . kbBindingInfo)) lst- then emptyWidget- else (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt $ "Keybindings: " <> sectionName) <=>- (hCenter $ vBox $ concat $ mkKeybindEventHelp <$> lst)+ then Nothing+ else Just $+ vertCat $ (mkHeading $ "Keybindings: " <> sectionName) :+ (mkKeybindHelpFunc <$> (catMaybes $ mkKeybindEventHelp <$> lst)) -mkKeybindEventHelp :: [Keybinding] -> [Widget Name]+keybindEventHelpWidget :: (Text, Text, [Text]) -> Widget Name+keybindEventHelpWidget (evName, desc, evs) =+ let evText = T.intercalate ", " evs+ in vBox [ txt (padTo 72 ("; " <> desc))+ , (withDefAttr helpEmphAttr $ txt evName) <+> txt (" = " <> evText)+ , str " "+ ]++keybindEventHelpMarkdown :: (Text, Text, [Text]) -> Text+keybindEventHelpMarkdown (_evName, desc, evs) =+ let quote s = "`" <> s <> "`"+ in "| " <> (T.intercalate ", " $ quote <$> evs) <> " | " <> desc <> " |"++keybindEventHelpText :: Int -> (Text, Text, [Text]) -> Text+keybindEventHelpText width (_evName, desc, evs) =+ padTo width (T.intercalate ", " evs) <> " " <> desc++mkKeybindEventHelp :: [Keybinding] -> Maybe (Text, Text, [Text]) mkKeybindEventHelp ks@(KB desc _ _ (Just e):_) = let evs = [ ev | KB _ ev _ _ <- ks ]- evText = T.intercalate ", " (map (ppBinding . eventToBinding) evs)- in [ txt (padTo 72 ("; " <> desc))- , (withDefAttr helpEmphAttr $ txt $ keyEventName e) <+>- txt (" = " <> evText)- , str " "- ]-mkKeybindEventHelp _ = []+ evText = map (ppBinding . eventToBinding) evs+ in Just (keyEventName e, desc, evText)+mkKeybindEventHelp _ = Nothing padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " "
src/Events.hs view
@@ -30,7 +30,6 @@ import Types import Types.Common -import Events.ChannelScroll import Events.ChannelSelect import Events.DeleteChannelConfirm import Events.JoinChannel@@ -160,7 +159,6 @@ UrlSelect -> onEventUrlSelect e LeaveChannelConfirm -> onEventLeaveChannelConfirm e JoinChannel -> onEventJoinChannel e- ChannelScroll -> onEventChannelScroll e MessageSelect -> onEventMessageSelect e MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e DeleteChannelConfirm -> onEventDeleteChannelConfirm e
− src/Events/ChannelScroll.hs
@@ -1,48 +0,0 @@-module Events.ChannelScroll where--import Prelude ()-import Prelude.MH--import Brick-import qualified Graphics.Vty as Vty--import Events.Keybindings-import State.ChannelScroll-import State.UrlSelect-import Types---channelScrollKeybindings :: KeyConfig -> [Keybinding]-channelScrollKeybindings = mkKeybindings- [ mkKb LoadMoreEvent "Load more messages in the current channel"- loadMoreMessages- , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel"- startUrlSelect- , mkKb ScrollUpEvent "Scroll up"- channelScrollUp- , mkKb ScrollDownEvent "Scroll down"- channelScrollDown- , mkKb PageUpEvent "Scroll up"- channelPageUp- , mkKb PageDownEvent "Scroll down"- channelPageDown- , mkKb CancelEvent "Cancel scrolling and return to channel view" $ do- cId <- use csCurrentChannelId- mh $ invalidateCacheEntry (ChannelMessages cId)- setMode Main- , mkKb ScrollTopEvent "Scroll to top"- channelScrollToTop- , mkKb ScrollBottomEvent "Scroll to bottom"- channelScrollToBottom- ]--onEventChannelScroll :: Vty.Event -> MH ()-onEventChannelScroll =- handleKeyboardEvent channelScrollKeybindings $ \ e -> case e of- (Vty.EvResize _ _) -> do- cId <- use csCurrentChannelId- mh $ do- invalidateCache- let vp = ChannelMessages cId- vScrollToEnd $ viewportScroll vp- _ -> return ()
src/Events/Keybindings.hs view
@@ -139,6 +139,7 @@ SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ] ViewMessageEvent -> [ key 'v' ]+ FillGapEvent -> [ kb Vty.KEnter ] FlagMessageEvent -> [ key 'f' ] YankMessageEvent -> [ key 'y' ] YankWholeMessageEvent -> [ key 'Y' ]
src/Events/Main.hs view
@@ -4,31 +4,25 @@ import Prelude () import Prelude.MH -import Brick hiding ( Direction ) import Brick.Widgets.Edit import qualified Brick.Widgets.List as L import Data.Char ( isSpace )-import qualified Data.Foldable as F-import qualified Data.Text as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z import qualified Graphics.Vty as Vty-import Lens.Micro.Platform ( (%=), (.=), to, at, _Just )+import Lens.Micro.Platform ( (%=), to, _Just ) import Command-import Constants import Events.Keybindings import HelpTopics ( mainHelpTopic )-import InputHistory import State.Attachments-import State.Help-import State.Channels import State.ChannelSelect+import State.Channels import State.Editing+import State.Help import State.MessageSelect import State.PostListOverlay ( enterFlaggedPostListMode ) import State.UrlSelect-import State.Messages ( sendMessage ) import Types @@ -86,7 +80,7 @@ "Scroll up in the channel input history" $ do -- Up in multiline mode does the usual thing; otherwise we -- navigate the history.- isMultiline <- use (csEditState.cedMultiline)+ isMultiline <- use (csEditState.cedEphemeral.eesMultiline) case isMultiline of True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KUp [])@@ -97,20 +91,19 @@ "Scroll down in the channel input history" $ do -- Down in multiline mode does the usual thing; otherwise -- we navigate the history.- isMultiline <- use (csEditState.cedMultiline)+ isMultiline <- use (csEditState.cedEphemeral.eesMultiline) case isMultiline of True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent (Vty.EvKey Vty.KDown []) False -> channelHistoryForward - , mkKb PageUpEvent "Page up in the channel message list" $ do- cId <- use csCurrentChannelId- let vp = ChannelMessages cId- mh $ invalidateCacheEntry vp- mh $ vScrollToEnd $ viewportScroll vp- mh $ vScrollBy (viewportScroll vp) (-1 * pageAmount)- setMode ChannelScroll+ , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do+ beginMessageSelect + , mkKb ScrollTopEvent "Scroll to top of channel message list" $ do+ beginMessageSelect+ messageSelectFirst+ , mkKb NextChannelEvent "Change to the next channel in the channel list" nextChannel @@ -132,13 +125,16 @@ , staticKb "Send the current message" (Vty.EvKey Vty.KEnter []) $ do- isMultiline <- use (csEditState.cedMultiline)+ isMultiline <- use (csEditState.cedEphemeral.eesMultiline) case isMultiline of -- Normally, this event causes the current message to -- be sent. But in multiline mode we want to insert a -- newline instead. True -> handleEditingInput (Vty.EvKey Vty.KEnter [])- False -> handleInputSubmission+ False -> do+ cId <- use csCurrentChannelId+ content <- getEditorContent+ handleInputSubmission cId content , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel" startUrlSelect@@ -155,40 +151,6 @@ , mkKb EnterFlaggedPostsEvent "View currently flagged posts" enterFlaggedPostListMode ]--handleInputSubmission :: MH ()-handleInputSubmission = do- cmdLine <- use (csEditState.cedEditor)- cId <- use csCurrentChannelId-- -- send the relevant message- mode <- use (csEditState.cedEditMode)- let (line:rest) = getEditContents cmdLine- allLines = T.intercalate "\n" $ line : rest-- -- We clean up before dispatching the command or sending the message- -- since otherwise the command could change the state and then doing- -- cleanup afterwards could clean up the wrong things.- csEditState.cedEditor %= applyEdit Z.clearZipper- csEditState.cedInputHistory %= addHistoryEntry allLines cId- csEditState.cedInputHistoryPosition.at cId .= Nothing-- case T.uncons allLines of- Just ('/', cmd) ->- dispatchCommand cmd- _ -> do- attachments <- use (csEditState.cedAttachmentList.L.listElementsL)- sendMessage mode allLines $ F.toList attachments-- -- Reset the autocomplete UI- resetAutocomplete-- -- Empty the attachment list- resetAttachmentList-- -- Reset the edit mode *after* handling the input so that the input- -- handler can tell whether we're editing, replying, etc.- csEditState.cedEditMode .= NewPost data Direction = Forwards | Backwards
src/Events/MessageSelect.hs view
@@ -32,6 +32,10 @@ , mkKb SelectUpEvent "Select the previous message" messageSelectUp , mkKb SelectDownEvent "Select the next message" messageSelectDown+ , mkKb ScrollTopEvent "Scroll to top and select the oldest message"+ messageSelectFirst+ , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message"+ messageSelectLast , mkKb PageUpEvent (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages")@@ -64,5 +68,8 @@ , mkKb ViewMessageEvent "View the selected message" viewSelectedMessage++ , mkKb FillGapEvent "Fetch messages for the selected gap"+ fillSelectedGap ]
src/Events/PostListOverlay.hs view
@@ -21,4 +21,5 @@ , mkKb SelectUpEvent "Select the previous message" postListSelectUp , mkKb SelectDownEvent "Select the next message" postListSelectDown , mkKb FlagMessageEvent "Toggle the selected message flag" postListUnflagSelected+ , mkKb ActivateListItemEvent "Jump to and select current message" postListJumpToCurrent ]
src/KeyMap.hs view
@@ -7,7 +7,6 @@ import Prelude.MH import Events.Keybindings-import Events.ChannelScroll import Events.ChannelSelect import Events.Main import Events.MessageSelect@@ -22,7 +21,6 @@ , ("help screen", helpKeybindings) , ("channel select", channelSelectKeybindings) , ("url select", urlSelectKeybindings)- , ("channel scroll", channelScrollKeybindings) , ("message select", messageSelectKeybindings) , ("post list overlay", postListOverlayKeybindings) , ("attachment list", attachmentListKeybindings)
src/Main.hs view
@@ -2,14 +2,16 @@ import Prelude () import Prelude.MH+import qualified Data.Text.IO as T -import System.Exit ( exitFailure )+import System.Exit ( exitFailure, exitSuccess ) import Config import Options import App import Events.Keybindings ( ensureKeybindingConsistency ) import KeyMap ( keybindingModeMap )+import Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable ) main :: IO ()@@ -26,7 +28,17 @@ exitFailure Right c -> return c - case ensureKeybindingConsistency (configUserKeys config) keybindingModeMap of+ let keyConfig = configUserKeys config++ case optPrintKeybindings opts of+ Nothing -> return ()+ Just ty -> do+ case ty of+ Markdown -> T.putStrLn $ keybindingMarkdownTable keyConfig+ Plain -> T.putStrLn $ keybindingTextTable keyConfig+ exitSuccess++ case ensureKeybindingConsistency keyConfig keybindingModeMap of Right () -> return () Left err -> do putStrLn $ "Configuration error: " <> err
src/Markdown.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE RecordWildCards #-}@@ -47,22 +48,23 @@ import Network.Mattermost.Types ( ServerTime(..) ) import Themes-import Types ( HighlightSet(..), userSigil, normalChannelSigil- , isNameFragment, takeWhileNameFragment )-import Types.Posts+import Types ( HighlightSet(..), userSigil, normalChannelSigil ) import Types.Messages+import Types.Posts+import Types.UserNames ( isNameFragment, takeWhileNameFragment ) emptyHSet :: HighlightSet emptyHSet = HighlightSet Set.empty Set.empty mempty -omitUsernameTypes :: [MessageType]-omitUsernameTypes =- [ CP Join- , CP Leave- , CP TopicChange- ]+omittedUsernameType :: MessageType -> Bool+omittedUsernameType = \case+ CP Join -> True+ CP Leave -> True+ CP TopicChange -> True+ _ -> False + -- The special string we use to indicate the placement of a styled -- indication that a message has been edited. editMarkingSentinel :: Text@@ -125,13 +127,11 @@ renderMessage :: MessageData -> Widget a renderMessage md@MessageData { mdMessage = msg, .. } = let msgUsr = case mdUserName of- Just u- | msg^.mType `elem` omitUsernameTypes -> Nothing- | otherwise -> Just u+ Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u Nothing -> Nothing nameElems = case msgUsr of Just un- | msg^.mType == CP Emote ->+ | isEmote msg -> [ B.txt "*", colorUsername un un , B.txt " " ]
src/Options.hs view
@@ -20,19 +20,24 @@ | ShowHelp deriving (Eq, Show) +data KeybindingPrintMode =+ Markdown | Plain deriving (Eq, Show)+ data Options = Options- { optConfLocation :: Maybe FilePath- , optLogLocation :: Maybe FilePath- , optBehaviour :: Behaviour- , optIgnoreConfig :: Bool+ { optConfLocation :: Maybe FilePath+ , optLogLocation :: Maybe FilePath+ , optBehaviour :: Behaviour+ , optIgnoreConfig :: Bool+ , optPrintKeybindings :: Maybe KeybindingPrintMode } deriving (Eq, Show) defaultOptions :: Options defaultOptions = Options- { optConfLocation = Nothing- , optLogLocation = Nothing- , optBehaviour = Normal- , optIgnoreConfig = False+ { optConfLocation = Nothing+ , optLogLocation = Nothing+ , optBehaviour = Normal+ , optIgnoreConfig = False+ , optPrintKeybindings = Nothing } optDescrs :: [OptDescr (Options -> Options)]@@ -52,6 +57,12 @@ , Option ['i'] ["ignore-config"] (NoArg (\ c -> c { optIgnoreConfig = True })) "Start with no configuration"+ , Option ['k'] ["keybindings-text"]+ (NoArg (\ c -> c { optPrintKeybindings = Just Plain }))+ "Print keybindings effective for the current configuration in plain text format"+ , Option ['K'] ["keybindings-markdown"]+ (NoArg (\ c -> c { optPrintKeybindings = Just Markdown }))+ "Print keybindings effective for the current configuration in Markdown format" ] mhVersion :: String
src/Prelude/MH.hs view
@@ -6,9 +6,24 @@ putting changed functions behind CPP in a single place. -} +{-+ GHC version <--> base version (https://wiki.haskell.org/Base_package) includes:+ 8.0.1 4.9.0.0+ 8.2.1 4.10.0.0+ 8.4.1 4.11.0.0++ GHC distributions include a set of core packages; overriding these+ with new versions is unwise. Core packages include (see+ https://downloads.haskell.org/~ghc/X.Y.Z/docs/html/users_guide/X.Y.Z-notes.html#included-libraries+ ):++ base, Cabal, array, bytestring, containers, deepseq, directory,+ filepath, mtl, parsec, process, text, time, unix+-}+ module Prelude.MH ( module P-#if !MIN_VERSION_base(4,11,0)+#if !MIN_VERSION_base(4,9,0) , (<>) #endif , (<|>)@@ -48,6 +63,13 @@ , (Lens.^.) , Lens.use + -- not available in all versions of GHC currently in use+#if MIN_VERSION_base(4,10,0)+ , Clock.nominalDay+#else+ , nominalDay+#endif+ -- various type aliases , Text , HashMap@@ -71,6 +93,9 @@ import qualified Data.List as List import qualified Data.Maybe as Maybe import qualified Data.Time as Time+#if MIN_VERSION_base(4,10,0)+import qualified Data.Time.Clock as Clock+#endif import qualified Data.Time.LocalTime.TimeZone.Series as Time import qualified GHC.Exts as Exts import qualified Lens.Micro.Platform as Lens@@ -83,3 +108,8 @@ import Data.Sequence ( Seq ) import Data.Set ( Set ) import Data.Text ( Text )++#if !MIN_VERSION_base(4,10,0)+nominalDay :: Time.NominalDiffTime+nominalDay = 86400+#endif
src/Scripts.hs view
@@ -46,7 +46,8 @@ case null $ programStderr po of True -> Just $ do mode <- use (csEditState.cedEditMode)- sendMessage mode (T.pack $ programStdout po) []+ cId <- use csCurrentChannelId+ sendMessage cId mode (T.pack $ programStdout po) [] False -> Nothing ExitFailure _ -> Nothing
src/State/Autocomplete.hs view
@@ -24,7 +24,7 @@ import Network.Mattermost.Types (userId, channelId) import qualified Network.Mattermost.Endpoints as MM -import Command ( commandList, printArgSpec )+import {-# SOURCE #-} Command ( commandList, printArgSpec ) import State.Common import Types hiding ( newState )
− src/State/ChannelScroll.hs
@@ -1,54 +0,0 @@-module State.ChannelScroll- (- channelScrollToTop- , channelScrollToBottom- , channelScrollUp- , channelScrollDown- , channelPageUp- , channelPageDown- , loadMoreMessages- )- where--import Prelude ()-import Prelude.MH--import Brick.Main--import Constants-import State.Messages-import Types---channelPageUp :: MH ()-channelPageUp = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1 * pageAmount)--channelPageDown :: MH ()-channelPageDown = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) pageAmount--channelScrollUp :: MH ()-channelScrollUp = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) (-1)--channelScrollDown :: MH ()-channelScrollDown = do- cId <- use csCurrentChannelId- mh $ vScrollBy (viewportScroll (ChannelMessages cId)) 1--channelScrollToTop :: MH ()-channelScrollToTop = do- cId <- use csCurrentChannelId- mh $ vScrollToBeginning (viewportScroll (ChannelMessages cId))--channelScrollToBottom :: MH ()-channelScrollToBottom = do- cId <- use csCurrentChannelId- mh $ vScrollToEnd (viewportScroll (ChannelMessages cId))--loadMoreMessages :: MH ()-loadMoreMessages = whenMode ChannelScroll asyncFetchMoreMessages
src/State/Channels.hs view
@@ -22,7 +22,6 @@ , nextChannel , recentChannel , hideDMChannel- , hideCurrentDMChannel , createGroupChannel , showGroupChannelPref , channelHistoryForward@@ -103,7 +102,8 @@ us <- getUsers prefs <- use (csResources.crUserPreferences) now <- liftIO getCurrentTime- csFocus %= Z.updateList (mkChannelZipperList now cconfig prefs cs us)+ config <- use (csResources.crConfiguration)+ csFocus %= Z.updateList (mkChannelZipperList now config cconfig prefs cs us) -- Send the new zipper to the status update thread so that we can -- fetch the statuses for the users in the new sidebar.@@ -158,9 +158,12 @@ mh invalidateCache csShowChannelList %= not -hideCurrentDMChannel :: MH ()-hideCurrentDMChannel = hideDMChannel =<< use csCurrentChannelId-+-- | If the current channel is a DM channel with a single user or a+-- group of users, hide it from the sidebar and adjust the server-side+-- preference to hide it persistently.+--+-- If the current channel is any other kind of channel, complain with a+-- usage error. hideDMChannel :: ChannelId -> MH () hideDMChannel cId = do me <- gets myUser@@ -485,32 +488,32 @@ postChangeChannelCommon :: MH () postChangeChannelCommon = do- resetHistoryPosition resetEditorState updateChannelListScroll loadLastEdit- resetCurrentEdit fetchVisibleIfNeeded -resetCurrentEdit :: MH ()-resetCurrentEdit = do- cId <- use csCurrentChannelId- csEditState.cedLastChannelInput.at cId .= Nothing- loadLastEdit :: MH () loadLastEdit = do cId <- use csCurrentChannelId- lastInput <- use (csEditState.cedLastChannelInput.at cId)- case lastInput of++ oldEphemeral <- preuse (csChannel(cId).ccEditState)+ case oldEphemeral of Nothing -> return ()- Just (lastEdit, lastEditMode) -> do- csEditState.cedEditor %= (applyEdit $ insertMany (lastEdit) . clearZipper)- csEditState.cedEditMode .= lastEditMode+ Just e -> csEditState.cedEphemeral .= e -resetHistoryPosition :: MH ()-resetHistoryPosition = do+ loadLastChannelInput++loadLastChannelInput :: MH ()+loadLastChannelInput = do cId <- use csCurrentChannelId- csEditState.cedInputHistoryPosition.at cId .= Just Nothing+ inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)+ case inputHistoryPos of+ Just i -> loadHistoryEntryToEditor cId i+ Nothing -> do+ (lastEdit, lastEditMode) <- use (csEditState.cedEphemeral.eesLastInput)+ csEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper)+ csEditState.cedEditMode .= lastEditMode updateChannelListScroll :: MH () updateChannelListScroll = do@@ -532,12 +535,25 @@ saveCurrentEdit :: MH () saveCurrentEdit = do+ saveCurrentChannelInput++ oldEphemeral <- use (csEditState.cedEphemeral) cId <- use csCurrentChannelId+ csChannel(cId).ccEditState .= oldEphemeral++saveCurrentChannelInput :: MH ()+saveCurrentChannelInput = do cmdLine <- use (csEditState.cedEditor) mode <- use (csEditState.cedEditMode)- csEditState.cedLastChannelInput.at cId .=- Just (T.intercalate "\n" $ getEditContents $ cmdLine, mode) + -- Only save the editor contents if the user is not navigating the+ -- history.+ inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)++ when (isNothing inputHistoryPos) $+ csEditState.cedEphemeral.eesLastInput .=+ (T.intercalate "\n" $ getEditContents $ cmdLine, mode)+ hideGroupChannelPref :: ChannelId -> UserId -> Preference hideGroupChannelPref cId uId = Preference { preferenceCategory = PreferenceCategoryGroupChannelShow@@ -625,8 +641,6 @@ when (chan^.ccInfo.cdType /= Direct) $ do origFocus <- use csCurrentChannelId when (origFocus == cId) nextChannelSkipPrevView- csEditState.cedInputHistoryPosition .at cId .= Nothing- csEditState.cedLastChannelInput .at cId .= Nothing -- Update input history csEditState.cedInputHistory %= removeChannelHistory cId -- Update msgMap@@ -778,50 +792,39 @@ channelHistoryForward :: MH () channelHistoryForward = do cId <- use csCurrentChannelId- inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)- inputHistory <- use (csEditState.cedInputHistory)+ inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition) case inputHistoryPos of- Just (Just i)+ Just i | i == 0 -> do -- Transition out of history navigation- csEditState.cedInputHistoryPosition.at cId .= Just Nothing- loadLastEdit+ csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing+ loadLastChannelInput | otherwise -> do- let Just entry = getHistoryEntry cId newI inputHistory- newI = i - 1- eLines = T.lines entry+ let newI = i - 1+ loadHistoryEntryToEditor cId newI+ csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)+ _ -> return ()++loadHistoryEntryToEditor :: ChannelId -> Int -> MH ()+loadHistoryEntryToEditor cId idx = do+ inputHistory <- use (csEditState.cedInputHistory)+ case getHistoryEntry cId idx inputHistory of+ Nothing -> return ()+ Just entry -> do+ let eLines = T.lines entry mv = if length eLines == 1 then gotoEOL else id csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)- csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)- _ -> return () channelHistoryBackward :: MH () channelHistoryBackward = do cId <- use csCurrentChannelId- inputHistoryPos <- use (csEditState.cedInputHistoryPosition.at cId)- inputHistory <- use (csEditState.cedInputHistory)- case inputHistoryPos of- Just (Just i) ->- let newI = i + 1- in case getHistoryEntry cId newI inputHistory of- Nothing -> return ()- Just entry -> do- let eLines = T.lines entry- mv = if length eLines == 1 then gotoEOL else id- csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)- csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)- _ ->- let newI = 0- in case getHistoryEntry cId newI inputHistory of- Nothing -> return ()- Just entry ->- let eLines = T.lines entry- mv = if length eLines == 1 then gotoEOL else id- in do- saveCurrentEdit- csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)- csEditState.cedInputHistoryPosition.at cId .= (Just $ Just newI)+ inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)+ saveCurrentChannelInput + let newI = maybe 0 (+ 1) inputHistoryPos+ loadHistoryEntryToEditor cId newI+ csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)+ createOrdinaryChannel :: Text -> MH () createOrdinaryChannel name = do session <- getSession@@ -943,11 +946,15 @@ csPendingChannelChange .= (Just $ ChangeByChannelId chanId) doAsyncChannelMM Preempt chanId (\ s _ c -> MM.mmAddUser c member s) endAsyncNOP -createOrFocusDMChannel :: UserInfo -> MH ()-createOrFocusDMChannel user = do+createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH ()+createOrFocusDMChannel user successAct = do cs <- use csChannels case getDmChannelFor (user^.uiId) cs of- Just cId -> setFocus cId+ Just cId -> do+ setFocus cId+ case successAct of+ Nothing -> return ()+ Just act -> act cId Nothing -> do -- We have a user of that name but no channel. Time to make one! myId <- gets myUserId@@ -955,8 +962,8 @@ csPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId) doAsyncWith Normal $ do -- create a new channel- void $ MM.mmCreateDirectMessageChannel (user^.uiId, myId) session- return Nothing+ chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session+ return $ successAct <*> pure (channelId chan) -- | This switches to the named channel or creates it if it is a missing -- but valid user channel.@@ -972,7 +979,7 @@ case foundUser of -- We know about the user but there isn't already a DM -- channel, so create one.- Just user -> createOrFocusDMChannel user+ Just user -> createOrFocusDMChannel user Nothing -- There were no matches of any kind. Nothing -> mhError $ NoSuchChannel name (Just cId, Nothing)
src/State/Editing.hs view
@@ -6,6 +6,8 @@ , toggleMultilineEditing , invokeExternalEditor , handlePaste+ , handleInputSubmission+ , getEditorContent , handleEditingInput , cancelAutocompleteOrReplyOrEdit , replyToLatestMessage@@ -18,10 +20,12 @@ import Brick.Main ( invalidateCache ) import Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent , getEditContents, editContentsL )+import qualified Brick.Widgets.List as L import qualified Codec.Binary.UTF8.Generic as UTF8 import Control.Arrow import qualified Control.Concurrent.STM as STM import qualified Data.ByteString as BS+import qualified Data.Foldable as F import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T@@ -37,13 +41,16 @@ import qualified System.Process as Sys import Text.Aspell ( AspellResponse(..), mistakeWord, askAspell ) -import Network.Mattermost.Types ( Post(..) )+import Network.Mattermost.Types ( Post(..), ChannelId ) import Config+import {-# SOURCE #-} Command ( dispatchCommand )+import InputHistory import Events.Keybindings import State.Common import State.Autocomplete import State.Attachments+import State.Messages import Types hiding ( newState ) import Types.Common ( sanitizeChar, sanitizeUserText' ) @@ -51,13 +58,22 @@ startMultilineEditing :: MH () startMultilineEditing = do mh invalidateCache- csEditState.cedMultiline .= True+ csEditState.cedEphemeral.eesMultiline .= True toggleMultilineEditing :: MH () toggleMultilineEditing = do mh invalidateCache- csEditState.cedMultiline %= not+ csEditState.cedEphemeral.eesMultiline %= not + -- If multiline is now disabled and there is more than one line in+ -- the editor, that means we're showing the multiline message status+ -- (see Draw.Main.renderUserCommandBox.commandBox) so we want to be+ -- sure no autocomplete UI is present in case the cursor was left on+ -- a word that would otherwise show completion alternatives.+ multiline <- use (csEditState.cedEphemeral.eesMultiline)+ numLines <- use (csEditState.cedEditor.to getEditContents.to length)+ when (not multiline && numLines > 1) resetAutocomplete+ invokeExternalEditor :: MH () invokeExternalEditor = do -- If EDITOR is in the environment, write the current message to a@@ -103,7 +119,7 @@ editingPermitted :: ChatState -> Bool editingPermitted st = (length (getEditContents $ st^.csEditState.cedEditor) == 1) ||- st^.csEditState.cedMultiline+ st^.csEditState.cedEphemeral.eesMultiline editingKeybindings :: [Keybinding] editingKeybindings =@@ -168,6 +184,50 @@ (kbAction >> sendUserTypingAction) kbBindingInfo +getEditorContent :: MH Text+getEditorContent = do+ cmdLine <- use (csEditState.cedEditor)+ let (line:rest) = getEditContents cmdLine+ return $ T.intercalate "\n" $ line : rest++-- | Handle an input submission in the message editor.+--+-- This handles the specified input text as if it were user input for+-- the specified channel. This means that if the specified input text+-- contains a command ("/...") then it is executed as normal. Otherwise+-- the text is sent as a message to the specified channel.+--+-- However, this function assumes that the message editor is the+-- *source* of the text, so it also takes care of clearing the editor,+-- resetting the edit mode, updating the input history for the specified+-- channel, etc.+handleInputSubmission :: ChannelId -> Text -> MH ()+handleInputSubmission cId content = do+ -- We clean up before dispatching the command or sending the message+ -- since otherwise the command could change the state and then doing+ -- cleanup afterwards could clean up the wrong things.+ csEditState.cedEditor %= applyEdit Z.clearZipper+ csEditState.cedInputHistory %= addHistoryEntry content cId+ csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing++ case T.uncons content of+ Just ('/', cmd) ->+ dispatchCommand cmd+ _ -> do+ attachments <- use (csEditState.cedAttachmentList.L.listElementsL)+ mode <- use (csEditState.cedEditMode)+ sendMessage cId mode content $ F.toList attachments++ -- Reset the autocomplete UI+ resetAutocomplete++ -- Empty the attachment list+ resetAttachmentList++ -- Reset the edit mode *after* handling the input so that the input+ -- handler can tell whether we're editing, replying, etc.+ csEditState.cedEditMode .= NewPost+ handleEditingInput :: Event -> MH () handleEditingInput e = do -- Only handle input events to the editor if we permit editing:@@ -180,6 +240,8 @@ smartBacktick <- use (csResources.crConfiguration.to configSmartBacktick) let smartChars = "*`_" st <- use id+ csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing+ case lookupKeybinding e editingKeybindings of Just kb | editingPermitted st -> kbAction kb _ -> do@@ -208,13 +270,33 @@ let doInsertChar = do csEditState.cedEditor %= applyEdit (Z.insertChar ch) sendUserTypingAction- in if | (editorEmpty $ st^.csEditState.cedEditor) ||+ curLine = Z.currentLine $ st^.csEditState.cedEditor.editContentsL+ -- First case: if the cursor is at the end of the current+ -- line and it contains "``" and the user entered a third+ -- "`", enable multi-line mode since they're likely typing+ -- a code block.+ in if | (cursorIsAtEnd $ st^.csEditState.cedEditor) &&+ curLine == "``" &&+ ch == '`' -> do+ csEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch))+ csEditState.cedEphemeral.eesMultiline .= True+ -- Second case: user entered some smart character+ -- (don't care which) on an empty line or at the end+ -- of the line after whitespace, so enter a pair of+ -- the smart chars and put the cursor between them.+ | (editorEmpty $ st^.csEditState.cedEditor) || ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) && (cursorIsAtEnd $ st^.csEditState.cedEditor)) -> csEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft)+ -- Third case: the cursor is already on a smart+ -- character and that character is the last one+ -- on the line, so instead of inserting a new+ -- character, just move past it. | (cursorAtChar ch $ st^.csEditState.cedEditor) && (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) -> csEditState.cedEditor %= applyEdit Z.moveRight+ -- Fall-through case: just insert one of the chars+ -- without doing anything smart. | otherwise -> doInsertChar | editingPermitted st -> do csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeChar ch))
src/State/MessageSelect.hs view
@@ -4,6 +4,7 @@ beginMessageSelect , flagSelectedMessage , viewSelectedMessage+ , fillSelectedGap , yankSelectedMessageVerbatim , yankSelectedMessage , openSelectedMessageURLs@@ -12,6 +13,8 @@ , messageSelectUpBy , messageSelectDown , messageSelectDownBy+ , messageSelectFirst+ , messageSelectLast , deleteSelectedMessage , beginReplyCompose , beginEditMessage@@ -35,9 +38,10 @@ import Clipboard ( copyToClipboard ) import Markdown ( findVerbatimChunk )+import State.Common+import State.Messages import Types import Types.Common-import State.Common getSelectedMessage :: ChatState -> Maybe Message@@ -79,9 +83,19 @@ viewSelectedMessage = do selected <- use (to getSelectedMessage) case selected of- Just msg -> viewMessage msg+ Just msg+ | not (isGap msg) -> viewMessage msg _ -> return () +fillSelectedGap :: MH ()+fillSelectedGap = do+ selected <- use (to getSelectedMessage)+ case selected of+ Just msg+ | isGap msg -> do cId <- use csCurrentChannelId+ asyncFetchMessagesForGap cId msg+ _ -> return ()+ viewMessage :: Message -> MH () viewMessage m = do csViewedMessage .= Just m@@ -114,7 +128,11 @@ openSelectedMessageURLs :: MH () openSelectedMessageURLs = whenMode MessageSelect $ do- Just curMsg <- use (to getSelectedMessage)+ mCurMsg <- use (to getSelectedMessage)+ curMsg <- case mCurMsg of+ Nothing -> error "BUG: openSelectedMessageURLs: no selected message available"+ Just m -> return m+ let urls = msgURLs curMsg when (not (null urls)) $ do openedAll <- and <$> mapM (openURL . OpenLinkChoice) urls@@ -165,6 +183,30 @@ | otherwise = messageSelectUp >> messageSelectUpBy (amt - 1) +messageSelectFirst :: MH ()+messageSelectFirst = do+ selected <- use (csMessageSelect.to selectMessageId)+ case selected of+ Just _ -> whenMode MessageSelect $ do+ chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+ case getEarliestSelectableMessage chanMsgs of+ Just firstMsg ->+ csMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)+ Nothing -> mhLog LogError "No first message found from current message?!"+ _ -> return ()++messageSelectLast :: MH ()+messageSelectLast = do+ selected <- use (csMessageSelect.to selectMessageId)+ case selected of+ Just _ -> whenMode MessageSelect $ do+ chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+ case getLatestSelectableMessage chanMsgs of+ Just lastSelMsg ->+ csMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)+ Nothing -> mhLog LogError "No last message found from current message?!"+ _ -> return ()+ deleteSelectedMessage :: MH () deleteSelectedMessage = do selectedMessage <- use (to getSelectedMessage)@@ -208,9 +250,10 @@ -- value of "emote" that we can look at. Note that the -- removed formatting needs to be reinstated just prior to -- issuing the API call to update the post.- let toEdit = if msg^.mType == CP Emote- then removeEmoteFormatting $ sanitizeUserText $ postMessage p- else sanitizeUserText $ postMessage p+ let sanitized = sanitizeUserText $ postMessage p+ let toEdit = if isEmote msg+ then removeEmoteFormatting sanitized+ else sanitized csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit)) _ -> return ()
src/State/Messages.hs view
@@ -7,7 +7,10 @@ , editMessage , deleteMessage , addNewPostedMessage+ , addObtainedMessages , asyncFetchMoreMessages+ , asyncFetchMessagesForGap+ , asyncFetchMessagesSurrounding , fetchVisibleIfNeeded , disconnectChannels )@@ -34,13 +37,14 @@ import Network.Mattermost.Types import Constants-import State.Common import State.Channels+import State.Common import State.Reactions import State.Users import TimeUtils import Types import Types.Common ( sanitizeUserText )+import Types.DirectionalSeq ( DirectionalSeq, SeqDirection ) -- ----------------------------------------------------------------------@@ -76,24 +80,25 @@ gapMsg = newGapMessage timeJustAfterLast timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_ t0 = ServerTime $ originTime -- use any time for a channel with no messages yet- newGapMessage = newMessageOfType (T.pack "Disconnected. Will refresh when connected.") (C UnknownGap)+ newGapMessage = newMessageOfType+ (T.pack "Disconnected. Will refresh when connected.")+ (C UnknownGapAfter) in unless lastIsGap (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg)) lastMsg :: RetrogradeMessages -> Maybe Message lastMsg = withFirstMessage id -sendMessage :: EditMode -> Text -> [AttachmentData] -> MH ()-sendMessage mode msg attachments =+-- | Send a message and attachments to the specified channel.+sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()+sendMessage chanId mode msg attachments = when (not $ shouldSkipMessage msg) $ do status <- use csConnectionStatus- st <- use id case status of Disconnected -> do let m = "Cannot send messages while disconnected." mhError $ GenericError m Connected -> do- let chanId = st^.csCurrentChannelId session <- getSession doAsync Preempt $ do -- Upload attachments@@ -116,9 +121,9 @@ } void $ MM.mmCreatePost pendingPost session Editing p ty -> do- let body = if ty == CP Emote- then addEmoteFormatting msg- else msg+ let body = case ty of+ CP Emote -> addEmoteFormatting msg+ _ -> msg update = (postUpdateBody body) { postUpdateFileIds = if null fileIds then Nothing else Just fileIds@@ -161,8 +166,19 @@ addNewPostedMessage p = addMessageToState True True p >>= postProcessMessageAdd -addObtainedMessages :: ChannelId -> Int -> Posts -> MH PostProcessMessageAdd-addObtainedMessages cId reqCnt posts = do+-- | Adds the set of Posts to the indicated channel. The Posts must+-- all be for the specified Channel. The reqCnt argument indicates+-- how many posts were requested, which will determine whether a gap+-- message is added to either end of the posts list or not.+--+-- The addTrailingGap is only True when fetching the very latest messages+-- for the channel, and will suppress the generation of a Gap message+-- following the added block of messages.+addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd+addObtainedMessages cId reqCnt addTrailingGap posts =+ if null $ posts^.postsOrderL+ then return NoAction+ else -- Adding a block of server-provided messages, which are known to -- be contiguous. Locally this may overlap with some UnknownGap -- messages, which can therefore be removed. Alternatively the@@ -178,6 +194,10 @@ localMessages = chan^.ccContents . cdMessages + -- Get a list of the duplicated message PostIds between+ -- the messages already in the channel and the new posts+ -- to be added.+ match = snd $ removeMatchesFromSubset (\m -> maybe False (\p -> p `elem` pIdList) (messagePostId m)) (Just (MessagePostId earliestPId))@@ -198,7 +218,19 @@ -- do not signal action needed for notifications), and -- remove any gaps in the overlapping region. - newGapMessage d = newMessageOfType "Additional messages???" (C UnknownGap) d+ newGapMessage d isOlder =+ -- newGapMessage is a helper for generating a gap+ -- message+ do uuid <- generateUUID+ let txt = "Load " <>+ (if isOlder then "older" else "newer") <>+ " messages" <>+ (if isOlder then " ↥↥↥" else " ↧↧↧")+ ty = if isOlder+ then C UnknownGapBefore+ else C UnknownGapAfter+ return (newMessageOfType txt ty d+ & mMessageId .~ Just (MessageUUID uuid)) -- If this batch contains the latest known messages, do -- not add a following gap. A gap at this point is added@@ -210,17 +242,28 @@ -- location, so adding the gap here would cause an -- infinite update loop. - addingAtEnd = maybe True ((<=) latestDate) $+ addingAtEnd = maybe True (latestDate >=) $ (^.mDate) <$> getLatestPostMsg localMessages - addingAtStart = maybe True ((>=) earliestDate) $+ addingAtStart = maybe True (earliestDate <=) $ (^.mDate) <$> getEarliestPostMsg localMessages- removeStart = if addingAtStart && noMoreBefore then Nothing else Just (MessagePostId earliestPId)- removeEnd = if addingAtEnd then Nothing else Just (MessagePostId latestPId)+ removeStart = if addingAtStart && noMoreBefore+ then Nothing+ else Just (MessagePostId earliestPId)+ removeEnd = if addTrailingGap || (addingAtEnd && noMoreAfter)+ then Nothing+ else Just (MessagePostId latestPId) noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)- noMoreAfter = reqCnt > 0 && length pIdList < reqCnt+ noMoreAfter = addTrailingGap || reqCnt > 0 && length pIdList < reqCnt + reAddGapBefore = earliestPId `elem` dupPIds || noMoreBefore+ -- addingAtEnd used to be in reAddGapAfter but does not+ -- seem to be needed. I may have missed a specific use+ -- case/scenario, so I've left it commented out here for+ -- debug assistance.+ reAddGapAfter = latestPId `elem` dupPIds || {- addingAtEnd || -} noMoreAfter+ -- The post map returned by the server will *already* have -- all thread messages for each post that is part of a -- thread. By calling installMessagesFromPosts here, we go ahead@@ -248,28 +291,111 @@ , not (p `elem` dupPIds) ] - csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ (fst . removeMatchesFromSubset isGap removeStart removeEnd))+ -- The channel messages now include all the fetched messages.+ -- Things to do at this point are:+ --+ -- 1. Remove any duplicates just added, as well as any gaps+ -- 2. Add new gaps (if needed) at either end of the added+ -- messages.+ -- 3. Update the "current selection" if it was on a removed message.+ --+ -- Do this with the updated copy of the channel's messages. - -- Add a gap at each end of the newly fetched data, unless:- -- 1. there is an overlap- -- 2. there is no more in the indicated direction- -- a. indicated by adding messages later than any currently- -- held messages (see note above re 'addingAtEnd').- -- b. the amount returned was less than the amount requested+ withChannelOrDefault cId () $ \updchan -> do+ let updMsgs = updchan ^. ccContents . cdMessages - unless (earliestPId `elem` dupPIds || noMoreBefore) $- let gapMsg = newGapMessage (justBefore earliestDate)- in csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ addMessage gapMsg)+ -- Remove any gaps in the added region. If there was an+ -- active message selection and it is one of the removed+ -- gaps, reset the selection to the beginning or end of the+ -- added region (if there are any added selectable messages,+ -- otherwise just the end if the message list in it's+ -- entirety, or no selection at all). - unless (latestPId `elem` dupPIds || addingAtEnd || noMoreAfter) $- let gapMsg = newGapMessage (justAfter latestDate)- in csChannels %= modifyChannelById cId- (ccContents.cdMessages %~ addMessage gapMsg)+ let (resultMessages, removedMessages) =+ removeMatchesFromSubset isGap removeStart removeEnd updMsgs+ csChannels %= modifyChannelById cId+ (ccContents.cdMessages .~ resultMessages) + -- Determine if the current selected message was one of the+ -- removed messages.++ selMsgId <- use (csMessageSelect.to selectMessageId)+ let rmvdSel = do+ i <- selMsgId -- :: Maybe MessageId+ findMessage i removedMessages+ rmvdSelType = _mType <$> rmvdSel++ case rmvdSel of+ Nothing -> return ()+ Just rm ->+ if isGap rm+ then return () -- handled during gap insertion below+ else do+ -- Replaced a selected message that wasn't a gap.+ -- This is unlikely, but may occur if the previously+ -- selected message was just deleted by another user+ -- and is in the fetched region. The choices here are+ -- to move the selection, or cancel the selection.+ -- Both will be unpleasant surprises for the user, but+ -- cancelling the selection is probably the better+ -- choice than allowing the user to perform select+ -- actions on a message that isn't the one they just+ -- selected.+ setMode Main+ csMessageSelect .= MessageSelectState Nothing++ -- Add a gap at each end of the newly fetched data, unless:+ -- 1. there is an overlap+ -- 2. there is no more in the indicated direction+ -- a. indicated by adding messages later than any currently+ -- held messages (see note above re 'addingAtEnd').+ -- b. the amount returned was less than the amount requested++ if reAddGapBefore+ then+ -- No more gaps. If the selected gap was removed, move+ -- select to first (earliest) message)+ case rmvdSelType of+ Just (C UnknownGapBefore) ->+ csMessageSelect .= MessageSelectState (pure $ MessagePostId earliestPId)+ _ -> return ()+ else do+ -- add a gap at the start of the newly fetched block and+ -- make that the active selection if this fetch removed+ -- the previously selected gap in this direction.+ gapMsg <- newGapMessage (justBefore earliestDate) True+ csChannels %= modifyChannelById cId+ (ccContents.cdMessages %~ addMessage gapMsg)+ -- Move selection from old gap to new gap+ case rmvdSelType of+ Just (C UnknownGapBefore) -> do+ csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)+ _ -> return ()++ if reAddGapAfter+ then+ -- No more gaps. If the selected gap was removed, move+ -- select to last (latest) message.+ case rmvdSelType of+ Just (C UnknownGapAfter) ->+ csMessageSelect .= MessageSelectState (pure $ MessagePostId latestPId)+ _ -> return ()+ else do+ -- add a gap at the end of the newly fetched block and+ -- make that the active selection if this fetch removed+ -- the previously selected gap in this direction.+ gapMsg <- newGapMessage (justAfter latestDate) False+ csChannels %= modifyChannelById cId+ (ccContents.cdMessages %~ addMessage gapMsg)+ -- Move selection from old gap to new gap+ case rmvdSelType of+ Just (C UnknownGapAfter) ->+ csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)+ _ -> return ()+ -- Now initiate fetches for use information for any -- as-yet-unknown users related to this new set of messages+ let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post)) Set.empty (posts^.postsPostsL) addUnknownUsers inputUserIds = do@@ -293,14 +419,24 @@ -- existing UnknownGap entries and should be called when those are -- irrelevant. ----- The boolean argument indicates whether this function should schedule--- a fetch for any mentioned users in the message. This is provided--- so that callers can batch this operation if a large collection of--- messages is being added together, in which case we don't want this--- function to schedule a single request per message (worst case). If--- you're calling this as part of scrollback processing, you should pass--- False. Otherwise if you're adding only a single message, you should--- pass True.+-- The first boolean argument ('fetchMentionedUsers') indicates+-- whether this function should schedule a fetch for any mentioned+-- users in the message. This is provided so that callers can batch+-- this operation if a large collection of messages is being added+-- together, in which case we don't want this function to schedule a+-- single request per message (worst case). If you're calling this as+-- part of scrollback processing, you should pass False. Otherwise if+-- you're adding only a single message, you should pass True.+--+-- The second boolean argument ('fetchAuthor') is similar to the first+-- boolean argument but it refers to the author of the message instead+-- of any user mentions within the message body.+--+-- The third argument ('newPostData') indicates whether this message+-- is being added as part of a fetch of old messages (e.g. scrollback)+-- or if ti is a new message and affects things like whether+-- notifications are generated and if the "New Messages" marker gets+-- updated. addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd addMessageToState fetchMentionedUsers fetchAuthor newPostData = do let (new, wasMentioned) = case newPostData of@@ -376,7 +512,10 @@ (adjustUpdated new) . (\c -> if currCId == cId then c- else updateNewMessageIndicator new c) .+ else case newPostData of+ OldPost _ -> c+ RecentPost _ _ ->+ updateNewMessageIndicator new c) . (\c -> if wasMentioned then c & ccInfo.cdMentionCount %~ succ else c)@@ -512,37 +651,156 @@ -- received in this mode are not normally shown, but this explicit -- user-driven fetch should be displayed, so this also invalidates the -- cache.+--+-- This function assumes it is being called to add "older" messages to+-- the message history (i.e. near the beginning of the known+-- messages). It will normally try to overlap the fetch with the+-- known existing messages so that when the fetch results are+-- processed (which should be a contiguous set of messages as provided+-- by the server) there will be an overlap with existing messages; if+-- there is no overlap, then a special "gap" must be inserted in the+-- area between the existing messages and the newly fetched messages+-- to indicate that this client does not know if there are missing+-- messages there or not.+--+-- In order to achieve an overlap, this code attempts to get the+-- second oldest messages as the message ID to pass to the server as+-- the "older than" marker ('postQueryBefore'), so that the oldest+-- message here overlaps with the fetched results to ensure no gap+-- needs to be inserted. However, there may already be a gap between+-- the oldest and second-oldest messages, so this code must actually+-- search for the first set of two *contiguous* messages it is aware+-- of to avoid adding additional gaps. (It's OK if gaps are added, but+-- the user must explicitly request a check for messages in order to+-- eliminate them, so it's better to avoid adding them in the first+-- place). This code is nearly always used to extend the older+-- history of a channel that information has already been retrieved+-- from, so it's almost certain that there are at least two contiguous+-- messages to use as a starting point, but exceptions are new+-- channels and empty channels. asyncFetchMoreMessages :: MH () asyncFetchMoreMessages = do cId <- use csCurrentChannelId withChannel cId $ \chan -> let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2- -- Fetch more messages prior to any existing messages, but- -- attempt to overlap with existing messages for- -- determining contiguity or gaps. Back up two messages- -- and request from there backward, which should include- -- the last message in the response. This is an attempt- -- to fetch *more* messages, so it's expected that there- -- are at least 2 messages already here, but in case there- -- aren't, just get another page from roughly the right- -- location.- first' = splitMessagesOn (isJust . messagePostId) (chan^.ccContents.cdMessages)- second' = splitMessagesOn (isJust . messagePostId) $ snd $ snd first'+ page = offset `div` pageAmount+ usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages)+ sndOldestId = (messagePostId . snd) =<< usefulMsgs query = MM.defaultPostQuery- { MM.postQueryPage = Just (offset `div` pageAmount)+ { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId , MM.postQueryPerPage = Just pageAmount+ , MM.postQueryBefore = sndOldestId }- & \q -> case (fst first', fst second' >>= messagePostId) of- (Just _, Just i) -> q { MM.postQueryBefore = Just i- , MM.postQueryPage = Just 0- }- _ -> q+ addTrailingGap = MM.postQueryBefore query == Nothing &&+ MM.postQueryPage query == Just 0 in doAsyncChannelMM Preempt cId (\s _ c -> MM.mmGetPostsForChannel c query s) (\c p -> Just $ do- addObtainedMessages c (-pageAmount) p >>= postProcessMessageAdd+ pp <- addObtainedMessages c (-pageAmount) addTrailingGap p+ postProcessMessageAdd pp mh $ invalidateCacheEntry (ChannelMessages cId)) ++-- | Given a starting point and a direction to move from that point,+-- returns the closest two adjacent messages on that direction (as a+-- tuple of closest and next-closest), or Nothing if there are no+-- adjacent messages in the indicated direction.+getTwoContiguousPosts :: SeqDirection dir =>+ Maybe Message+ -> DirectionalSeq dir Message+ -> Maybe (Message, Message)+getTwoContiguousPosts startMsg msgs =+ let go start =+ do anchor <- getRelMessageId (_mMessageId =<< start) msgs+ hinge <- getRelMessageId (anchor^.mMessageId) msgs+ if isGap anchor || isGap hinge+ then go $ Just anchor+ else Just (anchor, hinge)+ in go startMsg+++asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()+asyncFetchMessagesForGap cId gapMessage =+ when (isGap gapMessage) $+ withChannel cId $ \chan ->+ let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2+ page = offset `div` pageAmount+ chanMsgs = chan^.ccContents.cdMessages+ fromMsg = Just gapMessage+ fetchNewer = case gapMessage^.mType of+ C UnknownGapAfter -> True+ C UnknownGapBefore -> False+ _ -> error "fetch gap messages: unknown gap message type"+ baseId = messagePostId . snd =<<+ case gapMessage^.mType of+ C UnknownGapAfter -> getTwoContiguousPosts fromMsg $+ reverseMessages chanMsgs+ C UnknownGapBefore -> getTwoContiguousPosts fromMsg chanMsgs+ _ -> error "fetch gap messages: unknown gap message type"+ query = MM.defaultPostQuery+ { MM.postQueryPage = maybe (Just page) (const Nothing) baseId+ , MM.postQueryPerPage = Just pageAmount+ , MM.postQueryBefore = if fetchNewer then Nothing else baseId+ , MM.postQueryAfter = if fetchNewer then baseId else Nothing+ }+ addTrailingGap = MM.postQueryBefore query == Nothing &&+ MM.postQueryPage query == Just 0+ in doAsyncChannelMM Preempt cId+ (\s _ c -> MM.mmGetPostsForChannel c query s)+ (\c p -> Just $ do+ void $ addObtainedMessages c (-pageAmount) addTrailingGap p+ mh $ invalidateCacheEntry (ChannelMessages cId))++-- | Given a particular message ID, this fetches n messages before and+-- after immediately before and after the specified message in order+-- to establish some context for that message. This is frequently+-- used as a background operation when looking at search or flag+-- results so that jumping to message select mode for one of those+-- messages will show a bit of context (and it also prevents showing+-- gap messages for adjacent targets).+--+-- The result will be adding at most 2n messages to the channel, with+-- the input post ID being somewhere in the middle of the added+-- messages.+--+-- Note that this fetch will add messages to the channel, but it+-- performs no notifications or updates of new-unread indicators+-- because it is assumed to be used for non-current (previously-seen)+-- messages in background mode.+asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH ()+asyncFetchMessagesSurrounding cId pId = do+ let query = MM.defaultPostQuery+ { MM.postQueryBefore = Just pId+ , MM.postQueryPerPage = Just reqAmt+ }+ reqAmt = 5 -- both before and after+ doAsyncChannelMM Preempt cId+ -- first get some messages before the target, no overlap+ (\s _ c -> MM.mmGetPostsForChannel c query s)+ (\c p -> Just $ do+ let last2ndId = secondToLastPostId p+ void $ addObtainedMessages c (-reqAmt) False p+ mh $ invalidateCacheEntry (ChannelMessages cId)+ -- now start 2nd from end of this fetch to fetch some+ -- messages forward, also overlapping with this fetch and+ -- the original message ID to eliminate all gaps in this+ -- surrounding set of messages.+ let query' = MM.defaultPostQuery+ { MM.postQueryAfter = last2ndId+ , MM.postQueryPerPage = Just $ reqAmt + 2+ }+ doAsyncChannelMM Preempt cId+ (\s' _ c' -> MM.mmGetPostsForChannel c' query' s')+ (\c' p' -> Just $ do+ void $ addObtainedMessages c' (reqAmt + 2) False p'+ mh $ invalidateCacheEntry (ChannelMessages cId)+ )+ )+ where secondToLastPostId posts =+ let pl = toList $ postsOrder posts+ in if length pl > 1 then Just $ last $ init pl else Nothing++ fetchVisibleIfNeeded :: MH () fetchVisibleIfNeeded = do sts <- use csConnectionStatus@@ -567,11 +825,13 @@ Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid } _ -> query op = \s _ c -> MM.mmGetPostsForChannel c finalQuery s+ addTrailingGap = MM.postQueryBefore finalQuery == Nothing &&+ MM.postQueryPage finalQuery == Just 0 in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do csChannel(cId).ccContents.cdFetchPending .= True doAsyncChannelMM Preempt cId op (\c p -> Just $ do- addObtainedMessages c (-numToReq) p >>= postProcessMessageAdd+ addObtainedMessages c (-numToReq) addTrailingGap p >>= postProcessMessageAdd csChannel(c).ccContents.cdFetchPending .= False) asyncFetchAttachments :: Post -> MH ()
src/State/PostListOverlay.hs view
@@ -1,6 +1,7 @@ module State.PostListOverlay ( enterFlaggedPostListMode , enterSearchResultPostListMode+ , postListJumpToCurrent , postListSelectUp , postListSelectDown , postListUnflagSelected@@ -8,16 +9,21 @@ ) where +import GHC.Exts ( IsList(..) ) import Prelude () import Prelude.MH +import qualified Data.Foldable as F import qualified Data.Text as T import Lens.Micro.Platform ( (.=) ) import Network.Mattermost.Endpoints import Network.Mattermost.Types +import State.Channels import State.Common import State.MessageSelect+import State.Messages ( addObtainedMessages+ , asyncFetchMessagesSurrounding ) import Types import Types.DirectionalSeq (emptyDirSeq) @@ -27,8 +33,14 @@ enterPostListMode :: PostListContents -> Messages -> MH () enterPostListMode contents msgs = do csPostListOverlay.postListPosts .= msgs- csPostListOverlay.postListSelected .= (getLatestPostMsg msgs >>= messagePostId)+ let mlatest = getLatestPostMsg msgs+ pId = mlatest >>= messagePostId+ cId = mlatest >>= \m -> m^.mChannelId+ csPostListOverlay.postListSelected .= pId setMode $ PostListOverlay contents+ case (pId, cId) of+ (Just p, Just c) -> asyncFetchMessagesSurrounding c p+ _ -> return () -- | Clear out the state of a PostListOverlay exitPostListMode :: MH ()@@ -37,55 +49,78 @@ csPostListOverlay.postListSelected .= Nothing setMode Main --- | Create a PostListOverlay with flagged messages from the server.-enterFlaggedPostListMode :: MH ()-enterFlaggedPostListMode = do++createPostList :: PostListContents -> (Session -> IO Posts) -> MH ()+createPostList contentsType fetchOp = do session <- getSession doAsyncWith Preempt $ do- posts <- mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery session+ posts <- fetchOp session return $ Just $ do messages <- fst <$> installMessagesFromPosts posts- enterPostListMode PostListFlagged messages+ -- n.b. do not use addNewPostedMessage because these messages+ -- are not new, and so no notifications or channel highlighting+ -- or other post-processing should be performed.+ let plist = F.toList $ postsPosts posts+ postsSpec p = Posts { postsPosts = fromList [(postId p, p)]+ , postsOrder = fromList [postId p]+ }+ mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist+ enterPostListMode contentsType messages ++-- | Create a PostListOverlay with flagged messages from the server.+enterFlaggedPostListMode :: MH ()+enterFlaggedPostListMode = createPostList PostListFlagged $+ mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery++ -- | Create a PostListOverlay with post search result messages from the -- server. enterSearchResultPostListMode :: Text -> MH ()-enterSearchResultPostListMode terms = do- session <- getSession- tId <- gets myTeamId- case T.null $ T.strip terms of- True -> postInfoMessage "Search command requires at least one search term."- False -> do- enterPostListMode (PostListSearch terms True) noMessages- doAsyncWith Preempt $ do- posts <- mmSearchForTeamPosts tId (SearchPosts terms False) session- return $ Just $ do- messages <- fst <$> installMessagesFromPosts posts- enterPostListMode (PostListSearch terms False) messages+enterSearchResultPostListMode terms+ | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term."+ | otherwise = do+ enterPostListMode (PostListSearch terms True) noMessages+ tId <- gets myTeamId+ createPostList (PostListSearch terms False) $+ mmSearchForTeamPosts tId (SearchPosts terms False) + -- | Move the selection up in the PostListOverlay, which corresponds -- to finding a chronologically /newer/ message. postListSelectUp :: MH () postListSelectUp = do- msgId <- use (csPostListOverlay.postListSelected)+ selId <- use (csPostListOverlay.postListSelected) posts <- use (csPostListOverlay.postListPosts)- let nextId = (getNextPostId msgId posts)- case nextId of+ let nextMsg = getNextMessage (MessagePostId <$> selId) posts+ case nextMsg of Nothing -> return ()- Just _ ->- csPostListOverlay.postListSelected .= nextId+ Just m -> do+ let pId = m^.mMessageId >>= messageIdPostId+ csPostListOverlay.postListSelected .= pId+ case (m^.mChannelId, pId) of+ (Just c, Just p) -> asyncFetchMessagesSurrounding c p+ o -> mhLog LogError+ (T.pack $ "postListSelectUp" <>+ " unable to get channel or post ID: " <> show o) -- | Move the selection down in the PostListOverlay, which corresponds -- to finding a chronologically /old/ message. postListSelectDown :: MH () postListSelectDown = do- msgId <- use (csPostListOverlay.postListSelected)+ selId <- use (csPostListOverlay.postListSelected) posts <- use (csPostListOverlay.postListPosts)- let prevId = (getPrevPostId msgId posts)- case prevId of+ let prevMsg = getPrevMessage (MessagePostId <$> selId) posts+ case prevMsg of Nothing -> return ()- Just _ ->- csPostListOverlay.postListSelected .= prevId+ Just m -> do+ let pId = m^.mMessageId >>= messageIdPostId+ csPostListOverlay.postListSelected .= pId+ case (m^.mChannelId, pId) of+ (Just c, Just p) -> asyncFetchMessagesSurrounding c p+ o -> mhLog LogError+ (T.pack $ "postListSelectDown" <>+ " unable to get channel or post ID: " <> show o) -- | Unflag the post currently selected in the PostListOverlay, if any postListUnflagSelected :: MH ()@@ -94,3 +129,25 @@ case msgId of Nothing -> return () Just pId -> flagMessage pId False+++-- | Jumps to the specified message in the message's main channel+-- display and changes to MessageSelectState.+postListJumpToCurrent :: MH ()+postListJumpToCurrent = do+ msgId <- use (csPostListOverlay.postListSelected)+ st <- use id+ case msgId of+ Nothing -> return ()+ Just pId ->+ case getMessageForPostId st pId of+ Just msg ->+ case msg ^. mChannelId of+ Just cId -> do+ setFocus cId+ setMode MessageSelect+ csMessageSelect .= MessageSelectState (msg^.mMessageId)+ Nothing ->+ error "INTERNAL: selected Post ID not associated with a channel"+ Nothing ->+ error "INTERNAL: selected Post ID not added to global state!"
src/State/Reactions.hs view
@@ -8,6 +8,7 @@ import Prelude () import Prelude.MH +import Brick.Main ( invalidateCacheEntry ) import qualified Data.Map.Strict as Map import Lens.Micro.Platform @@ -27,7 +28,9 @@ (\_ rs -> Just $ addReactions cId rs) addReactions :: ChannelId -> [Reaction] -> MH ()-addReactions cId rs = csChannel(cId).ccContents.cdMessages %= fmap upd+addReactions cId rs = do+ mh $ invalidateCacheEntry $ ChannelMessages cId+ csChannel(cId).ccContents.cdMessages %= fmap upd where upd msg = msg & mReactions %~ insertAll (msg^.mMessageId) insert mId r | mId == Just (MessagePostId (r^.reactionPostIdL)) = Map.insertWith (+) (r^.reactionEmojiNameL) 1@@ -35,7 +38,9 @@ insertAll mId msg = foldr (insert mId) msg rs removeReaction :: Reaction -> ChannelId -> MH ()-removeReaction r cId = csChannel(cId).ccContents.cdMessages %= fmap upd+removeReaction r cId = do+ mh $ invalidateCacheEntry $ ChannelMessages cId+ csChannel(cId).ccContents.cdMessages %= fmap upd where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) = m & mReactions %~ (Map.insertWith (+) (r^.reactionEmojiNameL) (-1)) | otherwise = m
src/State/Setup.hs view
@@ -261,7 +261,7 @@ -- End thread startup ---------------------------------------------- now <- getCurrentTime- let chanIds = mkChannelZipperList now Nothing (cr^.crUserPreferences) clientChans noUsers+ let chanIds = mkChannelZipperList now (cr^.crConfiguration) Nothing (cr^.crUserPreferences) clientChans noUsers chanZip = Z.fromList chanIds clientChans = foldr (uncurry addChannel) noChannels chanPairs startupState =
src/State/UserListOverlay.hs view
@@ -45,7 +45,7 @@ myTId <- gets myTeamId enterUserListMode (ChannelMembers cId myTId) (\u -> case u^.uiId /= myId of- True -> createOrFocusDMChannel u >> return True+ True -> createOrFocusDMChannel u Nothing >> return True False -> return False ) @@ -75,7 +75,7 @@ _ -> Nothing enterUserListMode (AllUsers restrictTeam) (\u -> case u^.uiId /= myId of- True -> createOrFocusDMChannel u >> return True+ True -> createOrFocusDMChannel u Nothing >> return True False -> return False )
src/Types.hs view
@@ -18,6 +18,7 @@ , StartupStateInfo(..) , MHError(..) , AttachmentData(..)+ , CPUUsagePolicy(..) , OpenInBrowser(..) , ConnectionInfo(..) , SidebarUpdate(..)@@ -36,7 +37,6 @@ , HelpScreen(..) , PasswordSource(..) , MatchType(..)- , EditMode(..) , Mode(..) , ChannelSelectPattern(..) , PostListContents(..)@@ -93,11 +93,9 @@ , cedSpellChecker , cedMisspellings , cedEditMode+ , cedEphemeral , cedEditor- , cedMultiline , cedInputHistory- , cedInputHistoryPosition- , cedLastChannelInput , cedAutocomplete , cedAutocompletePending @@ -191,10 +189,7 @@ , requestLogDestination , sendLogMessage - , isNameFragment- , requestQuit- , clientPostToMessage , getMessageForPostId , getParentMessage , resetSpellCheckTimer@@ -233,8 +228,6 @@ , ChannelSet , getHighlightSet - , takeWhileNameFragment- , module Types.Channels , module Types.Messages , module Types.Posts@@ -253,7 +246,6 @@ import Brick.Widgets.Edit ( Editor, editor ) import Brick.Widgets.List ( List, list ) import qualified Brick.Widgets.FileBrowser as FB-import qualified Cheapskate as C import Control.Concurrent ( ThreadId ) import Control.Concurrent.Async ( Async ) import qualified Control.Concurrent.STM as STM@@ -261,15 +253,13 @@ import qualified Control.Monad.State as St import qualified Control.Monad.Reader as R import qualified Data.ByteString as BS-import Data.Char ( isAlpha ) import qualified Data.Foldable as F import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM-import Data.List ( sortBy, break )-import qualified Data.Set as S+import Data.List ( sortBy ) import qualified Data.Sequence as Seq import qualified Data.Text as T-import Data.Time.Clock ( UTCTime, getCurrentTime, nominalDay, addUTCTime )+import Data.Time.Clock ( UTCTime, getCurrentTime, addUTCTime ) import Data.UUID ( UUID ) import qualified Data.Vector as Vec import Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=)@@ -391,8 +381,26 @@ -- ^ Whether to enable terminal hyperlinking mode. , configSyntaxDirs :: [FilePath] -- ^ The search path for syntax description XML files.+ , configDirectChannelExpirationDays :: Int+ -- ^ The number of days to show a user in the channel menu after a direct+ -- message with them.+ , configCpuUsagePolicy :: CPUUsagePolicy+ -- ^ The CPU usage policy for the application. } deriving (Eq, Show) +-- | The policy for CPU usage.+--+-- The idea is that Matterhorn can benefit from using multiple CPUs,+-- but the exact number is application-determined. We expose this policy+-- setting to the user in the configuration.+data CPUUsagePolicy =+ SingleCPU+ -- ^ Constrain the application to use one CPU.+ | MultipleCPUs+ -- ^ Permit the usage of multiple CPUs (the exact number is+ -- determined by the application).+ deriving (Eq, Show)+ -- | The state of the UI diagnostic indicator for the async worker -- thread. data BackgroundInfo =@@ -425,14 +433,15 @@ (isJust $ _cdEditedMessageThreshold info) mkChannelZipperList :: UTCTime+ -> Config -> Maybe ClientConfig -> UserPreferences -> ClientChannels -> Users -> [(ChannelListGroup, [ChannelListEntry])]-mkChannelZipperList now cconfig prefs cs us =+mkChannelZipperList now config cconfig prefs cs us = [ (ChannelGroupPublicChannels, getNonDMChannelIdsInOrder cs)- , (ChannelGroupDirectMessages, getDMChannelsInOrder now cconfig prefs us cs)+ , (ChannelGroupDirectMessages, getDMChannelsInOrder now config cconfig prefs us cs) ] getNonDMChannelIdsInOrder :: ClientChannels -> [ChannelListEntry]@@ -443,14 +452,15 @@ filteredChannels matches cs getDMChannelsInOrder :: UTCTime+ -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [ChannelListEntry]-getDMChannelsInOrder now cconfig prefs us cs =- let oneOnOneDmChans = getDMChannels now cconfig prefs us cs- groupChans = getGroupDMChannels now prefs cs+getDMChannelsInOrder now config cconfig prefs us cs =+ let oneOnOneDmChans = getDMChannels now config cconfig prefs us cs+ groupChans = getGroupDMChannels now config prefs cs allDmChans = groupChans <> oneOnOneDmChans sorter (u1, n1, _) (u2, n2, _) = if u1 == u2@@ -479,22 +489,24 @@ u^.uiName getGroupDMChannels :: UTCTime+ -> Config -> UserPreferences -> ClientChannels -> [(Bool, T.Text, ChannelListEntry)]-getGroupDMChannels now prefs cs =+getGroupDMChannels now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group &&- groupChannelShouldAppear now prefs info+ groupChannelShouldAppear now config prefs info in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdName, CLGroupDM cId)) $ filteredChannels matches cs getDMChannels :: UTCTime+ -> Config -> Maybe ClientConfig -> UserPreferences -> Users -> ClientChannels -> [(Bool, T.Text, ChannelListEntry)]-getDMChannels now cconfig prefs us cs =+getDMChannels now config cconfig prefs us cs = let mapping = allDmChannelMappings cs mappingWithUserInfo = catMaybes $ getInfo <$> mapping getInfo (uId, cId) = do@@ -503,7 +515,7 @@ case u^.uiDeleted of True -> Nothing False ->- if dmChannelShouldAppear now prefs c+ if dmChannelShouldAppear now config prefs c then return (hasUnread' c, displayNameForUser u cconfig prefs, CLUserDM cId uId) else Nothing in mappingWithUserInfo@@ -515,10 +527,10 @@ -- -- Otherwise, only show it if at least one of the other conditions are -- met (see 'or' below).-dmChannelShouldAppear :: UTCTime -> UserPreferences -> ClientChannel -> Bool-dmChannelShouldAppear now prefs c =- let weeksAgo n = nominalDay * (-7 * n)- localCutoff = addUTCTime (weeksAgo 1) now+dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool+dmChannelShouldAppear now config prefs c =+ let ndays = configDirectChannelExpirationDays config+ localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated Just uId = c^.ccInfo.cdDMUserId@@ -531,10 +543,10 @@ updated >= cutoff ] -groupChannelShouldAppear :: UTCTime -> UserPreferences -> ClientChannel -> Bool-groupChannelShouldAppear now prefs c =- let weeksAgo n = nominalDay * (-7 * n)- localCutoff = addUTCTime (weeksAgo 1) now+groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool+groupChannelShouldAppear now config prefs c =+ let ndays = configDirectChannelExpirationDays config+ localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now cutoff = ServerTime localCutoff updated = c^.ccInfo.cdUpdated in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)@@ -837,10 +849,14 @@ data ChatEditState = ChatEditState { _cedEditor :: Editor Text Name , _cedEditMode :: EditMode- , _cedMultiline :: Bool+ , _cedEphemeral :: EphemeralEditState , _cedInputHistory :: InputHistory- , _cedInputHistoryPosition :: HashMap ChannelId (Maybe Int)- , _cedLastChannelInput :: HashMap ChannelId (Text, EditMode)+ -- ^ The map of per-channel input history for the+ -- application. We don't distribute the per-channel+ -- history into the per-channel states (like we do+ -- for other per-channel state) since keeping it+ -- under the InputHistory banner lets us use a nicer+ -- startup/shutdown disk file management API. , _cedYankBuffer :: Text , _cedSpellChecker :: Maybe (Aspell, IO ()) , _cedMisspellings :: Set Text@@ -869,28 +885,14 @@ } deriving (Eq, Show) --- | The input mode.-data EditMode =- NewPost- -- ^ The input is for a new post.- | Editing Post MessageType- -- ^ The input is to be used as a new body for an existing post of- -- the specified type.- | Replying Message Post- -- ^ The input is to be used as a new post in reply to the specified- -- post.- deriving (Show)- -- | We can initialize a new 'ChatEditState' value with just an edit -- history, which we save locally. emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState emptyEditState hist sp = do browser <- FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing return ChatEditState { _cedEditor = editor MessageInput Nothing ""- , _cedMultiline = False+ , _cedEphemeral = defaultEphemeralEditState , _cedInputHistory = hist- , _cedInputHistoryPosition = mempty- , _cedLastChannelInput = mempty , _cedEditMode = NewPost , _cedYankBuffer = "" , _cedSpellChecker = sp@@ -939,7 +941,6 @@ | LeaveChannelConfirm | DeleteChannelConfirm | JoinChannel- | ChannelScroll | MessageSelect | MessageSelectDeleteConfirm | PostListOverlay PostListContents@@ -1463,92 +1464,12 @@ | SidebarUpdateDeferred deriving (Eq, Show) -isValidNameChar :: Char -> Bool-isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-' -isNameFragment :: C.Inline -> Bool-isNameFragment (C.Str t) =- not (T.null t) && isValidNameChar (T.head t)-isNameFragment _ = False---- | Builds a message from a ClientPost and also returns the set of--- usernames mentioned in the text of the message.-clientPostToMessage :: ClientPost -> (Message, S.Set Text)-clientPostToMessage cp = (m, usernames)- where- usernames = findUsernames $ cp^.cpText- m = Message { _mText = cp^.cpText- , _mMarkdownSource = cp^.cpMarkdownSource- , _mUser =- case cp^.cpUserOverride of- Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]")- _ -> maybe NoUser UserI $ cp^.cpUser- , _mDate = cp^.cpDate- , _mType = CP $ cp^.cpType- , _mPending = cp^.cpPending- , _mDeleted = cp^.cpDeleted- , _mAttachments = cp^.cpAttachments- , _mInReplyToMsg =- case cp^.cpInReplyToPost of- Nothing -> NotAReply- Just pId -> InReplyTo pId- , _mMessageId = Just $ MessagePostId $ cp^.cpPostId- , _mReactions = cp^.cpReactions- , _mOriginalPost = Just $ cp^.cpOriginalPost- , _mFlagged = False- , _mChannelId = Just $ cp^.cpChannelId- }- resetAutocomplete :: MH () resetAutocomplete = do csEditState.cedAutocomplete .= Nothing csEditState.cedAutocompletePending .= Nothing -findUsernames :: C.Blocks -> S.Set Text-findUsernames = S.unions . F.toList . fmap blockFindUsernames--blockFindUsernames :: C.Block -> S.Set Text-blockFindUsernames (C.Para is) =- inlineFindUsernames $ F.toList is-blockFindUsernames (C.Header _ is) =- inlineFindUsernames $ F.toList is-blockFindUsernames (C.Blockquote bs) =- findUsernames bs-blockFindUsernames (C.List _ _ bs) =- S.unions $ F.toList $ findUsernames <$> bs-blockFindUsernames _ =- mempty--inlineFindUsernames :: [C.Inline] -> S.Set Text-inlineFindUsernames [] = mempty-inlineFindUsernames (C.Str "@" : rest) =- let (strs, remaining) = takeWhileNameFragment rest- in if null strs- then inlineFindUsernames remaining- else S.insert (T.concat $ getInlineStr <$> strs) $ inlineFindUsernames remaining-inlineFindUsernames (_ : rest) =- inlineFindUsernames rest--getInlineStr :: C.Inline -> T.Text-getInlineStr (C.Str s) = s-getInlineStr _ = ""--takeWhileNameFragment :: [C.Inline] -> ([C.Inline], [C.Inline])-takeWhileNameFragment [] = ([], [])-takeWhileNameFragment rest =- let (strs, remaining) = break (not . isNameFragment) rest- -- Does the last element in strs start with a letter? If- -- not, move it to the remaining list. This avoids pulling- -- punctuation-only tokens into usernames, e.g. "Hello,- -- @foobar."- (strs', remaining') =- if length strs <= 1- then (strs, remaining)- else let (initStrs, [lastStr]) = splitAt (length strs - 1) strs- in if isAlpha $ T.head $ getInlineStr lastStr- then (strs, remaining)- else (initStrs, lastStr : remaining)- in (strs', remaining') -- * Slash Commands
src/Types/Channels.hs view
@@ -10,8 +10,12 @@ , ChannelInfo(..) , ClientChannels -- constructor remains internal , NewMessageIndicator(..)+ , EphemeralEditState(..)+ , EditMode(..)+ , eesMultiline, eesInputHistoryPosition, eesLastInput+ , defaultEphemeralEditState -- * Lenses created for accessing ClientChannel fields- , ccContents, ccInfo+ , ccContents, ccInfo, ccEditState -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated , cdName, cdHeader, cdPurpose, cdType@@ -53,6 +57,7 @@ import qualified Data.HashMap.Strict as HM import qualified Data.Set as S+import qualified Data.Text as T import Lens.Micro.Platform ( (%~), (.~), Traversal', Lens' , makeLenses, ix, at , to, non )@@ -71,8 +76,8 @@ ) import Types.Messages ( Messages, noMessages, addMessage- , clientMessageToMessage )-import Types.Posts ( ClientMessageType(UnknownGap)+ , clientMessageToMessage, Message, MessageType )+import Types.Posts ( ClientMessageType(UnknownGapBefore) , newClientMessage, postIsLeave, postIsJoin ) import Types.Users ( TypingUsers, noTypingUsers, addTypingUser ) import Types.Common@@ -85,10 +90,36 @@ data ClientChannel = ClientChannel { _ccContents :: ChannelContents -- ^ A list of 'Message's in the channel- , _ccInfo :: ChannelInfo+ , _ccInfo :: ChannelInfo -- ^ The 'ChannelInfo' for the channel+ , _ccEditState :: EphemeralEditState+ -- ^ Editor state that we swap in and out as the current channel is+ -- changed. } +-- | The input state associated with the message editor.+data EditMode =+ NewPost+ -- ^ The input is for a new post.+ | Editing Post MessageType+ -- ^ The input is ultimately to replace the body of an existing post+ -- of the specified type.+ | Replying Message Post+ -- ^ The input is to be used as a new post in reply to the specified+ -- post.+ deriving (Show)++data EphemeralEditState =+ EphemeralEditState { _eesMultiline :: Bool+ -- ^ Whether the editor is in multiline mode+ , _eesInputHistoryPosition :: Maybe Int+ -- ^ The input history position, if any+ , _eesLastInput :: (T.Text, EditMode)+ -- ^ The input entered into the text editor last+ -- time the user was focused on the channel+ -- associated with this state.+ }+ -- Get a channel's name, depending on its type preferredChannelName :: Channel -> Text preferredChannelName ch@@ -148,13 +179,13 @@ } -- | An initial empty 'ChannelContents' value. This also contains an--- UnknownGap, which is a signal that causes actual content fetching.+-- UnknownGapBefore, which is a signal that causes actual content fetching. -- The initial Gap's timestamp is the local client time, but -- subsequent fetches will synchronize with the server (and eventually -- eliminate this Gap as well). emptyChannelContents :: MonadIO m => m ChannelContents emptyChannelContents = do- gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGap "--Fetching messages--"+ gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGapBefore "--Fetching messages--" return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages , _cdFetchPending = False }@@ -203,6 +234,7 @@ makeLenses ''ChannelContents makeLenses ''ChannelInfo makeLenses ''ClientChannel+makeLenses ''EphemeralEditState notifyPreference :: User -> ClientChannel -> NotifyOption notifyPreference u cc =@@ -217,7 +249,15 @@ return ClientChannel { _ccContents = contents , _ccInfo = initialChannelInfo myId nc+ , _ccEditState = defaultEphemeralEditState }++defaultEphemeralEditState :: EphemeralEditState+defaultEphemeralEditState =+ EphemeralEditState { _eesMultiline = False+ , _eesInputHistoryPosition = Nothing+ , _eesLastInput = ("", NewPost)+ } canLeaveChannel :: ChannelInfo -> Bool canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct]
src/Types/DirectionalSeq.hs view
@@ -1,6 +1,7 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-} {- | These declarations allow the use of a DirectionalSeq, which is a Seq that uses a phantom type to identify the ordering of the@@ -19,9 +20,12 @@ data Chronological data Retrograde-class SeqDirection a+class SeqDirection a where+ type ReverseDirection a instance SeqDirection Chronological+ where type ReverseDirection Chronological = Retrograde instance SeqDirection Retrograde+ where type ReverseDirection Retrograde = Chronological data SeqDirection dir => DirectionalSeq dir a = DSeq { dseq :: Seq a }
src/Types/KeyEvents.hs view
@@ -81,6 +81,7 @@ | ActivateListItemEvent | ViewMessageEvent+ | FillGapEvent | FlagMessageEvent | YankMessageEvent | YankWholeMessageEvent@@ -141,6 +142,7 @@ , FlagMessageEvent , ViewMessageEvent+ , FillGapEvent , YankMessageEvent , YankWholeMessageEvent , DeleteMessageEvent@@ -331,6 +333,7 @@ FlagMessageEvent -> "flag-message" ViewMessageEvent -> "view-message"+ FillGapEvent -> "fetch-for-gap" YankMessageEvent -> "yank-message" YankWholeMessageEvent -> "yank-whole-message" DeleteMessageEvent -> "delete-message"
src/Types/Messages.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveAnyClass #-} {-| @@ -41,6 +41,7 @@ ( -- * Message and operations on a single Message Message(..) , isDeletable, isReplyable, isEditable, isReplyTo, isGap, isFlaggable+ , isEmote, isJoinLeave, isTransition , mText, mUser, mDate, mType, mPending, mDeleted , mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged , mOriginalPost, mChannelId, mMarkdownSource@@ -52,6 +53,7 @@ , UserRef(..) , ReplyState(..) , clientMessageToMessage+ , clientPostToMessage , newMessageOfType -- * Message Collections , Messages@@ -67,12 +69,16 @@ , splitMessagesOn , splitRetrogradeMessagesOn , findMessage+ , getRelMessageId+ , getNextMessage+ , getPrevMessage , getNextMessageId , getPrevMessageId , getNextPostId , getPrevPostId , getEarliestPostMsg , getLatestPostMsg+ , getEarliestSelectableMessage , getLatestSelectableMessage , findLatestUserMessage -- * Operations on any Message type@@ -96,10 +102,12 @@ import Cheapskate ( Blocks ) import qualified Cheapskate as C+import Control.Monad import qualified Data.Foldable as F import Data.Hashable ( Hashable ) import qualified Data.Map.Strict as Map import Data.Sequence as Seq+import qualified Data.Set as S import Data.Tuple import Data.UUID ( UUID ) import GHC.Generics ( Generic )@@ -110,6 +118,7 @@ import Types.DirectionalSeq import Types.Posts+import Types.UserNames -- ----------------------------------------------------------------------@@ -154,7 +163,10 @@ isDeletable :: Message -> Bool isDeletable m = isJust (messagePostId m) &&- _mType m `elem` [CP NormalPost, CP Emote]+ case _mType m of+ CP NormalPost -> True+ CP Emote -> True+ _ -> False isFlaggable :: Message -> Bool isFlaggable = isJust . messagePostId@@ -162,12 +174,18 @@ isReplyable :: Message -> Bool isReplyable m = isJust (messagePostId m) &&- (_mType m `elem` [CP NormalPost, CP Emote])+ case _mType m of+ CP NormalPost -> True+ CP Emote -> True+ _ -> False isEditable :: Message -> Bool isEditable m = isJust (messagePostId m) &&- _mType m `elem` [CP NormalPost, CP Emote]+ case _mType m of+ CP NormalPost -> True+ CP Emote -> True+ _ -> False isReplyTo :: PostId -> Message -> Bool isReplyTo expectedParentId m =@@ -176,15 +194,35 @@ InReplyTo actualParentId -> actualParentId == expectedParentId isGap :: Message -> Bool-isGap m = _mType m == C UnknownGap+isGap m = case _mType m of+ C UnknownGapBefore -> True+ C UnknownGapAfter -> True+ _ -> False +isTransition :: Message -> Bool+isTransition m = case _mType m of+ C DateTransition -> True+ C NewMessagesTransition -> True+ _ -> False++isEmote :: Message -> Bool+isEmote m = case _mType m of+ CP Emote -> True+ _ -> False++isJoinLeave :: Message -> Bool+isJoinLeave m = case _mType m of+ CP Join -> True+ CP Leave -> True+ _ -> False+ -- | 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 ClientPostType- deriving (Eq, Show)+ deriving (Show) -- | There may be no user (usually an internal message), a reference -- to a user (by Id), or the server may have supplied a specific@@ -232,6 +270,36 @@ , _mChannelId = Nothing } ++-- | Builds a message from a ClientPost and also returns the set of+-- usernames mentioned in the text of the message.+clientPostToMessage :: ClientPost -> (Message, S.Set Text)+clientPostToMessage cp = (m, usernames)+ where+ usernames = findUsernames $ cp^.cpText+ m = Message { _mText = cp^.cpText+ , _mMarkdownSource = cp^.cpMarkdownSource+ , _mUser =+ case cp^.cpUserOverride of+ Just n | cp^.cpType == NormalPost -> UserOverride (n <> "[BOT]")+ _ -> maybe NoUser UserI $ cp^.cpUser+ , _mDate = cp^.cpDate+ , _mType = CP $ cp^.cpType+ , _mPending = cp^.cpPending+ , _mDeleted = cp^.cpDeleted+ , _mAttachments = cp^.cpAttachments+ , _mInReplyToMsg =+ case cp^.cpInReplyToPost of+ Nothing -> NotAReply+ Just pId -> InReplyTo pId+ , _mMessageId = Just $ MessagePostId $ cp^.cpPostId+ , _mReactions = cp^.cpReactions+ , _mOriginalPost = Just $ cp^.cpOriginalPost+ , _mFlagged = False+ , _mChannelId = Just $ cp^.cpChannelId+ }++ newMessageOfType :: Text -> MessageType -> ServerTime -> Message newMessageOfType text typ d = Message { _mText = getBlocks text@@ -347,10 +415,11 @@ -- unified into the following, but that will require TypeFamilies or -- similar to relate d and r SeqDirection types. For now, it's -- simplier to just have two API endpoints.-splitMsgSeqOn :: (SeqDirection d, SeqDirection r) =>- (Message -> Bool)- -> DirectionalSeq d Message- -> (Maybe Message, (DirectionalSeq r Message, DirectionalSeq d Message))+splitMsgSeqOn :: SeqDirection d =>+ (Message -> Bool)+ -> DirectionalSeq d Message+ -> (Maybe Message, (DirectionalSeq (ReverseDirection d) Message,+ DirectionalSeq d Message)) splitMsgSeqOn f msgs = let (removed, remaining) = dirSeqBreakl f msgs devomer = DSeq $ Seq.reverse $ dseq removed@@ -382,72 +451,67 @@ >>= Just . Seq.index (dseq msgs) -- | Look forward for the first Message with an ID that follows the--- specified PostId+-- specified Id and return it. If no input Id supplied, get the+-- latest (most recent chronologically) Message in the input set.+getNextMessage :: Maybe MessageId -> Messages -> Maybe Message+getNextMessage = getRelMessageId++-- | Look backward for the first Message with an ID that follows the+-- specified MessageId and return it. If no input MessageId supplied,+-- get the latest (most recent chronologically) Message in the input+-- set.+getPrevMessage :: Maybe MessageId -> Messages -> Maybe Message+getPrevMessage mId = getRelMessageId mId . reverseMessages++-- | Look forward for the first Message with an ID that follows the+-- specified MessageId and return that found Message's ID; if no input+-- MessageId is specified, return the latest (most recent+-- chronologically) MessageId (if any) in the input set. getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId-getNextMessageId = getRelMessageId foldl+getNextMessageId mId = _mMessageId <=< getNextMessage mId -- | Look backwards for the first Message with an ID that comes before--- the specified MessageId.+-- the specified MessageId and return that found Message's ID; if no+-- input MessageId is specified, return the latest (most recent+-- chronologically) MessageId (if any) in the input set. getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId-getPrevMessageId = getRelMessageId $ foldr . flip+getPrevMessageId mId = _mMessageId <=< getPrevMessage mId -- | Look forward for the first Message with an ID that follows the--- specified PostId+-- specified PostId and return that found Message's PostID; if no+-- input PostId is specified, return the latest (most recent+-- chronologically) PostId (if any) in the input set. getNextPostId :: Maybe PostId -> Messages -> Maybe PostId-getNextPostId = getRelPostId foldl+getNextPostId pid = messagePostId <=< getNextMessage (MessagePostId <$> pid) -- | Look backwards for the first Post with an ID that comes before -- the specified PostId. getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId-getPrevPostId = getRelPostId $ foldr . flip+getPrevPostId pid = messagePostId <=< getPrevMessage (MessagePostId <$> pid) --- | Find the next MessageId after the specified MessageId (if there is--- one) by folding in the specified direction-getRelMessageId :: ((Either MessageId (Maybe MessageId)- -> Message- -> Either MessageId (Maybe MessageId))- -> Either MessageId (Maybe MessageId)- -> Messages- -> Either MessageId (Maybe MessageId))- -> Maybe MessageId- -> Messages- -> Maybe MessageId-getRelMessageId folD jp = case jp of- Nothing -> \msgs -> (getLatestPostMsg msgs >>= _mMessageId)- Just p -> either (const Nothing) id . folD fnd (Left p)- where fnd = either fndp fndnext- fndp c v = if v^.mMessageId == Just c then Right Nothing else Left c- idOfPost m = if m^.mDeleted then Nothing else m^.mMessageId- fndnext n m = Right (n <|> idOfPost m) --- | Find the next PostId after the specified PostId (if there is--- one) by folding in the specified direction-getRelPostId :: ((Either PostId (Maybe PostId)- -> Message- -> Either PostId (Maybe PostId))- -> Either PostId (Maybe PostId)- -> Messages- -> Either PostId (Maybe PostId))- -> Maybe PostId- -> Messages- -> Maybe PostId-getRelPostId folD jp = case jp of- Nothing -> \msgs -> do- latest <- getLatestPostMsg msgs- mId <- latest^.mMessageId- case mId of- MessagePostId pId -> return pId- _ -> Nothing- Just p -> either (const Nothing) id . folD fnd (Left p)- where fnd = either fndp fndnext- fndp c v = if v^.mMessageId == Just (MessagePostId c) then Right Nothing else Left c- idOfPost m = if m^.mDeleted- then Nothing- else case m^.mMessageId of- Just (MessagePostId pId) -> Just pId- _ -> Nothing- fndnext n m = Right (n <|> idOfPost m)+getRelMessageId :: SeqDirection dir =>+ Maybe MessageId+ -> DirectionalSeq dir Message+ -> Maybe Message+getRelMessageId mId =+ let isMId = const ((==) mId . _mMessageId) <$> mId+ in getRelMessage isMId +-- | Internal worker function to return a different user message in+-- relation to either the latest point or a specific message.+getRelMessage :: SeqDirection dir =>+ Maybe (Message -> Bool)+ -> DirectionalSeq dir Message+ -> Maybe Message+getRelMessage matcher msgs =+ let after = case matcher of+ Just matchFun -> case splitMsgSeqOn matchFun msgs of+ (_, (_, ms)) -> ms+ Nothing -> msgs+ in withDirSeqHead id $ filterMessages validSelectableMessage after++ -- | Find the most recent message that is a Post (as opposed to a -- local message) (if any). getLatestPostMsg :: Messages -> Maybe Message@@ -455,6 +519,14 @@ case viewr $ dropWhileR (not . validUserMessage) (dseq msgs) of EmptyR -> Nothing _ :> m -> Just m++-- | Find the oldest message that is a message with an ID.+getEarliestSelectableMessage :: Messages -> Maybe Message+getEarliestSelectableMessage msgs =+ case viewl $ dropWhileL (not . validSelectableMessage) (dseq msgs) of+ EmptyL -> Nothing+ m :< _ -> Just m+ -- | Find the most recent message that is a message with an ID. getLatestSelectableMessage :: Messages -> Maybe Message
src/Types/Posts.hs view
@@ -70,7 +70,7 @@ { _cmText :: Text , _cmDate :: ServerTime , _cmType :: ClientMessageType- } deriving (Eq, Show)+ } deriving (Show) -- | Create a new 'ClientMessage' value. This is a message generated -- by this Matterhorn client and not by (or visible to) the Server.@@ -92,8 +92,13 @@ | Error | DateTransition | NewMessagesTransition- | UnknownGap -- ^ marks region where server may have messages unknown locally- deriving (Eq, Show)+ | UnknownGapBefore -- ^ a region where the server may have+ -- messages before the given timestamp that are+ -- not known locally by this client+ | UnknownGapAfter -- ^ a region where server may have messages+ -- after the given timestamp that are not known+ -- locally by this client+ deriving (Show) -- ** 'ClientMessage' Lenses
+ src/Types/UserNames.hs view
@@ -0,0 +1,70 @@+module Types.UserNames+ ( findUsernames+ , isNameFragment+ , takeWhileNameFragment+ )+where++import qualified Cheapskate as C+import Data.Char ( isAlpha )+import qualified Data.Foldable as F+import qualified Data.Set as S+import qualified Data.Text as T++import Prelude ()+import Prelude.MH+++findUsernames :: C.Blocks -> S.Set T.Text+findUsernames = S.unions . F.toList . fmap blockFindUsernames++blockFindUsernames :: C.Block -> S.Set T.Text+blockFindUsernames (C.Para is) =+ inlineFindUsernames $ F.toList is+blockFindUsernames (C.Header _ is) =+ inlineFindUsernames $ F.toList is+blockFindUsernames (C.Blockquote bs) =+ findUsernames bs+blockFindUsernames (C.List _ _ bs) =+ S.unions $ F.toList $ findUsernames <$> bs+blockFindUsernames _ =+ mempty++inlineFindUsernames :: [C.Inline] -> S.Set T.Text+inlineFindUsernames [] = mempty+inlineFindUsernames (C.Str "@" : rest) =+ let (strs, remaining) = takeWhileNameFragment rest+ in if null strs+ then inlineFindUsernames remaining+ else S.insert (T.concat $ getInlineStr <$> strs) $ inlineFindUsernames remaining+inlineFindUsernames (_ : rest) =+ inlineFindUsernames rest++getInlineStr :: C.Inline -> T.Text+getInlineStr (C.Str s) = s+getInlineStr _ = ""++takeWhileNameFragment :: [C.Inline] -> ([C.Inline], [C.Inline])+takeWhileNameFragment [] = ([], [])+takeWhileNameFragment rest =+ let (strs, remaining) = break (not . isNameFragment) rest+ -- Does the last element in strs start with a letter? If+ -- not, move it to the remaining list. This avoids pulling+ -- punctuation-only tokens into usernames, e.g. "Hello,+ -- @foobar."+ (strs', remaining') =+ if length strs <= 1+ then (strs, remaining)+ else let (initStrs, [lastStr]) = splitAt (length strs - 1) strs+ in if isAlpha $ T.head $ getInlineStr lastStr+ then (strs, remaining)+ else (initStrs, lastStr : remaining)+ in (strs', remaining')++isValidNameChar :: Char -> Bool+isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-'++isNameFragment :: C.Inline -> Bool+isNameFragment (C.Str t) =+ not (T.null t) && isValidNameChar (T.head t)+isNameFragment _ = False
src/Types/Users.hs view
@@ -62,7 +62,10 @@ -- | Is this user deleted? userDeleted :: User -> Bool-userDeleted u = userDeleteAt u > userCreateAt u+userDeleted u =+ case userCreateAt u of+ Nothing -> False+ Just c -> userDeleteAt u > c -- | Create a 'UserInfo' value from a Mattermost 'User' value userInfoFromUser :: User -> Bool -> UserInfo
test/test_messages.hs view
@@ -523,14 +523,14 @@ counterexample info $ null $ unreverseMessages before , testProperty "remaining after when found at first position" $ \(w', x', y', z') ->- let (_, (_, after)) = splitMessages (w^.mMessageId) msgs+ let (_, (_, afterMsgs)) = splitMessages (w^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']- info = show (idlist inpl) <> " ==> " <> (show $ idlist after)+ info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $- idlist (tail inpl) == idlist after+ idlist (tail inpl) == idlist afterMsgs , testProperty "found at last position" $ \(w', x', y', z') ->@@ -554,13 +554,13 @@ , testProperty "no after when found at last position" $ \(w', x', y', z') ->- let (_, (_, after)) = splitMessages (z^.mMessageId) msgs+ let (_, (_, afterMsgs)) = splitMessages (z^.mMessageId) msgs msgs = makeMsgs inpl inpl = [w, x, y, z] [w, x, y, z] = setDateOrderMessages [w', x', y', z']- info = show (idlist inpl) <> " ==> " <> (show $ idlist after)+ info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==>- counterexample info $ null after+ counterexample info $ null afterMsgs , testProperty "found at midpoint position" $ \(v', w', x', y', z') ->@@ -586,15 +586,15 @@ , testProperty "after when found at midpoint position" $ \(v', w', x', y', z') ->- let (_, (_, after)) = splitMessages (x^.mMessageId) msgs+ let (_, (_, afterMsgs)) = splitMessages (x^.mMessageId) msgs msgs = makeMsgs inpl inpl = [v, w, x, y, z] [v, w, x, y, z] = setDateOrderMessages [v', w', x', y', z']- info = show (idlist inpl) <> " ==> " <> (show $ idlist after)+ info = show (idlist inpl) <> " ==> " <> (show $ idlist afterMsgs) in validIds inpl && uniqueIds inpl ==> counterexample info $- idlist [y, z] == idlist after+ idlist [y, z] == idlist afterMsgs ]