diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 ========= diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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: diff --git a/PRACTICES.md b/PRACTICES.md deleted file mode 100644 --- a/PRACTICES.md +++ /dev/null @@ -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: - -``` -: - - -``` - -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 ` 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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/docs/AUTHORS.txt b/docs/AUTHORS.txt new file mode 100644 --- /dev/null +++ b/docs/AUTHORS.txt @@ -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 +- Adam Wick +- Joram Wilander +- Kelly McLaughlin +- Nicholas Skinsacos +- Ryan Scott +- Thomas M. DuBuisson +- Tristan Ravitch +- Brent Carmer +- @markus9122 +- @jakob diff --git a/docs/PRACTICES.md b/docs/PRACTICES.md new file mode 100644 --- /dev/null +++ b/docs/PRACTICES.md @@ -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: + +``` +: + + +``` + +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 ` 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. diff --git a/matterhorn.cabal b/matterhorn.cabal --- a/matterhorn.cabal +++ b/matterhorn.cabal @@ -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 diff --git a/src/App.hs b/src/App.hs --- a/src/App.hs +++ b/src/App.hs @@ -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) diff --git a/src/Command.hs b/src/Command.hs --- a/src/Command.hs +++ b/src/Command.hs @@ -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 $ \ () -> diff --git a/src/Config.hs b/src/Config.hs --- a/src/Config.hs +++ b/src/Config.hs @@ -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 diff --git a/src/Connection.hs b/src/Connection.hs --- a/src/Connection.hs +++ b/src/Connection.hs @@ -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 ) diff --git a/src/Draw.hs b/src/Draw.hs --- a/src/Draw.hs +++ b/src/Draw.hs @@ -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 diff --git a/src/Draw/ChannelList.hs b/src/Draw/ChannelList.hs --- a/src/Draw/ChannelList.hs +++ b/src/Draw/ChannelList.hs @@ -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 = diff --git a/src/Draw/Main.hs b/src/Draw/Main.hs --- a/src/Draw/Main.hs +++ b/src/Draw/Main.hs @@ -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 ↑]") diff --git a/src/Draw/Messages.hs b/src/Draw/Messages.hs --- a/src/Draw/Messages.hs +++ b/src/Draw/Messages.hs @@ -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 diff --git a/src/Draw/ShowHelp.hs b/src/Draw/ShowHelp.hs --- a/src/Draw/ShowHelp.hs +++ b/src/Draw/ShowHelp.hs @@ -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 diff --git a/src/Draw/TabbedWindow.hs b/src/Draw/TabbedWindow.hs new file mode 100644 --- /dev/null +++ b/src/Draw/TabbedWindow.hs @@ -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 diff --git a/src/Draw/ViewMessage.hs b/src/Draw/ViewMessage.hs deleted file mode 100644 --- a/src/Draw/ViewMessage.hs +++ /dev/null @@ -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 diff --git a/src/Events.hs b/src/Events.hs --- a/src/Events.hs +++ b/src/Events.hs @@ -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 diff --git a/src/Events/Keybindings.hs b/src/Events/Keybindings.hs --- a/src/Events/Keybindings.hs +++ b/src/Events/Keybindings.hs @@ -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 ] diff --git a/src/Events/ManageAttachments.hs b/src/Events/ManageAttachments.hs --- a/src/Events/ManageAttachments.hs +++ b/src/Events/ManageAttachments.hs @@ -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" diff --git a/src/Events/TabbedWindow.hs b/src/Events/TabbedWindow.hs new file mode 100644 --- /dev/null +++ b/src/Events/TabbedWindow.hs @@ -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' + ] diff --git a/src/Events/ViewMessage.hs b/src/Events/ViewMessage.hs deleted file mode 100644 --- a/src/Events/ViewMessage.hs +++ /dev/null @@ -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 - ] diff --git a/src/Markdown.hs b/src/Markdown.hs --- a/src/Markdown.hs +++ b/src/Markdown.hs @@ -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 ("• ") diff --git a/src/State/Attachments.hs b/src/State/Attachments.hs --- a/src/State/Attachments.hs +++ b/src/State/Attachments.hs @@ -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 diff --git a/src/State/Channels.hs b/src/State/Channels.hs --- a/src/State/Channels.hs +++ b/src/State/Channels.hs @@ -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 = diff --git a/src/State/MessageSelect.hs b/src/State/MessageSelect.hs --- a/src/State/MessageSelect.hs +++ b/src/State/MessageSelect.hs @@ -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 () diff --git a/src/State/Messages.hs b/src/State/Messages.hs --- a/src/State/Messages.hs +++ b/src/State/Messages.hs @@ -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 diff --git a/src/State/Setup.hs b/src/State/Setup.hs --- a/src/State/Setup.hs +++ b/src/State/Setup.hs @@ -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. diff --git a/src/State/Setup/Threads.hs b/src/State/Setup/Threads.hs --- a/src/State/Setup/Threads.hs +++ b/src/State/Setup/Threads.hs @@ -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 diff --git a/src/State/Setup/Threads/Logging.hs b/src/State/Setup/Threads/Logging.hs --- a/src/State/Setup/Threads/Logging.hs +++ b/src/State/Setup/Threads/Logging.hs @@ -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 diff --git a/src/TeamSelect.hs b/src/TeamSelect.hs --- a/src/TeamSelect.hs +++ b/src/TeamSelect.hs @@ -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 diff --git a/src/Themes.hs b/src/Themes.hs --- a/src/Themes.hs +++ b/src/Themes.hs @@ -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" diff --git a/src/TimeUtils.hs b/src/TimeUtils.hs --- a/src/TimeUtils.hs +++ b/src/TimeUtils.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs --- a/src/Types.hs +++ b/src/Types.hs @@ -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 () diff --git a/src/Types/KeyEvents.hs b/src/Types/KeyEvents.hs --- a/src/Types/KeyEvents.hs +++ b/src/Types/KeyEvents.hs @@ -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" diff --git a/src/Windows/ViewMessage.hs b/src/Windows/ViewMessage.hs new file mode 100644 --- /dev/null +++ b/src/Windows/ViewMessage.hs @@ -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 + ]