matterhorn 50200.8.0 → 50200.9.0
raw patch · 41 files changed
+1053/−459 lines, 41 filesdep +splitdep ~mattermost-apidep ~mattermost-api-qcdep ~timezone-olson
Dependencies added: split
Dependency ranges changed: mattermost-api, mattermost-api-qc, timezone-olson
Files
- CHANGELOG.md +87/−7
- README.md +41/−24
- docs/commands.md +4/−4
- docs/keybindings.md +83/−55
- matterhorn.cabal +7/−6
- notification-scripts/notify +6/−0
- src/Command.hs +4/−4
- src/Config.hs +32/−1
- src/Draw/Autocomplete.hs +10/−2
- src/Draw/ChannelList.hs +3/−1
- src/Draw/ListOverlay.hs +1/−1
- src/Draw/Main.hs +9/−7
- src/Draw/ShowHelp.hs +101/−58
- src/Emoji.hs +6/−1
- src/Events.hs +28/−7
- src/Events/ChannelListOverlay.hs +10/−3
- src/Events/ChannelSelect.hs +13/−4
- src/Events/Keybindings.hs +114/−36
- src/Events/Main.hs +7/−3
- src/Events/ManageAttachments.hs +10/−6
- src/Events/MessageSelect.hs +6/−3
- src/Events/PostListOverlay.hs +6/−3
- src/Events/ReactionEmojiListOverlay.hs +10/−3
- src/Events/ShowHelp.hs +6/−3
- src/Events/TabbedWindow.hs +9/−3
- src/Events/UrlSelect.hs +6/−3
- src/Events/UserListOverlay.hs +9/−3
- src/KeyMap.hs +1/−1
- src/Login.hs +1/−1
- src/Options.hs +1/−1
- src/State/Autocomplete.hs +76/−57
- src/State/ChannelListOverlay.hs +8/−4
- src/State/Channels.hs +2/−1
- src/State/Editing.hs +123/−66
- src/State/ListOverlay.hs +11/−5
- src/State/MessageSelect.hs +1/−1
- src/State/Setup/Threads.hs +57/−12
- src/Types.hs +42/−12
- src/Types/Common.hs +4/−9
- src/Types/KeyEvents.hs +54/−0
- src/Windows/ViewMessage.hs +44/−38
CHANGELOG.md view
@@ -1,15 +1,95 @@ +50200.9.0+=========++New features:+ * More text-editing keybindings are now rebindable rather than being+ hard-coded. In addition, the keybinding events for text editing are+ now respected by editors for the `/join` window, the `/msg` window,+ the `/members` window, as well as channel selection mode (`C-g`). For+ the complete list of supported configurable keybindings, please see+ the `Text Editing` section of `/help` and `/help keybindings` as well+ as the keybinding tables provided by `matterhorn -k`.+ * Matterhorn now has support for dealing with server API request rate+ limiting. When Matterhorn is denied an API request due to rate+ limiting it will now attempt to reissue the request once the server's+ rate limit has reset. Matterhorn will indicate when it does this by+ displaying an informative message in the current channel. If for+ some reason the second attempt fails, the user will be notified. We+ recommend that users encountering rate limiting issues (e.g. on fast+ connections to their servers) contact their server administrators.+ * Channel selection mode (triggered by event `enter-fast-select` /+ default key: `C-g`) now provides two alternative key events for+ changing the selected entry (#609). These new events are alternatives+ for the existing events:+ * `focus-prev-channel-alternate`, default key: `Up`, alternative to+ `focus-prev-channel`+ * `focus-next-channel-alternate`, default key: `Down`, alternative to+ `focus-next-channel`+ * The message editor's tab completion now supports more intelligent+ completion by detecting punctuation following completions.+ Previously, tab completion would insert the completion followed by+ a trailing space; for example, `@u<TAB>` might complete to `@user`+ followed by a space. While this is often desirable behavior, it+ also meant that if the very next input character was a punctuation+ character such as a period, the final text would be `@user .` Based+ on the observation that usally the intention is to end up with+ `@user.`, the editor now automatically replaces the trailing space+ when such a punctuation character is entered. This behavior is+ configurable with the `smartediting` configuration setting which+ defaults to On. The list of characters that trigger this behavior is:+ `.,'";:)]!?`.++Other improvements:+ * The current user's status is now displayed next to the current user's+ username at the top of the channel sidebar (#594).+ * Help for keybindings was improved to list all available bindings for+ each event. The help text also now makes it clear when an event has a+ non-bindable (fixed) key or has no binding at all. These improvements+ affected the output of `/help`, `/help keybindings`, and the output+ of the command-line options to print keybinding tables.+ * The sample configuration documentation clarified how to use the+ `host` field and also how to use Matterhorn without TLS.+ * The message editor's spell checking no longer checks the spelling of+ tokens that start with slashes or user/channel sigils (#611).+ * Matterhorn now sets the Markdown file extension when editing messages+ in external editors in order to help the external editors detect the+ file type and do syntax highlighting (#590).+ * The help text for the logging commands now makes it clear that the+ logging commands log application debug information, not chat+ messages.+ * The autocompletion list no longer appears if only a single completion+ is available when the user autocompletes input text.++Bug fixes:+ * Parsing for the configuration file's `host` field has been improved+ to accept only valid hostnames and IPv4/IPv6 addresses.+ * Editing a message now properly clears the message editor of any+ preexisting input (#614).+ * The example notification scripts for Linux and macOS have been+ improved with backslash and quote escaping (#613, thanks Bernhard+ Walle).+ * Incoming messages are now sanitized of unprintable characters (#604).+ * Matterhorn is now better behaved when the server has disabled custom+ emoji (#600).+ * Matterhorn's parsing of timezone data is now improved platforms where+ it previously could not parse the timezone files (#542).+ * The `/join` channel list no longer includes channels of which the+ user is already a member (#602).+ * The channel messages now render properly whenever the editor's+ multiline preview changes size (#587).+ 50200.8.0 ========= New features:- * Support for Personal Access Tokens and OAuth tokens was added. To- take advantage of this feature, paste either type of token in the- new "Access Token" field of the login user interface or set up the- new `tokencmd` configuration file setting. See the "Authentication"- section of the README for help and see `docs/sample-config.ini` for- documentation on `tokencmd`. Thanks to @ftilde for early work on this- feature!+ * Support for Personal Access Tokens and browser session tokens was+ added. To take advantage of this feature, paste either type of+ token in the new "Access Token" field of the login user interface+ or set up the new `tokencmd` configuration file setting. See+ the "Authentication" section of the README for help and see+ `docs/sample-config.ini` for documentation on `tokencmd`. Thanks to+ @ftilde for early work on this feature! * The attribute used to render the current user's username can now be customized. By default the attribute still uses the same color as before (chosen based on the username) but is bold. The new theme
README.md view
@@ -16,9 +16,9 @@ # Chat With the Developers The Matterhorn developers hang out on the official Mattermost-pre-release server. Stop by to get support and say hello!+community server. Stop by to get support and say hello! -[https://pre-release.mattermost.com/core/channels/matterhorn](https://pre-release.mattermost.com/core/channels/matterhorn)+[https://community.mattermost.com/core/channels/matterhorn](https://community.mattermost.com/core/channels/matterhorn) # Quick Start @@ -100,6 +100,10 @@ you log in with Matterhorn. As a result, we strongly recommend the use of a Personal Access Token instead if at all possible. +Firefox users: you might consider using the+[mattermost-session-cookie-firefox](https://github.com/ftilde/mattermost-session-cookie-firefox)+script to make this process easier.+ # Configuring For configuration options you have two choices:@@ -236,8 +240,14 @@ * Rebindable keys (see `/help keybindings`) * Message editor with kill/yank buffer and readline-style keybindings * Support for adding and removing emoji post reactions-* Tab-completion of usernames, channel names, commands, emoji, and- fenced code block languages+* Tab-completion of:+ * Usernames: type `@`, then `Tab` to cycle through matches+ * Channel names: type `~`, then `Tab` to cycle through matches+ * Commands: type `/`, then `Tab` to cycle through matches+ * Emoji: type `:` and then some text, then `Tab` to display and cycle+ through matches+ * Fenced code block languages: type three backticks to begin typing a+ code block, then `Tab` to cycle through available languages * Support for attachment upload and download * Spell-checking via Aspell * Syntax highlighting of fenced code blocks in messages (works best in@@ -291,25 +301,6 @@ and is obtained from [the Mattermost web client source tree](https://github.com/mattermost/mattermost-webapp/blob/master/utils/emoji.json). -# Building--If you just want to run Matterhorn, we strongly suggest running a binary-release (see above).--If you want to contribute changes to Matterhorn, you'll need to build-it from source. To do that you'll need an appropriate `ghc`/`cabal`-installation (see the latest Travis-CI builds for tested versions).-You'll also need a GitHub account, since our Git submodules are set up-to use SSH with GitHub.--`matterhorn` is built by running the following commands:--```-$ git pull-$ git submodule update --init-$ ./build.sh-```- # Our Versioning Scheme Matterhorn version strings will be of the form `ABBCC.X.Y` where ABBCC@@ -355,9 +346,14 @@ If you decide to contribute, that's great! Here are some guidelines you should consider to make submitting patches easier for all concerned: + - If you are new to Haskell and are unsure how much Haskell you need+ to know in order to contribute, please see [our list of Haskell+ skills needed](HASKELL.md). - Please base all patches against the `develop` branch unless you are specifically fixing a bug in a released version, in which case- `master` is a fine place to start.+ `master` is a fine place to start. Please also do this for submodules+ that have a `develop` branch if you need to contribute changes to+ submodules. - If you want to take on big things, let's have a design/vision discussion before you start coding. Create a GitHub issue and we can use that as the place to hash things out. We'll be interested to@@ -367,6 +363,27 @@ - We follow a few development practices to support our project and it helps when contributors are aware of these. Please see `docs/PRACTICES.md` for more information.++## Building++If you just want to run Matterhorn, we strongly suggest running a binary+release (see above). *Building from source is only recommended if you+intend to contribute.*++If you want to contribute changes to Matterhorn, you'll need to build+it from source. To do that you'll need an appropriate `ghc`/`cabal`+installation (see the latest Travis-CI builds for tested versions).+You'll also need a GitHub account, since our Git submodules are set up+to use SSH with GitHub. (But that should be fine since you'll need a+GitHub account to contribute anyway.)++`matterhorn` is built by running the following commands:++```+$ git pull+$ git submodule update --init+$ ./build.sh+``` # Frequently Asked Questions
docs/commands.md view
@@ -18,10 +18,10 @@ | `/join <~channel>` | Join the specified channel | | `/leave` | Leave the current channel | | `/left` | Focus on the previous channel |-| `/log-mark <message>` | Add a custom marker message to the Matterhorn log |-| `/log-snapshot <path>` | Dump the current log buffer to the specified path |-| `/log-start <path>` | Begin logging to the specified path |-| `/log-status` | Show current logging status |+| `/log-mark <message>` | Add a custom marker message to the Matterhorn debug log |+| `/log-snapshot <path>` | Dump the current debug log buffer to the specified path |+| `/log-start <path>` | Begin logging debug information to the specified path |+| `/log-status` | Show current debug logging status | | `/log-stop` | Stop logging | | `/me <message>` | Send an emote message | | `/members` | Show the current channel's members |
docs/keybindings.md view
@@ -8,113 +8,141 @@ # Help Page | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Esc`, `C-c` | `cancel` | Return to the previous interface |-| `PgDown` | `page-down` | Page down |+| `Up` | `scroll-up` | Scroll up |+| `Down` | `scroll-down` | Scroll down | | `PgUp` | `page-up` | Page up |+| `PgDown` | `page-down` | Page down |+| `Esc`, `C-c` | `cancel` | Return to the previous interface | | `End` | `scroll-bottom` | Scroll to the end of the help |-| `Down` | `scroll-down` | Scroll down | | `Home` | `scroll-top` | Scroll to the beginning of the help |-| `Up` | `scroll-up` | Scroll up | # Main Interface | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Esc`, `C-c` | `cancel` | Cancel autocomplete, message reply, or edit, in that order |-| `M-l` | `clear-unread` | Clear the current channel's unread / edited indicators |-| `C-g` | `enter-fast-select` | Enter fast channel selection mode |-| `C-o` | `enter-url-open` | Select and open a URL posted to the current channel |-| `M-s` | `focus-last-channel` | Change to the most recently-focused channel |-| `C-n` | `focus-next-channel` | Change to the next channel in the channel list |-| `M-a` | `focus-next-unread` | Change to the next channel with unread messages or return to the channel marked '~' |-| `C-p` | `focus-prev-channel` | Change to the previous channel in the channel list |+| `C-s` | `select-mode` | Select a message to edit/reply/delete |+| `C-r` | `reply-recent` | Reply to the most recent message |+| `M-p` | `toggle-message-preview` | Toggle message preview |+| `F2` | `toggle-channel-list-visibility` | Toggle channel list visibility | | `M-k` | `invoke-editor` | Invoke *$EDITOR* to edit the current message |-| `PgUp` | `page-up` | Page up in the channel message list (enters message select mode) |+| `C-g` | `enter-fast-select` | Enter fast channel selection mode | | `C-q` | `quit` | Quit |-| `C-r` | `reply-recent` | Reply to the most recent message |+| `Tab` | (non-customizable key) | Tab-complete forward |+| `BackTab` | (non-customizable key) | Tab-complete backward |+| `Up` | `scroll-up` | Scroll up in the channel input history | | `Down` | `scroll-down` | Scroll down in the channel input history |+| `PgUp` | `page-up` | Page up in the channel message list (enters message select mode) | | `Home` | `scroll-top` | Scroll to top of channel message list |-| `Up` | `scroll-up` | Scroll up in the channel input history |-| `C-s` | `select-mode` | Select a message to edit/reply/delete |+| `C-n` | `focus-next-channel` | Change to the next channel in the channel list |+| `C-p` | `focus-prev-channel` | Change to the previous channel in the channel list |+| `M-a` | `focus-next-unread` | Change to the next channel with unread messages or return to the channel marked '~' | | `C-x` | `show-attachment-list` | Show the attachment list |-| `M-8` | `show-flagged-posts` | View currently flagged posts |-| `F2` | `toggle-channel-list-visibility` | Toggle channel list visibility |-| `M-p` | `toggle-message-preview` | Toggle message preview |+| `(unbound)` | focus-next-unread-user-or-channel | Change to the next channel with unread messages preferring direct messages |+| `M-s` | `focus-last-channel` | Change to the most recently-focused channel |+| `Enter` | (non-customizable key) | Send the current message |+| `C-o` | `enter-url-open` | Select and open a URL posted to the current channel |+| `M-l` | `clear-unread` | Clear the current channel's unread / edited indicators | | `M-e` | `toggle-multiline` | Toggle multi-line message compose mode |+| `Esc`, `C-c` | `cancel` | Cancel autocomplete, message reply, or edit, in that order |+| `M-8` | `show-flagged-posts` | View currently flagged posts | # Channel Select Mode | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |+| `Enter` | (non-customizable key) | Switch to selected channel | | `Esc`, `C-c` | `cancel` | Cancel channel selection | | `C-n` | `focus-next-channel` | Select next match | | `C-p` | `focus-prev-channel` | Select previous match |+| `Down` | `focus-next-channel-alternate` | Select next match (alternate binding) |+| `Up` | `focus-prev-channel-alternate` | Select previous match (alternate binding) | # URL Select Mode | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |+| `Enter` | (non-customizable key) | Open the selected URL, if any | | `Esc`, `C-c` | `cancel` | Cancel URL selection |-| `j`, `Down` | `select-down` | Move cursor down | | `k`, `Up` | `select-up` | Move cursor up |+| `j`, `Down` | `select-down` | Move cursor down |+| `q` | (non-customizable key) | Cancel URL selection | # Message Select Mode | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- | | `Esc`, `C-c` | `cancel` | Cancel message selection |-| `d` | `delete-message` | Delete the selected message (with confirmation) |-| `e` | `edit-message` | Begin editing the selected message |-| `Enter` | `fetch-for-gap` | Fetch messages for the selected gap |-| `f` | `flag-message` | Flag the selected message |-| `o` | `open-message-url` | Open all URLs in the selected message |-| `PgDown` | `page-down` | Move the cursor down by 10 messages |+| `k`, `Up` | `select-up` | Select the previous message |+| `j`, `Down` | `select-down` | Select the next message |+| `Home` | `scroll-top` | Scroll to top and select the oldest message |+| `End` | `scroll-bottom` | Scroll to bottom and select the latest message | | `PgUp` | `page-up` | Move the cursor up by 10 messages |-| `p` | `pin-message` | Toggle whether the selected message is pinned |-| `a` | `react-to-message` | Post a reaction to the selected message |+| `PgDown` | `page-down` | Move the cursor down by 10 messages |+| `o` | `open-message-url` | Open all URLs in the selected message | | `r` | `reply-message` | Begin composing a reply to the selected message |-| `End` | `scroll-bottom` | Scroll to bottom and select the latest message |-| `Home` | `scroll-top` | Scroll to top and select the oldest message |-| `j`, `Down` | `select-down` | Select the next message |-| `k`, `Up` | `select-up` | Select the previous message |-| `v` | `view-message` | View the selected message |+| `e` | `edit-message` | Begin editing the selected message |+| `d` | `delete-message` | Delete the selected message (with confirmation) | | `y` | `yank-message` | Copy a verbatim section or message to the clipboard | | `Y` | `yank-whole-message` | Copy an entire message to the clipboard |+| `p` | `pin-message` | Toggle whether the selected message is pinned |+| `f` | `flag-message` | Flag the selected message |+| `v` | `view-message` | View the selected message |+| `Enter` | `fetch-for-gap` | Fetch messages for the selected gap |+| `a` | `react-to-message` | Post a reaction to the selected message | +# Text Editing+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `C-t` | `editor-transpose-chars` | Transpose the final two characters |+| `C-a` | `editor-beginning-of-line` | Go to the start of the current line |+| `C-e` | `editor-end-of-line` | Go to the end of the current line |+| `C-d` | `editor-delete-char` | Delete the character at the cursor |+| `C-u` | `editor-kill-to-beginning-of-line` | Delete from the cursor to the start of the current line |+| `C-k` | `editor-kill-to-end-of-line` | Kill the line to the right of the current position and copy it |+| `C-f` | `editor-next-char` | Move one character to the right |+| `C-b` | `editor-prev-char` | Move one character to the left |+| `M-f` | `editor-next-word` | Move one word to the right |+| `M-b` | `editor-prev-word` | Move one word to the left |+| `C-w`, `M-Backspace` | `editor-delete-prev-word` | Delete the word to the left of the cursor |+| `M-d` | `editor-delete-next-word` | Delete the word to the right of the cursor |+| `Home` | `editor-home` | Move the cursor to the beginning of the input |+| `End` | `editor-end` | Move the cursor to the end of the input |+| `C-y` | `editor-yank` | Paste the current buffer contents at the cursor |+ # Flagged Messages | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Enter` | `activate-list-item` | Jump to and select current message | | `Esc`, `C-c` | `cancel` | Exit post browsing |-| `f` | `flag-message` | Toggle the selected message flag |-| `j`, `Down` | `select-down` | Select the next message | | `k`, `Up` | `select-up` | Select the previous message |+| `j`, `Down` | `select-down` | Select the next message |+| `f` | `flag-message` | Toggle the selected message flag |+| `Enter` | `activate-list-item` | Jump to and select current message | # User Listings | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Enter` | `activate-list-item` | Interact with the selected user | | `Esc`, `C-c` | `cancel` | Close the user search list |+| `C-p`, `Up` | `search-select-up` | Select the previous user |+| `C-n`, `Down` | `search-select-down` | Select the next user | | `PgDown` | `page-down` | Page down in the user list | | `PgUp` | `page-up` | Page up in the user list |-| `C-n`, `Down` | `search-select-down` | Select the next user |-| `C-p`, `Up` | `search-select-up` | Select the previous user |+| `Enter` | `activate-list-item` | Interact with the selected user | # Channel Search Window | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Enter` | `activate-list-item` | Join the selected channel | | `Esc`, `C-c` | `cancel` | Close the channel search list |+| `C-p`, `Up` | `search-select-up` | Select the previous channel |+| `C-n`, `Down` | `search-select-down` | Select the next channel | | `PgDown` | `page-down` | Page down in the channel list | | `PgUp` | `page-up` | Page up in the channel list |-| `C-n`, `Down` | `search-select-down` | Select the next channel |-| `C-p`, `Up` | `search-select-up` | Select the previous channel |+| `Enter` | `activate-list-item` | Join the selected channel | # Reaction Emoji Search Window | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Enter` | `activate-list-item` | Post the selected emoji reaction | | `Esc`, `C-c` | `cancel` | Close the emoji search window |+| `C-p`, `Up` | `search-select-up` | Select the previous emoji |+| `C-n`, `Down` | `search-select-down` | Select the next emoji | | `PgDown` | `page-down` | Page down in the emoji list | | `PgUp` | `page-up` | Page up in the emoji list |-| `C-n`, `Down` | `search-select-down` | Select the next emoji |-| `C-p`, `Up` | `search-select-up` | Select the previous emoji |+| `Enter` | `activate-list-item` | Post the selected emoji reaction | # Message Viewer: Common | Keybinding | Event Name | Description |@@ -126,32 +154,32 @@ # Message Viewer: Message tab | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `PgDown` | `page-down` | Page down | | `PgUp` | `page-up` | Page up |-| `End` | `scroll-bottom` | Scroll to the end of the message |+| `PgDown` | `page-down` | Page down |+| `Up` | `scroll-up` | Scroll up | | `Down` | `scroll-down` | Scroll down | | `Left` | `scroll-left` | Scroll left | | `Right` | `scroll-right` | Scroll right |+| `End` | `scroll-bottom` | Scroll to the end of the message | | `Home` | `scroll-top` | Scroll to the beginning of the message |-| `Up` | `scroll-up` | Scroll up | # Message Viewer: Reactions tab | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `PgDown` | `page-down` | Page down | | `PgUp` | `page-up` | Page up |-| `End` | `scroll-bottom` | Scroll to the end of the reactions list |+| `PgDown` | `page-down` | Page down |+| `Up` | `scroll-up` | Scroll up | | `Down` | `scroll-down` | Scroll down |+| `End` | `scroll-bottom` | Scroll to the end of the reactions list | | `Home` | `scroll-top` | Scroll to the beginning of the reactions list |-| `Up` | `scroll-up` | Scroll up | # Attachment List | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `a` | `add-to-attachment-list` | Add a new attachment to the attachment list | | `Esc`, `C-c` | `cancel` | Close attachment list |-| `d` | `delete-from-attachment-list` | Delete the selected attachment from the attachment list |-| `o` | `open-attachment` | Open the selected attachment using the URL open command |-| `j`, `Down` | `select-down` | Move cursor down | | `k`, `Up` | `select-up` | Move cursor up |+| `j`, `Down` | `select-down` | Move cursor down |+| `a` | `add-to-attachment-list` | Add a new attachment to the attachment list |+| `o` | `open-attachment` | Open the selected attachment using the URL open command |+| `d` | `delete-from-attachment-list` | Delete the selected attachment from the attachment list |
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.8.0+version: 50200.9.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@@ -136,10 +136,11 @@ NoImplicitPrelude ghc-options: -Wall -threaded -with-rtsopts=-I0 -Wcompat build-depends: base >=4.8 && <5- , mattermost-api == 50200.5.0+ , mattermost-api == 50200.6.0 , base-compat >= 0.9 && < 0.12 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7+ , split >= 0.2 && < 0.3 , data-clist >= 0.1.2 && < 0.2 , semigroups >= 0.18 && < 0.20 , connection >= 0.2 && < 0.4@@ -172,7 +173,7 @@ , stm-delay >= 0.1 && < 0.2 , unix >= 2.7.1.0 && < 2.7.3.0 , skylighting-core >= 0.8 && < 0.9- , timezone-olson >= 0.1.7 && < 0.2+ , timezone-olson >= 0.2 && < 0.3 , timezone-series >= 0.1.6.1 && < 0.2 , aeson >= 1.2.3.0 && < 1.5 , async >= 2.2 && < 2.3@@ -211,8 +212,8 @@ , filepath >= 1.4 && < 1.5 , hashable >= 1.2 && < 1.4 , Hclip >= 3.0 && < 3.1- , mattermost-api == 50200.5.0- , mattermost-api-qc == 50200.5.0+ , mattermost-api == 50200.6.0+ , mattermost-api-qc == 50200.6.0 , microlens-platform >= 0.3 && < 0.5 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7@@ -226,7 +227,7 @@ , text >= 1.2 && < 1.3 , text-zipper >= 0.10 && < 0.11 , time >= 1.6 && < 2.0- , timezone-olson >= 0.1.7 && < 0.2+ , timezone-olson >= 0.2 && < 0.3 , timezone-series >= 0.1.6.1 && < 0.2 , transformers >= 0.4 && < 0.6 , Unique >= 0.4 && < 0.5
notification-scripts/notify view
@@ -27,6 +27,12 @@ # Notification header notify_HEAD="Matterhorn message from $sender" +# Escape backslashes in the message+message="${message//\\/\\\\}"++# Escape double quotes in the message+message="${message//\"/\\\"}"+ # Notification body notify_BODY="$message"
src/Command.hs view
@@ -164,11 +164,11 @@ handleInputSubmission cId msg Nothing -> mhError $ NoSuchUser name - , Cmd "log-start" "Begin logging to the specified path"+ , Cmd "log-start" "Begin logging debug information to the specified path" (TokenArg "path" NoArg) $ \ (path, ()) -> startLogging $ T.unpack path - , Cmd "log-snapshot" "Dump the current log buffer to the specified path"+ , Cmd "log-snapshot" "Dump the current debug log buffer to the specified path" (TokenArg "path" NoArg) $ \ (path, ()) -> logSnapshot $ T.unpack path @@ -176,11 +176,11 @@ NoArg $ \ () -> stopLogging - , Cmd "log-mark" "Add a custom marker message to the Matterhorn log"+ , Cmd "log-mark" "Add a custom marker message to the Matterhorn debug log" (LineArg "message") $ \ markMsg -> mhLog LogUserMark markMsg - , Cmd "log-status" "Show current logging status"+ , Cmd "log-status" "Show current debug logging status" NoArg $ \ () -> getLogDestination
src/Config.hs view
@@ -16,6 +16,9 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Class ( lift ) import Config.Schema+import Data.Char ( isDigit, isAlpha )+import Data.List ( isPrefixOf )+import Data.List.Split ( splitOn ) import qualified Data.Map.Strict as M import qualified Data.Text as T import qualified Data.Text.IO as T@@ -24,6 +27,7 @@ import System.FilePath ( (</>), takeDirectory, splitPath, joinPath ) import System.Process ( readProcess ) import Network.Mattermost.Types (ConnectionType(..))+import Network.URI ( isIPv4address, isIPv6address ) import FilePaths import IOUtil@@ -68,7 +72,7 @@ fromIni = do conf <- section "mattermost" $ do configUser <- fieldMbOf "user" stringField- configHost <- fieldMbOf "host" stringField+ configHost <- fieldMbOf "host" hostField configTeam <- fieldMbOf "team" stringField configPort <- fieldDefOf "port" number (configPort defaultConfig) configUrlPath <- fieldMbOf "urlPath" stringField@@ -87,6 +91,8 @@ configURLOpenCommandInteractive <- fieldFlagDef "urlOpenCommandIsInteractive" False configSmartBacktick <- fieldFlagDef "smartbacktick" (configSmartBacktick defaultConfig)+ configSmartEditing <- fieldFlagDef "smartediting"+ (configSmartEditing defaultConfig) configShowOlderEdits <- fieldFlagDef "showOlderEdits" (configShowOlderEdits defaultConfig) configShowBackground <- fieldDefOf "showBackgroundActivity" backgroundField@@ -132,6 +138,30 @@ syntaxDirsField :: Text -> Either String [FilePath] syntaxDirsField = listWithSeparator ":" string +validHostnameFragmentChar :: Char -> Bool+validHostnameFragmentChar c = isAlpha c || isDigit c || c == '-'++isHostnameFragment :: String -> Bool+isHostnameFragment "" = False+isHostnameFragment s = all validHostnameFragmentChar s++isHostname :: String -> Bool+isHostname "" = False+isHostname s =+ let parts@(h:_) = splitOn "." s+ in all isHostnameFragment parts && not ("-" `isPrefixOf` h)++hostField :: Text -> Either String Text+hostField t =+ let s = T.unpack t+ valid = or [ isIPv4address s+ , isIPv6address s+ , isHostname s+ ]+ in if valid+ then Right t+ else Left "Invalid 'host' value, must be a hostname or IPv4/IPv6 address"+ expandTilde :: FilePath -> FilePath -> FilePath expandTilde homeDir p = let parts = splitPath p@@ -193,6 +223,7 @@ , configTheme = Nothing , configThemeCustomizationFile = Nothing , configSmartBacktick = True+ , configSmartEditing = True , configURLOpenCommand = Nothing , configURLOpenCommandInteractive = False , configActivityNotifyCommand = Nothing
src/Draw/Autocomplete.hs view
@@ -32,6 +32,13 @@ userNotInChannelMarker :: T.Text userNotInChannelMarker = "*" +elementTypeLabel :: AutocompletionType -> Text+elementTypeLabel ACUsers = "Users"+elementTypeLabel ACChannels = "Channels"+elementTypeLabel ACCodeBlockLanguage = "Languages"+elementTypeLabel ACEmoji = "Emoji"+elementTypeLabel ACCommands = "Commands"+ renderAutocompleteBox :: ChatState -> AutocompleteState -> Widget Name renderAutocompleteBox st ac = let matchList = _acCompletionList ac@@ -40,8 +47,9 @@ numResults = length elements elements = matchList^.listElementsL label = withDefAttr clientMessageAttr $- txt $ _acListElementType ac <> ": " <> (T.pack $ show numResults) <>- " match" <> if numResults == 1 then "" else "es"+ txt $ elementTypeLabel (ac^.acType) <> ": " <> (T.pack $ show numResults) <>+ " match" <> (if numResults == 1 then "" else "es") <>+ " (Tab/Shift-Tab to select)" selElem = snd <$> listSelectedElement matchList curChan = st^.csCurrentChannel
src/Draw/ChannelList.hs view
@@ -58,8 +58,10 @@ withDefAttr clientEmphAttr $ txt $ "Team: " <> teamNameStr myUsername_ = myUsername st+ me = userById (myUserId st) st+ statusSigil = maybe ' ' userSigilFromInfo me selfHeader = hCenter $- colorUsername myUsername_ myUsername_ (userSigil <> myUsername_)+ colorUsername myUsername_ myUsername_ (T.singleton statusSigil <> " " <> userSigil <> myUsername_) teamNameStr = sanitizeUserText $ MM.teamDisplayName $ st^.csMyTeam body = case appMode st of ChannelSelect ->
src/Draw/ListOverlay.hs view
@@ -66,7 +66,7 @@ else case st^.listOverlaySearchResults.L.listSelectedL of Nothing -> hBorder Just _ ->- let msg = "Showing " <> show numSearchResults <> " result" <> plural numSearchResults+ let msg = "Found " <> show numSearchResults <> " result" <> plural numSearchResults in hBorderWithLabel $ str $ "[" <> msg <> "]" scope = st^.listOverlaySearchScope
src/Draw/Main.hs view
@@ -12,6 +12,7 @@ import Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents ) import Control.Arrow ( (>>>) ) import Data.Char ( isSpace, isPunctuation )+import qualified Data.Map as M import qualified Data.Sequence as Seq import qualified Data.Set as S import qualified Data.Text as T@@ -203,7 +204,8 @@ then Left t else Right t - ignoreChar c = isSpace c || isPunctuation c || c == '`'+ ignoreChar c = isSpace c || isPunctuation c || c == '`' || c == '/' ||+ T.singleton c == userSigil || T.singleton c == normalChannelSigil tokenize t curTok | T.null t = [curTok]@@ -443,13 +445,13 @@ -- make sure these keybinding pieces are up-to-date! ev e = let keyconf = st^.csResources.crConfiguration.to configUserKeys- keymap = messageSelectKeybindings keyconf+ KeyHandlerMap keymap = messageSelectKeybindings keyconf in T.intercalate ","- [ ppBinding (eventToBinding b)- | KB { kbBindingInfo = Just e'- , kbEvent = b- } <- keymap- , e' == e+ [ ppBinding (eventToBinding k)+ | KH { khKey = k+ , khHandler = h+ } <- M.elems keymap+ , kehEventTrigger h == ByEvent e ] options = [ ( not . isGap , ev YankWholeMessageEvent
src/Draw/ShowHelp.hs view
@@ -40,10 +40,11 @@ import HelpTopics ( helpTopics ) import Markdown ( renderText ) import Options ( mhVersion )-import State.Editing ( editingKeybindings )+import State.Editing ( editingKeyHandlers ) import Themes import Types-import Types.KeyEvents ( Binding(..), ppBinding, nonCharKeys, eventToBinding )+import Types.KeyEvents ( BindingState(..), Binding(..)+ , ppBinding, nonCharKeys, eventToBinding ) drawShowHelp :: HelpTopic -> ChatState -> [Widget Name]@@ -70,7 +71,7 @@ , mkCommandHelpText , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybindings" ] <>- (mkKeybindingHelp <$> keybindSections kc)+ (mkKeybindingHelp kc <$> keybindSections) mkCommandHelpText :: Widget Name mkCommandHelpText =@@ -166,8 +167,8 @@ keybindingMarkdownTable :: KeyConfig -> Text keybindingMarkdownTable kc = title <> keybindSectionStrings where title = "# Keybindings\n"- keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc- sectionText = mkKeybindEventSectionHelp keybindEventHelpMarkdown T.unlines mkHeading+ keybindSectionStrings = T.concat $ sectionText <$> keybindSections+ sectionText = mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines mkHeading mkHeading n = "\n# " <> n <> "\n| Keybinding | Event Name | Description |" <>@@ -176,8 +177,8 @@ keybindingTextTable :: KeyConfig -> Text keybindingTextTable kc = title <> keybindSectionStrings where title = "Keybindings\n===========\n"- keybindSectionStrings = T.concat $ catMaybes $ sectionText <$> keybindSections kc- sectionText = mkKeybindEventSectionHelp (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines mkHeading+ keybindSectionStrings = T.concat $ sectionText <$> keybindSections+ sectionText = mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines mkHeading keybindingWidth = 15 eventNameWidth = 30 mkHeading n =@@ -193,8 +194,8 @@ [ padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybinding Syntax" , padTop (Pad 1) $ hCenter $ vBox validKeys ]- where keybindSectionWidgets = catMaybes $ sectionWidget <$> keybindSections kc- sectionWidget = mkKeybindEventSectionHelp keybindEventHelpWidget vBox mkSectionHeading+ where keybindSectionWidgets = sectionWidget <$> keybindSections+ sectionWidget = mkKeybindEventSectionHelp kc keybindEventHelpWidget vBox mkSectionHeading mkSectionHeading = hCenter . padTop (Pad 1) . withDefAttr helpEmphAttr . txt keybindingHelpText = map (padTop (Pad 1) . renderText . mconcat)@@ -402,23 +403,23 @@ attrNameToConfig :: AttrName -> Text attrNameToConfig = T.pack . intercalate "." . attrNameComponents -keybindSections :: KeyConfig -> [(Text, [Keybinding])]-keybindSections kc =- [ ("Global Keybindings", globalKeybindings kc)- , ("Help Page", helpKeybindings kc)- , ("Main Interface", mainKeybindings kc)- , ("Channel Select Mode", channelSelectKeybindings kc)- , ("URL Select Mode", urlSelectKeybindings kc)- , ("Message Select Mode", messageSelectKeybindings kc)- , ("Text Editing", editingKeybindings)- , ("Flagged Messages", postListOverlayKeybindings kc)- , ("User Listings", userListOverlayKeybindings kc)- , ("Channel Search Window", channelListOverlayKeybindings kc)- , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeybindings 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)+keybindSections :: [(Text, [KeyEventHandler])]+keybindSections =+ [ ("Global Keybindings", globalKeyHandlers)+ , ("Help Page", helpKeyHandlers)+ , ("Main Interface", mainKeyHandlers)+ , ("Channel Select Mode", channelSelectKeyHandlers)+ , ("URL Select Mode", urlSelectKeyHandlers)+ , ("Message Select Mode", messageSelectKeyHandlers)+ , ("Text Editing", editingKeyHandlers (csEditState.cedEditor))+ , ("Flagged Messages", postListOverlayKeyHandlers)+ , ("User Listings", userListOverlayKeyHandlers)+ , ("Channel Search Window", channelListOverlayKeyHandlers)+ , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeyHandlers)+ , ("Message Viewer: Common", tabbedWindowKeyHandlers (csViewedMessage.singular _Just._2))+ , ("Message Viewer: Message tab", viewMessageKeyHandlers)+ , ("Message Viewer: Reactions tab", viewMessageReactionsKeyHandlers)+ , ("Attachment List", attachmentListKeyHandlers) ] helpBox :: Name -> Widget Name -> Widget Name@@ -429,59 +430,101 @@ cached n helpText kbColumnWidth :: Int-kbColumnWidth = 12+kbColumnWidth = 14 kbDescColumnWidth :: Int kbDescColumnWidth = 60 -mkKeybindingHelp :: (Text, [Keybinding]) -> Widget Name-mkKeybindingHelp (sectionName, kbs) =+mkKeybindingHelp :: KeyConfig -> (Text, [KeyEventHandler]) -> Widget Name+mkKeybindingHelp kc (sectionName, kbs) = (hCenter $ padTop (Pad 1) $ withDefAttr helpEmphAttr $ txt sectionName) <=>- (hCenter $ vBox $ mkKeybindHelp <$> (sortWith (ppBinding.eventToBinding.kbEvent) kbs))+ (hCenter $ vBox $ snd <$> sortWith fst results)+ where+ results = mkKeybindHelp kc <$> kbs -mkKeybindHelp :: Keybinding -> Widget Name-mkKeybindHelp (KB desc ev _ _) =- (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $ ppBinding $ eventToBinding ev) <+>- (hLimit kbDescColumnWidth $ padRight Max $ renderText desc)+mkKeybindHelp :: KeyConfig -> KeyEventHandler -> (Text, Widget Name)+mkKeybindHelp kc h =+ let unbound = ["(unbound)"]+ label = case kehEventTrigger h of+ Static k -> ppBinding $ eventToBinding k+ ByEvent ev ->+ let bindings = case M.lookup ev kc of+ Nothing ->+ let bs = defaultBindings ev+ in if not $ null bs+ then ppBinding <$> defaultBindings ev+ else unbound+ Just Unbound -> unbound+ Just (BindingList bs) | not (null bs) -> ppBinding <$> bs+ | otherwise -> unbound+ in T.intercalate ", " bindings -mkKeybindEventSectionHelp :: ((Text, Text, [Text]) -> a)+ rendering = (withDefAttr helpEmphAttr $ txt $ padTo kbColumnWidth $+ label) <+> txt " " <+>+ (hLimit kbDescColumnWidth $ padRight Max $ renderText $+ ehDescription $ kehHandler h)+ in (label, rendering)++mkKeybindEventSectionHelp :: KeyConfig+ -> ((Either Text Text, Text, [Text]) -> a) -> ([a] -> a) -> (Text -> a)- -> (Text, [Keybinding])- -> Maybe a-mkKeybindEventSectionHelp mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) =- let lst = sortWith (fmap keyEventName . kbBindingInfo . head) $ groupWith kbBindingInfo kbs- in if all (all (isNothing . kbBindingInfo)) lst- then Nothing- else Just $- vertCat $ (mkHeading sectionName) :- (mkKeybindHelpFunc <$> (catMaybes $ mkKeybindEventHelp <$> lst))+ -> (Text, [KeyEventHandler])+ -> a+mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) =+ vertCat $ (mkHeading sectionName) :+ (mkKeybindHelpFunc <$> (mkKeybindEventHelp kc <$> kbs)) -keybindEventHelpWidget :: (Text, Text, [Text]) -> Widget Name+keybindEventHelpWidget :: (Either Text Text, Text, [Text]) -> Widget Name keybindEventHelpWidget (evName, desc, evs) = let evText = T.intercalate ", " evs+ label = case evName of+ Left s -> txt $ "; " <> s+ Right s -> withDefAttr helpEmphAttr $ txt s in vBox [ txt (padTo 72 ("; " <> desc))- , (withDefAttr helpEmphAttr $ txt evName) <+> txt (" = " <> evText)+ , label <+> txt (" = " <> evText) , str " " ] -keybindEventHelpMarkdown :: (Text, Text, [Text]) -> Text+keybindEventHelpMarkdown :: (Either Text Text, Text, [Text]) -> Text keybindEventHelpMarkdown (evName, desc, evs) = let quote s = "`" <> s <> "`"- in "| " <> (T.intercalate ", " $ quote <$> evs) <> " | " <> quote evName <> " | " <> desc <> " |"+ name = case evName of+ Left s -> s+ Right s -> quote s+ in "| " <> (T.intercalate ", " $ quote <$> evs) <>+ " | " <> name <>+ " | " <> desc <>+ " |" -keybindEventHelpText :: Int -> Int -> (Text, Text, [Text]) -> Text+keybindEventHelpText :: Int -> Int -> (Either Text Text, Text, [Text]) -> Text keybindEventHelpText width eventNameWidth (evName, desc, evs) =- padTo width (T.intercalate ", " evs) <> " " <>- padTo eventNameWidth evName <> " " <>- desc+ let name = case evName of+ Left s -> s+ Right s -> s+ in padTo width (T.intercalate ", " evs) <> " " <>+ padTo eventNameWidth name <> " " <>+ desc -mkKeybindEventHelp :: [Keybinding] -> Maybe (Text, Text, [Text])-mkKeybindEventHelp ks@(KB desc _ _ (Just e):_) =- let evs = [ ev | KB _ ev _ _ <- ks ]- evText = map (ppBinding . eventToBinding) evs- in Just (keyEventName e, desc, evText)-mkKeybindEventHelp _ = Nothing+mkKeybindEventHelp :: KeyConfig -> KeyEventHandler -> (Either Text Text, Text, [Text])+mkKeybindEventHelp kc h =+ let trig = kehEventTrigger h+ unbound = ["(unbound)"]+ (label, evText) = case trig of+ Static key -> (Left "(non-customizable key)", [ppBinding $ eventToBinding key])+ ByEvent ev -> case M.lookup ev kc of+ Nothing ->+ let name = keyEventName ev+ in if not (null (defaultBindings ev))+ then (Right name, ppBinding <$> defaultBindings ev)+ else (Left name, unbound)+ Just Unbound -> (Right $ keyEventName ev, unbound)+ Just (BindingList bs) -> (Right $ keyEventName ev,+ if not (null bs)+ then ppBinding <$> bs+ else unbound+ )+ in (label, ehDescription $ kehHandler h, evText) padTo :: Int -> Text -> Text padTo n s = s <> T.replicate (n - T.length s) " "
src/Emoji.hs view
@@ -86,9 +86,14 @@ getMatchingEmoji session em rawSearchString = do let localAlts = lookupEmoji em rawSearchString sanitized = sanitizeEmojiSearch rawSearchString- custom <- case T.null sanitized of+ customResult <- E.try $ case T.null sanitized of True -> MM.mmGetListOfCustomEmoji Nothing Nothing session False -> MM.mmSearchCustomEmoji sanitized session++ let custom = case customResult of+ Left (_::E.SomeException) -> []+ Right result -> result+ return $ sort $ (MM.emojiName <$> custom) <> localAlts stripColons :: T.Text -> T.Text
src/Events.hs view
@@ -1,6 +1,7 @@ module Events ( onEvent , globalKeybindings+ , globalKeyHandlers ) where @@ -76,6 +77,22 @@ refreshChannelsAndUsers refreshClientConfig fetchVisibleIfNeeded+onAppEvent (RateLimitExceeded winSz) =+ mhError $ GenericError $ T.pack $+ let s = if winSz == 1 then "" else "s"+ in "The server's API request rate limit was exceeded; Matterhorn will " <>+ "retry the failed request in " <> show winSz <> " second" <> s <>+ ". Please contact your Mattermost administrator " <>+ "about API rate limiting issues."+onAppEvent RateLimitSettingsMissing =+ mhError $ GenericError $+ "A request was rate-limited but could not be retried due to rate " <>+ "limit settings missing"+onAppEvent RequestDropped =+ mhError $ GenericError $+ "An API request was retried and dropped due to a rate limit. Matterhorn " <>+ "may now be inconsistent with the server. Please contact your " <>+ "Mattermost administrator about API rate limiting issues." onAppEvent BGIdle = csWorkerIsBusy .= Nothing onAppEvent (BGBusy n) =@@ -160,16 +177,16 @@ mh invalidateCache _ -> return () - handleKeyboardEvent globalKeybindings handleGlobalEvent e+ void $ handleKeyboardEvent globalKeybindings handleGlobalEvent e handleGlobalEvent :: Vty.Event -> MH () handleGlobalEvent e = do mode <- gets appMode case mode of Main -> onEventMain e- ShowHelp _ _ -> onEventShowHelp e- ChannelSelect -> onEventChannelSelect e- UrlSelect -> onEventUrlSelect e+ ShowHelp _ _ -> void $ onEventShowHelp e+ ChannelSelect -> void $ onEventChannelSelect e+ UrlSelect -> void $ onEventUrlSelect e LeaveChannelConfirm -> onEventLeaveChannelConfirm e MessageSelect -> onEventMessageSelect e MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e@@ -178,12 +195,15 @@ UserListOverlay -> onEventUserListOverlay e ChannelListOverlay -> onEventChannelListOverlay e ReactionEmojiListOverlay -> onEventReactionEmojiListOverlay e- ViewMessage -> handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e+ ViewMessage -> void $ handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e ManageAttachments -> onEventManageAttachments e ManageAttachmentsBrowseFiles -> onEventManageAttachments e -globalKeybindings :: KeyConfig -> [Keybinding]-globalKeybindings = mkKeybindings+globalKeybindings :: KeyConfig -> KeyHandlerMap+globalKeybindings = mkKeybindings globalKeyHandlers++globalKeyHandlers :: [KeyEventHandler]+globalKeyHandlers = [ mkKb ShowHelpEvent "Show this help screen" (showHelpScreen mainHelpTopic)@@ -324,6 +344,7 @@ WMTeamDeleted -> return () WMUserUpdated -> return () WMLeaveTeam -> return ()+ WMChannelMemberUpdated {} -> return () -- We deliberately ignore these events: WMChannelCreated -> return ()
src/Events/ChannelListOverlay.hs view
@@ -1,9 +1,13 @@ module Events.ChannelListOverlay ( onEventChannelListOverlay , channelListOverlayKeybindings+ , channelListOverlayKeyHandlers ) where +import Prelude ()+import Prelude.MH+ import qualified Graphics.Vty as Vty import Events.Keybindings@@ -14,11 +18,14 @@ onEventChannelListOverlay :: Vty.Event -> MH () onEventChannelListOverlay =- onEventListOverlay csChannelListOverlay channelListOverlayKeybindings+ void . onEventListOverlay csChannelListOverlay channelListOverlayKeybindings -- | The keybindings we want to use while viewing a channel list overlay-channelListOverlayKeybindings :: KeyConfig -> [Keybinding]-channelListOverlayKeybindings = mkKeybindings+channelListOverlayKeybindings :: KeyConfig -> KeyHandlerMap+channelListOverlayKeybindings = mkKeybindings channelListOverlayKeyHandlers++channelListOverlayKeyHandlers :: [KeyEventHandler]+channelListOverlayKeyHandlers = [ mkKb CancelEvent "Close the channel search list" (exitListOverlay csChannelListOverlay) , mkKb SearchSelectUpEvent "Select the previous channel" channelListSelectUp , mkKb SearchSelectDownEvent "Select the next channel" channelListSelectDown
src/Events/ChannelSelect.hs view
@@ -9,18 +9,25 @@ import Events.Keybindings import State.Channels import State.ChannelSelect+import State.Editing ( editingKeybindings ) import Types import qualified Zipper as Z -onEventChannelSelect :: Vty.Event -> MH ()+onEventChannelSelect :: Vty.Event -> MH Bool onEventChannelSelect = handleKeyboardEvent channelSelectKeybindings $ \e -> do- mhHandleEventLensed (csChannelSelectState.channelSelectInput) handleEditorEvent e+ handled <- handleKeyboardEvent (editingKeybindings (csChannelSelectState.channelSelectInput)) (const $ return ()) e+ when (not handled) $+ mhHandleEventLensed (csChannelSelectState.channelSelectInput) handleEditorEvent e+ updateChannelSelectMatches -channelSelectKeybindings :: KeyConfig -> [Keybinding]-channelSelectKeybindings = mkKeybindings+channelSelectKeybindings :: KeyConfig -> KeyHandlerMap+channelSelectKeybindings = mkKeybindings channelSelectKeyHandlers++channelSelectKeyHandlers :: [KeyEventHandler]+channelSelectKeyHandlers = [ staticKb "Switch to selected channel" (Vty.EvKey Vty.KEnter []) $ do matches <- use (csChannelSelectState.channelSelectMatches)@@ -33,4 +40,6 @@ , mkKb CancelEvent "Cancel channel selection" $ setMode Main , mkKb NextChannelEvent "Select next match" channelSelectNext , mkKb PrevChannelEvent "Select previous match" channelSelectPrevious+ , mkKb NextChannelEventAlternate "Select next match (alternate binding)" channelSelectNext+ , mkKb PrevChannelEventAlternate "Select previous match (alternate binding)" channelSelectPrevious ]
src/Events/Keybindings.hs view
@@ -9,8 +9,13 @@ , handleKeyboardEvent + , EventHandler(..)+ , KeyHandler(..)+ , KeyEventHandler(..)+ , KeyEventTrigger(..)+ , KeyHandlerMap(..)+ -- Re-exports:- , Keybinding (..) , KeyEvent (..) , KeyConfig , allEvents@@ -35,46 +40,101 @@ -- * Keybindings --- | A 'Keybinding' represents a keybinding along with its--- implementation-data Keybinding =- KB { kbDescription :: Text- , kbEvent :: Vty.Event- , kbAction :: MH ()- , kbBindingInfo :: Maybe KeyEvent+-- | An 'EventHandler' represents a event handler.+data EventHandler =+ EH { ehDescription :: Text+ -- ^ The description of this handler's behavior.+ , ehAction :: MH ()+ -- ^ The action to take when this handler is invoked. } +-- | A trigger for a key event.+data KeyEventTrigger =+ Static Vty.Event+ -- ^ The key event is always triggered by a specific key.+ | ByEvent KeyEvent+ -- ^ The key event is always triggered by an abstract key event (and+ -- thus configured to be bound to specific key(s) in the KeyConfig).+ deriving (Show, Eq, Ord)++-- | A handler for an abstract key event.+data KeyEventHandler =+ KEH { kehHandler :: EventHandler+ -- ^ The handler to invoke.+ , kehEventTrigger :: KeyEventTrigger+ -- ^ The trigger for the handler.+ }++-- | A handler for a specific key.+data KeyHandler =+ KH { khHandler :: KeyEventHandler+ -- ^ The handler to invoke.+ , khKey :: Vty.Event+ -- ^ The specific key that should trigger this handler.+ }++newtype KeyHandlerMap = KeyHandlerMap (M.Map Vty.Event KeyHandler)+ -- | Find a keybinding that matches a Vty Event-lookupKeybinding :: Vty.Event -> [Keybinding] -> Maybe Keybinding-lookupKeybinding e kbs = case filter ((== e) . kbEvent) kbs of- [] -> Nothing- (x:_) -> Just x+lookupKeybinding :: Vty.Event -> KeyHandlerMap -> Maybe KeyHandler+lookupKeybinding e (KeyHandlerMap m) = M.lookup e m -handleKeyboardEvent- :: (KeyConfig -> [Keybinding])- -> (Vty.Event -> MH ())- -> Vty.Event- -> MH ()-handleKeyboardEvent keyList fallthrough e = do+-- | Handle a keyboard event by looking it up in a map of bindings and+-- invoking the matching binding's handler. If no match can be found,+-- invoke a fallback action instead. Return True if the key event was+-- handled with a matching binding; False if not (the fallback case).+handleKeyboardEvent :: (KeyConfig -> KeyHandlerMap)+ -- ^ The function to build a key handler map from a+ -- key configuration.+ -> (Vty.Event -> MH ())+ -- ^ The fallback action to invoke if no matching+ -- binding can be found.+ -> Vty.Event+ -- ^ The event to handle.+ -> MH Bool+handleKeyboardEvent mkKeyMap fallthrough e = do conf <- use (csResources.crConfiguration)- let keyMap = keyList (configUserKeys conf)+ let keyMap = mkKeyMap (configUserKeys conf) case lookupKeybinding e keyMap of- Just kb -> kbAction kb- Nothing -> fallthrough e+ Just kh -> (ehAction $ kehHandler $ khHandler kh) >> return True+ Nothing -> fallthrough e >> return False -mkKb :: KeyEvent -> Text -> MH () -> KeyConfig -> [Keybinding]-mkKb ev msg action conf =- [ KB msg (bindingToEvent key) action (Just ev) | key <- allKeys ]- where allKeys | Just (BindingList ks) <- M.lookup ev conf = ks- | Just Unbound <- M.lookup ev conf = []- | otherwise = defaultBindings ev+mkHandler :: Text -> MH () -> EventHandler+mkHandler msg action =+ EH { ehDescription = msg+ , ehAction = action+ } -staticKb :: Text -> Vty.Event -> MH () -> KeyConfig -> [Keybinding]-staticKb msg event action _ = [KB msg event action Nothing]+mkKb :: KeyEvent -> Text -> MH () -> KeyEventHandler+mkKb ev msg action =+ KEH { kehHandler = mkHandler msg action+ , kehEventTrigger = ByEvent ev+ } -mkKeybindings :: [KeyConfig -> [Keybinding]] -> KeyConfig -> [Keybinding]-mkKeybindings ks conf = concat [ k conf | k <- ks ]+keyHandlerFromConfig :: KeyConfig -> KeyEventHandler -> [KeyHandler]+keyHandlerFromConfig conf eh =+ case kehEventTrigger eh of+ Static key ->+ [ KH eh key ]+ ByEvent ev ->+ [ KH eh (bindingToEvent b) | b <- allBindings ]+ where allBindings | Just (BindingList ks) <- M.lookup ev conf = ks+ | Just Unbound <- M.lookup ev conf = []+ | otherwise = defaultBindings ev +staticKb :: Text -> Vty.Event -> MH () -> KeyEventHandler+staticKb msg event action =+ KEH { kehHandler = mkHandler msg action+ , kehEventTrigger = Static event+ }++mkKeybindings :: [KeyEventHandler] -> KeyConfig -> KeyHandlerMap+mkKeybindings ks conf = KeyHandlerMap $ M.fromList pairs+ where+ pairs = mkPair <$> handlers+ mkPair h = (khKey h, h)+ handlers = concat $ keyHandlerFromConfig conf <$> ks+ bindingToEvent :: Binding -> Vty.Event bindingToEvent binding = Vty.EvKey (kbKey binding) (kbMods binding)@@ -103,6 +163,8 @@ QuitEvent -> [ ctrl (key 'q') ] NextChannelEvent -> [ ctrl (key 'n') ] PrevChannelEvent -> [ ctrl (key 'p') ]+ NextChannelEventAlternate -> [ kb Vty.KDown ]+ PrevChannelEventAlternate -> [ kb Vty.KUp ] NextUnreadChannelEvent -> [ meta (key 'a') ] ShowAttachmentListEvent -> [ ctrl (key 'x') ] NextUnreadUserOrChannelEvent -> [ ]@@ -127,7 +189,7 @@ SelectDownEvent -> [ key 'j', kb Vty.KDown ] ActivateListItemEvent -> [ kb Vty.KEnter ] SearchSelectUpEvent -> [ ctrl (key 'p'), kb Vty.KUp ]- SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ]+ SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ] ViewMessageEvent -> [ key 'v' ] FillGapEvent -> [ kb Vty.KEnter ] FlagMessageEvent -> [ key 'f' ]@@ -143,6 +205,21 @@ AttachmentListDeleteEvent -> [ key 'd' ] AttachmentOpenEvent -> [ key 'o' ] CancelEvent -> [ kb Vty.KEsc, ctrl (key 'c') ]+ EditorBolEvent -> [ ctrl (key 'a') ]+ EditorEolEvent -> [ ctrl (key 'e') ]+ EditorTransposeCharsEvent -> [ ctrl (key 't') ]+ EditorDeleteCharacter -> [ ctrl (key 'd') ]+ EditorKillToBolEvent -> [ ctrl (key 'u') ]+ EditorKillToEolEvent -> [ ctrl (key 'k') ]+ EditorPrevCharEvent -> [ ctrl (key 'b') ]+ EditorNextCharEvent -> [ ctrl (key 'f') ]+ EditorPrevWordEvent -> [ meta (key 'b') ]+ EditorNextWordEvent -> [ meta (key 'f') ]+ EditorDeleteNextWordEvent -> [ meta (key 'd') ]+ EditorDeletePrevWordEvent -> [ ctrl (key 'w'), meta (kb Vty.KBS) ]+ EditorHomeEvent -> [ kb Vty.KHome ]+ EditorEndEvent -> [ kb Vty.KEnd ]+ EditorYankEvent -> [ ctrl (key 'y') ] -- | Given a configuration, we want to check it for internal consistency -- (i.e. that a given keybinding isn't associated with multiple events@@ -150,7 +227,7 @@ -- basic usability (i.e. we shouldn't be binding events which can appear -- in the main UI to a key like @e@, which would prevent us from being -- able to type messages containing an @e@ in them!-ensureKeybindingConsistency :: KeyConfig -> [(String, KeyConfig -> [Keybinding])] -> Either String ()+ensureKeybindingConsistency :: KeyConfig -> [(String, KeyConfig -> KeyHandlerMap)] -> Either String () ensureKeybindingConsistency kc modeMaps = mapM_ checkGroup allBindings where -- This is a list of lists, grouped by keybinding, of all the@@ -230,10 +307,11 @@ -- We generate the which-events-are-valid-in-which-modes map from -- our actual keybinding set, so this should never get out of date.+ modeMap :: KeyEvent -> [String] modeMap ev =- let bindingHasEvent (KB _ _ _ (Just ev')) = ev == ev'- bindingHasEvent _ = False+ let matches kh = ByEvent ev == (kehEventTrigger $ khHandler kh) in [ mode | (mode, mkBindings) <- modeMaps- , any bindingHasEvent (mkBindings kc)+ , let KeyHandlerMap m = mkBindings kc+ in not $ null $ M.filter matches m ]
src/Events/Main.hs view
@@ -21,14 +21,18 @@ onEventMain :: Vty.Event -> MH () onEventMain =- handleKeyboardEvent mainKeybindings $ \ ev -> do+ void . handleKeyboardEvent mainKeybindings (\ ev -> do resetReturnChannel case ev of (Vty.EvPaste bytes) -> handlePaste bytes _ -> handleEditingInput ev+ ) -mainKeybindings :: KeyConfig -> [Keybinding]-mainKeybindings = mkKeybindings+mainKeybindings :: KeyConfig -> KeyHandlerMap+mainKeybindings = mkKeybindings mainKeyHandlers++mainKeyHandlers :: [KeyEventHandler]+mainKeyHandlers = [ mkKb EnterSelectModeEvent "Select a message to edit/reply/delete" beginMessageSelect
src/Events/ManageAttachments.hs view
@@ -4,6 +4,7 @@ ( onEventManageAttachments , attachmentListKeybindings , attachmentBrowseKeybindings+ , attachmentListKeyHandlers ) where @@ -31,17 +32,20 @@ onEventManageAttachments e = do mode <- gets appMode case mode of- ManageAttachments -> onEventAttachmentList e+ ManageAttachments -> void $ onEventAttachmentList e ManageAttachmentsBrowseFiles -> onEventBrowseFile e _ -> error "BUG: onEventManageAttachments called in invalid mode" -onEventAttachmentList :: V.Event -> MH ()+onEventAttachmentList :: V.Event -> MH Bool onEventAttachmentList = handleKeyboardEvent attachmentListKeybindings $ mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent -attachmentListKeybindings :: KeyConfig -> [Keybinding]-attachmentListKeybindings = mkKeybindings+attachmentListKeybindings :: KeyConfig -> KeyHandlerMap+attachmentListKeybindings = mkKeybindings attachmentListKeyHandlers++attachmentListKeyHandlers :: [KeyEventHandler]+attachmentListKeyHandlers = [ mkKb CancelEvent "Close attachment list" (setMode Main) , mkKb SelectUpEvent "Move cursor up" $@@ -56,7 +60,7 @@ deleteSelectedAttachment ] -attachmentBrowseKeybindings :: KeyConfig -> [Keybinding]+attachmentBrowseKeybindings :: KeyConfig -> KeyHandlerMap attachmentBrowseKeybindings = mkKeybindings [ mkKb CancelEvent "Cancel attachment file browse" cancelAttachmentBrowse@@ -99,7 +103,7 @@ withFileBrowser $ \b -> do case FB.fileBrowserIsSearching b of False ->- handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e+ void $ handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e True -> handleFileBrowserEvent e
src/Events/MessageSelect.hs view
@@ -17,7 +17,7 @@ onEventMessageSelect :: Vty.Event -> MH () onEventMessageSelect =- handleKeyboardEvent messageSelectKeybindings $ \ _ -> return ()+ void . handleKeyboardEvent messageSelectKeybindings (const $ return ()) onEventMessageSelectDeleteConfirm :: Vty.Event -> MH () onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do@@ -26,8 +26,11 @@ onEventMessageSelectDeleteConfirm _ = setMode Main -messageSelectKeybindings :: KeyConfig -> [Keybinding]-messageSelectKeybindings = mkKeybindings+messageSelectKeybindings :: KeyConfig -> KeyHandlerMap+messageSelectKeybindings = mkKeybindings messageSelectKeyHandlers++messageSelectKeyHandlers :: [KeyEventHandler]+messageSelectKeyHandlers = [ mkKb CancelEvent "Cancel message selection" $ setMode Main
src/Events/PostListOverlay.hs view
@@ -12,11 +12,14 @@ onEventPostListOverlay :: Vty.Event -> MH () onEventPostListOverlay =- handleKeyboardEvent postListOverlayKeybindings $ \ _ -> return ()+ void . handleKeyboardEvent postListOverlayKeybindings (const $ return ()) -- | The keybindings we want to use while viewing a post list overlay-postListOverlayKeybindings :: KeyConfig -> [Keybinding]-postListOverlayKeybindings = mkKeybindings+postListOverlayKeybindings :: KeyConfig -> KeyHandlerMap+postListOverlayKeybindings = mkKeybindings postListOverlayKeyHandlers++postListOverlayKeyHandlers :: [KeyEventHandler]+postListOverlayKeyHandlers = [ mkKb CancelEvent "Exit post browsing" exitPostListMode , mkKb SelectUpEvent "Select the previous message" postListSelectUp , mkKb SelectDownEvent "Select the next message" postListSelectDown
src/Events/ReactionEmojiListOverlay.hs view
@@ -1,9 +1,13 @@ module Events.ReactionEmojiListOverlay ( onEventReactionEmojiListOverlay , reactionEmojiListOverlayKeybindings+ , reactionEmojiListOverlayKeyHandlers ) where +import Prelude ()+import Prelude.MH+ import qualified Graphics.Vty as Vty import Events.Keybindings@@ -14,11 +18,14 @@ onEventReactionEmojiListOverlay :: Vty.Event -> MH () onEventReactionEmojiListOverlay =- onEventListOverlay csReactionEmojiListOverlay reactionEmojiListOverlayKeybindings+ void . onEventListOverlay csReactionEmojiListOverlay reactionEmojiListOverlayKeybindings -- | The keybindings we want to use while viewing an emoji list overlay-reactionEmojiListOverlayKeybindings :: KeyConfig -> [Keybinding]-reactionEmojiListOverlayKeybindings = mkKeybindings+reactionEmojiListOverlayKeybindings :: KeyConfig -> KeyHandlerMap+reactionEmojiListOverlayKeybindings = mkKeybindings reactionEmojiListOverlayKeyHandlers++reactionEmojiListOverlayKeyHandlers :: [KeyEventHandler]+reactionEmojiListOverlayKeyHandlers = [ mkKb CancelEvent "Close the emoji search window" (exitListOverlay csReactionEmojiListOverlay) , mkKb SearchSelectUpEvent "Select the previous emoji" reactionEmojiListSelectUp , mkKb SearchSelectDownEvent "Select the next emoji" reactionEmojiListSelectDown
src/Events/ShowHelp.hs view
@@ -11,14 +11,17 @@ import Types -onEventShowHelp :: Vty.Event -> MH ()+onEventShowHelp :: Vty.Event -> MH Bool onEventShowHelp = handleKeyboardEvent helpKeybindings $ \ e -> case e of Vty.EvKey _ _ -> popMode _ -> return () -helpKeybindings :: KeyConfig -> [Keybinding]-helpKeybindings = mkKeybindings+helpKeybindings :: KeyConfig -> KeyHandlerMap+helpKeybindings = mkKeybindings helpKeyHandlers++helpKeyHandlers :: [KeyEventHandler]+helpKeyHandlers = [ mkKb ScrollUpEvent "Scroll up" $ mh $ vScrollBy (viewportScroll HelpViewport) (-1) , mkKb ScrollDownEvent "Scroll down" $
src/Events/TabbedWindow.hs view
@@ -2,6 +2,7 @@ module Events.TabbedWindow ( handleTabbedWindowEvent , tabbedWindowKeybindings+ , tabbedWindowKeyHandlers ) where @@ -18,7 +19,7 @@ handleTabbedWindowEvent :: (Show a, Eq a) => Lens' ChatState (TabbedWindow a) -> Vty.Event- -> MH ()+ -> MH Bool handleTabbedWindowEvent target e = do w <- use target handleKeyboardEvent (tabbedWindowKeybindings target) (forwardEvent w) e@@ -34,8 +35,13 @@ tabbedWindowKeybindings :: (Show a, Eq a) => Lens' ChatState (TabbedWindow a) -> KeyConfig- -> [Keybinding]-tabbedWindowKeybindings target = mkKeybindings+ -> KeyHandlerMap+tabbedWindowKeybindings target = mkKeybindings $ tabbedWindowKeyHandlers target++tabbedWindowKeyHandlers :: (Show a, Eq a)+ => Lens' ChatState (TabbedWindow a)+ -> [KeyEventHandler]+tabbedWindowKeyHandlers target = [ mkKb CancelEvent "Close window" $ do w <- use target setMode (twReturnMode w)
src/Events/UrlSelect.hs view
@@ -11,13 +11,16 @@ import Types -onEventUrlSelect :: Vty.Event -> MH ()+onEventUrlSelect :: Vty.Event -> MH Bool onEventUrlSelect = handleKeyboardEvent urlSelectKeybindings $ \ ev -> mhHandleEventLensed csUrlList handleListEvent ev -urlSelectKeybindings :: KeyConfig -> [Keybinding]-urlSelectKeybindings = mkKeybindings+urlSelectKeybindings :: KeyConfig -> KeyHandlerMap+urlSelectKeybindings = mkKeybindings urlSelectKeyHandlers++urlSelectKeyHandlers :: [KeyEventHandler]+urlSelectKeyHandlers = [ staticKb "Open the selected URL, if any" (Vty.EvKey Vty.KEnter []) $ do openSelectedURL
src/Events/UserListOverlay.hs view
@@ -1,5 +1,8 @@ module Events.UserListOverlay where +import Prelude ()+import Prelude.MH+ import qualified Graphics.Vty as Vty import Events.Keybindings@@ -10,11 +13,14 @@ onEventUserListOverlay :: Vty.Event -> MH () onEventUserListOverlay =- onEventListOverlay csUserListOverlay userListOverlayKeybindings+ void . onEventListOverlay csUserListOverlay userListOverlayKeybindings -- | The keybindings we want to use while viewing a user list overlay-userListOverlayKeybindings :: KeyConfig -> [Keybinding]-userListOverlayKeybindings = mkKeybindings+userListOverlayKeybindings :: KeyConfig -> KeyHandlerMap+userListOverlayKeybindings = mkKeybindings userListOverlayKeyHandlers++userListOverlayKeyHandlers :: [KeyEventHandler]+userListOverlayKeyHandlers = [ mkKb CancelEvent "Close the user search list" (exitListOverlay csUserListOverlay) , mkKb SearchSelectUpEvent "Select the previous user" userListSelectUp , mkKb SearchSelectDownEvent "Select the next user" userListSelectDown
src/KeyMap.hs view
@@ -15,7 +15,7 @@ import Events.UrlSelect import Events.ManageAttachments -keybindingModeMap :: [(String, KeyConfig -> [Keybinding])]+keybindingModeMap :: [(String, KeyConfig -> KeyHandlerMap)] keybindingModeMap = [ ("main", mainKeybindings) , ("help screen", helpKeybindings)
src/Login.hs view
@@ -408,7 +408,7 @@ , (above "Provide a username and password:" . label "Username:") @@= editTextField ciUsername Username (Just 1) , label "Password:" @@= editPasswordField ciPassword Password- , (above "Or provide an OAuth or Personal Access Token:" .+ , (above "Or provide a Session or Personal Access Token:" . label "Access Token:") @@= editPasswordField ciAccessToken AccessToken ]
src/Options.hs view
@@ -57,7 +57,7 @@ "Path to the configuration file" , Option ['l'] ["logs"] (ReqArg (\ path c -> c { optLogLocation = Just path }) "PATH")- "Path to the desired debug logs"+ "Debug log output path" , Option ['v'] ["version"] (NoArg (\ c -> c { optBehaviour = ShowVersion })) "Print version information and exit"
src/State/Autocomplete.hs view
@@ -59,15 +59,25 @@ result <- getCompleterForInput ctx case result of Nothing -> resetAutocomplete- Just (runUpdater, searchString) -> do+ Just (ty, runUpdater, searchString) -> do prevResult <- use (csEditState.cedAutocomplete)- let shouldUpdate = maybe True ((/= searchString) . _acPreviousSearchString)- prevResult+ -- We should update the completion state if EITHER:+ --+ -- 1) The type changed+ --+ -- or+ --+ -- 2) The search string changed but the type did NOT change+ let shouldUpdate = ((maybe True ((/= searchString) . _acPreviousSearchString)+ prevResult) &&+ (maybe True ((== ty) . _acType) prevResult)) ||+ (maybe False ((/= ty) . _acType) prevResult) when shouldUpdate $ do csEditState.cedAutocompletePending .= Just searchString- runUpdater ctx searchString+ runUpdater ty ctx searchString -getCompleterForInput :: AutocompleteContext -> MH (Maybe (AutocompleteContext -> Text -> MH (), Text))+getCompleterForInput :: AutocompleteContext+ -> MH (Maybe (AutocompletionType, AutocompletionType -> AutocompleteContext -> Text -> MH (), Text)) getCompleterForInput ctx = do z <- use (csEditState.cedEditor.editContentsL) @@ -77,40 +87,41 @@ return $ case wordAtColumn col curLine of Just (startCol, w) | userSigil `T.isPrefixOf` w ->- Just (doUserAutoCompletion, T.tail w)+ Just (ACUsers, doUserAutoCompletion, T.tail w) | normalChannelSigil `T.isPrefixOf` w ->- Just (doChannelAutoCompletion, T.tail w)+ Just (ACChannels, doChannelAutoCompletion, T.tail w) | ":" `T.isPrefixOf` w && autocompleteManual ctx ->- Just (doEmojiAutoCompletion, T.tail w)+ Just (ACEmoji, doEmojiAutoCompletion, T.tail w) | "```" `T.isPrefixOf` w ->- Just (doSyntaxAutoCompletion, T.drop 3 w)+ Just (ACCodeBlockLanguage, doSyntaxAutoCompletion, T.drop 3 w) | "/" `T.isPrefixOf` w && startCol == 0 ->- Just (doCommandAutoCompletion, T.tail w)+ Just (ACCommands, doCommandAutoCompletion, T.tail w) _ -> Nothing -doEmojiAutoCompletion :: AutocompleteContext -> Text -> MH ()-doEmojiAutoCompletion ctx searchString = do+-- Completion implementations++doEmojiAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doEmojiAutoCompletion ty ctx searchString = do session <- getSession em <- use (csResources.crEmoji)- let label = "Emoji"- withCachedAutocompleteResults ctx label searchString $+ withCachedAutocompleteResults ctx ty searchString $ doAsyncWith Preempt $ do results <- getMatchingEmoji session em searchString let alts = EmojiCompletion <$> results- return $ Just $ setCompletionAlternatives ctx searchString alts label+ return $ Just $ setCompletionAlternatives ctx searchString alts ty -doSyntaxAutoCompletion :: AutocompleteContext -> Text -> MH ()-doSyntaxAutoCompletion ctx searchString = do+doSyntaxAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doSyntaxAutoCompletion ty ctx searchString = do mapping <- use (csResources.crSyntaxMap) let allNames = Sky.sShortname <$> M.elems mapping (prefixed, notPrefixed) = partition isPrefixed $ filter match allNames match = (((T.toLower searchString) `T.isInfixOf`) . T.toLower) isPrefixed = (((T.toLower searchString) `T.isPrefixOf`) . T.toLower) alts = SyntaxCompletion <$> (sort prefixed <> sort notPrefixed)- setCompletionAlternatives ctx searchString alts "Languages"+ setCompletionAlternatives ctx searchString alts ty -doCommandAutoCompletion :: AutocompleteContext -> Text -> MH ()-doCommandAutoCompletion ctx searchString = do+doCommandAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doCommandAutoCompletion ty ctx searchString = do let alts = mkAlt <$> sortBy compareCommands (filter matches commandList) compareCommands a b = let isAPrefix = searchString `T.isPrefixOf` cmdName a@@ -125,41 +136,16 @@ lowerSearch `T.isInfixOf` (T.toLower $ cmdDescr c) mkAlt (Cmd name desc args _) = CommandCompletion name (printArgSpec args) desc- setCompletionAlternatives ctx searchString alts "Commands"---- | Attempt to re-use a cached autocomplete alternative list for--- a given search string. If the cache contains no such entry (keyed--- on search string), run the specified action, which is assumed to be--- responsible for fetching the completion results from the server.-withCachedAutocompleteResults :: AutocompleteContext- -- ^ The autocomplete context- -> Text- -- ^ The autocomplete UI label for the- -- results to be used- -> Text- -- ^ The search string to look for in the- -- cache- -> MH ()- -- ^ The action to execute on a cache miss- -> MH ()-withCachedAutocompleteResults ctx label searchString act = do- mCache <- preuse (csEditState.cedAutocomplete._Just.acCachedResponses)-- -- Does the cache have results for this search string? If so, use- -- them; otherwise invoke the specified action.- case HM.lookup searchString =<< mCache of- Just alts -> setCompletionAlternatives ctx searchString alts label- Nothing -> act+ setCompletionAlternatives ctx searchString alts ty -doUserAutoCompletion :: AutocompleteContext -> Text -> MH ()-doUserAutoCompletion ctx searchString = do+doUserAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doUserAutoCompletion ty ctx searchString = do session <- getSession myTid <- gets myTeamId myUid <- gets myUserId cId <- use csCurrentChannelId- let label = "Users" - withCachedAutocompleteResults ctx label searchString $+ withCachedAutocompleteResults ctx ty searchString $ doAsyncWith Preempt $ do ac <- MM.mmAutocompleteUsers (Just myTid) (Just cId) searchString session @@ -176,32 +162,65 @@ , (T.toLower searchString) `T.isInfixOf` specialMentionName m ] - return $ Just $ setCompletionAlternatives ctx searchString (extras <> alts) label+ return $ Just $ setCompletionAlternatives ctx searchString (extras <> alts) ty -doChannelAutoCompletion :: AutocompleteContext -> Text -> MH ()-doChannelAutoCompletion ctx searchString = do+doChannelAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doChannelAutoCompletion ty ctx searchString = do session <- getSession tId <- gets myTeamId- let label = "Channels" cs <- use csChannels - withCachedAutocompleteResults ctx label searchString $ do+ withCachedAutocompleteResults ctx ty searchString $ do doAsyncWith Preempt $ do results <- MM.mmAutocompleteChannels tId searchString session let alts = F.toList $ (ChannelCompletion True <$> inChannels) <> (ChannelCompletion False <$> notInChannels) (inChannels, notInChannels) = Seq.partition isMember results isMember c = isJust $ findChannelById (channelId c) cs- return $ Just $ setCompletionAlternatives ctx searchString alts label+ return $ Just $ setCompletionAlternatives ctx searchString alts ty -setCompletionAlternatives :: AutocompleteContext -> Text -> [AutocompleteAlternative] -> Text -> MH ()+-- Utility functions++-- | Attempt to re-use a cached autocomplete alternative list for+-- a given search string. If the cache contains no such entry (keyed+-- on search string), run the specified action, which is assumed to be+-- responsible for fetching the completion results from the server.+withCachedAutocompleteResults :: AutocompleteContext+ -- ^ The autocomplete context+ -> AutocompletionType+ -- ^ The type of autocompletion we're+ -- doing+ -> Text+ -- ^ The search string to look for in the+ -- cache+ -> MH ()+ -- ^ The action to execute on a cache miss+ -> MH ()+withCachedAutocompleteResults ctx ty searchString act = do+ mCache <- preuse (csEditState.cedAutocomplete._Just.acCachedResponses)+ mActiveTy <- preuse (csEditState.cedAutocomplete._Just.acType)++ case Just ty == mActiveTy of+ True ->+ -- Does the cache have results for this search string? If+ -- so, use them; otherwise invoke the specified action.+ case HM.lookup searchString =<< mCache of+ Just alts -> setCompletionAlternatives ctx searchString alts ty+ Nothing -> act+ False -> act++setCompletionAlternatives :: AutocompleteContext+ -> Text+ -> [AutocompleteAlternative]+ -> AutocompletionType+ -> MH () setCompletionAlternatives ctx searchString alts ty = do let list = L.list CompletionList (V.fromList $ F.toList alts) 1 state = AutocompleteState { _acPreviousSearchString = searchString , _acCompletionList = list & L.listSelectedL .~ Nothing- , _acListElementType = ty , _acCachedResponses = HM.fromList [(searchString, alts)]+ , _acType = ty } pending <- use (csEditState.cedAutocompletePending)
src/State/ChannelListOverlay.hs view
@@ -15,6 +15,7 @@ import qualified Data.Vector as Vec import qualified Data.Sequence as Seq import Data.Function ( on )+import Lens.Micro.Platform ( to ) import Network.Mattermost.Types import qualified Network.Mattermost.Endpoints as MM@@ -27,8 +28,9 @@ enterChannelListOverlayMode :: MH () enterChannelListOverlayMode = do myTId <- gets myTeamId+ myChannels <- use (csChannels.to (filteredChannelIds (const True))) enterListOverlayMode csChannelListOverlay ChannelListOverlay- AllChannels enterHandler (fetchResults myTId)+ AllChannels enterHandler (fetchResults myTId myChannels) enterHandler :: Channel -> MH Bool enterHandler chan = do@@ -36,6 +38,8 @@ return True fetchResults :: TeamId+ -> [ChannelId]+ -- ^ The channels to exclude from the results -> ChannelSearchScope -- ^ The scope to search -> Session@@ -43,10 +47,10 @@ -> Text -- ^ The search string -> IO (Vec.Vector Channel)-fetchResults myTId AllChannels session searchString = do+fetchResults myTId exclude AllChannels session searchString = do resultChans <- MM.mmSearchChannels myTId searchString session- -- chans <- Seq.filter (\ c -> not (channelId c `elem` myChannels)) <$> loop mempty 0- let sortedChans = Vec.fromList $ toList $ Seq.sortBy (compare `on` channelName) resultChans+ let filteredChans = Seq.filter (\ c -> not (channelId c `elem` exclude)) resultChans+ sortedChans = Vec.fromList $ toList $ Seq.sortBy (compare `on` channelName) filteredChans return sortedChans -- | Move the selection up in the channel list overlay by one channel.
src/State/Channels.hs view
@@ -107,7 +107,8 @@ -- Schedule the current sidebar for user status updates at the end -- of this MH action. newZ <- use csFocus- scheduleUserStatusFetches newZ+ myId <- gets myUserId+ scheduleUserStatusFetches $ myId : userIdsFromZipper newZ -- If the zipper rebuild caused the current channel to change, such -- as when the previously-focused channel was removed, we need to
src/State/Editing.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-} module State.Editing ( requestSpellCheck , editingKeybindings+ , editingKeyHandlers+ , messageEditingKeybindings , toggleMultilineEditing , invokeExternalEditor , handlePaste@@ -29,14 +32,15 @@ import qualified Data.ByteString as BS import Data.Char ( isSpace ) import qualified Data.Foldable as F+import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Zipper as Z import qualified Data.Text.Zipper.Generic.Words as Z import Data.Time ( getCurrentTime )-import Graphics.Vty ( Event(..), Key(..), Modifier(..) )-import Lens.Micro.Platform ( (%=), (.=), (.~), to, _Just )+import Graphics.Vty ( Event(..), Key(..) )+import Lens.Micro.Platform ( Lens', (%=), (.=), (.~), to, _Just ) import qualified System.Environment as Sys import qualified System.Exit as Sys import qualified System.IO as Sys@@ -55,7 +59,7 @@ import State.Attachments import State.Messages import Types hiding ( newState )-import Types.Common ( sanitizeChar, sanitizeUserText' )+import Types.Common ( sanitizeUserText' ) startMultilineEditing :: MH ()@@ -88,7 +92,7 @@ let editorProgram = maybe "vi" id mEnv mhSuspendAndResume $ \ st -> do- Sys.withSystemTempFile "matterhorn_editor.tmp" $ \tmpFileName tmpFileHandle -> do+ Sys.withSystemTempFile "matterhorn_editor.md" $ \tmpFileName tmpFileHandle -> do -- Write the current message to the temp file Sys.hPutStr tmpFileHandle $ T.unpack $ T.intercalate "\n" $ getEditContents $ st^.csEditState.cedEditor@@ -124,68 +128,75 @@ (length (getEditContents $ st^.csEditState.cedEditor) == 1) || st^.csEditState.cedEphemeral.eesMultiline -editingKeybindings :: [Keybinding]-editingKeybindings =- let kb desc ev mote = KB desc ev mote Nothing in- map withUserTypingAction- [ kb "Transpose the final two characters"- (EvKey (KChar 't') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.transposeChars- , kb "Go to the start of the current line"- (EvKey (KChar 'a') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.gotoBOL- , kb "Go to the end of the current line"- (EvKey (KChar 'e') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.gotoEOL- , kb "Delete the character at the cursor"- (EvKey (KChar 'd') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.deleteChar- , kb "Delete from the cursor to the start of the current line"- (EvKey (KChar 'u') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.killToBOL- , kb "Move one character to the right"- (EvKey (KChar 'f') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.moveRight- , kb "Move one character to the left"- (EvKey (KChar 'b') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.moveLeft- , kb "Move one word to the right"- (EvKey (KChar 'f') [MMeta]) $ do- csEditState.cedEditor %= applyEdit Z.moveWordRight- , kb "Move one word to the left"- (EvKey (KChar 'b') [MMeta]) $ do- csEditState.cedEditor %= applyEdit Z.moveWordLeft- , kb "Delete the word to the left of the cursor"- (EvKey KBS [MMeta]) $ do- csEditState.cedEditor %= applyEdit Z.deletePrevWord- , kb "Delete the word to the left of the cursor"- (EvKey (KChar 'w') [MCtrl]) $ do- csEditState.cedEditor %= applyEdit Z.deletePrevWord- , kb "Delete the word to the right of the cursor"- (EvKey (KChar 'd') [MMeta]) $ do- csEditState.cedEditor %= applyEdit Z.deleteWord- , kb "Move the cursor to the beginning of the input"- (EvKey KHome []) $ do- csEditState.cedEditor %= applyEdit gotoHome- , kb "Move the cursor to the end of the input"- (EvKey KEnd []) $ do- csEditState.cedEditor %= applyEdit gotoEnd- , kb "Kill the line to the right of the current position and copy it"- (EvKey (KChar 'k') [MCtrl]) $ do- z <- use (csEditState.cedEditor.editContentsL)+messageEditingKeybindings :: KeyConfig -> KeyHandlerMap+messageEditingKeybindings kc =+ let KeyHandlerMap m = editingKeybindings (csEditState.cedEditor) kc+ in KeyHandlerMap $ M.map withUserTypingAction m++withUserTypingAction :: KeyHandler -> KeyHandler+withUserTypingAction kh =+ kh { khHandler = newH }+ where+ oldH = khHandler kh+ newH = oldH { kehHandler = newKEH }+ oldKEH = kehHandler oldH+ newKEH = oldKEH { ehAction = ehAction oldKEH >> sendUserTypingAction }++editingKeybindings :: Lens' ChatState (Editor T.Text Name) -> KeyConfig -> KeyHandlerMap+editingKeybindings editor = mkKeybindings $ editingKeyHandlers editor++editingKeyHandlers :: Lens' ChatState (Editor T.Text Name) -> [KeyEventHandler]+editingKeyHandlers editor =+ [ mkKb EditorTransposeCharsEvent+ "Transpose the final two characters"+ (editor %= applyEdit Z.transposeChars)+ , mkKb EditorBolEvent+ "Go to the start of the current line"+ (editor %= applyEdit Z.gotoBOL)+ , mkKb EditorEolEvent+ "Go to the end of the current line"+ (editor %= applyEdit Z.gotoEOL)+ , mkKb EditorDeleteCharacter+ "Delete the character at the cursor"+ (editor %= applyEdit Z.deleteChar)+ , mkKb EditorKillToBolEvent+ "Delete from the cursor to the start of the current line"+ (editor %= applyEdit Z.killToBOL)+ , mkKb EditorKillToEolEvent+ "Kill the line to the right of the current position and copy it" $ do+ z <- use (editor.editContentsL) let restOfLine = Z.currentLine (Z.killToBOL z) csEditState.cedYankBuffer .= restOfLine- csEditState.cedEditor %= applyEdit Z.killToEOL- , kb "Paste the current buffer contents at the cursor"- (EvKey (KChar 'y') [MCtrl]) $ do+ editor %= applyEdit Z.killToEOL+ , mkKb EditorNextCharEvent+ "Move one character to the right"+ (editor %= applyEdit Z.moveRight)+ , mkKb EditorPrevCharEvent+ "Move one character to the left"+ (editor %= applyEdit Z.moveLeft)+ , mkKb EditorNextWordEvent+ "Move one word to the right"+ (editor %= applyEdit Z.moveWordRight)+ , mkKb EditorPrevWordEvent+ "Move one word to the left"+ (editor %= applyEdit Z.moveWordLeft)+ , mkKb EditorDeletePrevWordEvent+ "Delete the word to the left of the cursor" $ do+ editor %= applyEdit Z.deletePrevWord+ , mkKb EditorDeleteNextWordEvent+ "Delete the word to the right of the cursor" $ do+ editor %= applyEdit Z.deleteWord+ , mkKb EditorHomeEvent+ "Move the cursor to the beginning of the input" $ do+ editor %= applyEdit gotoHome+ , mkKb EditorEndEvent+ "Move the cursor to the end of the input" $ do+ editor %= applyEdit gotoEnd+ , mkKb EditorYankEvent+ "Paste the current buffer contents at the cursor" $ do buf <- use (csEditState.cedYankBuffer)- csEditState.cedEditor %= applyEdit (Z.insertMany buf)+ editor %= applyEdit (Z.insertMany buf) ]- where- withUserTypingAction (KB {..}) =- KB kbDescription kbEvent- (kbAction >> sendUserTypingAction)- kbBindingInfo getEditorContent :: MH Text getEditorContent = do@@ -231,6 +242,13 @@ -- handler can tell whether we're editing, replying, etc. csEditState.cedEditMode .= NewPost +closingPunctuationMarks :: String+closingPunctuationMarks = ".,'\";:)]!?"++isSmartClosingPunctuation :: Event -> Bool+isSmartClosingPunctuation (EvKey (KChar c) []) = c `elem` closingPunctuationMarks+isSmartClosingPunctuation _ = False+ handleEditingInput :: Event -> MH () handleEditingInput e = do -- Only handle input events to the editor if we permit editing:@@ -240,13 +258,23 @@ -- i.e., we are showing the user the status message about the -- current editor state and editing is not permitted. + -- Record the input line count before handling the editing event+ -- so we can tell whether the editing event changes the line count+ -- later.+ beforeLineCount <- use (csEditState.cedEditor.to getEditContents.to length)+ smartBacktick <- use (csResources.crConfiguration.to configSmartBacktick) let smartChars = "*`_" st <- use id csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing - case lookupKeybinding e editingKeybindings of- Just kb | editingPermitted st -> kbAction kb+ smartEditing <- use (csResources.crConfiguration.to configSmartEditing)+ justCompleted <- use (csEditState.cedJustCompleted)++ conf <- use (csResources.crConfiguration)+ let keyMap = editingKeybindings (csEditState.cedEditor) (configUserKeys conf)+ case lookupKeybinding e keyMap of+ Just kb | editingPermitted st -> (ehAction $ kehHandler $ khHandler kb) _ -> do case e of -- Not editing; backspace here means cancel multi-line message@@ -302,7 +330,14 @@ -- without doing anything smart. | otherwise -> doInsertChar | editingPermitted st -> do- csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeChar ch))++ -- If the most recent editing event was a tab completion,+ -- there is a trailing space that we want to remove if the+ -- next input character is punctuation.+ when (smartEditing && justCompleted && isSmartClosingPunctuation e) $+ csEditState.cedEditor %= applyEdit Z.deletePrevChar++ csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' $ T.singleton ch)) sendUserTypingAction _ | editingPermitted st -> do mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent e@@ -315,6 +350,22 @@ checkForAutocompletion ctx liftIO $ resetSpellCheckTimer $ st^.csEditState + -- If the preview is enabled and multi-line editing is enabled and+ -- the line count changed, we need to invalidate the rendering cache+ -- entry for the channel messages because we want to redraw them to+ -- fit in the space just changed by the size of the preview area.+ afterLineCount <- use (csEditState.cedEditor.to getEditContents.to length)+ isMultiline <- use (csEditState.cedEphemeral.eesMultiline)+ isPreviewing <- use csShowMessagePreview+ when (beforeLineCount /= afterLineCount && isMultiline && isPreviewing) $ do+ cId <- use csCurrentChannelId+ mh $ invalidateCacheEntry $ ChannelMessages cId++ -- Reset the recent autocompletion flag to stop smart punctuation+ -- handling.+ when justCompleted $+ csEditState.cedJustCompleted .= False+ -- | Send the user_typing action to the server asynchronously, over the -- connected websocket. If the websocket is not connected, drop the -- action silently.@@ -463,5 +514,11 @@ then z else Z.moveWordRight z csEditState.cedEditor %=- applyEdit (Z.insertMany replacement . Z.deletePrevWord .+ applyEdit (Z.insertChar ' ' . Z.insertMany replacement . Z.deletePrevWord . maybeEndOfWord)+ csEditState.cedJustCompleted .= True++ -- If there was only one completion alternative,+ -- hide the autocomplete listing now that we've+ -- completed the only completion.+ when (ac^.acCompletionList.to L.listElements.to length == 1) resetAutocomplete
src/State/ListOverlay.hs view
@@ -23,7 +23,8 @@ import Types import State.Common-import Events.Keybindings ( KeyConfig, Keybinding, handleKeyboardEvent )+import State.Editing ( editingKeybindings )+import Events.Keybindings ( KeyConfig, KeyHandlerMap, handleKeyboardEvent ) -- | Activate the specified list overlay's selected item by invoking the@@ -119,18 +120,23 @@ -- overlay's editor if the editor contents change. onEventListOverlay :: Lens' ChatState (ListOverlayState a b) -- ^ Which overlay to dispatch to?- -> (KeyConfig -> [Keybinding])+ -> (KeyConfig -> KeyHandlerMap) -- ^ The keybinding builder -> Vty.Event -- ^ The event- -> MH ()+ -> MH Bool onEventListOverlay which keybindings = handleKeyboardEvent keybindings $ \e -> do -- Get the editor content before the event. before <- listOverlaySearchString which - -- Handle the editor input event.- mhHandleEventLensed (which.listOverlaySearchInput) E.handleEditorEvent e+ -- First find a matching keybinding in the keybinding list.+ handled <- handleKeyboardEvent (editingKeybindings (which.listOverlaySearchInput)) (const $ return ()) e++ -- If we didn't find a matching binding, just handle the event+ -- as a normal editor input event.+ when (not handled) $+ mhHandleEventLensed (which.listOverlaySearchInput) E.handleEditorEvent e -- Get the editor content after the event. If the string changed, -- start a new search.
src/State/MessageSelect.hs view
@@ -269,7 +269,7 @@ let toEdit = if isEmote msg then removeEmoteFormatting sanitized else sanitized- csEditState.cedEditor %= applyEdit (clearZipper >> (insertMany toEdit))+ csEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper) _ -> return () -- | Tell the server that we have flagged or unflagged a message.
src/State/Setup/Threads.hs view
@@ -19,7 +19,7 @@ import Control.Concurrent ( threadDelay, forkIO ) import qualified Control.Concurrent.STM as STM import Control.Concurrent.STM.Delay-import Control.Exception ( SomeException, try, fromException )+import Control.Exception ( SomeException, try, fromException, catch ) import Data.List ( isInfixOf ) import qualified Data.Map as M import qualified Data.Sequence as Seq@@ -34,6 +34,8 @@ import System.Timeout ( timeout ) import Text.Aspell ( Aspell, AspellOption(..), startAspell ) +import Network.Mattermost.Exceptions ( RateLimitException+ , rateLimitExceptionReset ) import Network.Mattermost.Endpoints import Network.Mattermost.Types @@ -42,7 +44,6 @@ import State.Setup.Threads.Logging import TimeUtils ( lookupLocalTimeZone ) import Types-import qualified Zipper as Z updateUserStatuses :: [UserId] -> Session -> IO (Maybe (MH ()))@@ -55,7 +56,7 @@ setUserStatus (statusUserId s) (statusStatus s) True -> return Nothing -startUserStatusUpdateThread :: STM.TChan (Z.Zipper ChannelListGroup ChannelListEntry) -> Session -> RequestChan -> IO ()+startUserStatusUpdateThread :: STM.TChan [UserId] -> Session -> RequestChan -> IO () startUserStatusUpdateThread zipperChan session requestChan = void $ forkIO body where seconds = (* (1000 * 1000))@@ -65,8 +66,7 @@ result <- timeout (seconds userRefreshInterval) (STM.atomically $ STM.readTChan zipperChan) let (uIds, update) = case result of Nothing -> (prev, True)- Just z -> let ids = userIdsFromZipper z- in (ids, ids /= prev)+ Just ids -> (ids, ids /= prev) when update $ do STM.atomically $ STM.writeTChan requestChan $ do@@ -274,6 +274,9 @@ doAsyncWork :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO () doAsyncWork config requestChan eventChan = do+ let rateLimitNotify sec = do+ writeBChan eventChan $ RateLimitExceeded sec+ startWork <- case configShowBackground config of Disabled -> return $ return () Active -> do chk <- STM.atomically $ STM.tryPeekTChan requestChan@@ -297,18 +300,60 @@ req <- STM.atomically $ STM.readTChan requestChan startWork- res <- try req+ -- Run the IO action with up to one additional attempt if it makes+ -- rate-limited API requests.+ res <- try $ rateLimitRetry rateLimitNotify req case res of Left e -> do when (not $ shouldIgnore e) $ do- let err = case fromException e of- Nothing -> AsyncErrEvent e- Just mmErr -> ServerError mmErr- writeBChan eventChan $ IEvent $ DisplayError err+ case fromException e of+ Just (_::RateLimitException) ->+ writeBChan eventChan RequestDropped+ Nothing -> do+ let err = case fromException e of+ Nothing -> AsyncErrEvent e+ Just mmErr -> ServerError mmErr+ writeBChan eventChan $ IEvent $ DisplayError err Right upd -> case upd of- Nothing -> return ()- Just action -> writeBChan eventChan (RespEvent action)+ -- The IO action triggered a rate limit error but could+ -- not be retried due to rate limiting information being+ -- missing.+ Nothing -> writeBChan eventChan RateLimitSettingsMissing++ -- The IO action was run successfully but returned no+ -- state transformation.+ Just Nothing -> return ()++ -- The IO action was run successfully and returned a state+ -- transformation.+ Just (Just action) -> writeBChan eventChan (RespEvent action)++-- | Run an IO action. If the action raises a RateLimitException, invoke+-- the provided rate limit exception handler with the rate limit window+-- size (time in seconds until rate limit resets). Then block until the+-- rate limit resets and attempt to run the action one more time.+--+-- If the rate limit exception does not contain a rate limit reset+-- interval, return Nothing. Otherwise return IO action's result.+rateLimitRetry :: (Int -> IO ()) -> IO a -> IO (Maybe a)+rateLimitRetry rateLimitNotify act = do+ let retry e = do+ case rateLimitExceptionReset e of+ -- The rate limit exception contains no metadata so we+ -- cannot retry the action.+ Nothing -> return Nothing++ -- The rate limit exception contains the size of the+ -- rate limit reset interval, so block until that has+ -- passed and retry the action (only) one more time.+ Just sec -> do+ let adjusted = sec + 1+ rateLimitNotify adjusted+ threadDelay $ adjusted * 1000000+ Just <$> act++ (Just <$> act) `catch` retry -- Filter for exceptions that we don't want to report to the user, -- probably because they are not actionable and/or contain no useful
src/Types.hs view
@@ -115,13 +115,16 @@ , cedInputHistory , cedAutocomplete , cedAutocompletePending+ , cedJustCompleted , AutocompleteState(..) , acPreviousSearchString , acCompletionList- , acListElementType , acCachedResponses+ , acType + , AutocompletionType(..)+ , AutocompleteAlternative(..) , autocompleteAlternativeReplacement , SpecialMention(..)@@ -383,6 +386,8 @@ -- ^ The path to the theme customization file, if any. , configSmartBacktick :: Bool -- ^ Whether to enable smart quoting characters.+ , configSmartEditing :: Bool+ -- ^ Whether to enable smart editing behaviors. , configURLOpenCommand :: Maybe Text -- ^ The command to use to open URLs. , configURLOpenCommandInteractive :: Bool@@ -852,7 +857,7 @@ , _crSubprocessLog :: STM.TChan ProgramOutput , _crWebsocketActionChan :: STM.TChan WebsocketAction , _crTheme :: AttrMap- , _crStatusUpdateChan :: STM.TChan (Zipper ChannelListGroup ChannelListEntry)+ , _crStatusUpdateChan :: STM.TChan [UserId] , _crConfiguration :: Config , _crFlaggedPosts :: Set PostId , _crUserPreferences :: UserPreferences@@ -911,6 +916,17 @@ autocompleteAlternativeReplacement (CommandCompletion t _ _) = "/" <> t +-- | The type of data that the autocompletion logic supports. We use+-- this to track the kind of completion underway in case the type of+-- completion needs to change.+data AutocompletionType =+ ACUsers+ | ACChannels+ | ACCodeBlockLanguage+ | ACEmoji+ | ACCommands+ deriving (Eq, Show)+ data AutocompleteState = AutocompleteState { _acPreviousSearchString :: Text -- ^ The search string used for the@@ -920,9 +936,8 @@ , _acCompletionList :: List Name AutocompleteAlternative -- ^ The list of alternatives that the user -- selects from- , _acListElementType :: Text- -- ^ The label (plural noun, e.g. "Users") used to- -- display the result list to the user+ , _acType :: AutocompletionType+ -- ^ The type of data that we're completing , _acCachedResponses :: HM.HashMap Text [AutocompleteAlternative] -- ^ A cache of alternative lists, keyed on search -- string, for use in avoiding server requests.@@ -971,6 +986,10 @@ -- FileBrowser causes it to read and ingest the -- target directory, so this action is deferred -- until the browser is needed.+ , _cedJustCompleted :: Bool+ -- A flag that indicates whether the most recent+ -- editing event was a tab-completion. This is used by+ -- the smart trailing space handling. } -- | An attachment.@@ -995,6 +1014,7 @@ , _cedAutocompletePending = Nothing , _cedAttachmentList = list AttachmentList mempty 1 , _cedFileBrowser = Nothing+ , _cedJustCompleted = False } -- | A 'RequestChan' is a queue of operations we have to perform in the@@ -1478,7 +1498,7 @@ MHState { mhCurrentState :: ChatState , mhNextAction :: ChatState -> EventM Name (Next ChatState) , mhUsersToFetch :: [UserFetch]- , mhPendingStatusZipper :: Maybe (Zipper ChannelListGroup ChannelListEntry)+ , mhPendingStatusList :: Maybe [UserId] } -- | A value of type 'MH' @a@ represents a computation that can@@ -1534,7 +1554,7 @@ let mhSt = MHState { mhCurrentState = st , mhNextAction = Brick.continue , mhUsersToFetch = []- , mhPendingStatusZipper = Nothing+ , mhPendingStatusList = Nothing } ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt (mhNextAction st') (mhCurrentState st')@@ -1543,15 +1563,15 @@ scheduleUserFetches fs = MH $ do St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s } -scheduleUserStatusFetches :: Zipper ChannelListGroup ChannelListEntry -> MH ()-scheduleUserStatusFetches z = MH $ do- St.modify $ \s -> s { mhPendingStatusZipper = Just z }+scheduleUserStatusFetches :: [UserId] -> MH ()+scheduleUserStatusFetches is = MH $ do+ St.modify $ \s -> s { mhPendingStatusList = Just is } getScheduledUserFetches :: MH [UserFetch] getScheduledUserFetches = MH $ St.gets mhUsersToFetch -getScheduledUserStatusFetches :: MH (Maybe (Zipper ChannelListGroup ChannelListEntry))-getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusZipper+getScheduledUserStatusFetches :: MH (Maybe [UserId])+getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList -- | lift a computation in 'EventM' into 'MH' mh :: EventM Name a -> MH a@@ -1627,6 +1647,16 @@ -- ^ background worker is idle | BGBusy (Maybe Int) -- ^ background worker is busy (with n requests)+ | RateLimitExceeded Int+ -- ^ A request initially failed due to a rate limit but will be+ -- retried if possible. The argument is the number of seconds in+ -- which the retry will be attempted.+ | RateLimitSettingsMissing+ -- ^ A request denied by a rate limit could not be retried because+ -- the response contained no rate limit metadata+ | RequestDropped+ -- ^ A request was reattempted due to a rate limit and was rate+ -- limited again | IEvent InternalEvent -- ^ MH-internal events
src/Types/Common.hs view
@@ -2,7 +2,6 @@ module Types.Common ( sanitizeUserText , sanitizeUserText'- , sanitizeChar , userIdForDMChannel ) where@@ -18,14 +17,10 @@ sanitizeUserText = sanitizeUserText' . unsafeUserText sanitizeUserText' :: T.Text -> T.Text-sanitizeUserText' t =- T.replace "\ESC" "<ESC>" $- T.replace "\t" " " t--sanitizeChar :: Char -> T.Text-sanitizeChar '\ESC' = "<ESC>"-sanitizeChar '\t' = " "-sanitizeChar c = T.singleton c+sanitizeUserText' =+ T.replace "\ESC" "<ESC>" .+ T.replace "\t" " " .+ T.filter (\c -> c >= ' ' || c == '\n') -- remove non-printable -- | Extract the corresponding other user from a direct channel name. -- Returns Nothing if the string is not a direct channel name or if it
src/Types/KeyEvents.hs view
@@ -43,6 +43,8 @@ | QuitEvent | NextChannelEvent | PrevChannelEvent+ | NextChannelEventAlternate+ | PrevChannelEventAlternate | NextUnreadChannelEvent | NextUnreadUserOrChannelEvent | LastChannelEvent@@ -53,6 +55,22 @@ | ToggleChannelListVisibleEvent | ShowAttachmentListEvent + | EditorKillToBolEvent+ | EditorKillToEolEvent+ | EditorBolEvent+ | EditorEolEvent+ | EditorTransposeCharsEvent+ | EditorDeleteCharacter+ | EditorPrevCharEvent+ | EditorNextCharEvent+ | EditorPrevWordEvent+ | EditorNextWordEvent+ | EditorDeleteNextWordEvent+ | EditorDeletePrevWordEvent+ | EditorHomeEvent+ | EditorEndEvent+ | EditorYankEvent+ | SelectNextTabEvent | SelectPreviousTabEvent @@ -119,12 +137,30 @@ , EnterFastSelectModeEvent , NextChannelEvent , PrevChannelEvent+ , NextChannelEventAlternate+ , PrevChannelEventAlternate , NextUnreadChannelEvent , NextUnreadUserOrChannelEvent , LastChannelEvent , ShowAttachmentListEvent + , EditorKillToBolEvent+ , EditorKillToEolEvent+ , EditorBolEvent+ , EditorEolEvent+ , EditorTransposeCharsEvent+ , EditorDeleteCharacter+ , EditorPrevCharEvent+ , EditorNextCharEvent+ , EditorPrevWordEvent+ , EditorNextWordEvent+ , EditorDeleteNextWordEvent+ , EditorDeletePrevWordEvent+ , EditorHomeEvent+ , EditorEndEvent+ , EditorYankEvent+ , EnterFlaggedPostsEvent , ToggleChannelListVisibleEvent , ShowHelpEvent@@ -314,6 +350,8 @@ EnterFastSelectModeEvent -> "enter-fast-select" NextChannelEvent -> "focus-next-channel" PrevChannelEvent -> "focus-prev-channel"+ NextChannelEventAlternate -> "focus-next-channel-alternate"+ PrevChannelEventAlternate -> "focus-prev-channel-alternate" NextUnreadChannelEvent -> "focus-next-unread" NextUnreadUserOrChannelEvent -> "focus-next-unread-user-or-channel" LastChannelEvent -> "focus-last-channel"@@ -322,6 +360,22 @@ SelectPreviousTabEvent -> "select-previous-tab" ShowAttachmentListEvent -> "show-attachment-list"++ EditorKillToBolEvent -> "editor-kill-to-beginning-of-line"+ EditorKillToEolEvent -> "editor-kill-to-end-of-line"+ EditorBolEvent -> "editor-beginning-of-line"+ EditorEolEvent -> "editor-end-of-line"+ EditorTransposeCharsEvent -> "editor-transpose-chars"+ EditorDeleteCharacter -> "editor-delete-char"+ EditorPrevCharEvent -> "editor-prev-char"+ EditorNextCharEvent -> "editor-next-char"+ EditorPrevWordEvent -> "editor-prev-word"+ EditorNextWordEvent -> "editor-next-word"+ EditorDeleteNextWordEvent -> "editor-delete-next-word"+ EditorDeletePrevWordEvent -> "editor-delete-prev-word"+ EditorHomeEvent -> "editor-home"+ EditorEndEvent -> "editor-end"+ EditorYankEvent -> "editor-yank" EnterFlaggedPostsEvent -> "show-flagged-posts" ToggleChannelListVisibleEvent -> "toggle-channel-list-visibility"
src/Windows/ViewMessage.hs view
@@ -1,7 +1,9 @@ module Windows.ViewMessage ( viewMessageWindowTemplate , viewMessageKeybindings+ , viewMessageKeyHandlers , viewMessageReactionsKeybindings+ , viewMessageReactionsKeyHandlers ) where @@ -91,9 +93,9 @@ handleEvent :: ViewMessageWindowTab -> Vty.Event -> MH () handleEvent VMTabMessage =- handleKeyboardEvent viewMessageKeybindings (const $ return ())+ void . handleKeyboardEvent viewMessageKeybindings (const $ return ()) handleEvent VMTabReactions =- handleKeyboardEvent viewMessageReactionsKeybindings (const $ return ())+ void . handleKeyboardEvent viewMessageReactionsKeybindings (const $ return ()) reactionsText :: ChatState -> Message -> Widget Name reactionsText st m = viewport ViewMessageReactionsArea Vertical body@@ -152,54 +154,58 @@ ctx <- getContext render $ maybeWarn $ viewport ViewMessageArea Both $ mkBody (ctx^.availWidthL) -viewMessageKeybindings :: KeyConfig -> [Keybinding]-viewMessageKeybindings =+viewMessageKeybindings :: KeyConfig -> KeyHandlerMap+viewMessageKeybindings = mkKeybindings viewMessageKeyHandlers++viewMessageKeyHandlers :: [KeyEventHandler]+viewMessageKeyHandlers = let vs = viewportScroll ViewMessageArea- in mkKeybindings- [ mkKb PageUpEvent "Page up" $- mh $ vScrollBy vs (-1 * pageAmount)+ in [ mkKb PageUpEvent "Page up" $+ mh $ vScrollBy vs (-1 * pageAmount) - , mkKb PageDownEvent "Page down" $- mh $ vScrollBy vs pageAmount+ , mkKb PageDownEvent "Page down" $+ mh $ vScrollBy vs pageAmount - , mkKb ScrollUpEvent "Scroll up" $- mh $ vScrollBy vs (-1)+ , mkKb ScrollUpEvent "Scroll up" $+ mh $ vScrollBy vs (-1) - , mkKb ScrollDownEvent "Scroll down" $- mh $ vScrollBy vs 1+ , mkKb ScrollDownEvent "Scroll down" $+ mh $ vScrollBy vs 1 - , mkKb ScrollLeftEvent "Scroll left" $- mh $ hScrollBy vs (-1)+ , mkKb ScrollLeftEvent "Scroll left" $+ mh $ hScrollBy vs (-1) - , mkKb ScrollRightEvent "Scroll right" $- 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 ScrollBottomEvent "Scroll to the end of the message" $+ mh $ vScrollToEnd vs - , mkKb ScrollTopEvent "Scroll to the beginning of the message" $- mh $ vScrollToBeginning vs- ]+ , mkKb ScrollTopEvent "Scroll to the beginning of the message" $+ mh $ vScrollToBeginning vs+ ] -viewMessageReactionsKeybindings :: KeyConfig -> [Keybinding]-viewMessageReactionsKeybindings =+viewMessageReactionsKeybindings :: KeyConfig -> KeyHandlerMap+viewMessageReactionsKeybindings = mkKeybindings viewMessageReactionsKeyHandlers++viewMessageReactionsKeyHandlers :: [KeyEventHandler]+viewMessageReactionsKeyHandlers = let vs = viewportScroll ViewMessageReactionsArea- in mkKeybindings- [ mkKb PageUpEvent "Page up" $- mh $ vScrollBy vs (-1 * pageAmount)+ in [ mkKb PageUpEvent "Page up" $+ mh $ vScrollBy vs (-1 * pageAmount) - , mkKb PageDownEvent "Page down" $- mh $ vScrollBy vs pageAmount+ , mkKb PageDownEvent "Page down" $+ mh $ vScrollBy vs pageAmount - , mkKb ScrollUpEvent "Scroll up" $- mh $ vScrollBy vs (-1)+ , mkKb ScrollUpEvent "Scroll up" $+ mh $ vScrollBy vs (-1) - , mkKb ScrollDownEvent "Scroll down" $- 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 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- ]+ , mkKb ScrollTopEvent "Scroll to the beginning of the reactions list" $+ mh $ vScrollToBeginning vs+ ]