matterhorn 50200.4.0 → 50200.5.0
raw patch · 37 files changed
+1410/−676 lines, 37 filesdep ~brickdep ~checkersdep ~connection
Dependency ranges changed: brick, checkers, connection, skylighting-core
Files
- CHANGELOG.md +59/−0
- LICENSE +1/−1
- PRACTICES.md +0/−278
- README.md +27/−14
- docs/AUTHORS.txt +18/−0
- docs/PRACTICES.md +280/−0
- matterhorn.cabal +13/−11
- src/App.hs +16/−4
- src/Command.hs +10/−2
- src/Config.hs +76/−45
- src/Connection.hs +0/−1
- src/Draw.hs +4/−2
- src/Draw/ChannelList.hs +20/−7
- src/Draw/Main.hs +2/−2
- src/Draw/Messages.hs +1/−1
- src/Draw/ShowHelp.hs +15/−8
- src/Draw/TabbedWindow.hs +80/−0
- src/Draw/ViewMessage.hs +0/−95
- src/Events.hs +3/−3
- src/Events/Keybindings.hs +5/−0
- src/Events/ManageAttachments.hs +4/−0
- src/Events/TabbedWindow.hs +50/−0
- src/Events/ViewMessage.hs +0/−54
- src/Markdown.hs +104/−68
- src/State/Attachments.hs +19/−1
- src/State/Channels.hs +46/−26
- src/State/MessageSelect.hs +4/−9
- src/State/Messages.hs +10/−1
- src/State/Setup.hs +2/−2
- src/State/Setup/Threads.hs +1/−1
- src/State/Setup/Threads/Logging.hs +84/−23
- src/TeamSelect.hs +5/−1
- src/Themes.hs +16/−0
- src/TimeUtils.hs +0/−6
- src/Types.hs +216/−10
- src/Types/KeyEvents.hs +14/−0
- src/Windows/ViewMessage.hs +205/−0
CHANGELOG.md view
@@ -1,4 +1,63 @@ +50200.5.0+=========++New features:+ * The configuration file now supports tilde expansion in the following+ fields, where a tilde ("~") will be expanded to the path to the+ user's home directory:+ * `urlOpenCommand`+ * `syntaxDirectories`+ * `activityNotifyCommand`+ * `themeCustomizationFile`+ * The "message view" window (accessible in message selection mode by+ default with the `v` binding) has been redesigned.+ * The window now shows the message and the message's user reactions+ in separate tabs in a tabbed interface.+ * New key events, `select-next-tab` (default: `Tab`) and+ `select-previous-tab` (default: `Shift-Tab`), were added to control+ tab-switching behavior.+ * The window got some keybinding help text.+ * Message text is now wrapped in this view, whereas before long lines+ were not wrapped and had to be scrolled horizontally to be read.+ In addition, code blocks are not wrapped, making wide code blocks+ readable by scrolling as originally intended.+ * New theme attribute names, `tabSelected` and `tabUnselected`, were+ added to style the currently-selected and other tabs, respectively.+ * Sections on the available keybindings in the various tabs for this+ interface were added to the interactive help section on keybindings+ as well as the generated keybindings file provided with Matterhorn.+ * The application's default attachment browser path can now be+ configured, thanks to Victor Shamanov (@wiruzx). See the+ `defaultAttachmentPath` setting in `sample-config.ini` for details.+ * Added the `/log-mark` command to add user-specified marker messages+ to the log to aid in debugging.+ * Logging no longer includes duplicate overlapping messages when paused+ and resumed.+ * Added the `/create-private-channel` command to support creating+ private channels. (#512)+ * The attachment list now supports the `select-up` and `select-down`+ key events.+ * All editors in Matterhorn now support bracketed pastes if your+ terminal emulator supports bracketed paste mode.++Other improvements:+ * Various files (e.g. `keybindings.md`) were moved to `docs/` in the+ repository as well as in releases.+ * The team selection interface at startup now shows team display names.+ * The main user interface now shows the current team and user at the+ top of the channel list sidebar.++Bug fixes:+ * The attachment file browser will now no longer disappear if the user+ attempts to navigate a symlinked directory. Instead, the symlinked+ directory will be navigated as expected. (#507)+ * The "Fetching messages" message that appears in channels with pending+ server responses now gets cleaned up properly. (#498)+ * Creating new `/group-msg` channels now properly shows the new group+ immediately; previously the `/group-msg` command had to be issued a+ second time or Matterhorn had to be restarted. (#477)+ 50200.4.0 =========
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2016-2018, AUTHORS.txt+Copyright (c) 2016-2018, docs/AUTHORS.txt All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
− PRACTICES.md
@@ -1,278 +0,0 @@--Matterhorn Project Practices-============================--This document captures some important project practices that we employ.-If you want to contribute to Matterhorn, for best results, please follow-these practices.--Many of the practices described below are really about serving some-overall concerns:-- * We want to provide a working program to people who want to use it,- * We want to manage inevitable software evolution, and- * We want to reduce waste through good team coordination.--Design Philosophy--------------------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-------------When working with the code, we do not have a "style guide" and do not-want to enumerate all the different ways that the code can or should-be formatted. We also recognize that the specific formatting-decisions are often affected by editor behaviors and individual typing-habits.--The ultimate goal is readability and so in general, we recommend that-you loosely follow existing formatting by default (eyes like to see-familiar patterns), but feel free to implement specific practices where-these match the editor tooling and or your personal aesthetics.--The following are some of the aesthetic choices we've made; these are-not hard rules but help to explain the current overall appearance:-- * Imports are usually in alphabetical order and separated into 4-5- sections from the most global/generic to the most local/specific.- Because there can be a number of sections, we separate the imports- from the module body with two lines to help visually locate this- point. See Events.hs as an example.- - * We have collected the most common Prelude elements into a local- file included by all modules (and therefore hiding the normal- Prelude). This helps to reduce the number of overall imports, and- we keep this as the first import section to draw attention to the- fact that the normal Prelude is not in context by default.- - * We prefer not to mix the `.` and `$` operators on the same line:-- ```haskell- let foo = func . chain . call $ parse $ input- let foo = func $ chain $ call $ parse $ input -- preferred- ```-- * Top-level functions have haddock documentation to help describe- what the function is used for (and sometimes ways in which it- shouldn't be used).-- * Modules with more than a few exports should have an explicit export- list to help us identify dead code and capture API usage- expectations.- -Branching------------ * The `master` branch should be stable enough to be release-ready at- all times. This promise helps us be agile in the event of a need- to do an unplanned release and it ensures that users who clone the- repository will get a working build by default.-- * The `develop` branch is where development occurs.-- * New feature development begins and stays on a new feature branch,- typically named `feature/FEATURENAME`, until it is declared stable- enough to be merged. Once more testing of a feature is needed,- especially in concert with other work, it should be merged to- `develop`.-- * Once `develop` has been deemed stable enough to release, it can be- merged to `master`.-- * When a feature branch implementation is complete, before merging to- `develop` we do a code review that is appropriate to the level of- complexity and risk of the work being merged, which may involve an- in-person code tour but typically involves just commit review with- questions and requests for changes. We do this to ensure that other- team members are aware of the ramifications of the work, to provide- an opportunity for feedback, and to get fresh eyes on the work to- spot problems that won't be evident to its author.-- * Bug fixes and other small, uncontroversial changes can be committed- directly to `master` and merged back into `develop`. This ensures- that bug fixes are not held up by other development work in case a- bugfix release is desired.--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----------------- * We use the GitHub issue tracker for user bug reports and feature- requests, and to capture our own intentions about planned and- potential work.-- * We use milestones to group tickets for big efforts, such as server- compatibility releases or planning cycles.-- * When creating issues, we try to make issues as actionable as possible- when the scope and details are well-understood, but this isn't always- possible. If we can't be concrete about what a ticket entails, we- assign the label `high-level` to indicate that more team discussion- or context-gathering will be required before a concrete plan can be- made. We also use the label `high-level` to indicate any ticket with- insufficient detail that needs further discussion before we can- tackle it.--Workflow----------- * When planning big efforts, we strive to get team alignment on the- scope of planned efforts. Creation of a ticket does not necessarily- mean that we have gotten team alignment or settled on scope. The- appropriate scope will be a function of time and availability,- pragmatism, feature parity with upstream, motivation, etc.-- * When doing refactoring that may be risky or touch a lot of the- program, we strive to break the job down into a sequence of- incremental changes that each produce a working program and- ultimately get us where we want to be.-- * When planning new work, we strive to get input from the team before- the work begins, rather than after it is completed, to reduce waste- and to ensure that the work is well-informed. The bigger or more- impactful the change, the more important this is - and it applies to- work done in spare time as well as at work.-- * If resources allow, consider pair programming as a means of tackling- bigger, cross-cutting problems. Although it costs more in terms of- person-hours, it can be a very effective technique for producing- better designs with fewer bugs and more mind-sharing.-- * For experimental work or new features, consider "prototyping" or- "throwaway coding," in which the first implementation of a new- feature is *intended* to be discarded upon completion. Rather than- producing code, the result of this is the learning that occurs- when exploring a design. Then, having learned, one can embark on a- better-informed implementation.--Design---------We would like issues not to linger too long unaddressed, because then-the meaning of "open ticket" is ambiguous to us and to end users: is it-planned? Is it well-understood? It's unclear.--But we can only tackle so many things, and sometimes we don't even know-enough about what's involved in a task to know its level of effort. So-in the mean time, before we can investigate, the ticket lingers.--Once we're learning what is involved, using the ticket as a place to-hash out ideas or collect context is annoying because using ticket-comments for that isn't effective.--To address these concerns:-- * Whenever we have some high-level thing we want to implement, instead- of creating a placeholder ticket, make a page on the project wiki at-- https://github.com/matterhorn-chat/matterhorn/wiki-- On this page we'll collaboratively hash out design ideas, collect- context and research, and share approaches. These documents represent- a "staging ground" for new ideas.-- * Once enough context has been gathered to support moving forward on- the feature, create concrete tickets from the context. It's also- possible we decide *not* to move forward, in which case the rationale- for aborting can be clearly captured on the wiki. This way, external- users can see why we decided not to implement something.-- * When external users create tickets for high-level features that- cannot be implemented immediately but that we agree deserve- consideration and need further investigation, close the tickets- by referring to the newly-created context wiki page where we'll- be hashing out the details. This means that we strive to ensure that- open tickets are by definition always workable and fleshed-out.-- * This way, when external users stop by to ask about features, we can- point them at those pages to make it easier to 1) share the developed- context, 2) make it clear what is missing in case they want to help,- and 3) keep a record of design decisions for posterity even after the- feature is implemented.
README.md view
@@ -55,8 +55,8 @@ get up and running without worrying about making a configuration. Once you're ready to make your settings persistent, they can be added to a configuration file. An example configuration file can be found at-`sample-config.ini`. Any settings omitted from the configuration will be-obtained interactively at startup.+`docs/sample-config.ini`. Any settings omitted from the configuration+will be obtained interactively at startup. When looking for configuration files, matterhorn will prefer `config.ini` in the current working directory, but will look in the@@ -80,7 +80,7 @@ * The `/help` command within Matterhorn. * The `F1` key within Matterhorn. * Running matterhorn with the `-k` argument to get a text table of available keybindings-* Running matterhorn with the `-K` argument to get a [Markdown table of available keybindings](keybindings.md)+* Running matterhorn with the `-K` argument to get a [Markdown table of available keybindings](docs/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@@ -293,15 +293,15 @@ - Please make changes consistent with the conventions already used in the codebase. - We follow a few development practices to support our project and it- helps when contributors are aware of these. Please see `PRACTICES.md`- for more information.+ helps when contributors are aware of these. Please see+ `docs/PRACTICES.md` for more information. # Frequently Asked Questions ## Does matterhorn support Gitlab authentication? No. But we would be happy to work with contributors who are interested-in investigating what this would take and/or implementing it. See the+in investigating what this would take and/or implementing it. See the Contributing section for details. ## How can I get Matterhorn to render emphasized Markdown text with an italic font?@@ -316,19 +316,32 @@ themeCustomizationFile: theme.ini ``` -This is known to work on `gnome-terminal` version `3.32.2`, VTE version `0.56.3`; it may work for you, too. Many terminal emulators do not support italics at all or without various hacks. Let us know what works for you!+This is known to work on `gnome-terminal` version `3.32.2`, VTE version+`0.56.3`; it may work for you, too. Many terminal emulators do not+support italics at all or without various hacks. Let us know what works+for you! ## I enabled italicized text in my theme configuration. Why doesn't it work? -Most terminfo files for typical terminal configurations do not-provide support for italicized text. If your terminal emulator-supports italics, you must enable it in your terminfo database in-order to use it in Matterhorn. For more information, see these links:+Most terminfo files for typical terminal configurations do not provide+support for italicized text. If your terminal emulator supports italics,+you must enable it in your terminfo database in order to use it in+Matterhorn. For more information, see these links:+ * 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- + ## I am seeing malformed characters when I run matterhorn in my terminal. What could be causing this? -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.+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.++## Does Matterhorn support graphical emoji?++At present Matterhorn does not reliably support graphical emoji due to+the lack of consistent support for wide Unicode characters in various+terminal emulators. Results may vary, and use of emoji characters may+cause terminal rendering issues depending on the terminal emulator in+use.
+ docs/AUTHORS.txt view
@@ -0,0 +1,18 @@+- Jonathan Daugherty+- Jason Dagit+- Getty Ritter+- Kevin Quick++We're also grateful to the many contributors who have submitted patches:++- Abhinav Sarkar <abhinav@abhinavsarkar.net>+- Adam Wick <awick@uhsure.com>+- Joram Wilander <jwawilander@gmail.com>+- Kelly McLaughlin <kelly@kelly-mclaughlin.com>+- Nicholas Skinsacos <nskins@umich.edu>+- Ryan Scott <ryan.gl.scott@gmail.com>+- Thomas M. DuBuisson <tommd@galois.com>+- Tristan Ravitch <tristan@nochair.net>+- Brent Carmer <bcarmer@galois.com>+- @markus9122+- @jakob
+ docs/PRACTICES.md view
@@ -0,0 +1,280 @@++Matterhorn Project Practices+============================++This document captures some important project practices that we employ.+If you want to contribute to Matterhorn, for best results, please follow+these practices.++Many of the practices described below are really about serving some+overall concerns:++ * We want to provide a working program to people who want to use it,+ * We want to manage inevitable software evolution, and+ * We want to reduce waste through good team coordination.++Design Philosophy+-----------------++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+----------++When working with the code, we do not have a "style guide" and do not+want to enumerate all the different ways that the code can or should+be formatted. We also recognize that the specific formatting+decisions are often affected by editor behaviors and individual typing+habits.++The ultimate goal is readability and so in general, we recommend that+you loosely follow existing formatting by default (eyes like to see+familiar patterns), but feel free to implement specific practices where+these match the editor tooling and or your personal aesthetics.++The following are some of the aesthetic choices we've made; these are+not hard rules but help to explain the current overall appearance:++ * Indentation increment is four spaces. No tabs.++ * Imports are usually in alphabetical order and separated into 4-5+ sections from the most global/generic to the most local/specific.+ Because there can be a number of sections, we separate the imports+ from the module body with two lines to help visually locate this+ point. See Events.hs as an example.+ + * We have collected the most common Prelude elements into a local+ file included by all modules (and therefore hiding the normal+ Prelude). This helps to reduce the number of overall imports, and+ we keep this as the first import section to draw attention to the+ fact that the normal Prelude is not in context by default.+ + * We prefer not to mix the `.` and `$` operators on the same line:++ ```haskell+ let foo = func . chain . call $ parse $ input+ let foo = func $ chain $ call $ parse $ input -- preferred+ ```++ * Top-level functions have haddock documentation to help describe+ what the function is used for (and sometimes ways in which it+ shouldn't be used).++ * Modules with more than a few exports should have an explicit export+ list to help us identify dead code and capture API usage+ expectations.+ +Branching+---------++ * The `master` branch should be stable enough to be release-ready at+ all times. This promise helps us be agile in the event of a need+ to do an unplanned release and it ensures that users who clone the+ repository will get a working build by default.++ * The `develop` branch is where development occurs.++ * New feature development begins and stays on a new feature branch,+ typically named `feature/FEATURENAME`, until it is declared stable+ enough to be merged. Once more testing of a feature is needed,+ especially in concert with other work, it should be merged to+ `develop`.++ * Once `develop` has been deemed stable enough to release, it can be+ merged to `master`.++ * When a feature branch implementation is complete, before merging to+ `develop` we do a code review that is appropriate to the level of+ complexity and risk of the work being merged, which may involve an+ in-person code tour but typically involves just commit review with+ questions and requests for changes. We do this to ensure that other+ team members are aware of the ramifications of the work, to provide+ an opportunity for feedback, and to get fresh eyes on the work to+ spot problems that won't be evident to its author.++ * Bug fixes and other small, uncontroversial changes can be committed+ directly to `master` and merged back into `develop`. This ensures+ that bug fixes are not held up by other development work in case a+ bugfix release is desired.++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+--------------++ * We use the GitHub issue tracker for user bug reports and feature+ requests, and to capture our own intentions about planned and+ potential work.++ * We use milestones to group tickets for big efforts, such as server+ compatibility releases or planning cycles.++ * When creating issues, we try to make issues as actionable as possible+ when the scope and details are well-understood, but this isn't always+ possible. If we can't be concrete about what a ticket entails, we+ assign the label `high-level` to indicate that more team discussion+ or context-gathering will be required before a concrete plan can be+ made. We also use the label `high-level` to indicate any ticket with+ insufficient detail that needs further discussion before we can+ tackle it.++Workflow+--------++ * When planning big efforts, we strive to get team alignment on the+ scope of planned efforts. Creation of a ticket does not necessarily+ mean that we have gotten team alignment or settled on scope. The+ appropriate scope will be a function of time and availability,+ pragmatism, feature parity with upstream, motivation, etc.++ * When doing refactoring that may be risky or touch a lot of the+ program, we strive to break the job down into a sequence of+ incremental changes that each produce a working program and+ ultimately get us where we want to be.++ * When planning new work, we strive to get input from the team before+ the work begins, rather than after it is completed, to reduce waste+ and to ensure that the work is well-informed. The bigger or more+ impactful the change, the more important this is - and it applies to+ work done in spare time as well as at work.++ * If resources allow, consider pair programming as a means of tackling+ bigger, cross-cutting problems. Although it costs more in terms of+ person-hours, it can be a very effective technique for producing+ better designs with fewer bugs and more mind-sharing.++ * For experimental work or new features, consider "prototyping" or+ "throwaway coding," in which the first implementation of a new+ feature is *intended* to be discarded upon completion. Rather than+ producing code, the result of this is the learning that occurs+ when exploring a design. Then, having learned, one can embark on a+ better-informed implementation.++Design+------++We would like issues not to linger too long unaddressed, because then+the meaning of "open ticket" is ambiguous to us and to end users: is it+planned? Is it well-understood? It's unclear.++But we can only tackle so many things, and sometimes we don't even know+enough about what's involved in a task to know its level of effort. So+in the mean time, before we can investigate, the ticket lingers.++Once we're learning what is involved, using the ticket as a place to+hash out ideas or collect context is annoying because using ticket+comments for that isn't effective.++To address these concerns:++ * Whenever we have some high-level thing we want to implement, instead+ of creating a placeholder ticket, make a page on the project wiki at++ https://github.com/matterhorn-chat/matterhorn/wiki++ On this page we'll collaboratively hash out design ideas, collect+ context and research, and share approaches. These documents represent+ a "staging ground" for new ideas.++ * Once enough context has been gathered to support moving forward on+ the feature, create concrete tickets from the context. It's also+ possible we decide *not* to move forward, in which case the rationale+ for aborting can be clearly captured on the wiki. This way, external+ users can see why we decided not to implement something.++ * When external users create tickets for high-level features that+ cannot be implemented immediately but that we agree deserve+ consideration and need further investigation, close the tickets+ by referring to the newly-created context wiki page where we'll+ be hashing out the details. This means that we strive to ensure that+ open tickets are by definition always workable and fleshed-out.++ * This way, when external users stop by to ask about features, we can+ point them at those pages to make it easier to 1) share the developed+ context, 2) make it clear what is missing in case they want to help,+ and 3) keep a record of design decisions for posterity even after the+ feature is implemented.
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.4.0+version: 50200.5.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,7 +8,7 @@ license-file: LICENSE author: matterhorn@galois.com maintainer: matterhorn@galois.com-copyright: ©2016-2019 AUTHORS.txt+copyright: ©2016-2019 docs/AUTHORS.txt category: Chat build-type: Simple cabal-version: >= 1.18@@ -20,7 +20,8 @@ extra-doc-files: CHANGELOG.md README.md- PRACTICES.md+ docs/AUTHORS.txt+ docs/PRACTICES.md scripts/cowsay scripts/figlet scripts/rot13@@ -85,7 +86,7 @@ Draw.ListOverlay Draw.URLList Draw.Util- Draw.ViewMessage+ Draw.TabbedWindow InputHistory IOUtil Events@@ -102,7 +103,8 @@ Events.ReactionEmojiListOverlay Events.LeaveChannelConfirm Events.DeleteChannelConfirm- Events.ViewMessage+ Events.TabbedWindow+ Windows.ViewMessage HelpTopics KeyMap LastRunState@@ -136,14 +138,14 @@ , containers >= 0.5.7 && < 0.7 , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.19- , connection >= 0.2 && < 0.3+ , connection >= 0.2 && < 0.4 , text >= 1.2 && < 1.3 , bytestring >= 0.10 && < 0.11 , 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.47 && < 0.48+ , brick >= 0.50 && < 0.51 , brick-skylighting >= 0.2 && < 0.4 , vty >= 5.23.1 && < 5.26 , word-wrap >= 0.4.0 && < 0.5@@ -165,7 +167,7 @@ , aspell-pipe >= 0.3 && < 0.4 , stm-delay >= 0.1 && < 0.2 , unix >= 2.7.1.0 && < 2.7.3.0- , skylighting-core >= 0.7 && < 0.8+ , skylighting-core >= 0.7 && < 0.9 , timezone-olson >= 0.1.7 && < 0.2 , timezone-series >= 0.1.6.1 && < 0.2 , aeson >= 1.2.3.0 && < 1.5@@ -193,12 +195,12 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.11- , brick >= 0.47 && < 0.48+ , brick >= 0.50 && < 0.51 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2- , checkers >= 0.4 && < 0.5+ , checkers >= 0.4 && < 0.6 , config-ini >= 0.2.2.0 && < 0.3- , connection >= 0.2 && < 0.3+ , connection >= 0.2 && < 0.4 , containers >= 0.5.7 && < 0.7 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5
src/App.hs view
@@ -21,7 +21,7 @@ import IOUtil import InputHistory import LastRunState-import Options+import Options hiding ( ShowHelp ) import State.Setup import State.Setup.Threads.Logging ( shutdownLogManager ) import Types@@ -31,9 +31,21 @@ app = App { appDraw = draw , appChooseCursor = \s cs -> case appMode s of- ManageAttachments -> Nothing- ManageAttachmentsBrowseFiles -> Nothing- _ -> showFirstCursor s cs+ Main -> showFirstCursor s cs+ ChannelSelect -> showFirstCursor s cs+ UserListOverlay -> showFirstCursor s cs+ ReactionEmojiListOverlay -> showFirstCursor s cs+ ChannelListOverlay -> showFirstCursor s cs+ ManageAttachmentsBrowseFiles -> showFirstCursor s cs+ LeaveChannelConfirm -> Nothing+ DeleteChannelConfirm -> Nothing+ MessageSelect -> Nothing+ MessageSelectDeleteConfirm -> Nothing+ PostListOverlay _ -> Nothing+ ManageAttachments -> Nothing+ ViewMessage -> Nothing+ ShowHelp _ -> Nothing+ UrlSelect -> Nothing , appHandleEvent = onEvent , appStartEvent = return , appAttrMap = (^.csResources.crTheme)
src/Command.hs view
@@ -92,10 +92,14 @@ , Cmd "left" "Focus on the previous channel" NoArg $ \ () -> prevChannel - , Cmd "create-channel" "Create a new channel"+ , Cmd "create-channel" "Create a new public channel" (LineArg "channel name") $ \ name ->- createOrdinaryChannel name+ createOrdinaryChannel True name + , Cmd "create-private-channel" "Create a new private channel"+ (LineArg "channel name") $ \ name ->+ createOrdinaryChannel False name+ , Cmd "delete-channel" "Delete the current channel" NoArg $ \ () -> beginCurrentChannelDeleteConfirm@@ -163,6 +167,10 @@ , Cmd "log-stop" "Stop logging" NoArg $ \ () -> stopLogging++ , Cmd "log-mark" "Add marker message to the current log"+ (LineArg "log marking message") $ \ markMsg ->+ mhLog LogUserMark markMsg , Cmd "log-status" "Show current logging status" NoArg $ \ () ->
src/Config.hs view
@@ -14,11 +14,13 @@ import Prelude.MH import Control.Monad.Trans.Except+import Control.Monad.Trans.Class ( lift )+import Control.Monad.IO.Class ( liftIO ) import Data.Ini.Config import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.IO as T-import System.Directory ( makeAbsolute )+import System.Directory ( makeAbsolute, getHomeDirectory ) import System.Environment ( getExecutablePath ) import System.FilePath ( (</>), takeDirectory, splitPath, joinPath ) import System.Process ( readProcess )@@ -109,29 +111,37 @@ fieldFlagDef "unsafeUseUnauthenticatedConnection" False configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number (configDirectChannelExpirationDays defaultConfig)+ configDefaultAttachmentPath <- fieldMbOf "defaultAttachmentPath" filePathField let configAbsPath = Nothing configUserKeys = mempty return Config { .. } keys <- sectionMb "keybindings" $ do- fmap (M.fromList . catMaybes) $ forM allEvents $ \ ev -> do- kb <- fieldMbOf (keyEventName ev) parseBindingList- case kb of- Nothing -> return Nothing- Just binding -> return (Just (ev, binding))+ fmap (M.fromList . catMaybes) $ forM allEvents $ \ ev -> do+ kb <- fieldMbOf (keyEventName ev) parseBindingList+ case kb of+ Nothing -> return Nothing+ Just binding -> return (Just (ev, binding)) return conf { configUserKeys = fromMaybe mempty keys } syntaxDirsField :: Text -> Either String [FilePath] syntaxDirsField = listWithSeparator ":" string +expandTilde :: FilePath -> FilePath -> FilePath+expandTilde homeDir p =+ let parts = splitPath p+ f part | part == "~/" = homeDir <> "/"+ | otherwise = part+ in joinPath $ f <$> parts+ backgroundField :: Text -> Either String BackgroundInfo backgroundField t =- case t of- "Disabled" -> Right Disabled- "Active" -> Right Active- "ActiveCount" -> Right ActiveCount- _ -> Left ("Invalid value " <> show t- <> "; must be one of: Disabled, Active, ActiveCount")+ case t of+ "Disabled" -> Right Disabled+ "Active" -> Right Active+ "ActiveCount" -> Right ActiveCount+ _ -> Left ("Invalid value " <> show t+ <> "; must be one of: Disabled, Active, ActiveCount") cpuUsagePolicy :: Text -> Either String CPUUsagePolicy cpuUsagePolicy t =@@ -146,6 +156,9 @@ True -> Right $ parseQuotedString t False -> Right t +filePathField :: Text -> Either String FilePath+filePathField t = let path = T.unpack t in Right path+ parseQuotedString :: Text -> Text parseQuotedString t = let body = T.drop 1 $ T.init t@@ -192,56 +205,74 @@ , configSyntaxDirs = [] , configDirectChannelExpirationDays = 7 , configCpuUsagePolicy = MultipleCPUs+ , configDefaultAttachmentPath = Nothing } findConfig :: Maybe FilePath -> IO (Either String Config)-findConfig Nothing = do- cfg <- locateConfig configFileName- fixupSyntaxDirs =<< case cfg of- Nothing -> return $ Right defaultConfig+findConfig Nothing = runExceptT $ do+ cfg <- lift $ locateConfig configFileName+ fixupPaths =<< case cfg of+ Nothing -> return defaultConfig Just path -> getConfig path-findConfig (Just path) = fixupSyntaxDirs =<< getConfig path+findConfig (Just path) =+ runExceptT $ fixupPaths =<< getConfig path +-- | Fix path references in the configuration:+--+-- * Rewrite the syntax directory path list with 'fixupSyntaxDirs'+-- * Expand "~" encountered in any setting that contains a path value+fixupPaths :: Config -> ExceptT String IO Config+fixupPaths initial = do+ new <- fixupSyntaxDirs initial+ homeDir <- liftIO getHomeDirectory+ let fixP = expandTilde homeDir+ fixPText = T.pack . expandTilde homeDir . T.unpack+ return $ new { configThemeCustomizationFile = fixPText <$> configThemeCustomizationFile new+ , configSyntaxDirs = fixP <$> configSyntaxDirs new+ , configURLOpenCommand = fixPText <$> configURLOpenCommand new+ , configActivityNotifyCommand = fixPText <$> configActivityNotifyCommand new+ , configDefaultAttachmentPath = fixP <$> configDefaultAttachmentPath new+ }+ -- | If the configuration has no syntax directories specified (the -- default if the user did not provide the setting), fill in the -- list with the defaults. Otherwise replace any bundled directory -- placeholders in the config's syntax path list.-fixupSyntaxDirs :: Either String Config -> IO (Either String Config)-fixupSyntaxDirs (Left e) = return $ Left e-fixupSyntaxDirs (Right c) =+fixupSyntaxDirs :: Config -> ExceptT String IO Config+fixupSyntaxDirs c = if configSyntaxDirs c == [] then do- dirs <- defaultSkylightingPaths- return $ Right c { configSyntaxDirs = dirs }+ dirs <- liftIO defaultSkylightingPaths+ return $ c { configSyntaxDirs = dirs } else do newDirs <- forM (configSyntaxDirs c) $ \dir ->- if | dir == bundledSyntaxPlaceholderName -> getBundledSyntaxPath- | dir == userSyntaxPlaceholderName -> xdgSyntaxDir+ if | dir == bundledSyntaxPlaceholderName -> liftIO getBundledSyntaxPath+ | dir == userSyntaxPlaceholderName -> liftIO xdgSyntaxDir | otherwise -> return dir - return $ Right $ c { configSyntaxDirs = newDirs }+ return $ c { configSyntaxDirs = newDirs } -getConfig :: FilePath -> IO (Either String Config)-getConfig fp = runExceptT $ do- absPath <- convertIOException $ makeAbsolute fp- t <- (convertIOException $ T.readFile absPath) `catchE`- (\e -> throwE $ "Could not read " <> show absPath <> ": " <> e)- case parseIniFile t fromIni of- Left err -> do- throwE $ "Unable to parse " ++ absPath ++ ":" ++ err- Right conf -> do- actualPass <- case configPass conf of- Just (PasswordCommand cmdString) -> do- let (cmd:rest) = T.unpack <$> T.words cmdString- output <- convertIOException (readProcess cmd rest "") `catchE`- (\e -> throwE $ "Could not execute password command: " <> e)- return $ Just $ T.pack (takeWhile (/= '\n') output)- Just (PasswordString pass) -> return $ Just pass- Nothing -> return Nothing+getConfig :: FilePath -> ExceptT String IO Config+getConfig fp = do+ absPath <- convertIOException $ makeAbsolute fp+ t <- (convertIOException $ T.readFile absPath) `catchE`+ (\e -> throwE $ "Could not read " <> show absPath <> ": " <> e)+ case parseIniFile t fromIni of+ Left err -> do+ throwE $ "Unable to parse " ++ absPath ++ ":" ++ err+ Right conf -> do+ actualPass <- case configPass conf of+ Just (PasswordCommand cmdString) -> do+ let (cmd:rest) = T.unpack <$> T.words cmdString+ output <- convertIOException (readProcess cmd rest "") `catchE`+ (\e -> throwE $ "Could not execute password command: " <> e)+ return $ Just $ T.pack (takeWhile (/= '\n') output)+ Just (PasswordString pass) -> return $ Just pass+ Nothing -> return Nothing - return conf { configPass = PasswordString <$> actualPass- , configAbsPath = Just absPath- }+ return conf { configPass = PasswordString <$> actualPass+ , configAbsPath = Just absPath+ } -- | Returns the hostname, username, and password from the config. Only -- returns Just if all three have been provided. The idea is that if
src/Connection.hs view
@@ -3,7 +3,6 @@ import Prelude () import Prelude.MH -import Brick.BChan import Control.Concurrent ( forkIO, threadDelay, killThread ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException, catch, AsyncException(..), throwIO )
src/Draw.hs view
@@ -7,6 +7,8 @@ import Brick +import Lens.Micro.Platform ( _2, singular, _Just )+ import Draw.DeleteChannelConfirm import Draw.LeaveChannelConfirm import Draw.Main@@ -15,7 +17,7 @@ import Draw.UserListOverlay import Draw.ChannelListOverlay import Draw.ReactionEmojiListOverlay-import Draw.ViewMessage+import Draw.TabbedWindow import Draw.ManageAttachments import Types @@ -35,6 +37,6 @@ UserListOverlay -> drawUserListOverlay st ChannelListOverlay -> drawChannelListOverlay st ReactionEmojiListOverlay -> drawReactionEmojiListOverlay st- ViewMessage -> drawViewMessage st+ ViewMessage -> drawTabbedWindow (st^.csViewedMessage.singular _Just._2) st : drawMain False st ManageAttachments -> drawManageAttachments st ManageAttachmentsBrowseFiles -> drawManageAttachments st
src/Draw/ChannelList.hs view
@@ -33,6 +33,7 @@ import State.Channels import Themes import Types+import Types.Common ( sanitizeUserText ) import qualified Zipper as Z -- | Internal record describing each channel entry and its associated@@ -52,19 +53,31 @@ renderChannelList st = viewport ChannelList Vertical body where+ teamHeader = hCenter $+ withDefAttr clientEmphAttr $+ txt $ "Team: " <> teamNameStr+ myUsername = MM.userUsername $ myUser st+ selfHeader = hCenter $+ colorUsername myUsername (userSigil <> myUsername)+ teamNameStr = sanitizeUserText $ MM.teamDisplayName $ st^.csMyTeam body = case appMode st of ChannelSelect -> let zipper = st^.csChannelSelectState.channelSelectMatches- in if Z.isEmpty zipper- then hCenter $ txt "No matches"- else vBox $- renderChannelListGroup st (renderChannelSelectListEntry (Z.focus zipper)) <$>- Z.toList zipper+ matches = if Z.isEmpty zipper+ then [hCenter $ txt "No matches"]+ else (renderChannelListGroup st (renderChannelSelectListEntry (Z.focus zipper)) <$>+ Z.toList zipper)+ in vBox $+ teamHeader :+ selfHeader :+ matches _ -> cached ChannelSidebar $ vBox $- renderChannelListGroup st (\s e -> renderChannelListEntry $ mkChannelEntryData s e) <$>- Z.toList (st^.csFocus)+ teamHeader :+ selfHeader :+ (renderChannelListGroup st (\s e -> renderChannelListEntry $ mkChannelEntryData s e) <$>+ Z.toList (st^.csFocus)) renderChannelListGroupHeading :: ChannelListGroup -> Bool -> Widget Name renderChannelListGroupHeading g anyUnread =
src/Draw/Main.hs view
@@ -244,7 +244,6 @@ , addEllipsis $ renderMessage MessageData { mdMessage = msgWithoutParent , mdUserName = msgWithoutParent^.mUser.to (nameForUserRef st)- , mdIsBot = isBotMessage msg , mdParentMessage = Nothing , mdParentUserName = Nothing , mdHighlightSet = hs@@ -254,6 +253,7 @@ , mdIndentBlocks = False , mdThreadState = NoThread , mdShowReactions = True+ , mdMessageWidthLimit = Nothing } ] _ -> emptyWidget@@ -544,7 +544,6 @@ { mdMessage = m , mdUserName = m^.mUser.to (nameForUserRef st) , mdParentMessage = p- , mdIsBot = isBotMessage m , mdParentUserName = p >>= (^.mUser.to (nameForUserRef st)) , mdHighlightSet = hs , mdEditThreshold = Nothing@@ -553,6 +552,7 @@ , mdIndentBlocks = True , mdThreadState = NoThread , mdShowReactions = True+ , mdMessageWidthLimit = Nothing } in (maybePreviewViewport msgPreview) <=> hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")
src/Draw/Messages.hs view
@@ -64,7 +64,6 @@ m = renderMessage MessageData { mdMessage = msg , mdUserName = msg^.mUser.to (nameForUserRef st)- , mdIsBot = isBotMessage msg , mdParentMessage = parent , mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st)) , mdEditThreshold = ind@@ -74,6 +73,7 @@ , mdIndentBlocks = True , mdThreadState = threadState , mdShowReactions = True+ , mdMessageWidthLimit = Nothing } fullMsg = case msg^.mUser of
src/Draw/ShowHelp.hs view
@@ -16,6 +16,7 @@ import qualified Data.Map as M import qualified Data.Text as T import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( singular, _Just, _2 ) import Network.Mattermost.Version ( mmApiVersion ) @@ -31,7 +32,8 @@ import Events.ChannelListOverlay import Events.ReactionEmojiListOverlay import Events.ManageAttachments-import Events.ViewMessage+import Events.TabbedWindow+import Windows.ViewMessage import HelpTopics ( helpTopics ) import Markdown ( renderText ) import Options ( mhVersion )@@ -63,6 +65,7 @@ , drawHelpTopics , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands" , mkCommandHelpText $ sortWith commandName commandList+ , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybindings" ] <> (mkKeybindingHelp <$> keybindSections kc) @@ -132,8 +135,9 @@ ] keybindingMarkdownTable :: KeyConfig -> Text-keybindingMarkdownTable kc = keybindSectionStrings- where keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc+keybindingMarkdownTable kc = title <> keybindSectionStrings+ where title = "# Keybindings\n"+ keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc sectionText = mkKeybindEventSectionHelp keybindEventHelpMarkdown T.unlines mkHeading mkHeading n = "\n# " <> n <>@@ -141,8 +145,9 @@ "\n| ---------- | ---------- | ----------- |" keybindingTextTable :: KeyConfig -> Text-keybindingTextTable kc = keybindSectionStrings- where keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc+keybindingTextTable kc = title <> keybindSectionStrings+ where title = "Keybindings\n===========\n"+ keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc sectionText = mkKeybindEventSectionHelp (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines mkHeading keybindingWidth = 15 eventNameWidth = 30@@ -380,7 +385,9 @@ , ("User Listings", userListOverlayKeybindings kc) , ("Channel Search Window", channelListOverlayKeybindings kc) , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeybindings kc)- , ("Message Viewer", viewMessageKeybindings kc)+ , ("Message Viewer: Common", tabbedWindowKeybindings (csViewedMessage.singular _Just._2) kc)+ , ("Message Viewer: Message tab", viewMessageKeybindings kc)+ , ("Message Viewer: Reactions tab", viewMessageReactionsKeybindings kc) , ("Attachment List", attachmentListKeybindings kc) ] @@ -399,7 +406,7 @@ mkKeybindingHelp :: (Text, [Keybinding]) -> Widget Name mkKeybindingHelp (sectionName, kbs) =- (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt $ "Keybindings: " <> sectionName) <=>+ (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt sectionName) <=> (hCenter $ vBox $ mkKeybindHelp <$> (sortWith (ppBinding.eventToBinding.kbEvent) kbs)) mkKeybindHelp :: Keybinding -> Widget Name@@ -417,7 +424,7 @@ in if all (all (isNothing . kbBindingInfo)) lst then Nothing else Just $- vertCat $ (mkHeading $ "Keybindings: " <> sectionName) :+ vertCat $ (mkHeading sectionName) : (mkKeybindHelpFunc <$> (catMaybes $ mkKeybindEventHelp <$> lst)) keybindEventHelpWidget :: (Text, Text, [Text]) -> Widget Name
+ src/Draw/TabbedWindow.hs view
@@ -0,0 +1,80 @@+module Draw.TabbedWindow+ ( drawTabbedWindow+ )+where++import Prelude ()+import Prelude.MH++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Data.List ( intersperse )+import qualified Graphics.Vty as Vty++import Types+import Themes+import Types.KeyEvents+import Events.Keybindings ( getFirstDefaultBinding )++-- | Render a tabbed window.+drawTabbedWindow :: (Eq a, Show a)+ => TabbedWindow a+ -> ChatState+ -> Widget Name+drawTabbedWindow w cs =+ let cur = getCurrentTabbedWindowEntry w+ tabBody = tweRender cur (twValue w) cs+ title = forceAttr clientEmphAttr $ twtTitle (twTemplate w) (tweValue cur)+ in centerLayer $+ vLimit (twWindowHeight w) $+ hLimit (twWindowWidth w) $+ joinBorders $+ borderWithLabel title $+ (tabBar w <=> tabBody <=> hBorder <=> hCenter keybindingHelp)++-- | Keybinding help to show at the bottom of a tabbed window.+keybindingHelp :: Widget Name+keybindingHelp =+ let ppPair (label, evs) = hBox $ (intersperse (txt "/") $ ppEv <$> evs) <> [txt (":" <> label)]+ ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (getFirstDefaultBinding ev))+ pairs = [ ("Switch tabs", [SelectNextTabEvent, SelectPreviousTabEvent])+ , ("Scroll", [ScrollUpEvent, ScrollDownEvent, ScrollLeftEvent, ScrollRightEvent])+ , ("Close", [CancelEvent])+ ]+ in hBox $ intersperse (txt " ") $ ppPair <$> pairs++-- | The scrollable tab bar to show at the top of a tabbed window.+tabBar :: (Eq a, Show a)+ => TabbedWindow a+ -> Widget Name+tabBar w =+ let cur = getCurrentTabbedWindowEntry w+ entries = twtEntries (twTemplate w)+ renderEntry e =+ let useAttr = if isCurrent+ then withDefAttr tabSelectedAttr+ else withDefAttr tabUnselectedAttr+ isCurrent = tweValue e == tweValue cur+ makeVisible = if isCurrent then visible else id+ decorateTab v = Widget Fixed Fixed $ do+ result <- render v+ let width = Vty.imageWidth (result^.imageL)+ if isCurrent+ then+ render $ padBottom (Pad 1) $ raw $ result^.imageL+ else+ render $ vBox [raw $ result^.imageL, hLimit width hBorder]+ in makeVisible $+ decorateTab $+ useAttr $+ padLeftRight 2 $+ txt $+ tweTitle e (tweValue e) isCurrent+ contents = Widget Fixed Fixed $ do+ ctx <- getContext+ let width = ctx^.availWidthL+ render $ hBox $ (intersperse divider $ renderEntry <$> entries) <>+ [divider, padTop (Pad 1) $ hLimit width hBorder]+ divider = vLimit 1 vBorder <=> joinableBorder (Edges True False False False)+ in vLimit 2 $ viewport TabbedWindowTabBar Horizontal contents
− src/Draw/ViewMessage.hs
@@ -1,95 +0,0 @@-module Draw.ViewMessage- ( drawViewMessage- )-where--import Prelude ()-import Prelude.MH--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center-import Lens.Micro.Platform ( to )-import qualified Data.Set as S-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Data.Foldable as F--import Draw.Main-import Draw.Messages ( nameForUserRef )-import Markdown-import Themes-import Types---drawViewMessage :: ChatState -> [Widget Name]-drawViewMessage st = (viewMessageBox st) : (drawMain False st)--maxWidth :: Int-maxWidth = 78--maxHeight :: Int-maxHeight = 25--viewMessageBox :: ChatState -> Widget Name-viewMessageBox st =- let body = case st^.csViewedMessage of- Nothing -> str "BUG: no message to show, please report!"- Just msg ->- let hs = getHighlightSet st- parent = case msg^.mInReplyToMsg of- NotAReply -> Nothing- InReplyTo pId -> getMessageForPostId st pId- reactionsBody = reactionsText st msg- msgW = renderMessage $ MessageData { mdEditThreshold = Nothing- , mdShowOlderEdits = False- , mdMessage = msg- , mdIsBot = isBotMessage msg- , mdUserName = msg^.mUser.to (nameForUserRef st)- , mdParentMessage = parent- , mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st))- , mdRenderReplyParent = True- , mdHighlightSet = hs- , mdIndentBlocks = True- , mdThreadState = NoThread- , mdShowReactions = False- }- in cached ViewMessageArea $ msgW <=> reactionsBody-- in centerLayer $- Widget Fixed Fixed $ do- ctx <- getContext- let width = min (maxWidth + 2) (ctx^.availWidthL)- height = min maxHeight (ctx^.availHeightL)- render $ vLimit height $- hLimit width $- borderWithLabel (withDefAttr clientEmphAttr $ str "View Message") $- viewport ViewMessageArea Both $- body--reactionsText :: ChatState -> Message -> Widget Name-reactionsText st m =- hLimit maxWidth body- where- body = case null reacList of- True -> emptyWidget- False -> padTop (Pad 1) $- vBox $- (hBorderWithLabel (withDefAttr clientEmphAttr $ txt "Reactions")) : (mkEntry <$> reacList)- reacList = M.toList (m^.mReactions)- mkEntry (reactionName, userIdSet) =- let count = str $ "(" <> show (S.size userIdSet) <> ")"- name = withDefAttr emojiAttr $ txt $ ":" <> reactionName <> ":"- usernameList = usernameText userIdSet- in (name <+> (padLeft (Pad 1) count)) <=>- (padLeft (Pad 2) usernameList)-- hs = getHighlightSet st-- usernameText uids =- renderText' hs $- T.intercalate ", " $- fmap (userSigil <>) $- catMaybes (lookupUsername <$> F.toList uids)-- lookupUsername uid = usernameForUserId uid st
src/Events.hs view
@@ -11,7 +11,7 @@ import qualified Data.Set as Set import qualified Data.Text as T import qualified Graphics.Vty as Vty-import Lens.Micro.Platform ( (.=), preuse )+import Lens.Micro.Platform ( (.=), preuse, _2, singular, _Just ) import qualified Network.Mattermost.Endpoints as MM import Network.Mattermost.Exceptions ( mattermostErrorMessage )@@ -41,7 +41,7 @@ import Events.UserListOverlay import Events.ChannelListOverlay import Events.ReactionEmojiListOverlay-import Events.ViewMessage+import Events.TabbedWindow import Events.ManageAttachments @@ -169,7 +169,7 @@ UserListOverlay -> onEventUserListOverlay e ChannelListOverlay -> onEventChannelListOverlay e ReactionEmojiListOverlay -> onEventReactionEmojiListOverlay e- ViewMessage -> onEventViewMessage e+ ViewMessage -> handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e ManageAttachments -> onEventManageAttachments e ManageAttachmentsBrowseFiles -> onEventManageAttachments e
src/Events/Keybindings.hs view
@@ -117,12 +117,17 @@ , ctrl (key 'c') ] + SelectNextTabEvent -> [ key '\t' ]+ SelectPreviousTabEvent -> [ kb Vty.KBackTab ]+ -- channel-scroll-specific LoadMoreEvent -> [ ctrl (key 'b') ] -- scrolling events ScrollUpEvent -> [ kb Vty.KUp ] ScrollDownEvent -> [ kb Vty.KDown ]+ ScrollLeftEvent -> [ kb Vty.KLeft ]+ ScrollRightEvent -> [ kb Vty.KRight ] PageUpEvent -> [ kb Vty.KPageUp ] PageDownEvent -> [ kb Vty.KPageDown ] ScrollTopEvent -> [ kb Vty.KHome ]
src/Events/ManageAttachments.hs view
@@ -43,6 +43,10 @@ attachmentListKeybindings = mkKeybindings [ mkKb CancelEvent "Close attachment list" (setMode Main)+ , mkKb SelectUpEvent "Move cursor up" $+ mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KUp [])+ , mkKb SelectDownEvent "Move cursor down" $+ mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KDown []) , mkKb AttachmentListAddEvent "Add a new attachment to the attachment list" showAttachmentFileBrowser , mkKb AttachmentOpenEvent "Open the selected attachment using the URL open command"
+ src/Events/TabbedWindow.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE RankNTypes #-}+module Events.TabbedWindow+ ( handleTabbedWindowEvent+ , tabbedWindowKeybindings+ )+where++import Prelude ()+import Prelude.MH++import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( Lens', (.=) )++import Types+import Types.KeyEvents+import Events.Keybindings++handleTabbedWindowEvent :: (Show a, Eq a)+ => Lens' ChatState (TabbedWindow a)+ -> Vty.Event+ -> MH ()+handleTabbedWindowEvent target e = do+ w <- use target+ handleKeyboardEvent (tabbedWindowKeybindings target) (forwardEvent w) e++forwardEvent :: (Show a, Eq a)+ => TabbedWindow a+ -> Vty.Event+ -> MH ()+forwardEvent w e = do+ let cur = getCurrentTabbedWindowEntry w+ tweHandleEvent cur (twValue w) e++tabbedWindowKeybindings :: (Show a, Eq a)+ => Lens' ChatState (TabbedWindow a)+ -> KeyConfig+ -> [Keybinding]+tabbedWindowKeybindings target = mkKeybindings+ [ mkKb CancelEvent "Close window" $ do+ w <- use target+ setMode (twReturnMode w)++ , mkKb SelectNextTabEvent "Select next tab" $ do+ w' <- tabbedWindowNextTab =<< use target+ target .= w'++ , mkKb SelectPreviousTabEvent "Select previous tab" $ do+ w' <- tabbedWindowPreviousTab =<< use target+ target .= w'+ ]
− src/Events/ViewMessage.hs
@@ -1,54 +0,0 @@-module Events.ViewMessage- ( onEventViewMessage- , viewMessageKeybindings- )-where--import Prelude ()-import Prelude.MH--import Brick.Main-import qualified Graphics.Vty as Vty--import Constants-import Events.Keybindings-import Types---onEventViewMessage :: Vty.Event -> MH ()-onEventViewMessage =- handleKeyboardEvent viewMessageKeybindings handleMessageViewEvent--vs :: ViewportScroll Name-vs = viewportScroll ViewMessageArea--handleMessageViewEvent :: Vty.Event -> MH ()-handleMessageViewEvent (Vty.EvKey Vty.KLeft []) =- mh $ hScrollBy vs (-1)-handleMessageViewEvent (Vty.EvKey Vty.KRight []) =- mh $ hScrollBy vs 1-handleMessageViewEvent _ = return ()--viewMessageKeybindings :: KeyConfig -> [Keybinding]-viewMessageKeybindings = mkKeybindings- [ mkKb CancelEvent "Close window" $- setMode Main-- , mkKb PageUpEvent "Page up" $- mh $ vScrollBy vs (-1 * pageAmount)-- , mkKb PageDownEvent "Page down" $- mh $ vScrollBy vs pageAmount-- , mkKb ScrollUpEvent "Scroll up" $- mh $ vScrollBy vs (-1)-- , mkKb ScrollDownEvent "Scroll down" $- mh $ vScrollBy vs 1-- , mkKb ScrollBottomEvent "Scroll to the end of the message" $- mh $ vScrollToEnd vs-- , mkKb ScrollTopEvent "Scroll to the beginning of the message" $- mh $ vScrollToBeginning vs- ]
src/Markdown.hs view
@@ -18,7 +18,9 @@ import Prelude () import Prelude.MH -import Brick ( (<+>), Widget, textWidth )+import Brick ( (<+>), Widget, textWidth, hLimit, imageL+ , raw, render, Size(..), Widget(..)+ ) import qualified Brick as B import qualified Brick.Widgets.Border as B import qualified Brick.Widgets.Skylighting as BS@@ -48,7 +50,7 @@ import Network.Mattermost.Types ( ServerTime(..) ) import Themes-import Types ( HighlightSet(..), userSigil, normalChannelSigil )+import Types ( Name, HighlightSet(..), userSigil, normalChannelSigil ) import Types.Messages import Types.Posts import Types.UserNames ( isNameFragment, takeWhileNameFragment )@@ -100,39 +102,55 @@ -- | A bundled structure that includes all the information necessary -- to render a given message-data MessageData = MessageData- { mdEditThreshold :: Maybe ServerTime- , mdShowOlderEdits :: Bool- , mdShowReactions :: Bool- , mdMessage :: Message- , mdUserName :: Maybe Text- , mdIsBot :: Bool- , mdParentMessage :: Maybe Message- , mdParentUserName :: Maybe Text- , mdThreadState :: ThreadState- , mdRenderReplyParent :: Bool- , mdHighlightSet :: HighlightSet- , mdIndentBlocks :: Bool- }+data MessageData =+ MessageData { mdEditThreshold :: Maybe ServerTime+ -- ^ If specified, any messages edited before this point+ -- in time are not indicated as edited.+ , mdShowOlderEdits :: Bool+ -- ^ Indicates whether "edited" markers should be shown+ -- for old messages (i.e., ignore the mdEditThreshold+ -- value).+ , mdShowReactions :: Bool+ -- ^ Whether to render reactions.+ , mdMessage :: Message+ -- ^ The message to render.+ , mdUserName :: Maybe Text+ -- ^ The username of the message's author, if any. This+ -- is passed here rather than obtaining from the message+ -- because we need to do lookups in the ChatState to+ -- compute this, and we don't pass the ChatState into+ -- renderMessage.+ , mdParentMessage :: Maybe Message+ -- ^ The parent message of this message, if any.+ , mdParentUserName :: Maybe Text+ -- ^ The author of the parent message, if any.+ , mdThreadState :: ThreadState+ -- ^ The thread state of this message.+ , mdRenderReplyParent :: Bool+ -- ^ Whether to render the parent message.+ , mdHighlightSet :: HighlightSet+ -- ^ The highlight set to use to highlight usernames,+ -- channel names, etc.+ , mdIndentBlocks :: Bool+ -- ^ Whether to indent the message underneath the+ -- author's name (True) or just display it to the right+ -- of the author's name (False).+ , mdMessageWidthLimit :: Maybe Int+ -- ^ A width override to use to wrap non-code blocks. If+ -- unspecified, all blocks in the message will be+ -- wrapped and truncated at the width specified by the+ -- rendering context. If specified, all non-code blocks+ -- will be wrapped at this width and code blocks will be+ -- rendered using the context's width.+ } -- | renderMessage performs markdown rendering of the specified message.------ The 'mdEditThreshold' argument specifies a time boundary where--- "edited" markers are not shown for any messages older than this--- mark (under the presumption that they are distracting for really--- old stuff). The mdEditThreshold will be None if there is no--- boundary known yet; the boundary is typically set to the "new"--- message boundary.------ The 'mdShowOlderEdits' argument is a value read from the user's--- configuration file that indicates that "edited" markers should be--- shown for old messages (i.e., ignore the mdEditThreshold value).-renderMessage :: MessageData -> Widget a+renderMessage :: MessageData -> Widget Name renderMessage md@MessageData { mdMessage = msg, .. } = let msgUsr = case mdUserName of Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u Nothing -> Nothing- botElem = if mdIsBot then B.txt "[BOT]" else B.emptyWidget+ botElem = if isBotMessage msg then B.txt "[BOT]" else B.emptyWidget nameElems = case msgUsr of Just un | isEmote msg ->@@ -167,9 +185,8 @@ else bs augmentedText = maybeAugment $ msg^.mText- rmd = renderMarkdown mdHighlightSet augmentedText msgWidget =- vBox $ (layout nameElems rmd . viewl) augmentedText :+ vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText : catMaybes [msgAtch, msgReac] replyIndent = B.Widget B.Fixed B.Fixed $ do ctx <- B.getContext@@ -217,26 +234,33 @@ in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg) where- layout n m xs- | length xs > 1 = multiLnLayout n m- layout n m (C.Blockquote {} :< _) = multiLnLayout n m- layout n m (C.CodeBlock {} :< _) = multiLnLayout n m- layout n m (C.HtmlBlock {} :< _) = multiLnLayout n m- layout n m (C.List {} :< _) = multiLnLayout n m- layout n m (C.Para inlns :< _)- | F.any breakCheck inlns = multiLnLayout n m- layout n m _ = hBox $ join [n, return m]- multiLnLayout n m =+ layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Blocks -> ViewL Block -> Widget Name+ layout hs w nameElems bs xs | length xs > 1 = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (C.Blockquote {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (C.CodeBlock {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (C.HtmlBlock {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (C.List {} :< _) = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs (C.Para inlns :< _)+ | F.any breakCheck inlns = multiLnLayout hs w nameElems bs+ layout hs w nameElems bs _ = nameNextToMessage hs w nameElems bs++ multiLnLayout hs w nameElems bs = if mdIndentBlocks- then vBox [ hBox n- , hBox [B.txt " ", m]+ then vBox [ hBox nameElems+ , hBox [B.txt " ", renderMarkdown hs ((subtract 2) <$> w) bs] ]- else hBox $ n <> [m]+ else nameNextToMessage hs w nameElems bs++ nameNextToMessage hs w nameElems bs =+ Widget Fixed Fixed $ do+ nameResult <- render $ hBox nameElems+ let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w+ render $ hBox [raw (nameResult^.imageL), renderMarkdown hs newW bs]+ breakCheck C.LineBreak = True breakCheck C.SoftBreak = True breakCheck _ = False - addEllipsis :: Widget a -> Widget a addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do ctx <- B.getContext@@ -253,9 +277,9 @@ cursorSentinel = '‸' -- Render markdown with username highlighting-renderMarkdown :: HighlightSet -> Blocks -> Widget a-renderMarkdown hSet =- B.vBox . toList . fmap (blockToWidget hSet) . addBlankLines+renderMarkdown :: HighlightSet -> Maybe Int -> Blocks -> Widget a+renderMarkdown hSet w =+ B.vBox . toList . fmap (blockToWidget hSet w) . addBlankLines -- Add blank lines only between adjacent elements of the same type, to -- save space@@ -284,7 +308,7 @@ renderText txt = renderText' emptyHSet txt renderText' :: HighlightSet -> Text -> Widget a-renderText' hSet txt = renderMarkdown hSet bs+renderText' hSet txt = renderMarkdown hSet Nothing bs where C.Doc _ bs = C.markdown C.def txt vBox :: F.Foldable f => f (Widget a) -> Widget a@@ -296,20 +320,32 @@ header :: Int -> Widget a header n = B.txt (T.replicate n "#") -blockToWidget :: HighlightSet -> Block -> Widget a-blockToWidget hSet (C.Para is) = toInlineChunk is hSet-blockToWidget hSet (C.Header n is) =+maybeHLimit :: Maybe Int -> Widget a -> Widget a+maybeHLimit Nothing w = w+maybeHLimit (Just i) w = hLimit i w++blockToWidget :: HighlightSet -> Maybe Int -> Block -> Widget a+blockToWidget hSet w (C.Para is) =+ toInlineChunk w is hSet+blockToWidget hSet w (C.Header n is) = B.withDefAttr clientHeaderAttr $- hBox [B.padRight (B.Pad 1) $ header n, toInlineChunk is hSet]-blockToWidget hSet (C.Blockquote is) =- addQuoting (vBox $ fmap (blockToWidget hSet) is)-blockToWidget hSet (C.List _ l bs) = blocksToList l bs hSet-blockToWidget hSet (C.CodeBlock ci tx) =- let f = maybe rawCodeBlockToWidget (codeBlockToWidget (hSyntaxMap hSet)) mSyntax- mSyntax = Sky.lookupSyntax (C.codeLang ci) (hSyntaxMap hSet)- in f tx-blockToWidget _ (C.HtmlBlock txt) = textWithCursor txt-blockToWidget _ (C.HRule) = B.vLimit 1 (B.fill '*')+ hBox [B.padRight (B.Pad 1) $ header n, toInlineChunk (subtract 1 <$> w) is hSet]+blockToWidget hSet w (C.Blockquote is) =+ maybeHLimit w $+ addQuoting (vBox $ fmap (blockToWidget hSet w) is)+blockToWidget hSet w (C.List _ l bs) =+ maybeHLimit w $+ blocksToList l w bs hSet+blockToWidget hSet _ (C.CodeBlock ci tx) =+ let f = maybe rawCodeBlockToWidget (codeBlockToWidget (hSyntaxMap hSet)) mSyntax+ mSyntax = Sky.lookupSyntax (C.codeLang ci) (hSyntaxMap hSet)+ in f tx+blockToWidget _ w (C.HtmlBlock txt) =+ maybeHLimit w $+ textWithCursor txt+blockToWidget _ w (C.HRule) =+ maybeHLimit w $+ B.vLimit 1 (B.fill '*') quoteChar :: Char quoteChar = '>'@@ -347,17 +383,17 @@ expandEmpty s = s in padding <+> (B.vBox $ textWithCursor <$> theLines) -toInlineChunk :: Inlines -> HighlightSet -> Widget a-toInlineChunk is hSet = B.Widget B.Fixed B.Fixed $ do+toInlineChunk :: Maybe Int -> Inlines -> HighlightSet -> Widget a+toInlineChunk w is hSet = B.Widget B.Fixed B.Fixed $ do ctx <- B.getContext- let width = ctx^.B.availWidthL+ let width = fromMaybe (ctx^.B.availWidthL) w fs = toFragments hSet is ws = fmap gatherWidgets (split width hSet fs) B.render (vBox (fmap hBox ws)) -blocksToList :: ListType -> [Blocks] -> HighlightSet -> Widget a-blocksToList lt bs hSet = vBox- [ B.txt i <+> (vBox (fmap (blockToWidget hSet) b))+blocksToList :: ListType -> Maybe Int -> [Blocks] -> HighlightSet -> Widget a+blocksToList lt w bs hSet = vBox+ [ B.txt i <+> (vBox (fmap (blockToWidget hSet w) b)) | b <- bs | i <- is ] where is = case lt of C.Bullet _ -> repeat ("• ")
src/State/Attachments.hs view
@@ -7,6 +7,10 @@ import Prelude () import Prelude.MH+import qualified Control.Exception as E+import Data.Either ( isRight )+import System.Directory ( doesDirectoryExist, getDirectoryContents )+import Data.Bool ( bool ) import Brick ( vScrollToBeginning, viewportScroll ) import qualified Brick.Widgets.List as L@@ -15,7 +19,19 @@ import Types +validateAttachmentPath :: FilePath -> IO (Maybe FilePath)+validateAttachmentPath path = bool Nothing (Just path) <$> do+ ex <- doesDirectoryExist path+ case ex of+ False -> return False+ True -> do+ result :: Either E.SomeException [FilePath]+ <- E.try $ getDirectoryContents path+ return $ isRight result +defaultAttachmentsPath :: Config -> IO (Maybe FilePath)+defaultAttachmentsPath = maybe (return Nothing) validateAttachmentPath . configDefaultAttachmentPath+ showAttachmentList :: MH () showAttachmentList = do lst <- use (csEditState.cedAttachmentList)@@ -30,6 +46,8 @@ showAttachmentFileBrowser :: MH () showAttachmentFileBrowser = do- browser <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing+ config <- use (csResources.crConfiguration)+ filePath <- liftIO $ defaultAttachmentsPath config+ browser <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser filePath csEditState.cedFileBrowser .= browser setMode ManageAttachmentsBrowseFiles
src/State/Channels.hs view
@@ -392,16 +392,12 @@ when (switch || pending1 || pending2) $ setFocus (getId nc) -- | Check to see whether the specified channel has been queued up to--- be switched to now that the channel is registered in the state. If--- so, return True and clear the state. Otherwise return False.+-- be switched to. Note that this condition is only cleared by the+-- actual setFocus switch to the channel because there may be multiple+-- operations that must complete before the channel is fully ready for+-- display/use. checkPendingChannelChange :: PendingChannelChange -> MH Bool-checkPendingChannelChange change = do- pending <- use csPendingChannelChange- case pending of- Just p | p == change -> do- csPendingChannelChange .= Nothing- return True- _ -> return False+checkPendingChannelChange change = (==) (Just change) <$> use csPendingChannelChange -- | Update the indicated Channel entry with the new data retrieved from -- the Mattermost server. Also update the channel name if it changed.@@ -424,8 +420,27 @@ session <- getSession case mChan of- Nothing -> return ()+ Nothing ->+ -- The requested channel doesn't actually exist yet, so no+ -- action can be taken. It's likely that this is a+ -- pendingChannel situation and not all of the operations to+ -- locally define the channel have completed, in which case+ -- this code will be re-entered later and the mChan will be+ -- known.+ return () Just ch -> do++ -- Able to successfully switch to a known channel. This+ -- should clear any pending channel intention. If the+ -- intention was for this channel, then: done. If the+ -- intention was for a different channel, reaching this+ -- point means that the pending is still outstanding but+ -- that the user identified a new channel which *was*+ -- displayable, and the UI should always prefer to SATISFY+ -- the user's latest request over any pending/background+ -- task.+ csPendingChannelChange .= Nothing+ now <- liftIO getCurrentTime csChannel(cId).ccInfo.cdSidebarShowOverride .= Just now updateSidebar@@ -765,16 +780,19 @@ case length results == length usernames of True -> do chan <- MM.mmCreateGroupMessageChannel (userId <$> results) session- -- If we already know about the channel ID, that means- -- the channel already exists so we can just switch to- -- it.- case findChannelById (channelId chan) cs of- Just _ -> return $ Just $ setFocus (channelId chan)- Nothing -> do- let pref = showGroupChannelPref (channelId chan) (me^.userIdL)- MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session- return $ Just $ do- applyPreferenceChange pref+ return $ Just $ do+ case findChannelById (channelId chan) cs of+ Just _ ->+ -- If we already know about the channel ID,+ -- that means the channel already exists so+ -- we can just switch to it.+ setFocus (channelId chan)+ Nothing -> do+ csPendingChannelChange .= (Just $ ChangeByChannelId $ channelId chan)+ let pref = showGroupChannelPref (channelId chan) (me^.userIdL)+ doAsyncWith Normal $ do+ MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+ return $ Just $ applyPreferenceChange pref False -> do let foundUsernames = userUsername <$> results missingUsernames = S.toList $@@ -819,8 +837,8 @@ loadHistoryEntryToEditor cId newI csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI) -createOrdinaryChannel :: Text -> MH ()-createOrdinaryChannel name = do+createOrdinaryChannel :: Bool -> Text -> MH ()+createOrdinaryChannel public name = do session <- getSession myTId <- gets myTeamId doAsyncWith Preempt $ do@@ -831,7 +849,7 @@ , minChannelDisplayName = name , minChannelPurpose = Nothing , minChannelHeader = Nothing- , minChannelType = Ordinary+ , minChannelType = if public then Ordinary else Private , minChannelTeamId = myTId } tryMM (do c <- MM.mmCreateChannel minChannel session@@ -841,15 +859,17 @@ ) (return . Just . uncurry (handleNewChannel True SidebarUpdateImmediate)) --- | When another user adds us to a channel, we need to fetch the--- channel info for that channel.+-- | When we are added to a channel not locally known about, we need+-- to fetch the channel info for that channel. handleChannelInvite :: ChannelId -> MH () handleChannelInvite cId = do session <- getSession doAsyncWith Normal $ do member <- MM.mmGetChannelMember cId UserMe session tryMM (MM.mmGetChannel cId session)- (\cwd -> return $ Just $ handleNewChannel False SidebarUpdateImmediate cwd member)+ (\cwd -> return $ Just $ do+ pending <- checkPendingChannelChange $ ChangeByChannelId cId+ handleNewChannel pending SidebarUpdateImmediate cwd member) addUserByNameToCurrentChannel :: Text -> MH () addUserByNameToCurrentChannel uname =
src/State/MessageSelect.hs view
@@ -26,9 +26,6 @@ import Prelude () import Prelude.MH -import Brick ( invalidateCacheEntry )-import Brick.Main ( viewportScroll, hScrollToBeginning- , vScrollToBeginning ) import Brick.Widgets.Edit ( applyEdit ) import Data.Text.Zipper ( clearZipper, insertMany ) import Lens.Micro.Platform@@ -42,6 +39,7 @@ import State.Messages import Types import Types.Common+import Windows.ViewMessage -- | In these modes, we allow access to the selected message state.@@ -106,12 +104,9 @@ viewMessage :: Message -> MH () viewMessage m = do- csViewedMessage .= Just m- let vs = viewportScroll ViewMessageArea- mh $ do- vScrollToBeginning vs- hScrollToBeginning vs- invalidateCacheEntry ViewMessageArea+ let w = tabbedWindow VMTabMessage viewMessageWindowTemplate Main (78, 25)+ csViewedMessage .= Just (m, w)+ runTabShowHandlerFor (twValue w) w setMode ViewMessage yankSelectedMessageVerbatim :: MH ()
src/State/Messages.hs view
@@ -177,7 +177,16 @@ addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd addObtainedMessages cId reqCnt addTrailingGap posts = if null $ posts^.postsOrderL- then return NoAction+ then do when addTrailingGap $+ -- Fetched at the end of the channel, but nothing was+ -- available. This is common if this is a new channel+ -- with no messages in it. Need to remove any gaps that+ -- exist at the end of the channel.+ csChannels %= modifyChannelById cId+ (ccContents.cdMessages %~+ \msgs -> let startPoint = join $ _mMessageId <$> getLatestPostMsg msgs+ in fst $ removeMatchesFromSubset isGap startPoint Nothing msgs)+ return NoAction else -- Adding a block of server-provided messages, which are known to -- be contiguous. Locally this may overlap with some UnknownGap
src/State/Setup.hs view
@@ -7,7 +7,7 @@ import Prelude () import Prelude.MH -import Brick.BChan+import Brick.BChan ( newBChan ) import Brick.Themes ( themeToAttrMap, loadCustomizations ) import qualified Control.Concurrent.STM as STM import Data.Maybe ( fromJust )@@ -63,7 +63,7 @@ setupState mkVty mLogLocation config = do initialVty <- mkVty - eventChan <- newBChan 25+ eventChan <- newBChan 2500 logMgr <- newLogManager eventChan (configLogMaxBufferSize config) -- If we got an initial log location, start logging there.
src/State/Setup/Threads.hs view
@@ -14,7 +14,7 @@ import Prelude () import Prelude.MH -import Brick.BChan+import Brick.BChan ( BChan ) import Brick.Main ( invalidateCache ) import Control.Concurrent ( threadDelay, forkIO ) import qualified Control.Concurrent.STM as STM
src/State/Setup/Threads/Logging.hs view
@@ -22,7 +22,7 @@ import Prelude () import Prelude.MH -import Brick.BChan+import Brick.BChan ( BChan ) import Control.Concurrent.Async ( Async, async, wait ) import qualified Control.Concurrent.STM as STM import Control.Exception ( SomeException, try )@@ -36,6 +36,36 @@ import Types +-- | Used to remember the last logging output point for various log output targets.+newtype LogMemory = LogMemory { logMem :: [(FilePath, LogMessage)] }++blankLogMemory :: LogMemory+blankLogMemory = LogMemory []++-- | Adds or updates the last log message output to this destination.+-- This is used for the case when logging is re-enabled to that+-- destination to avoid repeating logging output.+--+-- The number of log memories is limited by forgetting the oldest ones+-- if over a threshold. This handles a pathological case where the+-- user has redirected output to a very large number of logfiles.+-- This is very unlikely to happen (a script or bad paste buffer+-- maybe?) but this provides defensive behavior to prevent+-- uncontrolled memory consumption in this case. The limit here is+-- arbitrary, but it should suffice and once it's reached the+-- degradation case is simply the potential for duplicated messages+-- when returning to logfiles that haven't been recently logged to.+rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory+rememberOutputPoint logPath logMsg oldLogMem =+ LogMemory $+ take 50 $ -- upper limit on number of logpath+message memories retained+ (logPath, logMsg) : filter ((/=) logPath . fst) (logMem oldLogMem)++-- | Returns the last LogMessage logged to the specified output log+-- file path if it was previously logged to.+memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage+memoryOfOutputPath p = lookup p . logMem+ -- | The state of the logging thread. data LogThreadState = LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)@@ -52,6 +82,10 @@ -- ^ The internal bounded log message buffer. , logThreadMaxBufferSize :: Int -- ^ The size bound of the logThreadMessageBuffer.+ , logPreviousStopPoint :: LogMemory+ -- ^ Previous logging stop points to avoid+ -- duplication if logging is re-enabled to the same+ -- output } -- | Create a new log manager and start a logging thread for it.@@ -78,6 +112,7 @@ , logThreadCommandChan = logChan , logThreadMessageBuffer = mempty , logThreadMaxBufferSize = maxBufferSize+ , logPreviousStopPoint = blankLogMemory } async $ void $ runStateT logThreadBody initialState @@ -114,10 +149,16 @@ putLogEndMarker oldHandle hClose oldHandle writeBChan eventChan $ IEvent $ LoggingStopped oldPath- modify $ \s -> s { logThreadDestination = Nothing }+ modify $ \s ->+ let buf = logThreadMessageBuffer s+ lastLm = Seq.index buf (Seq.length buf - 1) -- n.b. putLogEndMarker ensures buf not empty+ stops = rememberOutputPoint oldPath lastLm $ logPreviousStopPoint s+ in s { logThreadDestination = Nothing+ , logPreviousStopPoint = stops+ } -stopLogging :: StateT LogThreadState IO ()-stopLogging = do+stopLogOutput :: StateT LogThreadState IO ()+stopLogOutput = do oldDest <- gets logThreadDestination case oldDest of Nothing -> return ()@@ -144,7 +185,7 @@ Left (e::SomeException) -> do liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotFailed path (show e) Right handle -> do- flushLogMessageBuffer handle+ flushLogMessageBuffer path handle liftIO $ hClose handle liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotSucceeded path @@ -159,12 +200,12 @@ handleLogCommand ShutdownLogging = do -- ShutdownLogging: if we were logging to a file, close it. Then -- unlock the shutdown lock.- stopLogging+ stopLogOutput return False handleLogCommand StopLogging = do -- StopLogging: if we were logging to a file, close it and notify -- the application. Otherwise do nothing.- stopLogging+ stopLogOutput return True handleLogCommand (LogToFile newPath) = do -- LogToFile: if we were logging to a file, close that file, notify@@ -188,10 +229,10 @@ ": " <> show e writeBChan eventChan $ IEvent $ LogStartFailed newPath msg Right handle -> do- stopLogging+ stopLogOutput modify $ \s -> s { logThreadDestination = Just (newPath, handle) }- flushLogMessageBuffer handle+ flushLogMessageBuffer newPath handle liftIO $ putLogStartMarker handle liftIO $ writeBChan eventChan $ IEvent $ LoggingStarted newPath @@ -231,26 +272,46 @@ hPutStr handle $ "[" <> show logMessageTimestamp <> "] " hPutStr handle $ "[" <> show logMessageCategory <> "] " case logMessageContext of- Nothing -> hPutStr handle "[No context] "+ Nothing -> hPutStr handle "[*] " Just c -> hPutStr handle $ "[" <> show c <> "] " hPutStrLn handle $ T.unpack logMessageText -- | Flush the contents of the internal log message buffer.-flushLogMessageBuffer :: Handle -> StateT LogThreadState IO ()-flushLogMessageBuffer handle = do+flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()+flushLogMessageBuffer pathOfHandle handle = do buf <- gets logThreadMessageBuffer- when (Seq.length buf > 0) $ do- liftIO $ do- let firstLm = Seq.index buf 0- lastLm = Seq.index buf (Seq.length buf - 1)- mkMsg t m = "[" <> show t <> "] " <> m+ when (not $ Seq.null buf) $ do+ lastPoint <- memoryOfOutputPath pathOfHandle <$> gets logPreviousStopPoint+ case lastPoint of+ Nothing ->+ -- never logged to this output point before, so dump the+ -- current internal buffer of log messages to the beginning of+ -- the output file.+ dumpBuf buf+ Just lm ->+ -- There was previous logging to this file. If the log buffer+ -- contains the entirety of the log messages during the+ -- logging disable, then just dump that portion; otherwise+ -- dump the entire buffer and indicate there may be missing+ -- entries before the buffer.+ let unseen = Seq.takeWhileR (not . (==) lm) buf+ firstM = Seq.index buf 0 -- above ensures that buf is not empty here+ in do when (Seq.length buf == Seq.length unseen) $ liftIO $+ hPutStrLn handle $ mkMsg (logMessageTimestamp firstM)+ "<<< Potentially missing log messages here... >>>"+ dumpBuf unseen+ where+ mkMsg t m = "[" <> show t <> "] " <> m+ dumpBuf buf = liftIO $ do+ let firstLm = Seq.index buf 0+ lastLm = Seq.index buf (Seq.length buf - 1) - hPutStrLn handle $ mkMsg (logMessageTimestamp firstLm)- "<<< Log message buffer begin >>>"+ hPutStrLn handle $ mkMsg (logMessageTimestamp firstLm)+ "<<< Log message buffer begin >>>" - forM_ buf (hPutLogMessage handle)+ forM_ buf (hPutLogMessage handle) - hPutStrLn handle $ mkMsg (logMessageTimestamp lastLm)- "<<< Log message buffer end >>>"+ hPutStrLn handle $ mkMsg (logMessageTimestamp lastLm)+ "<<< Log message buffer end >>>" - hFlush handle+ hFlush handle
src/TeamSelect.hs view
@@ -14,6 +14,7 @@ import Data.List ( sortBy ) import qualified Data.Vector as V import Graphics.Vty hiding (mkVty)+import qualified Data.Text as T import Network.Mattermost.Types @@ -74,7 +75,10 @@ renderTeamItem :: Bool -> Team -> Widget () renderTeamItem _ t =- padRight Max $ txt $ sanitizeUserText $ teamName t+ padRight Max $ txt $ (sanitizeUserText $ teamName t) <>+ if not $ T.null (sanitizeUserText $ teamDisplayName t)+ then " (" <> (sanitizeUserText $ teamDisplayName t) <> ")"+ else "" onEvent :: State -> BrickEvent () e -> EventM () (Next State) onEvent st (VtyEvent (EvKey KEsc [])) = do
src/Themes.hs view
@@ -45,6 +45,8 @@ , misspellingAttr , editedMarkingAttr , editedRecentlyMarkingAttr+ , tabSelectedAttr+ , tabUnselectedAttr -- * Username formatting , colorUsername@@ -141,6 +143,12 @@ mentionsChannelAttr :: AttrName mentionsChannelAttr = "channelWithMentions" +tabSelectedAttr :: AttrName+tabSelectedAttr = "tabSelected"++tabUnselectedAttr :: AttrName+tabUnselectedAttr = "tabUnselected"+ dateTransitionAttr :: AttrName dateTransitionAttr = "dateTransition" @@ -260,6 +268,7 @@ , (misspellingAttr, fg red `withStyle` underline) , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, black `on` yellow)+ , (tabSelectedAttr, black `on` yellow) , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue) , (FB.fileBrowserSelectionInfoAttr, white `on` blue) , (FB.fileBrowserDirectoryAttr, fg blue)@@ -312,6 +321,7 @@ , (misspellingAttr, fg red `withStyle` underline) , (editedMarkingAttr, fg yellow) , (editedRecentlyMarkingAttr, black `on` yellow)+ , (tabSelectedAttr, black `on` yellow) , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue) , (FB.fileBrowserSelectionInfoAttr, white `on` blue) , (FB.fileBrowserDirectoryAttr, fg blue)@@ -422,6 +432,12 @@ ) , ( newMessageTransitionAttr , "The 'New Messages' line that appears above unread messages"+ )+ , ( tabSelectedAttr+ , "Selected tabs in tabbed windows"+ )+ , ( tabUnselectedAttr+ , "Unselected tabs in tabbed windows" ) , ( errorMessageAttr , "Matterhorn error messages"
src/TimeUtils.hs view
@@ -22,7 +22,6 @@ import Network.Mattermost.Types ( ServerTime(..) ) - -- | Get the timezone series that should be used for converting UTC -- times into local times with appropriate DST adjustments. lookupLocalTimeZone :: IO TimeZoneSeries@@ -41,14 +40,12 @@ justAfter = ServerTime . justAfterUTC . withServerTime where justAfterUTC time = let UTCTime d t = time in UTCTime d (succ t) - -- | Obtain a time value that is just moments before the input time; -- see the comment for the 'justAfter' function for more details. justBefore :: ServerTime -> ServerTime justBefore = ServerTime . justBeforeUTC . withServerTime where justBeforeUTC time = let UTCTime d t = time in UTCTime d (pred t) - -- | The timestamp for the start of the day associated with the input -- timestamp. If timezone information is supplied, then the returned -- value will correspond to when the day started in that timezone;@@ -60,16 +57,13 @@ ls = LocalTime (localDay lt) (TimeOfDay 0 0 0) in localTimeToUTC' tz ls - -- | Convert a UTC time value to a local time. asLocalTime :: TimeZoneSeries -> UTCTime -> LocalTime asLocalTime = utcToLocalTime' - -- | Local time in displayable format localTimeText :: Text -> LocalTime -> Text localTimeText fmt time = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) time- -- | Provides a time value that can be used when there are no other times available originTime :: UTCTime
src/Types.hs view
@@ -19,10 +19,19 @@ , MHError(..) , AttachmentData(..) , CPUUsagePolicy(..)+ , tabbedWindow+ , getCurrentTabbedWindowEntry+ , tabbedWindowNextTab+ , tabbedWindowPreviousTab+ , runTabShowHandlerFor+ , TabbedWindow(..)+ , TabbedWindowEntry(..)+ , TabbedWindowTemplate(..) , OpenInBrowser(..) , ConnectionInfo(..) , SidebarUpdate(..) , PendingChannelChange(..)+ , ViewMessageWindowTab(..) , clearChannelUnreadStatus , ChannelListEntry(..) , channelListEntryChannelId@@ -44,6 +53,7 @@ , BackgroundInfo(..) , RequestChan , UserFetch(..)+ , writeBChan , mkChannelZipperList , ChannelListGroup(..)@@ -250,11 +260,12 @@ import Prelude () import Prelude.MH +import qualified Graphics.Vty as Vty import qualified Brick-import Brick ( EventM, Next )+import Brick ( EventM, Next, Widget ) import Brick.Main ( invalidateCache, invalidateCacheEntry ) import Brick.AttrMap ( AttrMap )-import Brick.BChan+import qualified Brick.BChan as BCH import Brick.Widgets.Edit ( Editor, editor ) import Brick.Widgets.List ( List, list ) import qualified Brick.Widgets.FileBrowser as FB@@ -269,7 +280,7 @@ import qualified Data.Foldable as F import Data.Ord ( comparing ) import qualified Data.HashMap.Strict as HM-import Data.List ( sortBy )+import Data.List ( sortBy, nub, elemIndex ) import qualified Data.Sequence as Seq import qualified Data.Text as T import Data.Time.Clock ( UTCTime, getCurrentTime, addUTCTime )@@ -400,6 +411,8 @@ -- message with them. , configCpuUsagePolicy :: CPUUsagePolicy -- ^ The CPU usage policy for the application.+ , configDefaultAttachmentPath :: Maybe FilePath+ -- ^ The default path for browsing attachments } deriving (Eq, Show) -- | The policy for CPU usage.@@ -602,6 +615,7 @@ | JoinChannelListSearchInput | UserListSearchResults | ViewMessageArea+ | ViewMessageReactionsArea | ChannelSidebar | ChannelSelectInput | AttachmentList@@ -609,6 +623,7 @@ | MessageReactionsArea | ReactionEmojiList | ReactionEmojiListInput+ | TabbedWindowTabBar deriving (Eq, Show, Ord) -- | The sum type of exceptions we expect to encounter on authentication@@ -737,6 +752,7 @@ | LogAPI | LogWebsocket | LogError+ | LogUserMark deriving (Eq, Show) -- | A log message.@@ -751,7 +767,7 @@ , logMessageTimestamp :: !UTCTime -- ^ The timestamp of the log message. }- deriving (Show)+ deriving (Eq, Show) -- | A logging thread command. data LogCommand =@@ -805,7 +821,7 @@ , _crWebsocketThreadId :: Maybe ThreadId , _crConn :: ConnectionData , _crRequestQueue :: RequestChan- , _crEventQueue :: BChan MHEvent+ , _crEventQueue :: BCH.BChan MHEvent , _crSubprocessLog :: STM.TChan ProgramOutput , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap@@ -1002,9 +1018,178 @@ -- | We're either connected or we're not. data ConnectionStatus = Connected | Disconnected deriving (Eq) +-- | An entry in a tabbed window corresponding to a tab and its content.+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindowEntry a =+ TabbedWindowEntry { tweValue :: a+ -- ^ The handle for this tab.+ , tweRender :: a -> ChatState -> Widget Name+ -- ^ The rendering function to use when this tab+ -- is selected.+ , tweHandleEvent :: a -> Vty.Event -> MH ()+ -- ^ The event-handling function to use when this+ -- tab is selected.+ , tweTitle :: a -> Bool -> T.Text+ -- ^ Title function for this tab, with a boolean+ -- indicating whether this is the current tab.+ , tweShowHandler :: a -> MH ()+ -- ^ A handler to be invoked when this tab is+ -- shown.+ }++-- | The definition of a tabbed window. Note that this does not track+-- the *state* of the window; it merely provides a collection of tab+-- window entries (see above). To track the state of a tabbed window,+-- use a TabbedWindow.+--+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindowTemplate a =+ TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a]+ -- ^ The entries in tabbed windows with this+ -- structure.+ , twtTitle :: a -> Widget Name+ -- ^ The title-rendering function for this kind+ -- of tabbed window.+ }++-- | An instantiated tab window. This is based on a template and tracks+-- the state of the tabbed window (current tab).+--+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindow a =+ TabbedWindow { twValue :: a+ -- ^ The handle of the currently-selected tab.+ , twReturnMode :: Mode+ -- ^ The mode to return to when the tab is closed.+ , twTemplate :: TabbedWindowTemplate a+ -- ^ The template to use as a basis for rendering the+ -- window and handling user input.+ , twWindowWidth :: Int+ , twWindowHeight :: Int+ -- ^ Window dimensions+ }++-- | Construct a new tabbed window from a template. This will raise an+-- exception if the initially-selected tab does not exist in the window+-- template, or if the window template has any duplicated tab handles.+--+-- Note that the caller is responsible for determining whether to call+-- the initially-selected tab's on-show handler.+tabbedWindow :: (Show a, Eq a)+ => a+ -- ^ The handle corresponding to the tab that should be+ -- selected initially.+ -> TabbedWindowTemplate a+ -- ^ The template for the window to construct.+ -> Mode+ -- ^ When the window is closed, return to this application+ -- mode.+ -> (Int, Int)+ -- ^ The window dimensions (width, height).+ -> TabbedWindow a+tabbedWindow initialVal t retMode (width, height) =+ let handles = tweValue <$> twtEntries t+ in if | null handles ->+ error "BUG: tabbed window template must provide at least one entry"+ | length handles /= length (nub handles) ->+ error "BUG: tabbed window should have one entry per handle"+ | not (initialVal `elem` handles) ->+ error $ "BUG: tabbed window handle " <>+ show initialVal <> " not present in template"+ | otherwise ->+ TabbedWindow { twTemplate = t+ , twValue = initialVal+ , twReturnMode = retMode+ , twWindowWidth = width+ , twWindowHeight = height+ }++-- | Get the currently-selected tab entry for a tabbed window. Raise+-- an exception if the window's selected tab handle is not found in its+-- template (which is a bug in the tabbed window infrastructure).+getCurrentTabbedWindowEntry :: (Show a, Eq a)+ => TabbedWindow a+ -> TabbedWindowEntry a+getCurrentTabbedWindowEntry w =+ lookupTabbedWindowEntry (twValue w) w++-- | Run the on-show handler for the window tab entry with the specified+-- handle.+runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH ()+runTabShowHandlerFor handle w = do+ let entry = lookupTabbedWindowEntry handle w+ tweShowHandler entry handle++-- | Look up a tabbed window entry by handle. Raises an exception if no+-- such entry exists.+lookupTabbedWindowEntry :: (Eq a, Show a)+ => a+ -> TabbedWindow a+ -> TabbedWindowEntry a+lookupTabbedWindowEntry handle w =+ let matchesVal e = tweValue e == handle+ in case filter matchesVal (twtEntries $ twTemplate w) of+ [e] -> e+ _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <>+ " should have matched a single entry"++-- | Switch a tabbed window's selected tab to its next tab, cycling back+-- to the first tab if the last tab is the selected tab. This also+-- invokes the on-show handler for the newly-selected tab.+--+-- Note that this does nothing if the window has only one tab.+tabbedWindowNextTab :: (Show a, Eq a)+ => TabbedWindow a+ -> MH (TabbedWindow a)+tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w+tabbedWindowNextTab w = do+ let curIdx = case elemIndex (tweValue curEntry) allHandles of+ Nothing ->+ error $ "BUG: tabbedWindowNextTab: could not find " <>+ "current handle in handle list"+ Just i -> i+ nextIdx = if curIdx == length allHandles - 1+ then 0+ else curIdx + 1+ newHandle = allHandles !! nextIdx+ allHandles = tweValue <$> twtEntries (twTemplate w)+ curEntry = getCurrentTabbedWindowEntry w+ newWin = w { twValue = newHandle }++ runTabShowHandlerFor newHandle newWin+ return newWin++-- | Switch a tabbed window's selected tab to its previous tab, cycling+-- to the last tab if the first tab is the selected tab. This also+-- invokes the on-show handler for the newly-selected tab.+--+-- Note that this does nothing if the window has only one tab.+tabbedWindowPreviousTab :: (Show a, Eq a)+ => TabbedWindow a+ -> MH (TabbedWindow a)+tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w+tabbedWindowPreviousTab w = do+ let curIdx = case elemIndex (tweValue curEntry) allHandles of+ Nothing ->+ error $ "BUG: tabbedWindowPreviousTab: could not find " <>+ "current handle in handle list"+ Just i -> i+ nextIdx = if curIdx == 0+ then length allHandles - 1+ else curIdx - 1+ newHandle = allHandles !! nextIdx+ allHandles = tweValue <$> twtEntries (twTemplate w)+ curEntry = getCurrentTabbedWindowEntry w+ newWin = w { twValue = newHandle }++ runTabShowHandlerFor newHandle newWin+ return newWin+ -- | This is the giant bundle of fields that represents the current--- state of our application at any given time. Some of this should be--- broken out further, but hasn't yet been.+-- state of our application at any given time. data ChatState = ChatState { _csResources :: ChatResources -- ^ Global application-wide resources that don't change@@ -1069,11 +1254,26 @@ -- when we need to change to a channel in the sidebar, but -- it isn't even there yet because we haven't loaded its -- metadata.- , _csViewedMessage :: Maybe Message+ , _csViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab) -- ^ Set when the ViewMessage mode is active. The message- -- being viewed.+ -- being viewed. Note that this stores a message, not+ -- a message ID. That's because not all messages have+ -- message IDs (e.g. client messages) and we still+ -- want to support viewing of those messages. It's the+ -- responsibility of code that uses this message to always+ -- consult the chat state for the latest *version* of any+ -- message with an ID here, to be sure that the latest+ -- version is used (e.g. if it gets edited, etc.). } +-- | Handles for the View Message window's tabs.+data ViewMessageWindowTab =+ VMTabMessage+ -- ^ The message tab.+ | VMTabReactions+ -- ^ The reactions tab.+ deriving (Eq, Show)+ data PendingChannelChange = ChangeByChannelId ChannelId | ChangeByUserId UserId@@ -1516,7 +1716,13 @@ raiseInternalEvent :: InternalEvent -> MH () raiseInternalEvent ev = do queue <- use (csResources.crEventQueue)- St.liftIO $ writeBChan queue (IEvent ev)+ writeBChan queue (IEvent ev)++writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m ()+writeBChan chan e = do+ written <- liftIO $ BCH.writeBChanNonBlocking chan e+ when (not written) $+ error $ "mhSendEvent: BChan full, please report this as a bug!" -- | Log and raise an error. mhError :: MHError -> MH ()
src/Types/KeyEvents.hs view
@@ -53,6 +53,9 @@ | ToggleChannelListVisibleEvent | ShowAttachmentListEvent + | SelectNextTabEvent+ | SelectPreviousTabEvent+ -- generic cancel | CancelEvent @@ -63,6 +66,8 @@ -- scrolling events---maybe rebindable? | ScrollUpEvent | ScrollDownEvent+ | ScrollLeftEvent+ | ScrollRightEvent | PageUpEvent | PageDownEvent | ScrollTopEvent@@ -107,6 +112,8 @@ , ToggleMultiLineEvent , CancelEvent , ReplyRecentEvent+ , SelectNextTabEvent+ , SelectPreviousTabEvent , EnterFastSelectModeEvent , NextChannelEvent@@ -128,6 +135,8 @@ , ScrollUpEvent , ScrollDownEvent+ , ScrollLeftEvent+ , ScrollRightEvent , PageUpEvent , PageDownEvent , ScrollTopEvent@@ -307,6 +316,9 @@ NextUnreadUserOrChannelEvent -> "focus-next-unread-user-or-channel" LastChannelEvent -> "focus-last-channel" + SelectNextTabEvent -> "select-next-tab"+ SelectPreviousTabEvent -> "select-previous-tab"+ ShowAttachmentListEvent -> "show-attachment-list" EnterFlaggedPostsEvent -> "show-flagged-posts"@@ -320,6 +332,8 @@ ScrollUpEvent -> "scroll-up" ScrollDownEvent -> "scroll-down"+ ScrollLeftEvent -> "scroll-left"+ ScrollRightEvent -> "scroll-right" PageUpEvent -> "page-up" PageDownEvent -> "page-down" ScrollTopEvent -> "scroll-top"
+ src/Windows/ViewMessage.hs view
@@ -0,0 +1,205 @@+module Windows.ViewMessage+ ( viewMessageWindowTemplate+ , viewMessageKeybindings+ , viewMessageReactionsKeybindings+ )+where++import Prelude ()+import Prelude.MH++import Brick+import Brick.Widgets.Border++import qualified Data.Set as S+import qualified Data.Map as M+import Data.Maybe ( fromJust )+import qualified Data.Text as T+import qualified Data.Foldable as F+import qualified Graphics.Vty as Vty+import Lens.Micro.Platform ( to )++import Constants+import Events.Keybindings+import Themes+import Types+import Types.Messages ( findMessage )+import Markdown+import Draw.Messages ( nameForUserRef )++-- | The template for "View Message" windows triggered by message+-- selection mode.+viewMessageWindowTemplate :: TabbedWindowTemplate ViewMessageWindowTab+viewMessageWindowTemplate =+ TabbedWindowTemplate { twtEntries = [ messageEntry+ , reactionsEntry+ ]+ , twtTitle = const $ txt "View Message"+ }++messageEntry :: TabbedWindowEntry ViewMessageWindowTab+messageEntry =+ TabbedWindowEntry { tweValue = VMTabMessage+ , tweRender = renderTab+ , tweHandleEvent = handleEvent+ , tweTitle = tabTitle+ , tweShowHandler = onShow+ }++reactionsEntry :: TabbedWindowEntry ViewMessageWindowTab+reactionsEntry =+ TabbedWindowEntry { tweValue = VMTabReactions+ , tweRender = renderTab+ , tweHandleEvent = handleEvent+ , tweTitle = tabTitle+ , tweShowHandler = onShow+ }++tabTitle :: ViewMessageWindowTab -> Bool -> T.Text+tabTitle VMTabMessage _ = "Message"+tabTitle VMTabReactions _ = "Reactions"++-- When we show the tabs, we need to reset the viewport scroll position+-- for viewports in that tab. This is because an older View Message+-- window used the same handle for the viewport and we don't want that+-- old state affecting this window. This also means that switching tabs+-- in an existing window resets this state, too.+onShow :: ViewMessageWindowTab -> MH ()+onShow VMTabMessage = resetVp ViewMessageArea+onShow VMTabReactions = resetVp ViewMessageArea++resetVp :: Name -> MH ()+resetVp n = do+ let vs = viewportScroll n+ mh $ do+ vScrollToBeginning vs+ hScrollToBeginning vs++renderTab :: ViewMessageWindowTab -> ChatState -> Widget Name+renderTab tab cs =+ let latestMessage = case cs^.csViewedMessage of+ Nothing -> error "BUG: no message to show, please report!"+ Just (m, _) -> getLatestMessage cs m+ in case tab of+ VMTabMessage -> viewMessageBox cs latestMessage+ VMTabReactions -> reactionsText cs latestMessage++getLatestMessage :: ChatState -> Message -> Message+getLatestMessage cs m =+ case m^.mMessageId of+ Nothing -> m+ Just mId -> fromJust $ findMessage mId $ cs^.csCurrentChannel.ccContents.cdMessages++handleEvent :: ViewMessageWindowTab -> Vty.Event -> MH ()+handleEvent VMTabMessage =+ handleKeyboardEvent viewMessageKeybindings (const $ return ())+handleEvent VMTabReactions =+ handleKeyboardEvent viewMessageReactionsKeybindings (const $ return ())++reactionsText :: ChatState -> Message -> Widget Name+reactionsText st m = viewport ViewMessageReactionsArea Vertical body+ where+ body = case null reacList of+ True -> txt "This message has no reactions."+ False -> vBox $ mkEntry <$> reacList+ reacList = M.toList (m^.mReactions)+ mkEntry (reactionName, userIdSet) =+ let count = str $ "(" <> show (S.size userIdSet) <> ")"+ name = withDefAttr emojiAttr $ txt $ ":" <> reactionName <> ":"+ usernameList = usernameText userIdSet+ in (name <+> (padLeft (Pad 1) count)) <=>+ (padLeft (Pad 2) usernameList)++ hs = getHighlightSet st++ usernameText uids =+ renderText' hs $+ T.intercalate ", " $+ fmap (userSigil <>) $+ catMaybes (lookupUsername <$> F.toList uids)++ lookupUsername uid = usernameForUserId uid st++viewMessageBox :: ChatState -> Message -> Widget Name+viewMessageBox st msg =+ let maybeWarn = if not (msg^.mDeleted) then id else warn+ warn w = vBox [w, hBorder, deleteWarning]+ deleteWarning = withDefAttr errorMessageAttr $+ txtWrap $ "Alert: this message has been deleted and " <>+ "will no longer be accessible once this window " <>+ "is closed."+ mkBody vpWidth =+ let hs = getHighlightSet st+ parent = case msg^.mInReplyToMsg of+ NotAReply -> Nothing+ InReplyTo pId -> getMessageForPostId st pId+ md = MessageData { mdEditThreshold = Nothing+ , mdShowOlderEdits = False+ , mdMessage = msg+ , mdUserName = msg^.mUser.to (nameForUserRef st)+ , mdParentMessage = parent+ , mdParentUserName = parent >>= (^.mUser.to (nameForUserRef st))+ , mdRenderReplyParent = True+ , mdHighlightSet = hs+ , mdIndentBlocks = True+ , mdThreadState = NoThread+ , mdShowReactions = False+ , mdMessageWidthLimit = Just vpWidth+ }+ in renderMessage md++ in Widget Greedy Greedy $ do+ ctx <- getContext+ render $ maybeWarn $ viewport ViewMessageArea Both $ mkBody (ctx^.availWidthL)++viewMessageKeybindings :: KeyConfig -> [Keybinding]+viewMessageKeybindings =+ let vs = viewportScroll ViewMessageArea+ in mkKeybindings+ [ mkKb PageUpEvent "Page up" $+ mh $ vScrollBy vs (-1 * pageAmount)++ , mkKb PageDownEvent "Page down" $+ mh $ vScrollBy vs pageAmount++ , mkKb ScrollUpEvent "Scroll up" $+ mh $ vScrollBy vs (-1)++ , mkKb ScrollDownEvent "Scroll down" $+ mh $ vScrollBy vs 1++ , mkKb ScrollLeftEvent "Scroll left" $+ mh $ hScrollBy vs (-1)++ , mkKb ScrollRightEvent "Scroll right" $+ mh $ hScrollBy vs 1++ , mkKb ScrollBottomEvent "Scroll to the end of the message" $+ mh $ vScrollToEnd vs++ , mkKb ScrollTopEvent "Scroll to the beginning of the message" $+ mh $ vScrollToBeginning vs+ ]++viewMessageReactionsKeybindings :: KeyConfig -> [Keybinding]+viewMessageReactionsKeybindings =+ let vs = viewportScroll ViewMessageReactionsArea+ in mkKeybindings+ [ mkKb PageUpEvent "Page up" $+ mh $ vScrollBy vs (-1 * pageAmount)++ , mkKb PageDownEvent "Page down" $+ mh $ vScrollBy vs pageAmount++ , mkKb ScrollUpEvent "Scroll up" $+ mh $ vScrollBy vs (-1)++ , mkKb ScrollDownEvent "Scroll down" $+ mh $ vScrollBy vs 1++ , mkKb ScrollBottomEvent "Scroll to the end of the reactions list" $+ mh $ vScrollToEnd vs++ , mkKb ScrollTopEvent "Scroll to the beginning of the reactions list" $+ mh $ vScrollToBeginning vs+ ]