packages feed

matterhorn 50200.10.3 → 50200.11.0

raw patch · 217 files changed

+20640/−19671 lines, 217 filesdep +matterhorndep −quickcheck-textdep −string-conversionsdep ~brickdep ~bytestringdep ~cheapskate

Dependencies added: matterhorn

Dependencies removed: quickcheck-text, string-conversions

Dependency ranges changed: brick, bytestring, cheapskate, containers, mattermost-api, mattermost-api-qc, text, time, uuid, vty

Files

CHANGELOG.md view
@@ -1,4 +1,113 @@ +50200.11.0+==========++New features:+ * Matterhorn now opens post links itself rather than invoking the+   configured URL open command. This means that if a user obtains a link+   to a post in the web client and pastes it into a message, Matterhorn+   will detect it, and if the user chooses to open that link, Matterhorn+   will switch to the post's channel and show the post. This change+   comes a new theme attribute, `permalink`, that is used to style post+   permalinks. Post links with no labels appear as `<post link>`; post+   links with labels are rendered with their labels. Post links also+   appear in the URL list accessed with `C-o`, and they are opened by+   the message selection mode `o` binding.+ * Message timestamp visibility can now be controlled with the+   configuration setting `showMessageTimestamps` (default: `True`) and+   can be toggled at runtime with the new `/toggle-message-timestamps`+   command.+ * The channel list can now be displayed on either the left side of+   the screen or the right. This is controlled with a new configuration+   setting, `channelListOrientation`, set to either `left` (the default+   and previous behavior) or `right`.+ * Matterhorn now supports strikethrough syntax in messages. This change+   adds a new theme attribute, `markdownStrikethrough`, that+   is used to style strikethrough text. This change also adds+   support for `strikethrough` as a valid style specifier in theme+   customization files. Bear in mind that your terminal might+   not support strikethrough; for details, see the FAQ entry on+   strikethrough support.+ * Matterhorn now has improved handling for channel topics (headers)+   with multiple lines of text. Previously Matterhorn displayed all+   lines in a multi-line channel topic but replaced newlines with+   spaces. That resulted in broken layouts for multi-line topics where+   layout was important. Now it renders the topics as originally+   intended with user control over how multi-line topics are displayed+   in order to let the user control how the topic affects screen real+   estate use.+   * Added a new key event, `toggle-expanded-channel-topics`, to toggle+     whether channel topics show only their first line or all lines.+   * Added a new configuration setting, `showExpandedChannelTopics`, to+     set this behavior on startup (default: `True`).+   * Added a new command, `/toggle-expanded-topics`, and a new default+     keybinding, `F3`, to control this behavior at runtime.+ * Added a `/topic` command that opens an interactive topic editor when+   run with no arguments. The editor provides a live Markdown preview+   of the channel topic. As part of the UI for this feature, new theme+   attributes were added: `button` and `button.focused` for rendering+   unfocused and focused buttons, respectively.+ * Command autocompletion now queries the server for available commands+   and includes those in the command list. Server commands are also+   indicated as being provided by the server to help distinguish them+   from Matterhorn-specific commands.++Other changes:+ * Channel selection mode (`C-g`) now displays entries more consistently+   with the normal channel sidebar, including:+   * Channel mention counts and visual styles+   * The previous channel sigil (`<`) and first-unread channel sigil+     (`~`)+   * Channel mute status (`(m)`)+   * Unread status and visual style+ * When composing replies, Mattehorn now displays the threat root+   message of the thread being replied to, rather than the message+   the user selected for reply (#670). This is intended to be less+   surprising than the old behavior since showing the root post in the+   preview is consistent with the display of the post in the message+   list once it is posted, where the root post is shown above the reply.+ * Matterhorn no longer considers external program output to constitute+   an error, instead only reporting external program errors on non-zero+   exit status (#665).+ * Matterhorn now decorates all hyperlinks with angle brackets. This+   change is intended to get around issues caused when a hyperlink label+   has a style or color that prevents the normal hyperlink color from+   being used, thus concealing the fact that it is a link. This makes+   all links visible regardless of link label content. In particular,+   links labeled `foo` now get rendered as `<foo>`. Links with no labels+   also get decorated this way.+ * The total unread channel count is now included in the window title+   bar updates.+ * The total unread channel count is now included in the channel list+   header.+ * Long lines in code blocks with no syntax highlighting are now wrapped+   to improve readability.+ * Command autocompletion now sorts command completions to prefer prefix+   matches first.+ * Command autocomplete now makes only one request for the server+   command list per completion attempt.+ * There is now a new `/shortcuts` command to stand in for+   server-provided version which did nothing in Matterhorn.+ * Message selection mode now remains active when:+   * Opening message URLs (`C-s`/`o`),+   * Exiting the message view window (`C-s`/`v`), and+   * Exiting the emoji reaction list window (`C-s`/`a`).+ * The channel list now includes an unread indicator in the DM channel+   section header when any DM channels are unread.+ * The visual style for channel selection match text now includes the+   underline style.+ * All unknown websocket events are now logged rather than triggering+   messages to ask the user to report issues.++Bug fixes:+ * The URL list (`C-o`) now has a fixed header when the channel in+   question is a DM channel.+ * The URL list no longer treats URLs with the same target but different+   labels as duplicates.+ * The message editor's multi-line toggle UI hint now looks up the+   active keybinding rather than hard-coding it.+ * The channel sidebar's unread logic was improved (#655).+ 50200.10.3 ========== @@ -128,7 +237,7 @@    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+   on the observation that usually 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
README.md view
@@ -24,8 +24,9 @@  When you run Matterhorn you'll be prompted for your server URL and credentials. To connect, just paste your web client's Mattermost URL-into the Server URL box and enter your credentials. See the next section-on the details for providing each kind of supported credentials.+into the Server URL box and enter your credentials. See the [Matterhorn+User Guide](docs/UserGuide.md) on the details for providing each kind of+supported credentials.  Note: Version `ABBCC.X.Y` matches Mattermost server version `A.BB.CC`. For example, if your Mattermost server version is `3.6.0` then you
+ client-scripts/cowsay view
@@ -0,0 +1,7 @@+#!/bin/bash -e++# We want the fences so that the cowsay block gets rendered+# in Markdown as a code block. Otherwise, we just call cowsay.+echo '~~~~~~~~~~'+cowsay+echo '~~~~~~~~~~'
+ client-scripts/figlet view
@@ -0,0 +1,7 @@+#!/bin/bash -e++# We want the fences so that the cowsay block gets rendered+# in Markdown as a code block. Otherwise, we just call cowsay.+echo '~~~~~~~~~~'+figlet+echo '~~~~~~~~~~'
+ client-scripts/rot13 view
@@ -0,0 +1,4 @@+#!/bin/bash -e++# This should be a reasonably portable ROT-13-izer across Unixes+tr '[A-Za-z]' '[N-ZA-Mn-za-m]'
+ client-scripts/talky view
@@ -0,0 +1,38 @@+#!/bin/bash -e++BASE_URL="https://talky.io"++base64enc() {+    if [[ -x $(which shasum) ]] ; then+        retval=$(echo $1 | shasum | sed 's/ .*//g')+    elif [[ -x $(which openssl) ]] ; then+        retval=$(echo $1 | openssl enc -base64 | sed 's/\//x/g' | sed 's/+/x/g' | sed 's/=/x/g')+    elif [[ -x $(which base64) ]] ; then+        retval=$(echo $1 | base64 | sed 's/\//x/g' | sed 's/+/x/g' | sed 's/=/x/g')+    else+        echo "Unable to base64 encode, install base64?"+        exit+    fi+    echo $retval+}++getroom() {+if [[ -z "$1" ]]; then+    if [[ ! -a /dev/urandom ]] ; then+        echo "No urandom! Can not make random room name."+        exit+    elif [[ ! -x $(which dd) ]] ; then+        echo "No `dd` utility, can not read random file."+        exit+    else+        ROOM_RAND=$(dd if=/dev/urandom bs=1 count=32 2>/dev/null)+        ROOM_NAME=$( base64enc ${ROOM_RAND} )+    fi+else+    ROOM_NAME=$1+fi+}++getroom++echo "${BASE_URL}/${ROOM_NAME}"
docs/commands.md view
@@ -11,7 +11,7 @@ | `/focus <~channel>` | Focus on a channel or user | | `/focus` | Select from available channels | | `/group-msg <@user [@user ...]>` | Create a group chat |-| `/help` | Show this help screen |+| `/help` | Show the main help screen | | `/help <topic>` | Show help about a particular topic | | `/hide` | Hide the current DM or group channel from the channel list | | `/join` | Find a channel to join |@@ -23,7 +23,6 @@ | `/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 | | `/message-preview` | Toggle preview of the current message | | `/msg` | Search for a user to enter a private chat |@@ -31,7 +30,6 @@ | `/msg <@user> <message or command>` | Go to a user's channel and send the specified message or command | | `/notify-prefs` | Edit the current channel's notification preferences | | `/pinned-posts` | Open a window of this channel's pinned posts |-| `/purpose <purpose>` | Set the current channel's purpose | | `/quit` | Exit Matterhorn | | `/reconnect` | Force a reconnection attempt to the server | | `/remove-user <@user>` | Remove a user from the current channel |@@ -39,10 +37,13 @@ | `/search <terms>` | Search for posts with given terms | | `/sh` | List the available shell scripts | | `/sh <script> <message>` | Run a prewritten shell script |-| `/shrug <message>` | Send a message followed by a shrug emoticon |+| `/shortcuts` | Show keyboard shortcuts | | `/theme` | List the available themes | | `/theme <theme>` | Set the color theme | | `/toggle-channel-list` | Toggle channel list visibility |+| `/toggle-expanded-topics` | Toggle expanded channel topics |+| `/toggle-message-timestamps` | Toggle message timestamps |+| `/topic` | Set the current channel's topic (header) interactively | | `/topic <topic>` | Set the current channel's topic (header) | | `/user` | Show users to initiate a private DM chat channel | | `/username-attribute <@user>` | Display the attribute used to color the specified username |
docs/keybindings.md view
@@ -23,6 +23,7 @@ | `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 |+| `F3` | `toggle-expanded-channel-topics` | Toggle display of expanded channel topics | | `M-k` | `invoke-editor` | Invoke `$EDITOR` to edit the current message | | `C-g` | `enter-fast-select` | Enter fast channel selection mode | | `C-q` | `quit` | Quit |@@ -45,6 +46,25 @@ | `Esc`, `C-c` | `cancel` | Cancel autocomplete, message reply, or edit, in that order | | `M-8` | `show-flagged-posts` | View currently flagged posts | +# 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 |+ # Channel Select Mode | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |@@ -55,15 +75,6 @@ | `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 |-| `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 | | ---------- | ---------- | ----------- |@@ -86,33 +97,24 @@ | `Enter` | `fetch-for-gap` | Fetch messages for the selected gap | | `a` | `react-to-message` | Post a reaction to the selected message | -# Text Editing+# User Listings | 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 |+| `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 |+| `Enter` | `activate-list-item` | Interact with the selected user | -# Flagged Messages+# URL Select Mode | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |-| `Esc`, `C-c` | `cancel` | Exit post browsing |-| `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 |+| `Enter` | (non-customizable key) | Open the selected URL, if any |+| `Esc`, `C-c` | `cancel` | Cancel URL selection |+| `k`, `Up` | `select-up` | Move cursor up |+| `j`, `Down` | `select-down` | Move cursor down |+| `q` | (non-customizable key) | Cancel URL selection |  # Theme List Window | Keybinding | Event Name | Description |@@ -124,16 +126,6 @@ | `PgUp` | `page-up` | Page up in the theme list | | `Enter` | `activate-list-item` | Switch to the selected color theme | -# User Listings-| Keybinding | Event Name | Description |-| ---------- | ---------- | ----------- |-| `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 |-| `Enter` | `activate-list-item` | Interact with the selected user |- # Channel Search Window | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |@@ -144,16 +136,6 @@ | `PgUp` | `page-up` | Page up in the channel list | | `Enter` | `activate-list-item` | Join the selected channel | -# Reaction Emoji Search Window-| Keybinding | Event Name | Description |-| ---------- | ---------- | ----------- |-| `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 |-| `Enter` | `activate-list-item` | Post the selected emoji reaction |- # Message Viewer: Common | Keybinding | Event Name | Description | | ---------- | ---------- | ----------- |@@ -200,4 +182,23 @@ | ---------- | ---------- | ----------- | | `Esc`, `C-c` | `cancel` | Cancel attachment file browse | | `o` | `open-attachment` | Open the selected file using the URL open command |++# Flagged Messages+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Exit post browsing |+| `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 |++# Reaction Emoji Search Window+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `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 |+| `Enter` | `activate-list-item` | Post the selected emoji reaction |
matterhorn.cabal view
@@ -1,5 +1,5 @@ name:                matterhorn-version:             50200.10.3+version:             50200.11.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@@ -25,9 +25,10 @@                      docs/commands.md                      docs/AUTHORS.txt                      docs/PRACTICES.md-                     scripts/cowsay-                     scripts/figlet-                     scripts/rot13+                     client-scripts/cowsay+                     client-scripts/figlet+                     client-scripts/rot13+                     client-scripts/talky                      notification-scripts/notify                      emoji/LICENSE.txt                      emoji/emoji.json@@ -37,115 +38,119 @@   type: git   location: https://github.com/matterhorn-chat/matterhorn.git -executable matterhorn+library   hs-source-dirs:      src-  main-is:             Main.hs-  other-modules:       Config-                       Config.Schema-                       Command-                       Connection-                       App-                       Clipboard-                       Constants-                       State.Async-                       State.Attachments-                       State.Autocomplete-                       State.Channels-                       State.ChannelSelect-                       State.Common-                       State.Editing-                       State.Flagging-                       State.Help-                       State.Logging-                       State.Messages-                       State.MessageSelect-                       State.NotifyPrefs-                       State.PostListOverlay-                       State.ThemeListOverlay-                       State.ReactionEmojiListOverlay-                       State.Reactions-                       State.Setup-                       State.Setup.Threads-                       State.Setup.Threads.Logging-                       State.UrlSelect-                       State.ListOverlay-                       State.UserListOverlay-                       State.ChannelListOverlay-                       State.Users-                       Zipper-                       Themes-                       Draw-                       Emoji-                       Draw.RichText-                       Draw.ManageAttachments-                       Draw.Autocomplete-                       Draw.Main-                       Draw.Messages-                       Draw.ChannelList-                       Draw.ChannelListOverlay-                       Draw.ReactionEmojiListOverlay-                       Draw.ShowHelp-                       Draw.LeaveChannelConfirm-                       Draw.DeleteChannelConfirm-                       Draw.PostListOverlay-                       Draw.ThemeListOverlay-                       Draw.UserListOverlay-                       Draw.ListOverlay-                       Draw.URLList-                       Draw.Util-                       Draw.TabbedWindow-                       Draw.NotifyPrefs-                       InputHistory-                       IOUtil-                       Events-                       Events.ManageAttachments-                       Events.Keybindings-                       Events.ShowHelp-                       Events.MessageSelect-                       Events.Main-                       Events.ChannelSelect-                       Events.PostListOverlay-                       Events.ThemeListOverlay-                       Events.UrlSelect-                       Events.UserListOverlay-                       Events.ChannelListOverlay-                       Events.ReactionEmojiListOverlay-                       Events.LeaveChannelConfirm-                       Events.DeleteChannelConfirm-                       Events.TabbedWindow-                       Events.EditNotifyPrefs-                       Windows.ViewMessage-                       HelpTopics-                       KeyMap-                       LastRunState-                       Scripts-                       TimeUtils-                       Prelude.MH-                       Types-                       Types.Channels-                       Types.Common-                       Types.DirectionalSeq-                       Types.KeyEvents-                       Types.Messages-                       Types.RichText-                       Types.Users-                       Types.Posts-                       FilePaths-                       TeamSelect-                       Login-                       Options-                       Util+  exposed-modules:     Matterhorn.App+                       Matterhorn.Clipboard+                       Matterhorn.Command+                       Matterhorn.Config+                       Matterhorn.Config.Schema+                       Matterhorn.Connection+                       Matterhorn.Constants+                       Matterhorn.Draw+                       Matterhorn.Draw.Autocomplete+                       Matterhorn.Draw.Buttons+                       Matterhorn.Draw.ChannelList+                       Matterhorn.Draw.ChannelListOverlay+                       Matterhorn.Draw.ChannelTopicWindow+                       Matterhorn.Draw.DeleteChannelConfirm+                       Matterhorn.Draw.LeaveChannelConfirm+                       Matterhorn.Draw.ListOverlay+                       Matterhorn.Draw.Main+                       Matterhorn.Draw.ManageAttachments+                       Matterhorn.Draw.Messages+                       Matterhorn.Draw.NotifyPrefs+                       Matterhorn.Draw.PostListOverlay+                       Matterhorn.Draw.ReactionEmojiListOverlay+                       Matterhorn.Draw.RichText+                       Matterhorn.Draw.ShowHelp+                       Matterhorn.Draw.TabbedWindow+                       Matterhorn.Draw.ThemeListOverlay+                       Matterhorn.Draw.URLList+                       Matterhorn.Draw.UserListOverlay+                       Matterhorn.Draw.Util+                       Matterhorn.Emoji+                       Matterhorn.Events+                       Matterhorn.Events.ChannelListOverlay+                       Matterhorn.Events.ChannelSelect+                       Matterhorn.Events.ChannelTopicWindow+                       Matterhorn.Events.DeleteChannelConfirm+                       Matterhorn.Events.EditNotifyPrefs+                       Matterhorn.Events.Keybindings+                       Matterhorn.Events.LeaveChannelConfirm+                       Matterhorn.Events.Main+                       Matterhorn.Events.ManageAttachments+                       Matterhorn.Events.MessageSelect+                       Matterhorn.Events.PostListOverlay+                       Matterhorn.Events.ReactionEmojiListOverlay+                       Matterhorn.Events.ShowHelp+                       Matterhorn.Events.TabbedWindow+                       Matterhorn.Events.ThemeListOverlay+                       Matterhorn.Events.UrlSelect+                       Matterhorn.Events.UserListOverlay+                       Matterhorn.FilePaths+                       Matterhorn.HelpTopics+                       Matterhorn.IOUtil+                       Matterhorn.InputHistory+                       Matterhorn.KeyMap+                       Matterhorn.LastRunState+                       Matterhorn.Login+                       Matterhorn.Options+                       Matterhorn.Prelude+                       Matterhorn.Scripts+                       Matterhorn.State.Async+                       Matterhorn.State.Attachments+                       Matterhorn.State.Autocomplete+                       Matterhorn.State.ChannelListOverlay+                       Matterhorn.State.ChannelSelect+                       Matterhorn.State.Channels+                       Matterhorn.State.ChannelTopicWindow+                       Matterhorn.State.Common+                       Matterhorn.State.Editing+                       Matterhorn.State.Flagging+                       Matterhorn.State.Help+                       Matterhorn.State.Links+                       Matterhorn.State.ListOverlay+                       Matterhorn.State.Logging+                       Matterhorn.State.MessageSelect+                       Matterhorn.State.Messages+                       Matterhorn.State.NotifyPrefs+                       Matterhorn.State.PostListOverlay+                       Matterhorn.State.ReactionEmojiListOverlay+                       Matterhorn.State.Reactions+                       Matterhorn.State.Setup+                       Matterhorn.State.Setup.Threads+                       Matterhorn.State.Setup.Threads.Logging+                       Matterhorn.State.ThemeListOverlay+                       Matterhorn.State.UrlSelect+                       Matterhorn.State.UserListOverlay+                       Matterhorn.State.Users+                       Matterhorn.TeamSelect+                       Matterhorn.Themes+                       Matterhorn.TimeUtils+                       Matterhorn.Types+                       Matterhorn.Types.Channels+                       Matterhorn.Types.Common+                       Matterhorn.Types.DirectionalSeq+                       Matterhorn.Types.KeyEvents+                       Matterhorn.Types.Messages+                       Matterhorn.Types.Posts+                       Matterhorn.Types.RichText+                       Matterhorn.Types.Users+                       Matterhorn.Util+                       Matterhorn.Windows.ViewMessage+                       Matterhorn.Zipper                        Paths_matterhorn   default-extensions:  OverloadedStrings,                        ScopedTypeVariables,                        NoImplicitPrelude -  ghc-options:         -Wall -threaded -with-rtsopts=-I0 -Wcompat+  ghc-options:         -Wall -Wcompat   if impl(ghc >= 8.2)     ghc-options: -fhide-source-paths    build-depends:       base                 >=4.8      && <5-                     , mattermost-api       == 50200.8.0+                     , mattermost-api       == 50200.9.0                      , base-compat          >= 0.9     && < 0.12                      , unordered-containers >= 0.2     && < 0.3                      , containers           >= 0.5.7   && < 0.7@@ -159,9 +164,9 @@                      , config-ini           >= 0.2.2.0 && < 0.3                      , process              >= 1.4     && < 1.7                      , microlens-platform   >= 0.3     && < 0.5-                     , brick                >= 0.55    && < 0.56+                     , brick                >= 0.57    && < 0.58                      , brick-skylighting    >= 0.2     && < 0.4-                     , vty                  >= 5.30    && < 5.31+                     , vty                  >= 5.31    && < 5.32                      , word-wrap            >= 0.4.0   && < 0.5                      , transformers         >= 0.4     && < 0.6                      , text-zipper          >= 0.10    && < 0.11@@ -191,19 +196,24 @@                      , network-uri          >= 2.6     && < 2.7   default-language:    Haskell2010 +executable matterhorn+  hs-source-dirs:      programs+  main-is:             Main.hs++  ghc-options:         -Wall -threaded -with-rtsopts=-I0 -Wcompat+  if impl(ghc >= 8.2)+    ghc-options: -fhide-source-paths++  build-depends:       base                 >=4.8      && <5+                     , matterhorn+                     , text+  default-language:    Haskell2010+ test-suite test_messages   type:               exitcode-stdio-1.0   main-is:            test_messages.hs   other-modules:      Cheapskate_QCA                     , Message_QCA-                    , TimeUtils-                    , Types.Messages-                    , Types.Posts-                    , Types.Common-                    , Types.DirectionalSeq-                    , Types.RichText-                    , Constants-                    , Prelude.MH   default-language:   Haskell2010   default-extensions: OverloadedStrings                     , ScopedTypeVariables@@ -211,42 +221,19 @@   if impl(ghc >= 8.2)     ghc-options: -fhide-source-paths -  hs-source-dirs:     src, test+  hs-source-dirs:     test   build-depends:      base                 >=4.7      && <5-                    , base-compat          >= 0.9     && < 0.12-                    , brick                >= 0.55    && < 0.56-                    , bytestring           >= 0.10    && < 0.11-                    , cheapskate           >= 0.1     && < 0.2+                    , Unique               >= 0.4     && < 0.5                     , checkers             >= 0.4     && < 0.6-                    , config-ini           >= 0.2.2.0 && < 0.3-                    , connection           >= 0.2     && < 0.4-                    , containers           >= 0.5.7   && < 0.7-                    , directory            >= 1.3     && < 1.4-                    , filepath             >= 1.4     && < 1.5-                    , hashable             >= 1.2     && < 1.4-                    , Hclip                >= 3.0     && < 3.1-                    , mattermost-api       == 50200.8.0-                    , mattermost-api-qc    == 50200.8.0-                    , microlens-platform   >= 0.3     && < 0.5-                    , mtl                  >= 2.2     && < 2.3-                    , process              >= 1.4     && < 1.7-                    , quickcheck-text      >= 0.1     && < 0.2-                    , stm                  >= 2.4     && < 2.6-                    , strict               >= 0.3     && < 0.4-                    , string-conversions   >= 0.4     && < 0.5                     , tasty                >= 0.11    && < 1.3                     , tasty-hunit          >= 0.9     && < 0.12                     , tasty-quickcheck     >= 0.8     && < 0.12-                    , text                 >= 1.2     && < 1.3-                    , text-zipper          >= 0.10    && < 0.11-                    , time                 >= 1.6     && < 2.0-                    , timezone-olson       >= 0.2     && < 0.3-                    , timezone-series      >= 0.1.6.1 && < 0.2-                    , transformers         >= 0.4     && < 0.6-                    , Unique               >= 0.4     && < 0.5-                    , unordered-containers >= 0.2     && < 0.3-                    , vector               <  0.13-                    , vty                  >= 5.30    && < 5.31-                    , xdg-basedir          >= 0.2     && < 0.3-                    , semigroups           >= 0.18    && < 0.20-                    , uuid                 >= 1.3     && < 1.4+                    , bytestring+                    , cheapskate+                    , containers+                    , matterhorn+                    , mattermost-api+                    , mattermost-api-qc+                    , text+                    , time+                    , uuid
+ programs/Main.hs view
@@ -0,0 +1,60 @@+module Main where++import Prelude ()+import qualified Data.Text.IO as T++import System.Exit ( exitFailure, exitSuccess )++import Matterhorn.Prelude+import Matterhorn.Config+import Matterhorn.Options+import Matterhorn.App+import Matterhorn.Events.Keybindings ( ensureKeybindingConsistency )+import Matterhorn.KeyMap ( keybindingModeMap )+import Matterhorn.Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable+                                , commandMarkdownTable, commandTextTable )+++main :: IO ()+main = do+    opts <- grabOptions++    configResult <- if optIgnoreConfig opts+                    then return $ Right defaultConfig+                    else fmap snd <$> findConfig (optConfLocation opts)++    config <- case configResult of+        Left err -> do+            putStrLn $ "Error loading config: " <> err+            exitFailure+        Right c -> return c++    let keyConfig = configUserKeys config+        format = optPrintFormat opts++    printedCommands <- case optPrintCommands opts of+        False -> return False+        True -> do+            case format of+                Markdown -> T.putStrLn commandMarkdownTable+                Plain -> T.putStrLn commandTextTable+            return True++    printedKeybindings <- case optPrintKeybindings opts of+        False -> return False+        True -> do+            case format of+                Markdown -> T.putStrLn $ keybindingMarkdownTable keyConfig+                Plain -> T.putStrLn $ keybindingTextTable keyConfig+            return True++    when (printedKeybindings || printedCommands) exitSuccess++    case ensureKeybindingConsistency keyConfig keybindingModeMap of+        Right () -> return ()+        Left err -> do+            putStrLn $ "Configuration error: " <> err+            exitFailure++    finalSt <- runMatterhorn opts config+    closeMatterhorn finalSt
− scripts/cowsay 
@@ -1,7 +0,0 @@-#!/bin/bash -e--# We want the fences so that the cowsay block gets rendered-# in Markdown as a code block. Otherwise, we just call cowsay.-echo '~~~~~~~~~~'-cowsay-echo '~~~~~~~~~~'
− scripts/figlet 
@@ -1,7 +0,0 @@-#!/bin/bash -e--# We want the fences so that the cowsay block gets rendered-# in Markdown as a code block. Otherwise, we just call cowsay.-echo '~~~~~~~~~~'-figlet-echo '~~~~~~~~~~'
− scripts/rot13 
@@ -1,4 +0,0 @@-#!/bin/bash -e--# This should be a reasonably portable ROT-13-izer across Unixes-tr '[A-Za-z]' '[N-ZA-Mn-za-m]'
− src/App.hs 
@@ -1,114 +0,0 @@-module App-  ( runMatterhorn-  , closeMatterhorn-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Control.Monad.Trans.Except ( runExceptT )-import qualified Graphics.Vty as Vty-import           Text.Aspell ( stopAspell )-import           GHC.Conc (getNumProcessors, setNumCapabilities)-import           System.Posix.IO ( stdInput )--import           Network.Mattermost--import           Config-import           Draw-import qualified Events-import           IOUtil-import           InputHistory-import           LastRunState-import           Options hiding ( ShowHelp )-import           State.Setup-import           State.Setup.Threads.Logging ( shutdownLogManager )-import           Types---app :: App ChatState MHEvent Name-app = App-  { appDraw         = draw-  , appChooseCursor = \s cs -> case appMode s of-      Main                          -> showFirstCursor s cs-      ChannelSelect                 -> showFirstCursor s cs-      UserListOverlay               -> showFirstCursor s cs-      ReactionEmojiListOverlay      -> showFirstCursor s cs-      ChannelListOverlay            -> showFirstCursor s cs-      ManageAttachmentsBrowseFiles  -> showFirstCursor s cs-      ThemeListOverlay              -> showFirstCursor s cs-      LeaveChannelConfirm           -> Nothing-      DeleteChannelConfirm          -> Nothing-      MessageSelect                 -> Nothing-      MessageSelectDeleteConfirm    -> Nothing-      PostListOverlay _             -> Nothing-      ManageAttachments             -> Nothing-      ViewMessage                   -> Nothing-      ShowHelp _ _                  -> Nothing-      UrlSelect                     -> Nothing-      EditNotifyPrefs               -> Nothing-  , appHandleEvent  = Events.onEvent-  , appStartEvent   = return-  , appAttrMap      = (^.csResources.crTheme)-  }--applicationMaxCPUs :: Int-applicationMaxCPUs = 2--setupCpuUsage :: Config -> IO ()-setupCpuUsage config = do-    actualNumCpus <- getNumProcessors--    let requestedCPUs = case configCpuUsagePolicy config of-            SingleCPU -> 1-            MultipleCPUs -> min applicationMaxCPUs actualNumCpus--    setNumCapabilities requestedCPUs--runMatterhorn :: Options -> Config -> IO ChatState-runMatterhorn opts config = do-    setupCpuUsage config--    let mkVty = do-          mEraseChar <- Vty.getTtyEraseChar stdInput-          let addEraseChar cfg = case mEraseChar of-                  Nothing -> cfg-                  Just ch -> cfg { Vty.inputMap = (Nothing, [ch], Vty.EvKey Vty.KBS []) : Vty.inputMap cfg }--          vty <- Vty.mkVty $ addEraseChar Vty.defaultConfig-          let output = Vty.outputIface vty-          Vty.setMode output Vty.BracketedPaste True-          Vty.setMode output Vty.Hyperlink $ configHyperlinkingMode config-          return vty--    (st, vty) <- setupState mkVty (optLogLocation opts) config-    finalSt <- customMain vty mkVty (Just $ st^.csResources.crEventQueue) app st--    case finalSt^.csEditState.cedSpellChecker of-        Nothing -> return ()-        Just (s, _) -> stopAspell s--    return finalSt---- | Cleanup resources and save data for restoring on program restart.-closeMatterhorn :: ChatState -> IO ()-closeMatterhorn finalSt = do-  logIfError (mmCloseSession $ getResourceSession $ finalSt^.csResources)-      "Error in closing session"--  logIfError (writeHistory (finalSt^.csEditState.cedInputHistory))-      "Error in writing history"--  logIfError (writeLastRunState finalSt)-      "Error in writing last run state"--  shutdownLogManager $ finalSt^.csResources.crLogManager--  where-    logIfError action msg = do-      done <- runExceptT $ convertIOException $ action-      case done of-        Left err -> putStrLn $ msg <> ": " <> err-        Right _  -> return ()
− src/Clipboard.hs 
@@ -1,31 +0,0 @@-module Clipboard-  ( copyToClipboard-  )-where--import           Prelude ()-import           Prelude.MH--import           Control.Exception ( try )-import qualified Data.Text as T-import           System.Hclip ( setClipboard, ClipboardException(..) )--import           Types---copyToClipboard :: Text -> MH ()-copyToClipboard txt = do-  result <- liftIO (try (setClipboard (T.unpack txt)))-  case result of-    Left e -> do-      let errMsg = case e of-            UnsupportedOS _ ->-              "Matterhorn does not support yanking on this operating system."-            NoTextualData ->-              "Textual data is required to set the clipboard."-            MissingCommands cmds ->-              "Could not set clipboard due to missing one of the " <>-              "required program(s): " <> (T.pack $ show cmds)-      mhError $ ClipboardError errMsg-    Right () ->-      return ()
− src/Command.hs 
@@ -1,335 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-module Command-  ( commandList-  , dispatchCommand-  , printArgSpec-  , toggleMessagePreview-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( invalidateCache )-import qualified Control.Exception as Exn-import qualified Data.Char as Char-import qualified Data.Text as T-import           Lens.Micro.Platform ( (%=) )--import qualified Network.Mattermost.Endpoints as MM-import qualified Network.Mattermost.Exceptions as MM-import qualified Network.Mattermost.Types as MM--import           Connection ( connectWebsockets )-import           Constants ( userSigil, normalChannelSigil )-import           HelpTopics-import           Scripts-import           State.Help-import           State.Editing-import           State.Channels-import           State.ChannelSelect-import           State.Logging-import           State.PostListOverlay-import           State.UserListOverlay-import           State.ChannelListOverlay-import           State.ThemeListOverlay-import           State.NotifyPrefs-import           State.Common ( postInfoMessage )-import           State.Users-import           Themes ( attrForUsername )-import           Types----- | This function skips any initial whitespace and returns the first--- 'token' (i.e. any sequence of non-whitespace characters) as well as--- the trailing rest of the string, after any whitespace. This is used--- for tokenizing the first bits of command input while leaving the--- subsequent chunks unchanged, preserving newlines and other--- important formatting.-unwordHead :: Text -> Maybe (Text, Text)-unwordHead t =-  let t' = T.dropWhile Char.isSpace t-      (w, rs)  = T.break Char.isSpace t'-  in if T.null w-       then Nothing-       else Just (w, T.dropWhile Char.isSpace rs)--printArgSpec :: CmdArgs a -> Text-printArgSpec NoArg = ""-printArgSpec (LineArg ts) = "<" <> ts <> ">"-printArgSpec (TokenArg t NoArg) = "<" <> t <> ">"-printArgSpec (UserArg rs) = "<" <> userSigil <> "user>" <> addSpace (printArgSpec rs)-printArgSpec (ChannelArg rs) = "<" <> normalChannelSigil <> "channel>" <> addSpace (printArgSpec rs)-printArgSpec (TokenArg t rs) = "<" <> t <> ">" <> addSpace (printArgSpec rs)--addSpace :: Text -> Text-addSpace "" = ""-addSpace t = " " <> t--matchArgs :: CmdArgs a -> Text -> Either Text a-matchArgs NoArg t = case unwordHead t of-  Nothing -> return ()-  Just (a, as)-    | not (T.all Char.isSpace as) -> Left ("Unexpected arguments '" <> t <> "'")-    | otherwise -> Left ("Unexpected argument '" <> a <> "'")-matchArgs (LineArg _) t = return t-matchArgs spec@(UserArg rs) t = case unwordHead t of-  Nothing -> case rs of-    NoArg -> Left ("Missing argument: " <> printArgSpec spec)-    _     -> Left ("Missing arguments: " <> printArgSpec spec)-  Just (a, as) -> (,) <$> pure a <*> matchArgs rs as-matchArgs spec@(ChannelArg rs) t = case unwordHead t of-  Nothing -> case rs of-    NoArg -> Left ("Missing argument: " <> printArgSpec spec)-    _     -> Left ("Missing arguments: " <> printArgSpec spec)-  Just (a, as) -> (,) <$> pure a <*> matchArgs rs as-matchArgs spec@(TokenArg _ rs) t = case unwordHead t of-  Nothing -> case rs of-    NoArg -> Left ("Missing argument: " <> printArgSpec spec)-    _     -> Left ("Missing arguments: " <> printArgSpec spec)-  Just (a, as) -> (,) <$> pure a <*> matchArgs rs as--commandList :: [Cmd]-commandList =-  [ Cmd "quit" "Exit Matterhorn" NoArg $ \ () -> requestQuit--  , Cmd "right" "Focus on the next channel" NoArg $ \ () ->-      nextChannel--  , Cmd "left" "Focus on the previous channel" NoArg $ \ () ->-      prevChannel--  , Cmd "create-channel" "Create a new public channel"-    (LineArg "channel name") $ \ name ->-      createOrdinaryChannel True name--  , Cmd "create-private-channel" "Create a new private channel"-    (LineArg "channel name") $ \ name ->-      createOrdinaryChannel False name--  , Cmd "delete-channel" "Delete the current channel"-    NoArg $ \ () ->-      beginCurrentChannelDeleteConfirm--  , Cmd "hide" "Hide the current DM or group channel from the channel list"-    NoArg $ \ () -> do-      hideDMChannel =<< use csCurrentChannelId--  , Cmd "reconnect" "Force a reconnection attempt to the server"-    NoArg $ \ () ->-      connectWebsockets--  , Cmd "members" "Show the current channel's members"-    NoArg $ \ () ->-      enterChannelMembersUserList--  , Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () ->-      startLeaveCurrentChannel--  , Cmd "join" "Find a channel to join" NoArg $ \ () ->-      enterChannelListOverlayMode--  , Cmd "join" "Join the specified channel" (ChannelArg NoArg) $ \(n, ()) ->-      joinChannelByName n--  , Cmd "theme" "List the available themes" NoArg $ \ () ->-      enterThemeListMode--  , Cmd "theme" "Set the color theme"-    (TokenArg "theme" NoArg) $ \ (themeName, ()) ->-      setTheme themeName--  , Cmd "topic" "Set the current channel's topic (header)"-    (LineArg "topic") $ \ p ->-      if not (T.null p) then setChannelTopic p else return ()--  , Cmd "purpose" "Set the current channel's purpose"-    (LineArg "purpose") $ \ p ->-      if not (T.null p) then setChannelPurpose p else return ()--  , Cmd "add-user" "Search for a user to add to the current channel"-    NoArg $ \ () ->-        enterChannelInviteUserList--  , Cmd "msg" "Search for a user to enter a private chat"-    NoArg $ \ () ->-        enterDMSearchUserList--  , Cmd "msg" "Chat with the specified user"-    (UserArg NoArg) $ \ (name, ()) ->-        changeChannelByName name--  , Cmd "username-attribute" "Display the attribute used to color the specified username"-    (UserArg NoArg) $ \ (name, ()) ->-        displayUsernameAttribute name--  , Cmd "msg" "Go to a user's channel and send the specified message or command"-    (UserArg $ LineArg "message or command") $ \ (name, msg) -> do-        withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do-            case foundUser of-                Just user -> createOrFocusDMChannel user $ Just $ \cId ->-                    handleInputSubmission cId msg-                Nothing -> mhError $ NoSuchUser name--  , Cmd "log-start" "Begin logging debug information to the specified path"-    (TokenArg "path" NoArg) $ \ (path, ()) ->-        startLogging $ T.unpack path--  , Cmd "log-snapshot" "Dump the current debug log buffer to the specified path"-    (TokenArg "path" NoArg) $ \ (path, ()) ->-        logSnapshot $ T.unpack path--  , Cmd "log-stop" "Stop logging"-    NoArg $ \ () ->-        stopLogging--  , Cmd "log-mark" "Add a custom marker message to the Matterhorn debug log"-    (LineArg "message") $ \ markMsg ->-        mhLog LogUserMark markMsg--  , Cmd "log-status" "Show current debug logging status"-    NoArg $ \ () ->-        getLogDestination--  , Cmd "add-user" "Add a user to the current channel"-    (UserArg NoArg) $ \ (uname, ()) ->-        addUserByNameToCurrentChannel uname--  , Cmd "remove-user" "Remove a user from the current channel"-    (UserArg NoArg) $ \ (uname, ()) ->-        removeUserFromCurrentChannel uname--  , Cmd "user" "Show users to initiate a private DM chat channel"-    -- n.b. this is identical to "msg", but is provided as an-    -- alternative mental model for useability.-    NoArg $ \ () ->-        enterDMSearchUserList--  , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ ->-        toggleMessagePreview--  , Cmd "toggle-channel-list" "Toggle channel list visibility" NoArg $ \_ ->-        toggleChannelListVisibility--  , Cmd "focus" "Focus on a channel or user"-    (ChannelArg NoArg) $ \ (name, ()) ->-        changeChannelByName name--  , Cmd "focus" "Select from available channels" NoArg $ \ () ->-        beginChannelSelect--  , Cmd "help" "Show this help screen" NoArg $ \ _ ->-        showHelpScreen mainHelpTopic--  , Cmd "help" "Show help about a particular topic"-      (TokenArg "topic" NoArg) $ \ (topicName, ()) ->-          case lookupHelpTopic topicName of-              Nothing -> mhError $ NoSuchHelpTopic topicName-              Just topic -> showHelpScreen topic--  , Cmd "sh" "List the available shell scripts" NoArg $ \ () ->-      listScripts--  , Cmd "group-msg" "Create a group chat"-    (LineArg (userSigil <> "user [" <> userSigil <> "user ...]")) createGroupChannel--  , Cmd "sh" "Run a prewritten shell script"-    (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do-        cId <- use csCurrentChannelId-        findAndRunScript cId script text--  , Cmd "me" "Send an emote message"-    (LineArg "message") $-    \msg -> execMMCommand "me" msg--  , Cmd "shrug" "Send a message followed by a shrug emoticon"-    (LineArg "message") $-    \msg -> execMMCommand "shrug" msg--  , Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () ->-      enterFlaggedPostListMode--  , Cmd "pinned-posts" "Open a window of this channel's pinned posts" NoArg $ \ () ->-      enterPinnedPostListMode--  , Cmd "search" "Search for posts with given terms" (LineArg "terms") $-      enterSearchResultPostListMode--  , Cmd "notify-prefs" "Edit the current channel's notification preferences" NoArg $ \_ ->-          enterEditNotifyPrefsMode--  ]--displayUsernameAttribute :: Text -> MH ()-displayUsernameAttribute name = do-    let an = attrForUsername trimmed-        trimmed = trimUserSigil name-    postInfoMessage $ "The attribute used for " <> userSigil <> trimmed <>-                      " is " <> (attrNameToConfig an)--execMMCommand :: Text -> Text -> MH ()-execMMCommand name rest = do-  cId      <- use csCurrentChannelId-  session  <- getSession-  em       <- use (csEditState.cedEditMode)-  tId      <- gets myTeamId-  let mc = MM.MinCommand-             { MM.minComChannelId = cId-             , MM.minComCommand   = "/" <> name <> " " <> rest-             , MM.minComParentId  = case em of-                 Replying _ p -> Just $ MM.getId p-                 Editing p _  -> MM.postRootId p-                 _            -> Nothing-             , MM.minComRootId  = case em of-                 Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p)-                 Editing p _  -> MM.postRootId p-                 _            -> Nothing-             , MM.minComTeamId = tId-             }-      runCmd = liftIO $ do-        void $ MM.mmExecuteCommand mc session-      handleHTTP (MM.HTTPResponseException err) =-        return (Just (T.pack err))-        -- XXX: this might be a bit brittle in the future, because it-        -- assumes the shape of an error message. We might want to-        -- think about a better way of discovering this error and-        -- reporting it accordingly?-      handleCmdErr (MM.MattermostServerError err) =-        let (_, msg) = T.breakOn ": " err in-          return (Just (T.drop 2 msg))-      handleMMErr (MM.MattermostError-                     { MM.mattermostErrorMessage = msg }) =-        return (Just msg)-  errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP-                                                `Exn.catch` handleCmdErr-                                                `Exn.catch` handleMMErr-  case errMsg of-    Nothing -> return ()-    Just err ->-      mhError $ GenericError ("Error running command: " <> err)--dispatchCommand :: Text -> MH ()-dispatchCommand cmd =-  case unwordHead cmd of-    Just (x, xs)-      | matchingCmds <- [ c-                        | c@(Cmd name _ _ _) <- commandList-                        , name == x-                        ] -> go [] matchingCmds-      where go [] [] = do-              execMMCommand x xs-            go errs [] = do-              let msg = ("error running command /" <> x <> ":\n" <>-                         mconcat [ "    " <> e | e <- errs ])-              mhError $ GenericError msg-            go errs (Cmd _ _ spec exe : cs) =-              case matchArgs spec xs of-                Left e -> go (e:errs) cs-                Right args -> exe args-    _ -> return ()--toggleMessagePreview :: MH ()-toggleMessagePreview = do-    mh invalidateCache-    csShowMessagePreview %= not
− src/Command.hs-boot 
@@ -1,9 +0,0 @@-module Command where--import Data.Text ( Text )--import Types ( MH, Cmd, CmdArgs )--commandList :: [Cmd]-printArgSpec :: CmdArgs a -> Text-dispatchCommand :: Text -> MH ()
− src/Config.hs 
@@ -1,351 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE MultiWayIf #-}-module Config-  ( Config(..)-  , PasswordSource(..)-  , findConfig-  , defaultConfig-  , configConnectionType-  )-where--import           Prelude ()-import           Prelude.MH--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-import           System.Directory ( makeAbsolute, getHomeDirectory )-import           System.Environment ( getExecutablePath )-import           System.FilePath ( (</>), takeDirectory, splitPath, joinPath )-import           System.Process ( readProcess )-import           Network.Mattermost.Types (ConnectionType(..))-import           Network.URI ( isIPv4address, isIPv6address )--import           FilePaths-import           IOUtil-import           Types-import           Types.KeyEvents---defaultPort :: Int-defaultPort = 443--bundledSyntaxPlaceholderName :: String-bundledSyntaxPlaceholderName = "BUNDLED_SYNTAX"--userSyntaxPlaceholderName :: String-userSyntaxPlaceholderName = "USER_SYNTAX"--defaultSkylightingPaths :: IO [FilePath]-defaultSkylightingPaths = do-    xdg <- xdgSyntaxDir-    adjacent <- getBundledSyntaxPath-    return [xdg, adjacent]--getBundledSyntaxPath :: IO FilePath-getBundledSyntaxPath = do-    selfPath <- getExecutablePath-    let distDir = "dist-newstyle/"-        pathBits = splitPath selfPath--    return $ if distDir `elem` pathBits-             then-                 -- We're in development, so use the development-                 -- executable path to locate the XML path in the-                 -- development tree.-                 (joinPath $ takeWhile (/= distDir) pathBits) </> syntaxDirName-             else-                 -- In this case we assume the binary is being run from-                 -- a release, in which case the syntax directory is a-                 -- sibling of the executable path.-                 takeDirectory selfPath </> syntaxDirName--fromIni :: IniParser Config-fromIni = do-  conf <- section "mattermost" $ do-    configUser           <- fieldMbOf "user" stringField-    configHost           <- fieldMbOf "host" hostField-    configTeam           <- fieldMbOf "team" stringField-    configPort           <- fieldDefOf "port" number (configPort defaultConfig)-    configUrlPath        <- fieldMbOf "urlPath" stringField-    configChannelListWidth <- fieldDefOf "channelListWidth" number-                              (configChannelListWidth defaultConfig)-    configCpuUsagePolicy <- fieldDefOf "cpuUsagePolicy" cpuUsagePolicy-                            (configCpuUsagePolicy defaultConfig)-    configLogMaxBufferSize <- fieldDefOf "logMaxBufferSize" number-                              (configLogMaxBufferSize defaultConfig)-    configTimeFormat     <- fieldMbOf "timeFormat" stringField-    configDateFormat     <- fieldMbOf "dateFormat" stringField-    configTheme          <- fieldMbOf "theme" stringField-    configThemeCustomizationFile <- fieldMbOf "themeCustomizationFile" stringField-    configAspellDictionary <- fieldMbOf "aspellDictionary" stringField-    configURLOpenCommand <- fieldMbOf "urlOpenCommand" stringField-    configURLOpenCommandInteractive <- fieldFlagDef "urlOpenCommandIsInteractive" False-    configSmartBacktick  <- fieldFlagDef "smartbacktick"-      (configSmartBacktick defaultConfig)-    configSmartEditing <- fieldFlagDef "smartediting"-      (configSmartEditing defaultConfig)-    configShowOlderEdits <- fieldFlagDef "showOlderEdits"-      (configShowOlderEdits defaultConfig)-    configShowBackground <- fieldDefOf "showBackgroundActivity" backgroundField-      (configShowBackground defaultConfig)-    configShowMessagePreview <- fieldFlagDef "showMessagePreview"-      (configShowMessagePreview defaultConfig)-    configShowChannelList <- fieldFlagDef "showChannelList"-      (configShowChannelList defaultConfig)-    configShowTypingIndicator <- fieldFlagDef "showTypingIndicator"-      (configShowTypingIndicator defaultConfig)-    configEnableAspell <- fieldFlagDef "enableAspell"-      (configEnableAspell defaultConfig)-    configSyntaxDirs <- fieldDefOf "syntaxDirectories" syntaxDirsField []-    configActivityNotifyCommand <- fieldMb "activityNotifyCommand"-    configActivityBell <- fieldFlagDef "activityBell"-      (configActivityBell defaultConfig)-    configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs"-      (configHyperlinkingMode defaultConfig)-    configMessageSelectAfterURLOpen <- fieldFlagDef "messageSelectAfterURLOpen"-      (configMessageSelectAfterURLOpen defaultConfig)-    configPass <- (Just . PasswordCommand <$> field "passcmd") <!>-                  (Just . PasswordString  <$> field "pass") <!>-                  pure Nothing-    configToken <- (Just . TokenCommand  <$> field "tokencmd") <!>-                  pure Nothing-    configUnsafeUseHTTP <--      fieldFlagDef "unsafeUseUnauthenticatedConnection" False-    configValidateServerCertificate <--      fieldFlagDef "validateServerCertificate" True-    configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number-      (configDirectChannelExpirationDays defaultConfig)-    configDefaultAttachmentPath <- fieldMbOf "defaultAttachmentPath" filePathField--    let configAbsPath = Nothing-        configUserKeys = mempty-    return Config { .. }-  keys <- sectionMb "keybindings" $ do-      fmap (M.fromList . catMaybes) $ forM allEvents $ \ ev -> do-          kb <- fieldMbOf (keyEventName ev) parseBindingList-          case kb of-              Nothing      -> return Nothing-              Just binding -> return (Just (ev, binding))-  return conf { configUserKeys = fromMaybe mempty keys }--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-        f part | part == "~/" = homeDir <> "/"-               | otherwise    = part-    in joinPath $ f <$> parts--backgroundField :: Text -> Either String BackgroundInfo-backgroundField t =-    case t of-        "Disabled" -> Right Disabled-        "Active" -> Right Active-        "ActiveCount" -> Right ActiveCount-        _ -> Left ("Invalid value " <> show t-                  <> "; must be one of: Disabled, Active, ActiveCount")--cpuUsagePolicy :: Text -> Either String CPUUsagePolicy-cpuUsagePolicy t =-    case T.toLower t of-        "single" -> return SingleCPU-        "multiple" -> return MultipleCPUs-        _ -> Left $ "Invalid CPU usage policy value: " <> show t--stringField :: Text -> Either e Text-stringField t =-    case isQuoted t of-        True -> Right $ parseQuotedString t-        False -> Right t--filePathField :: Text -> Either e FilePath-filePathField t = let path = T.unpack t in Right path--parseQuotedString :: Text -> Text-parseQuotedString t =-    let body = T.drop 1 $ T.init t-        unescapeQuotes s | T.null s = s-                         | "\\\"" `T.isPrefixOf` s = "\"" <> unescapeQuotes (T.drop 2 s)-                         | otherwise = (T.singleton $ T.head s) <> unescapeQuotes (T.drop 1 s)-    in unescapeQuotes body--isQuoted :: Text -> Bool-isQuoted t =-    let quote = "\""-    in (quote `T.isPrefixOf` t) &&-       (quote `T.isSuffixOf` t)--defaultConfig :: Config-defaultConfig =-    Config { configAbsPath                     = Nothing-           , configUser                        = Nothing-           , configHost                        = Nothing-           , configTeam                        = Nothing-           , configPort                        = defaultPort-           , configUrlPath                     = Nothing-           , configPass                        = Nothing-           , configToken                       = Nothing-           , configTimeFormat                  = Nothing-           , configDateFormat                  = Nothing-           , configTheme                       = Nothing-           , configThemeCustomizationFile      = Nothing-           , configSmartBacktick               = True-           , configSmartEditing                = True-           , configURLOpenCommand              = Nothing-           , configURLOpenCommandInteractive   = False-           , configActivityNotifyCommand       = Nothing-           , configActivityBell                = False-           , configShowBackground              = Disabled-           , configShowMessagePreview          = False-           , configShowChannelList             = True-           , configEnableAspell                = False-           , configAspellDictionary            = Nothing-           , configUnsafeUseHTTP               = False-           , configValidateServerCertificate   = True-           , configChannelListWidth            = 20-           , configLogMaxBufferSize            = 200-           , configShowOlderEdits              = True-           , configUserKeys                    = mempty-           , configShowTypingIndicator         = False-           , configHyperlinkingMode            = True-           , configMessageSelectAfterURLOpen   = False-           , configSyntaxDirs                  = []-           , configDirectChannelExpirationDays = 7-           , configCpuUsagePolicy              = MultipleCPUs-           , configDefaultAttachmentPath       = Nothing-           }--findConfig :: Maybe FilePath -> IO (Either String ([String], Config))-findConfig Nothing = runExceptT $ do-    cfg <- lift $ locateConfig configFileName-    (warns, config) <--      case cfg of-        Nothing -> return ([], defaultConfig)-        Just path -> getConfig path-    config' <- fixupPaths config-    return (warns, config')-findConfig (Just path) =-    runExceptT $ do (warns, config) <- getConfig path-                    config' <- fixupPaths config-                    return (warns, config')---- | Fix path references in the configuration:------ * Rewrite the syntax directory path list with 'fixupSyntaxDirs'--- * Expand "~" encountered in any setting that contains a path value-fixupPaths :: Config -> ExceptT String IO Config-fixupPaths initial = do-    new <- fixupSyntaxDirs initial-    homeDir <- liftIO getHomeDirectory-    let fixP = expandTilde homeDir-        fixPText = T.pack . expandTilde homeDir . T.unpack-    return $ new { configThemeCustomizationFile = fixPText <$> configThemeCustomizationFile new-                 , configSyntaxDirs             = fixP <$> configSyntaxDirs new-                 , configURLOpenCommand         = fixPText <$> configURLOpenCommand new-                 , configActivityNotifyCommand  = fixPText <$> configActivityNotifyCommand new-                 , configDefaultAttachmentPath  = fixP <$> configDefaultAttachmentPath new-                 }---- | If the configuration has no syntax directories specified (the--- default if the user did not provide the setting), fill in the--- list with the defaults. Otherwise replace any bundled directory--- placeholders in the config's syntax path list.-fixupSyntaxDirs :: Config -> ExceptT String IO Config-fixupSyntaxDirs c =-    if configSyntaxDirs c == []-    then do-        dirs <- liftIO defaultSkylightingPaths-        return $ c { configSyntaxDirs = dirs }-    else do-        newDirs <- forM (configSyntaxDirs c) $ \dir ->-            if | dir == bundledSyntaxPlaceholderName -> liftIO getBundledSyntaxPath-               | dir == userSyntaxPlaceholderName    -> liftIO xdgSyntaxDir-               | otherwise                           -> return dir--        return $ c { configSyntaxDirs = newDirs }--getConfig :: FilePath -> ExceptT String IO ([String], Config)-getConfig fp = do-    absPath <- convertIOException $ makeAbsolute fp-    t <- (convertIOException $ T.readFile absPath) `catchE`-         (\e -> throwE $ "Could not read " <> show absPath <> ": " <> e)--    -- HACK ALERT FIXME:-    ---    -- The config parser library we use, config-ini (as of 0.2.4.0)-    -- cannot handle configuration files without trailing newlines.-    -- Since that's not a really good reason for this function to raise-    -- an exception (and is fixable on the fly), we have the following-    -- check. This check is admittedly not a great thing to have to do,-    -- and we should definitely get rid of it when config-ini fixes this-    -- issue.-    let t' = if "\n" `T.isSuffixOf` t then t else t <> "\n"--    case parseIniFile t' fromIni of-        Left err -> do-            throwE $ "Unable to parse " ++ absPath ++ ":" ++ fatalString err-        Right (warns, conf) -> do-            actualPass <- case configPass conf of-                Just (PasswordCommand cmdString) -> do-                    let (cmd:rest) = T.unpack <$> T.words cmdString-                    output <- convertIOException (readProcess cmd rest "") `catchE`-                              (\e -> throwE $ "Could not execute password command: " <> e)-                    return $ Just $ T.pack (takeWhile (/= '\n') output)-                Just (PasswordString pass) -> return $ Just pass-                Nothing -> return Nothing--            actualToken <- case configToken conf of-                Just (TokenCommand cmdString) -> do-                    let (cmd:rest) = T.unpack <$> T.words cmdString-                    output <- convertIOException (readProcess cmd rest "") `catchE`-                              (\e -> throwE $ "Could not execute token command: " <> e)-                    return $ Just $ T.pack (takeWhile (/= '\n') output)-                Just (TokenString _) -> error $ "BUG: getConfig: token in the Config was already a TokenString"-                Nothing -> return Nothing--            let conf' = conf-                  { configPass = PasswordString <$> actualPass-                  , configToken = TokenString <$> actualToken-                  , configAbsPath = Just absPath-                  }-            return (map warningString warns, conf')--configConnectionType :: Config -> ConnectionType-configConnectionType config-  | configUnsafeUseHTTP config = ConnectHTTP-  | otherwise = ConnectHTTPS (configValidateServerCertificate config)
− src/Config/Schema.hs 
@@ -1,203 +0,0 @@-{- |--This module provides an INI schema validator that is able to track unused-sections and fields in order to report warning messages to the user.--- -}-module Config.Schema-  ( IniParser-  , parseIniFile-  , (<!>)--  , Fatal(..)-  , fatalString--  , Warning(..)-  , warningString--  , section-  , sectionMb-  , fieldMbOf-  , fieldMb-  , field-  , fieldDefOf-  , fieldFlagDef--  -- * Re-exports-  , number-  , string-  , listWithSeparator-  ) where--import           Prelude ()-import           Prelude.MH--import           Data.Map (Map)-import qualified Data.Map as Map-import           Data.List.NonEmpty (NonEmpty)-import qualified Data.List.NonEmpty as NonEmpty-import qualified Data.Text as T-import           Control.Monad-import           Data.Ini.Config (flag, number, listWithSeparator, string)-import           Data.Ini.Config.Raw-----------------------------------------------------------------------------newtype Parser e t a = Parser { unParser :: e -> Map NormalizedText (NonEmpty t) -> Either Fatal (Map NormalizedText (NonEmpty t), [Warning], a) }--instance Functor (Parser e t) where-  fmap = liftM--instance Applicative (Parser e t) where-  pure x = Parser $ \_ s -> Right (s, [], x)-  (<*>) = ap--instance Monad (Parser e t) where-  m >>= f = Parser $ \e s0 ->-              do (s1, ws1, x1) <- unParser m e s0-                 (s2, ws2, x2) <- unParser (f x1) e s1-                 Right (s2, ws1++ws2, x2)----(<!>) :: Parser e t a -> Parser e t a -> Parser e t a-p <!> q = Parser $ \e s ->-  case unParser p e s of-    Right r -> Right r-    Left {} -> unParser q e s--getenv :: Parser e t e-getenv = Parser $ \e s -> Right (s, [], e)--request :: Text -> Parser e t (Maybe t)-request name = Parser $ \_ s ->-  let name' = normalize name in-  Right $!-  case Map.lookup name' s of-    Nothing                 -> (s , [], Nothing)-    Just (x NonEmpty.:| xs) -> (s', [], Just x)-      where-        s' = case NonEmpty.nonEmpty xs of-               Nothing -> Map.delete name' s-               Just ne -> Map.insert name' ne s--fatal :: Fatal -> Parser e t a-fatal e = Parser $ \_ _ -> Left e--warnings :: [Warning] -> IniParser ()-warnings ws = Parser $ \_ s -> Right (s, ws, ())----------------------------------------------------------------------------type IniParser = Parser RawIni IniSection--type SectionParser = Parser IniSection IniValue--data Fatal-  = NoSection Text-  | MissingField IniSection Text-  | BadField IniSection IniValue String-  | ParseError String-  deriving Show--data Warning-  = UnusedSection IniSection-  | UnusedField IniSection IniValue-  deriving Show----------------------------------------------------------------------------fatalString :: Fatal -> String-fatalString (NoSection name) = "No top-level section named " ++ show name-fatalString (MissingField sec name) = "Missing field " ++ show name ++ " in section " ++ show (isName sec)-fatalString (BadField sec val err) =-  "Line " ++ show (vLineNo val) ++-  " in section " ++ show (isName sec) ++-  ": " ++ err-fatalString (ParseError err) = err--warningString :: Warning -> String-warningString (UnusedSection sec) = "Unused section " ++ show (isName sec)-warningString (UnusedField sec val) =-  "Line " ++ show (vLineNo val) ++-  " in section " ++ show (isName sec) ++-  ": unused field"----------------------------------------------------------------------------parseIniFile :: Text -> IniParser a -> Either Fatal ([Warning], a)-parseIniFile text parser =-  case parseRawIni text of-    Left e -> Left (ParseError e)-    Right ini ->-      let entries = Map.fromListWith (<>)-                       [ (k, pure v) | (k,v) <- toList (fromRawIni ini) ]-      in-      case unParser parser ini entries of-        Left e -> Left e-        Right (entries', ws, x) -> Right (ws ++ unused, x)-          where-            unused = [ UnusedSection e | e <- concatMap toList entries' ]----------------------------------------------------------------------------section :: Text -> SectionParser a -> IniParser a-section name parser =-  do mb <- sectionMb name parser-     case mb of-       Nothing -> fatal (NoSection name)-       Just x  -> pure x--sectionMb :: Text -> SectionParser a -> IniParser (Maybe a)-sectionMb name parser =-  do mb <- request name-     case mb of-       Nothing -> pure Nothing-       Just sec ->-         let entries = Map.fromListWith (<>)-                       [ (k, pure v) | (k,v) <- toList (isVals sec) ]-         in-         case unParser parser sec entries of-           Left e -> fatal e-           Right (entries', ws, result) ->-             do warnings (ws ++ [ UnusedField sec v | v <- concatMap toList entries' ])-                pure (Just result)----------------------------------------------------------------------------field :: Text -> SectionParser Text-field name =-  do mb <- fieldMb name-     case mb of-       Just x -> pure x-       Nothing ->-         do s <- getenv-            fatal (MissingField s name)--fieldMbOf :: Text -> (Text -> Either String a) -> SectionParser (Maybe a)-fieldMbOf name validate =-  do mb <- request name-     case mb of-       Nothing -> pure Nothing-       Just val ->-         case validate (getVal val) of-           Left e ->-             do sec <- getenv-                fatal (BadField sec val e)-           Right x -> pure (Just x)--fieldMb :: Text -> SectionParser (Maybe Text)-fieldMb name = fmap getVal <$> request name--fieldDefOf :: Text -> (Text -> Either String a) -> a -> SectionParser a-fieldDefOf name validate def = fromMaybe def <$> fieldMbOf name validate--fieldFlagDef :: Text -> Bool -> SectionParser Bool-fieldFlagDef name def = fieldDefOf name flag def----------------------------------------------------------------------------getVal :: IniValue -> Text-getVal = T.strip . vValue
− src/Connection.hs 
@@ -1,104 +0,0 @@-module Connection where--import           Prelude ()-import           Prelude.MH--import           Control.Concurrent ( forkIO, threadDelay, killThread )-import qualified Control.Concurrent.STM as STM-import           Control.Exception ( SomeException, catch, AsyncException(..), throwIO )-import qualified Data.HashMap.Strict as HM-import           Data.Int (Int64)-import           Data.Semigroup ( Max(..) )-import qualified Data.Text as T-import           Data.Time ( UTCTime(..), secondsToDiffTime, getCurrentTime-                           , diffUTCTime )-import           Data.Time.Calendar ( Day(..) )-import           Lens.Micro.Platform ( (.=) )--import           Network.Mattermost.Types ( ChannelId )-import qualified Network.Mattermost.WebSocket as WS--import           Constants-import           Types---connectWebsockets :: MH ()-connectWebsockets = do-  logger <- mhGetIOLogger--  -- If we have an old websocket thread, kill it.-  mOldTid <- use (csResources.crWebsocketThreadId)-  case mOldTid of-      Nothing -> return ()-      Just oldTid -> liftIO $ do-          logger LogWebsocket "Terminating previous websocket thread"-          killThread oldTid--  st <- use id-  session <- getSession--  tid <- liftIO $ do-    let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg)-        shunt (Right (Right e)) = writeBChan (st^.csResources.crEventQueue) (WSEvent e)-        shunt (Right (Left e)) = writeBChan (st^.csResources.crEventQueue) (WSActionResponse e)-        runWS = WS.mmWithWebSocket session shunt $ \ws -> do-                  writeBChan (st^.csResources.crEventQueue) WebsocketConnect-                  processWebsocketActions st ws 1 HM.empty-    logger LogWebsocket "Starting new websocket thread"-    forkIO $ runWS `catch` ignoreThreadKilled-                   `catch` handleTimeout logger 1 st-                   `catch` handleError logger 5 st--  csResources.crWebsocketThreadId .= Just tid--ignoreThreadKilled :: AsyncException -> IO ()-ignoreThreadKilled ThreadKilled = return ()-ignoreThreadKilled e = throwIO e---- | Take websocket actions from the websocket action channel in the--- ChatState and send them to the server over the websocket.------ Takes and propagates the action sequence number which is incremented--- for each successful send.------ Keeps and propagates a map of channel id to last user_typing--- notification send time so that the new user_typing actions are--- throttled to be send only once in two seconds.-processWebsocketActions :: ChatState -> WS.MMWebSocket -> Int64 -> HashMap ChannelId (Max UTCTime) -> IO ()-processWebsocketActions st ws s userTypingLastNotifTimeMap = do-  action <- STM.atomically $ STM.readTChan (st^.csResources.crWebsocketActionChan)-  if (shouldSendAction action)-    then do-      WS.mmSendWSAction (st^.csResources.crConn) ws $ convert action-      now <- getCurrentTime-      processWebsocketActions st ws (s + 1) $ userTypingLastNotifTimeMap' action now-    else do-      processWebsocketActions st ws s userTypingLastNotifTimeMap-  where-    convert (UserTyping _ cId pId) = WS.UserTyping s cId pId--    shouldSendAction (UserTyping ts cId _) =-      diffUTCTime ts (userTypingLastNotifTime cId) >= (userTypingExpiryInterval / 2 - 0.5)--    userTypingLastNotifTime cId = getMax $ HM.lookupDefault (Max zeroTime) cId userTypingLastNotifTimeMap--    zeroTime = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)--    userTypingLastNotifTimeMap' (UserTyping _ cId _) now =-      HM.insertWith (<>) cId (Max now) userTypingLastNotifTimeMap--handleTimeout :: (LogCategory -> Text -> IO ()) -> Int -> ChatState -> WS.MMWebSocketTimeoutException -> IO ()-handleTimeout logger seconds st e = do-    logger LogWebsocket $ T.pack $ "Websocket timeout exception: " <> show e-    reconnectAfter seconds st--handleError :: (LogCategory -> Text -> IO ()) -> Int -> ChatState -> SomeException -> IO ()-handleError logger seconds st e = do-    logger LogWebsocket $ T.pack $ "Websocket error: " <> show e-    reconnectAfter seconds st--reconnectAfter :: Int -> ChatState -> IO ()-reconnectAfter seconds st = do-  writeBChan (st^.csResources.crEventQueue) WebsocketDisconnect-  threadDelay (seconds * 1000 * 1000)-  writeBChan (st^.csResources.crEventQueue) RefreshWebsocketEvent
− src/Constants.hs 
@@ -1,35 +0,0 @@-module Constants-  ( pageAmount-  , userTypingExpiryInterval-  , numScrollbackPosts-  , previewMaxHeight-  , normalChannelSigil-  , userSigil-  )-where--import Prelude ()-import Prelude.MH----- | The number of rows to consider a "page" when scrolling-pageAmount :: Int-pageAmount = 15---- | The expiry interval in seconds for user typing notifications.-userTypingExpiryInterval :: NominalDiffTime-userTypingExpiryInterval = 5--numScrollbackPosts :: Int-numScrollbackPosts = 100---- | The maximum height of the message preview, in lines.-previewMaxHeight :: Int-previewMaxHeight = 5---- Sigils-normalChannelSigil :: Text-normalChannelSigil = "~"--userSigil :: Text-userSigil = "@"
− src/Draw.hs 
@@ -1,46 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE PackageImports #-}-module Draw (draw) where--import Prelude ()-import Prelude.MH--import Brick--import Lens.Micro.Platform ( _2, singular, _Just )--import Draw.DeleteChannelConfirm-import Draw.LeaveChannelConfirm-import Draw.Main-import Draw.ThemeListOverlay-import Draw.PostListOverlay-import Draw.ShowHelp-import Draw.UserListOverlay-import Draw.ChannelListOverlay-import Draw.ReactionEmojiListOverlay-import Draw.TabbedWindow-import Draw.ManageAttachments-import Draw.NotifyPrefs-import Types---draw :: ChatState -> [Widget Name]-draw st =-    case appMode st of-        Main                       -> drawMain True st-        UrlSelect                  -> drawMain True st-        ShowHelp topic _           -> drawShowHelp topic st-        ChannelSelect              -> drawMain True st-        LeaveChannelConfirm        -> drawLeaveChannelConfirm st-        MessageSelect              -> drawMain True st-        MessageSelectDeleteConfirm -> drawMain True st-        DeleteChannelConfirm       -> drawDeleteChannelConfirm st-        ThemeListOverlay           -> drawThemeListOverlay st-        PostListOverlay contents   -> drawPostListOverlay contents st-        UserListOverlay            -> drawUserListOverlay st-        ChannelListOverlay         -> drawChannelListOverlay st-        ReactionEmojiListOverlay   -> drawReactionEmojiListOverlay st-        ViewMessage                -> drawTabbedWindow (st^.csViewedMessage.singular _Just._2) st : drawMain False st-        ManageAttachments          -> drawManageAttachments st-        ManageAttachmentsBrowseFiles -> drawManageAttachments st-        EditNotifyPrefs            -> drawNotifyPrefs st : drawMain False st
− src/Draw/Autocomplete.hs 
@@ -1,188 +0,0 @@-module Draw.Autocomplete-  ( autocompleteLayer-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.List ( renderList, listElementsL, listSelectedFocusedAttr-                                    , listSelectedElement-                                    )-import qualified Data.Text as T--import           Network.Mattermost.Types ( User(..), Channel(..) )--import           Constants ( normalChannelSigil )-import           Draw.Util-import           Themes-import           Types-import           Types.Common ( sanitizeUserText )---autocompleteLayer :: ChatState -> Widget Name-autocompleteLayer st =-    case st^.csEditState.cedAutocomplete of-        Nothing ->-            emptyWidget-        Just ac ->-            renderAutocompleteBox st ac--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-        maxListHeight = 5-        visibleHeight = min maxListHeight numResults-        numResults = length elements-        elements = matchList^.listElementsL-        label = withDefAttr clientMessageAttr $-                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-        footer = case renderAutocompleteFooterFor curChan =<< selElem of-            Just w -> hBorderWithLabel w-            _ -> hBorder-        curUser = myUsername st--    in if numResults == 0-       then emptyWidget-       else Widget Greedy Greedy $ do-           ctx <- getContext-           let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight-               editorOffset = if st^.csEditState.cedEphemeral.eesMultiline-                              then multilineHeightLimit-                              else 0-           render $ translateBy (Location (0, rowOffset)) $-                    vBox [ hBorderWithLabel label-                         , vLimit visibleHeight $-                           renderList (renderAutocompleteAlternative curUser) True matchList-                         , footer-                         ]--renderAutocompleteFooterFor :: ClientChannel -> AutocompleteAlternative -> Maybe (Widget Name)-renderAutocompleteFooterFor _ (SpecialMention MentionChannel) = Nothing-renderAutocompleteFooterFor _ (SpecialMention MentionAll) = Nothing-renderAutocompleteFooterFor ch (UserCompletion _ False) =-    Just $ hBox [ txt $ "("-                , withDefAttr clientEmphAttr (txt userNotInChannelMarker)-                , txt ": not a member of "-                , withDefAttr channelNameAttr (txt $ normalChannelSigil <> ch^.ccInfo.cdName)-                , txt ")"-                ]-renderAutocompleteFooterFor _ (ChannelCompletion False ch) =-    Just $ hBox [ txt $ "("-                , withDefAttr clientEmphAttr (txt userNotInChannelMarker)-                , txt ": you are not a member of "-                , withDefAttr channelNameAttr (txt $ normalChannelSigil <> sanitizeUserText (channelName ch))-                , txt ")"-                ]-renderAutocompleteFooterFor _ _ = Nothing--renderAutocompleteAlternative :: Text -> Bool -> AutocompleteAlternative -> Widget Name-renderAutocompleteAlternative _ sel (EmojiCompletion e) =-    padRight Max $ renderEmojiCompletion sel e-renderAutocompleteAlternative _ sel (SpecialMention m) =-    padRight Max $ renderSpecialMention m sel-renderAutocompleteAlternative curUser sel (UserCompletion u inChan) =-    padRight Max $ renderUserCompletion curUser u inChan sel-renderAutocompleteAlternative _ sel (ChannelCompletion inChan c) =-    padRight Max $ renderChannelCompletion c inChan sel-renderAutocompleteAlternative _ _ (SyntaxCompletion t) =-    padRight Max $ txt t-renderAutocompleteAlternative _ _ (CommandCompletion n args desc) =-    padRight Max $ renderCommandCompletion n args desc--renderSpecialMention :: SpecialMention -> Bool -> Widget Name-renderSpecialMention m sel =-    let usernameWidth = 18-        padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ')-        maybeForce = if sel-                     then forceAttr listSelectedFocusedAttr-                     else id-        t = autocompleteAlternativeReplacement $ SpecialMention m-        desc = case m of-            MentionChannel -> "Notifies all users in this channel"-            MentionAll     -> "Mentions all users in this channel"-    in maybeForce $-       hBox [ txt "  "-            , padTo usernameWidth $ withDefAttr clientEmphAttr $ txt t-            , txt desc-            ]--renderEmojiCompletion :: Bool -> T.Text -> Widget Name-renderEmojiCompletion sel e =-    let maybeForce = if sel-                     then forceAttr listSelectedFocusedAttr-                     else id-    in maybeForce $-       padLeft (Pad 2) $-       withDefAttr emojiAttr $-       txt $-       autocompleteAlternativeReplacement $ EmojiCompletion e--renderUserCompletion :: Text -> User -> Bool -> Bool -> Widget Name-renderUserCompletion curUser u inChan selected =-    let usernameWidth = 18-        fullNameWidth = 25-        padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ')-        username = userUsername u-        fullName = (sanitizeUserText $ userFirstName u) <> " " <>-                   (sanitizeUserText $ userLastName u)-        nickname = sanitizeUserText $ userNickname u-        maybeForce = if selected-                     then forceAttr listSelectedFocusedAttr-                     else id-        memberDisplay = if inChan-                        then txt "  "-                        else withDefAttr clientEmphAttr $-                             txt $ userNotInChannelMarker <> " "-    in maybeForce $-       hBox [ memberDisplay-            , padTo usernameWidth $ colorUsername curUser username ("@" <> username)-            , padTo fullNameWidth $ txt fullName-            , txt nickname-            ]--renderChannelCompletion :: Channel -> Bool -> Bool -> Widget Name-renderChannelCompletion c inChan selected =-    let urlNameWidth = 30-        displayNameWidth = 30-        padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ')-        maybeForce = if selected-                     then forceAttr listSelectedFocusedAttr-                     else id-        memberDisplay = if inChan-                        then txt "  "-                        else withDefAttr clientEmphAttr $-                             txt $ userNotInChannelMarker <> " "-    in maybeForce $-       hBox [ memberDisplay-            , padTo urlNameWidth $-              withDefAttr channelNameAttr $-              txt $ normalChannelSigil <> (sanitizeUserText $ channelName c)-            , padTo displayNameWidth $-              withDefAttr channelNameAttr $-              txt $ sanitizeUserText $ channelDisplayName c-            , txt $ sanitizeUserText $ channelPurpose c-            ]--renderCommandCompletion :: Text -> Text -> Text -> Widget Name-renderCommandCompletion name args desc =-    withDefAttr clientMessageAttr-        (txt $ "/" <> name <> if T.null args then "" else " " <> args) <+>-    (txt $ " - " <> desc)
− src/Draw/ChannelList.hs 
@@ -1,208 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RankNTypes #-}---- | This module provides the Drawing functionality for the--- ChannelList sidebar.  The sidebar is divided vertically into groups--- and each group is rendered separately.------ There are actually two UI modes handled by this code:------   * Normal display of the channels, with various markers to---     indicate the current channel, channels with unread messages,---     user state (for Direct Message channels), etc.------   * ChannelSelect display where the user is typing match characters---     into a prompt at the ChannelList sidebar is showing only those---     channels matching the entered text (and highlighting the---     matching portion).--module Draw.ChannelList (renderChannelList) where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Center (hCenter)-import qualified Data.Text as T-import           Lens.Micro.Platform (non)--import qualified Network.Mattermost.Types as MM--import           Constants ( userSigil )-import           Draw.Util-import           State.Channels-import           Themes-import           Types-import           Types.Common ( sanitizeUserText )-import qualified Zipper as Z---- | Internal record describing each channel entry and its associated--- attributes.  This is the object passed to the rendering function so--- that it can determine how to render each channel.-data ChannelListEntryData =-    ChannelListEntryData { entrySigil       :: Text-                         , entryLabel       :: Text-                         , entryHasUnread   :: Bool-                         , entryMentions    :: Int-                         , entryIsRecent    :: Bool-                         , entryIsReturn    :: Bool-                         , entryIsCurrent   :: Bool-                         , entryIsMuted     :: Bool-                         , entryUserStatus  :: Maybe UserStatus-                         }--renderChannelList :: ChatState -> Widget Name-renderChannelList st =-    viewport ChannelList Vertical body-    where-        teamHeader = hCenter $-                     withDefAttr clientEmphAttr $-                     txt $ "Team: " <> teamNameStr-        myUsername_ = myUsername st-        me = userById (myUserId st) st-        statusSigil = maybe ' ' userSigilFromInfo me-        selfHeader = hCenter $-                     colorUsername myUsername_ myUsername_ (T.singleton statusSigil <> " " <> userSigil <> myUsername_)-        teamNameStr = sanitizeUserText $ MM.teamDisplayName $ st^.csMyTeam-        body = case appMode st of-            ChannelSelect ->-                let zipper = st^.csChannelSelectState.channelSelectMatches-                    matches = if Z.isEmpty zipper-                              then [hCenter $ txt "No matches"]-                              else (renderChannelListGroup st (renderChannelSelectListEntry (Z.focus zipper)) <$>-                                   Z.toList zipper)-                in vBox $-                   teamHeader :-                   selfHeader :-                   matches-            _ ->-                cached ChannelSidebar $-                vBox $-                teamHeader :-                selfHeader :-                (renderChannelListGroup st (\s e -> renderChannelListEntry myUsername_ $ mkChannelEntryData s e) <$>-                    Z.toList (st^.csFocus))--renderChannelListGroupHeading :: ChannelListGroup -> Widget Name-renderChannelListGroupHeading g =-    let (anyUnread, label) = case g of-            ChannelGroupPublicChannels u -> (u, "Public Channels")-            ChannelGroupPrivateChannels u -> (u, "Private Channels")-            ChannelGroupDirectMessages u -> (u, "Direct Messages")-        addUnread = if anyUnread-                    then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*"))-                    else id-        labelWidget = addUnread $ withDefAttr channelListHeaderAttr $ txt label-    in hBorderWithLabel labelWidget--renderChannelListGroup :: ChatState-                       -> (ChatState -> e -> Widget Name)-                       -> (ChannelListGroup, [e])-                       -> Widget Name-renderChannelListGroup st renderEntry (group, es) =-    let heading = renderChannelListGroupHeading group-        entryWidgets = renderEntry st <$> es-    in if null entryWidgets-       then emptyWidget-       else vBox (heading : entryWidgets)--mkChannelEntryData :: ChatState-                   -> ChannelListEntry-                   -> ChannelListEntryData-mkChannelEntryData st e =-    ChannelListEntryData sigilWithSpace name unread mentions recent ret current muted status-    where-        cId = channelListEntryChannelId e-        Just chan = findChannelById cId (st^.csChannels)-        unread = hasUnread' chan-        recent = isRecentChannel st cId-        ret = isReturnChannel st cId-        current = isCurrentChannel st cId-        muted = isMuted chan-        (name, normalSigil, addSpace, status) = case e of-            CLChannel _ ->-                (chan^.ccInfo.cdDisplayName, Nothing, False, Nothing)-            CLGroupDM _ ->-                (chan^.ccInfo.cdDisplayName, Just " ", True, Nothing)-            CLUserDM _ uId ->-                let Just u = userById uId st-                    uname = if useNickname st-                            then u^.uiNickName.non (u^.uiName)-                            else u^.uiName-                in (uname, Just $ T.singleton $ userSigilFromInfo u, True, Just $ u^.uiStatus)-        sigilWithSpace = sigil <> if addSpace then " " else ""-        prevEditSigil = "»"-        sigil = if current-                then fromMaybe "" normalSigil-                else case chan^.ccEditState.eesInputHistoryPosition of-                    Just _ -> prevEditSigil-                    Nothing ->-                        case chan^.ccEditState.eesLastInput of-                            ("", _) -> fromMaybe "" normalSigil-                            _       -> prevEditSigil-        mentions = chan^.ccInfo.cdMentionCount---- | Render an individual Channel List entry (in Normal mode) with--- appropriate visual decorations.-renderChannelListEntry :: Text -> ChannelListEntryData -> Widget Name-renderChannelListEntry myUName entry = body-    where-    body = decorate $ decorateEntry entry $ decorateMentions $ padRight Max $-           entryWidget $ entrySigil entry <> entryLabel entry-    decorate = if | entryIsCurrent entry ->-                      visible . forceAttr currentChannelNameAttr-                  | entryMentions entry > 0 && not (entryIsMuted entry) ->-                      forceAttr mentionsChannelAttr-                  | entryHasUnread entry ->-                      forceAttr unreadChannelAttr-                  | otherwise -> id-    entryWidget = case entryUserStatus entry of-                    Just Offline -> withDefAttr clientMessageAttr . txt-                    Just _       -> colorUsername myUName (entryLabel entry)-                    Nothing      -> txt-    decorateMentions-      | entryMentions entry > 9 =-        (<+> str "(9+)")-      | entryMentions entry > 0 =-        (<+> str ("(" <> show (entryMentions entry) <> ")"))-      | entryIsMuted entry =-        (<+> str "(m)")-      | otherwise = id---- | Render an individual entry when in Channel Select mode,--- highlighting the matching portion, or completely suppressing the--- entry if it doesn't match.-renderChannelSelectListEntry :: Maybe ChannelSelectMatch -> ChatState -> ChannelSelectMatch -> Widget Name-renderChannelSelectListEntry curMatch st match =-    let ChannelSelectMatch preMatch inMatch postMatch _ entry = match-        maybeSelect = if (Just entry) == (matchEntry <$> curMatch)-                      then visible . withDefAttr currentChannelNameAttr-                      else id-        entryData = mkChannelEntryData st entry-    in maybeSelect $-       decorateEntry entryData $-       padRight Max $-         hBox [ txt $ entrySigil entryData <> preMatch-              , forceAttr channelSelectMatchAttr $ txt inMatch-              , txt postMatch-              ]---- If this channel is the return channel, add a decoration to denote--- that.------ Otherwise, if this channel is the most recently viewed channel (prior--- to the currently viewed channel), add a decoration to denote that.-decorateEntry :: ChannelListEntryData -> Widget n -> Widget n-decorateEntry entry =-    if entryIsReturn entry-    then (<+> (withDefAttr recentMarkerAttr $ str returnChannelSigil))-    else if entryIsRecent entry-         then (<+> (withDefAttr recentMarkerAttr $ str recentChannelSigil))-         else id--recentChannelSigil :: String-recentChannelSigil = "<"--returnChannelSigil :: String-returnChannelSigil = "~"
− src/Draw/ChannelListOverlay.hs 
@@ -1,54 +0,0 @@-module Draw.ChannelListOverlay-  ( drawChannelListOverlay-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import qualified Data.Text as T-import           Text.Wrap ( defaultWrapSettings, preserveIndentation )--import           Network.Mattermost.Types-import           Network.Mattermost.Lenses--import           Draw.Main-import           Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import           Types-import           Types.Common ( sanitizeUserText )-import           Themes---drawChannelListOverlay :: ChatState -> [Widget Name]-drawChannelListOverlay st =-    let overlay = drawListOverlay (st^.csChannelListOverlay) channelSearchScopeHeader-                                  channelSearchScopeNoResults channelSearchScopePrompt-                                  renderChannel-                                  Nothing-                                  OverlayCenter-                                  80-    in joinBorders overlay : drawMain False st--channelSearchScopePrompt :: ChannelSearchScope -> Widget Name-channelSearchScopePrompt scope =-    txt $ case scope of-        AllChannels -> "Search channels:"--channelSearchScopeNoResults :: ChannelSearchScope -> Widget Name-channelSearchScopeNoResults scope =-    txt $ case scope of-        AllChannels -> "No matching channels found."--channelSearchScopeHeader :: ChannelSearchScope -> Widget Name-channelSearchScopeHeader scope =-    withDefAttr clientEmphAttr $ txt $ case scope of-        AllChannels -> "Join a Channel"--renderChannel :: Bool -> Channel -> Widget Name-renderChannel _ chan =-    let baseStr = (sanitizeUserText $ chan^.channelNameL) <> " (" <>-                  (sanitizeUserText $ chan^.channelDisplayNameL) <> ")"-        s = "  " <> (T.strip $ sanitizeUserText $ chan^.channelPurposeL)-    in (vLimit 1 $ padRight Max $ withDefAttr clientEmphAttr $ txt baseStr) <=>-       (vLimit 1 $ txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s)
− src/Draw/DeleteChannelConfirm.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Draw.DeleteChannelConfirm-    ( drawDeleteChannelConfirm-    )-where--import Prelude ()-import Prelude.MH--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center--import Draw.Main-import Themes-import Types---drawDeleteChannelConfirm :: ChatState -> [Widget Name]-drawDeleteChannelConfirm st =-    confirmBox st : (drawMain False st)--confirmBox :: ChatState -> Widget Name-confirmBox st =-    let cName = st^.csCurrentChannel.ccInfo.cdName-    in centerLayer $ hLimit 50 $ vLimit 15 $-       withDefAttr dialogAttr $-       borderWithLabel (txt "Confirm Delete Channel") $-       vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to delete this channel?"-            , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName-            , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to delete the channel"-            , hCenter $ txt "or any other key to cancel."-            ]
− src/Draw/LeaveChannelConfirm.hs 
@@ -1,33 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Draw.LeaveChannelConfirm-    ( drawLeaveChannelConfirm-    )-where--import Prelude ()-import Prelude.MH--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center--import Draw.Main-import Themes-import Types---drawLeaveChannelConfirm :: ChatState -> [Widget Name]-drawLeaveChannelConfirm st =-    confirmBox st : (drawMain False st)--confirmBox :: ChatState -> Widget Name-confirmBox st =-    let cName = st^.csCurrentChannel.ccInfo.cdName-    in centerLayer $ hLimit 50 $ vLimit 15 $-       withDefAttr dialogAttr $-       borderWithLabel (txt "Confirm Leave Channel") $-       vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to leave this channel?"-            , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName-            , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to leave the channel"-            , hCenter $ txt "or any other key to cancel."-            ]
− src/Draw/ListOverlay.hs 
@@ -1,134 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Draw.ListOverlay-  ( drawListOverlay-  , OverlayPosition(..)-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Center-import           Brick.Widgets.Edit-import qualified Brick.Widgets.List as L-import           Control.Monad.Trans.Reader ( withReaderT )-import qualified Data.Foldable as F-import qualified Data.Text as T-import           Graphics.Vty ( imageWidth, translateX)-import           Lens.Micro.Platform ( (%~), (.~), to )--import           Themes-import           Types---hLimitWithPadding :: Int -> Widget n -> Widget n-hLimitWithPadding pad contents = Widget-  { hSize  = Fixed-  , vSize  = (vSize contents)-  , render =-      withReaderT (& availWidthL  %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents-  }--data OverlayPosition =-    OverlayCenter-    | OverlayUpperRight-    deriving (Eq, Show)---- | Draw a ListOverlayState. This draws a bordered box with the--- overlay's search input and results list inside the box. The provided--- functions determine how to render the overlay in various states.-drawListOverlay :: ListOverlayState a b-                -- ^ The overlay state-                -> (b -> Widget Name)-                -- ^ The function to build the window title from the-                -- current search scope-                -> (b -> Widget Name)-                -- ^ The function to generate a message for the search-                -- scope indicating that no results were found-                -> (b -> Widget Name)-                -- ^ The function to generate the editor prompt for the-                -- search scope-                -> (Bool -> a -> Widget Name)-                -- ^ The function to render an item from the overlay's-                -- list-                -> Maybe (Widget Name)-                -- ^ The footer widget to render underneath the search-                -- results-                -> OverlayPosition-                -- ^ How to position the overlay layer-                -> Int-                -- ^ The maximum window width in columns-                -> Widget Name-drawListOverlay st scopeHeader scopeNoResults scopePrompt renderItem footer layerPos maxWinWidth =-  positionLayer $ hLimitWithPadding 10 $ vLimit 25 $-  hLimit maxWinWidth $-  borderWithLabel title body-  where-      title = withDefAttr clientEmphAttr $-              hBox [ scopeHeader scope-                   , case st^.listOverlayRecordCount of-                         Nothing -> emptyWidget-                         Just c -> txt " (" <+> str (show c) <+> txt ")"-                   ]-      positionLayer = case layerPos of-          OverlayCenter -> centerLayer-          OverlayUpperRight -> upperRightLayer-      body = vBox [ (padRight (Pad 1) promptMsg) <+>-                    renderEditor (txt . T.unlines) True (st^.listOverlaySearchInput)-                  , cursorPositionBorder-                  , showResults-                  , fromMaybe emptyWidget footer-                  ]-      plural 1 = ""-      plural _ = "s"-      cursorPositionBorder =-          if st^.listOverlaySearching-          then hBorderWithLabel $ txt "[Searching...]"-          else case st^.listOverlaySearchResults.L.listSelectedL of-              Nothing -> hBorder-              Just _ ->-                  let showingFirst = "Showing first " <> show numSearchResults <>-                                     " result" <> plural numSearchResults-                      showingAll = "Showing all " <> show numSearchResults <>-                                   " result" <> plural numSearchResults-                      showing = "Showing " <> show numSearchResults <>-                                " result" <> plural numSearchResults-                      msg = case getEditContents (st^.listOverlaySearchInput) of-                          [""] ->-                              case st^.listOverlayRecordCount of-                                  Nothing -> showing-                                  Just total -> if numSearchResults < total-                                                then showingFirst-                                                else showingAll-                          _ -> showing-                  in hBorderWithLabel $ str $ "[" <> msg <> "]"--      scope = st^.listOverlaySearchScope-      promptMsg = scopePrompt scope--      showMessage = center . withDefAttr clientEmphAttr--      showResults-        | numSearchResults == 0 = showMessage $ scopeNoResults scope-        | otherwise = renderedUserList--      renderedUserList = L.renderList renderItem True (st^.listOverlaySearchResults)-      numSearchResults = F.length $ st^.listOverlaySearchResults.L.listElementsL--upperRightLayer :: Widget a -> Widget a-upperRightLayer w =-    Widget (hSize w) (vSize w) $ do-        result <- render w-        c <- getContext-        let rWidth = result^.imageL.to imageWidth-            leftPaddingAmount = max 0 $ c^.availWidthL - rWidth-            paddedImage = translateX leftPaddingAmount $ result^.imageL-            off = Location (leftPaddingAmount, 0)-        if leftPaddingAmount == 0 then-            return result else-            return $ addResultOffset off-                   $ result & imageL .~ paddedImage
− src/Draw/Main.hs 
@@ -1,655 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module Draw.Main (drawMain) where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Border.Style-import           Brick.Widgets.Center ( hCenter )-import           Brick.Widgets.List ( listElements )-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-import           Data.Text.Zipper ( cursorPosition, insertChar, getText, gotoEOL )-import           Data.Time.Calendar ( fromGregorian )-import           Data.Time.Clock ( UTCTime(..) )-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( (.~), (^?!), to, view, folding )--import           Network.Mattermost.Types ( ChannelId, Type(Direct, Private, Group)-                                          , ServerTime(..), UserId-                                          )---import           Constants-import           Draw.ChannelList ( renderChannelList )-import           Draw.Messages-import           Draw.Autocomplete-import           Draw.URLList-import           Draw.Util-import           Draw.RichText-import           Events.Keybindings-import           Events.MessageSelect-import           State.MessageSelect-import           Themes-import           TimeUtils ( justAfter, justBefore )-import           Types-import           Types.RichText ( parseMarkdown )-import           Types.KeyEvents---previewFromInput :: Maybe MessageType -> UserId -> Text -> Maybe Message-previewFromInput _ _ s | s == T.singleton cursorSentinel = Nothing-previewFromInput overrideTy uId s =-    -- If it starts with a slash but not /me, this has no preview-    -- representation-    let isCommand = "/" `T.isPrefixOf` s-        isEmoteCmd = "/me " `T.isPrefixOf` s-        content = if isEmoteCmd-                  then T.stripStart $ T.drop 3 s-                  else s-        msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy-    in if isCommand && not isEmoteCmd-       then Nothing-       else Just $ Message { _mText          = parseMarkdown content-                           , _mMarkdownSource = content-                           , _mUser          = UserI False uId-                           , _mDate          = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0-                           -- The date is not used for preview-                           -- rendering, but we need to provide one.-                           -- Ideally we'd just use today's date, but-                           -- the rendering function is pure so we-                           -- can't.-                           , _mType          = msgTy-                           , _mPending       = False-                           , _mDeleted       = False-                           , _mAttachments   = mempty-                           , _mInReplyToMsg  = NotAReply-                           , _mMessageId     = Nothing-                           , _mReactions     = mempty-                           , _mOriginalPost  = Nothing-                           , _mFlagged       = False-                           , _mPinned        = False-                           , _mChannelId     = Nothing-                           }---- | Tokens in spell check highlighting.-data Token =-    Ignore Text-    -- ^ This bit of text is to be ignored for the purposes of-    -- spell-checking.-    | Check Text-    -- ^ This bit of text should be checked against the spell checker's-    -- misspelling list.-    deriving (Show)--drawEditorContents :: ChatState -> HighlightSet -> [Text] -> Widget Name-drawEditorContents st hs =-    let noHighlight = txt . T.unlines-    in case st^.csEditState.cedSpellChecker of-        Nothing -> noHighlight-        Just _ ->-            case S.null (st^.csEditState.cedMisspellings) of-                True -> noHighlight-                False -> doHighlightMisspellings-                           hs-                           (st^.csEditState.cedMisspellings)---- | This function takes a set of misspellings from the spell--- checker, the editor lines, and builds a rendering of the text with--- misspellings highlighted.------ This function processes each line of text from the editor as follows:------ * Tokenize the line based on our rules for what constitutes---   whitespace. We do this because we need to check "words" in the---   user's input against the list of misspellings returned by the spell---   checker. But to do this we need to ignore the same things that---   Aspell ignores, and it ignores whitespace and lots of puncutation.---   We also do this because once we have identified the misspellings---   present in the input, we need to reconstruct the user's input and---   that means preserving whitespace so that the input looks as it was---   originally typed.------ * Once we have a list of tokens -- the whitespace tokens to be---   preserved but ignored and the tokens to be checked -- we check---   each non-whitespace token for presence in the list of misspellings---   reported by the checker.------ * Having indicated which tokens correspond to misspelled words, we---   then need to coallesce adjacent tokens that are of the same---   "misspelling status", i.e., two neighboring tokens (of whitespace---   or check type) need to be coallesced if they both correspond to---   text that is a misspelling or if they both are NOT a misspelling.---   We do this so that the final Brick widget is optimal in that it---   uses a minimal number of box cells to display substrings that have---   the same attribute.------ * Finally we build a widget out of these coallesced tokens and apply---   the misspellingAttr attribute to the misspelled tokens.------ Note that since we have to come to our own conclusion about which--- words are worth checking in the checker's output, sometimes our--- algorithm will differ from aspell in what is considered "part of a--- word" and what isn't. In particular, Aspell is smart about sometimes--- noticing that "'" is an apostrophe and at other times that it is--- a single quote as part of a quoted string. As a result there will--- be cases where Markdown formatting characters interact poorly--- with Aspell's checking to result in misspellings that are *not*--- highlighted.------ One way to deal with this would be to *not* parse the user's input--- as done here, complete with all its Markdown metacharacters, but to--- instead 1) parse the input as Markdown, 2) traverse the Markdown AST--- and extract the words from the relevant subtrees, and 3) spell-check--- those words. The reason we don't do it that way in the first place is--- because 1) the user's input might not be valid markdown and 2) even--- if we did that, we'd still have to do this tokenization operation to--- annotate misspellings and reconstruct the user's raw input.-doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name-doHighlightMisspellings hSet misspellings contents =-    -- Traverse the input, gathering non-whitespace into tokens and-    -- checking if they appear in the misspelling collection-    let whitelist = S.union (hUserSet hSet) (hChannelSet hSet)--        handleLine t | t == "" = txt " "-        handleLine t =-            -- For annotated tokens, coallesce tokens of the same type-            -- and add attributes for misspellings.-            let mkW (Left tok) =-                    let s = getTokenText tok-                    in if T.null s-                       then emptyWidget-                       else withDefAttr misspellingAttr $ txt $ getTokenText tok-                mkW (Right tok) =-                    let s = getTokenText tok-                    in if T.null s-                       then emptyWidget-                       else txt s--                go :: Either Token Token -> [Either Token Token] -> [Either Token Token]-                go lst [] = [lst]-                go lst (tok:toks) =-                    case (lst, tok) of-                        (Left a, Left b)   -> go (Left $ combineTokens a b) toks-                        (Right a, Right b) -> go (Right $ combineTokens a b) toks-                        _                  -> lst : go tok toks--            in hBox $ mkW <$> (go (Right $ Ignore "") $ annotatedTokens t)--        combineTokens (Ignore a) (Ignore b) = Ignore $ a <> b-        combineTokens (Check a) (Check b) = Check $ a <> b-        combineTokens (Ignore a) (Check b) = Check $ a <> b-        combineTokens (Check a) (Ignore b) = Check $ a <> b--        getTokenText (Ignore a) = a-        getTokenText (Check a) = a--        annotatedTokens t =-            -- For every token, check on whether it is a misspelling.-            -- The result is Either Token Token where the Left is a-            -- misspelling and the Right is not.-            checkMisspelling <$> tokenize t (Ignore "")--        checkMisspelling t@(Ignore _) = Right t-        checkMisspelling t@(Check s) =-            if s `S.member` whitelist-            then Right t-            else if s `S.member` misspellings-                 then Left t-                 else Right t--        ignoreChar c = isSpace c || isPunctuation c || c == '`' || c == '/' ||-                       T.singleton c == userSigil || T.singleton c == normalChannelSigil--        tokenize t curTok-            | T.null t = [curTok]-            | ignoreChar $ T.head t =-                case curTok of-                    Ignore s -> tokenize (T.tail t) (Ignore $ s <> (T.singleton $ T.head t))-                    Check s -> Check s : tokenize (T.tail t) (Ignore $ T.singleton $ T.head t)-            | otherwise =-                case curTok of-                    Ignore s -> Ignore s : tokenize (T.tail t) (Check $ T.singleton $ T.head t)-                    Check s -> tokenize (T.tail t) (Check $ s <> (T.singleton $ T.head t))--    in vBox $ handleLine <$> contents--renderUserCommandBox :: ChatState -> HighlightSet -> Widget Name-renderUserCommandBox st hs =-    let prompt = txt $ case st^.csEditState.cedEditMode of-            Replying _ _ -> "reply> "-            Editing _ _  ->  "edit> "-            NewPost      ->      "> "-        inputBox = renderEditor (drawEditorContents st hs) True (st^.csEditState.cedEditor)-        curContents = getEditContents $ st^.csEditState.cedEditor-        multilineContent = length curContents > 1-        multilineHints =-            hBox [ borderElem bsHorizontal-                 , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $-                                        st^.csEditState.cedEditor.editContentsL) <>-                         "/" <> (show $ length curContents) <> "]"-                 , hBorderWithLabel $ withDefAttr clientEmphAttr $-                   txt $ "In multi-line mode. Press " <>-                         (ppBinding (getFirstDefaultBinding ToggleMultiLineEvent)) <>-                         " to finish."-                 ]--        replyDisplay = case st^.csEditState.cedEditMode of-            Replying msg _ ->-                let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply-                in hBox [ replyArrow-                        , addEllipsis $ renderMessage MessageData-                          { mdMessage           = msgWithoutParent-                          , mdUserName          = msgWithoutParent^.mUser.to (nameForUserRef st)-                          , mdParentMessage     = Nothing-                          , mdParentUserName    = Nothing-                          , mdHighlightSet      = hs-                          , mdEditThreshold     = Nothing-                          , mdShowOlderEdits    = False-                          , mdRenderReplyParent = True-                          , mdIndentBlocks      = False-                          , mdThreadState       = NoThread-                          , mdShowReactions     = True-                          , mdMessageWidthLimit = Nothing-                          , mdMyUsername        = myUsername st-                          }-                        ]-            _ -> emptyWidget--        commandBox = case st^.csEditState.cedEphemeral.eesMultiline of-            False ->-                let linesStr = "line" <> if numLines == 1 then "" else "s"-                    numLines = length curContents-                in vLimit 1 $ hBox $-                   prompt : if multilineContent-                            then [ withDefAttr clientEmphAttr $-                                   str $ "[" <> show numLines <> " " <> linesStr <>-                                         "; Enter: send, M-e: edit, Backspace: cancel] "-                                 , txt $ head curContents-                                 , showCursor MessageInput (Location (0,0)) $ str " "-                                 ]-                            else [inputBox]-            True -> vLimit multilineHeightLimit inputBox <=> multilineHints-    in replyDisplay <=> commandBox--renderChannelHeader :: ChatState -> HighlightSet -> ClientChannel -> Widget Name-renderChannelHeader st hs chan =-    let chnType = chan^.ccInfo.cdType-        topicStr = chan^.ccInfo.cdHeader-        userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts-                           parts = [ userSigil <> u^.uiName-                                   , if (all T.null names)-                                     then mempty-                                     else "is"-                                   ] <> names <> [-                                     if T.null (u^.uiEmail)-                                     then mempty-                                     else "(" <> u^.uiEmail <> ")"-                                   ]-                           names = [ u^.uiFirstName-                                   , nick-                                   , u^.uiLastName-                                   ]-                           quote n = "\"" <> n <> "\""-                           nick = maybe "" quote $ u^.uiNickName-                       in s-        maybeTopic = if T.null topicStr-                     then ""-                     else " - " <> topicStr-        channelNameString = case chnType of-            Direct ->-                case chan^.ccInfo.cdDMUserId >>= flip userById st of-                    Nothing -> mkChannelName (chan^.ccInfo)-                    Just u -> userHeader u-            Private ->-                channelNamePair <> " (Private)"-            Group ->-                channelNamePair <> " (Private group)"-            _ ->-                channelNamePair-        newlineToSpace '\n' = ' '-        newlineToSpace c = c-        channelNamePair = mkChannelName (chan^.ccInfo) <> " - " <> (chan^.ccInfo.cdDisplayName)--    in renderText' (myUsername st)-         hs-         (T.map newlineToSpace (channelNameString <> maybeTopic))--renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name-renderCurrentChannelDisplay st hs = header <=> messages-    where-    header = withDefAttr channelHeaderAttr $-             padRight Max $-             renderChannelHeader st hs chan-    messages = padTop Max $ padRight (Pad 1) body--    body = chatText--    chatText = case appMode st of-        MessageSelect ->-            renderMessagesWithSelect (st^.csMessageSelect) channelMessages-        MessageSelectDeleteConfirm ->-            renderMessagesWithSelect (st^.csMessageSelect) channelMessages-        _ ->-            cached (ChannelMessages cId) $-            renderLastMessages st hs editCutoff $-            retrogradeMsgsWithThreadStates $-            reverseMessages channelMessages--    renderMessagesWithSelect (MessageSelectState selMsgId) msgs =-        -- In this case, we want to fill the message list with messages-        -- but use the post ID as a cursor. To do this efficiently we-        -- only want to render enough messages to fill the screen.-        ---        -- If the message area is H rows high, this actually renders at-        -- most 2H rows' worth of messages and then does the appropriate-        -- cropping. This way we can simplify the math needed to figure-        -- out how to crop while bounding the number of messages we-        -- render around the cursor.-        ---        -- First, we sanity-check the application state because under-        -- some conditions, the selected message might be gone (e.g.-        -- deleted).-        let (s, (before, after)) = splitDirSeqOn (\(m, _) -> m^.mMessageId == selMsgId) msgsWithStates-            msgsWithStates = chronologicalMsgsWithThreadStates msgs-        in case s of-             Nothing ->-                 renderLastMessages st hs editCutoff before-             Just m ->-                 unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st hs Nothing)--    cutoff = getNewMessageCutoff cId st-    editCutoff = getEditedMessageCutoff cId st-    channelMessages =-        insertTransitions (getMessageListing cId st)-                          cutoff-                          (getDateFormat st)-                          (st ^. timeZone)--    cId = st^.csCurrentChannelId-    chan = st^.csCurrentChannel--getMessageListing :: ChannelId -> ChatState -> Messages-getMessageListing cId st =-    st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown)-    where isShown m-            | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True-            | otherwise = not $ isJoinLeave m--insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages-insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT-    where anyNondeletedNewMessages t =-              isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms)-          newMessagesT = case cutoff of-              Nothing -> []-              Just Hide -> []-              Just (NewPostsAfterServerTime t)-                  | anyNondeletedNewMessages t -> [newMessagesMsg $ justAfter t]-                  | otherwise -> []-              Just (NewPostsStartingAt t)-                  | anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t]-                  | otherwise -> []-          newMessagesMsg d = newMessageOfType (T.pack "New Messages")-                             (C NewMessagesTransition) d--renderChannelSelectPrompt :: ChatState -> Widget Name-renderChannelSelectPrompt st =-    let e = st^.csChannelSelectState.channelSelectInput-    in withDefAttr channelSelectPromptAttr $-       (txt "Switch to channel [use ^ and $ to anchor]: ") <+>-       (renderEditor (txt . T.concat) True e)--drawMain :: Bool -> ChatState -> [Widget Name]-drawMain useColor st =-    let maybeColor = if useColor then id else forceAttr "invalid"-    in maybeColor <$>-           [ connectionLayer st-           , autocompleteLayer st-           , joinBorders $ mainInterface st-           ]--connectionLayer :: ChatState -> Widget Name-connectionLayer st =-    case st^.csConnectionStatus of-        Connected -> emptyWidget-        Disconnected ->-            Widget Fixed Fixed $ do-                ctx <- getContext-                let aw = ctx^.availWidthL-                    w = length msg + 2-                    msg = "NOT CONNECTED"-                render $ translateBy (Location (max 0 (aw - w), 0)) $-                         withDefAttr errorMessageAttr $-                         border $ str msg--messageSelectBottomBar :: ChatState -> Widget Name-messageSelectBottomBar st =-    let optionStr = if null usableOptions-                    then "(no actions available for this message)"-                    else T.intercalate " " usableOptions-        usableOptions = catMaybes $ mkOption <$> options-        mkOption (f, k, desc) = if f postMsg-                                then Just $ k <> ":" <> desc-                                else Nothing-        numURLs = Seq.length $ msgURLs postMsg-        s = if numURLs == 1 then "" else "s"-        hasURLs = numURLs > 0-        openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s-        hasVerb = isJust (findVerbatimChunk (postMsg^.mText))-        -- make sure these keybinding pieces are up-to-date!-        ev e =-          let keyconf = st^.csResources.crConfiguration.to configUserKeys-              KeyHandlerMap keymap = messageSelectKeybindings keyconf-          in T.intercalate ","-               [ ppBinding (eventToBinding k)-               | KH { khKey     = k-                    , khHandler = h-                    } <- M.elems keymap-               , kehEventTrigger h == ByEvent e-               ]-        options = [ ( not . isGap-                    , ev YankWholeMessageEvent-                    , "yank-all"-                    )-                  , ( \m -> isFlaggable m && not (m^.mFlagged)-                    , ev FlagMessageEvent-                    , "flag"-                    )-                  , ( \m -> isFlaggable m && m^.mFlagged-                    , ev FlagMessageEvent-                    , "unflag"-                    )-                  , ( \m -> isPinnable m && not (m^.mPinned)-                    , ev PinMessageEvent-                    , "pin"-                    )-                  , ( \m -> isPinnable m && m^.mPinned-                    , ev PinMessageEvent-                    , "unpin"-                    )-                  , ( isReplyable-                    , ev ReplyMessageEvent-                    , "reply"-                    )-                  , ( not . isGap-                    , ev ViewMessageEvent-                    , "view"-                    )-                  , ( isGap-                    , ev FillGapEvent-                    , "load messages"-                    )-                  , ( \m -> isMine st m && isEditable m-                    , ev EditMessageEvent-                    , "edit"-                    )-                  , ( \m -> isMine st m && isDeletable m-                    , ev DeleteMessageEvent-                    , "delete"-                    )-                  , ( const hasURLs-                    , ev OpenMessageURLEvent-                    , openUrlsMsg-                    )-                  , ( const hasVerb-                    , ev YankMessageEvent-                    , "yank-code"-                    )-                  , ( isReactable-                    , ev ReactToMessageEvent-                    , "react"-                    )-                  ]-        Just postMsg = getSelectedMessage st--    in hBox [ borderElem bsHorizontal-            , txt "["-            , withDefAttr messageSelectStatusAttr $-              txt $ "Message select: " <> optionStr-            , txt "]"-            , hBorder-            ]--maybePreviewViewport :: Widget Name -> Widget Name-maybePreviewViewport w =-    Widget Greedy Fixed $ do-        result <- render w-        case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of-            False -> return result-            True ->-                render $ vLimit previewMaxHeight $ viewport MessagePreviewViewport Vertical $-                         (Widget Fixed Fixed $ return result)--inputPreview :: ChatState -> HighlightSet -> Widget Name-inputPreview st hs | not $ st^.csShowMessagePreview = emptyWidget-                   | otherwise = thePreview-    where-    uId = myUserId st-    -- Insert a cursor sentinel into the input text just before-    -- rendering the preview. We use the inserted sentinel (which is-    -- not rendered) to get brick to ensure that the line the cursor is-    -- on is visible in the preview viewport. We put the sentinel at-    -- the *end* of the line because it will still influence markdown-    -- parsing and can create undesirable/confusing churn in the-    -- rendering while the cursor moves around. If the cursor is at the-    -- end of whatever line the user is editing, that is very unlikely-    -- to be a problem.-    curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $-                  st^.csEditState.cedEditor.editContentsL-    curStr = T.intercalate "\n" curContents-    overrideTy = case st^.csEditState.cedEditMode of-        Editing _ ty -> Just ty-        _ -> Nothing-    previewMsg = previewFromInput overrideTy uId curStr-    thePreview = let noPreview = str "(No preview)"-                     msgPreview = case previewMsg of-                       Nothing -> noPreview-                       Just pm -> if T.null curStr-                                  then noPreview-                                  else prview pm $ getParentMessage st pm-                     prview m p = renderMessage MessageData-                                  { mdMessage           = m-                                  , mdUserName          = m^.mUser.to (nameForUserRef st)-                                  , mdParentMessage     = p-                                  , mdParentUserName    = p >>= (^.mUser.to (nameForUserRef st))-                                  , mdHighlightSet      = hs-                                  , mdEditThreshold     = Nothing-                                  , mdShowOlderEdits    = False-                                  , mdRenderReplyParent = True-                                  , mdIndentBlocks      = True-                                  , mdThreadState       = NoThread-                                  , mdShowReactions     = True-                                  , mdMessageWidthLimit = Nothing-                                  , mdMyUsername        = myUsername st-                                  }-                 in (maybePreviewViewport msgPreview) <=>-                    hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")--userInputArea :: ChatState -> HighlightSet -> Widget Name-userInputArea st hs =-    case appMode st of-        ChannelSelect -> renderChannelSelectPrompt st-        UrlSelect     -> hCenter $ hBox [ txt "Press "-                                        , withDefAttr clientEmphAttr $ txt "Enter"-                                        , txt " to open the selected URL or "-                                        , withDefAttr clientEmphAttr $ txt "Escape"-                                        , txt " to cancel."-                                        ]-        MessageSelectDeleteConfirm -> renderDeleteConfirm-        _             -> renderUserCommandBox st hs--renderDeleteConfirm :: Widget Name-renderDeleteConfirm =-    hCenter $ txt "Are you sure you want to delete the selected message? (y/n)"--mainInterface :: ChatState -> Widget Name-mainInterface st =-    vBox [ if st^.csShowChannelList || appMode st == ChannelSelect-           then hBox [hLimit channelListWidth (renderChannelList st), vBorder, mainDisplay]-           else mainDisplay-         , bottomBorder-         , inputPreview st hs-         , userInputArea st hs-         ]-    where-    hs = getHighlightSet st-    channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration-    mainDisplay = case appMode st of-        UrlSelect -> renderUrlList st-        _         -> maybeSubdue $ renderCurrentChannelDisplay st hs--    bottomBorder = case appMode st of-        MessageSelect -> messageSelectBottomBar st-        _ -> maybeSubdue $ hBox-             [ showAttachmentCount-             , hBorder-             , showTypingUsers-             , showBusy-             ]--    showAttachmentCount =-        let count = length $ listElements $ st^.csEditState.cedAttachmentList-        in if count == 0-           then emptyWidget-           else hBox [ borderElem bsHorizontal-                     , withDefAttr clientMessageAttr $-                       txt $ "(" <> (T.pack $ show count) <> " attachment" <>-                             (if count == 1 then "" else "s") <> "; "-                     , withDefAttr clientEmphAttr $-                       txt $ ppBinding (getFirstDefaultBinding ShowAttachmentListEvent)-                     , txt " to manage)"-                     ]--    showTypingUsers =-        let format = renderText' (myUsername st) hs-        in case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of-            [] -> emptyWidget-            [uId] | Just un <- usernameForUserId uId st ->-               format $ "[" <> userSigil <> un <> " is typing]"-            [uId1, uId2] | Just un1 <- usernameForUserId uId1 st-                         , Just un2 <- usernameForUserId uId2 st ->-               format $ "[" <> userSigil <> un1 <> " and " <> userSigil <> un2 <> " are typing]"-            _ -> format "[several people are typing]"--    showBusy = case st^.csWorkerIsBusy of-                 Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)-                 Just Nothing -> hLimit 2 hBorder <+> txt "*"-                 Nothing -> emptyWidget--    maybeSubdue = if appMode st == ChannelSelect-                  then forceAttr ""-                  else id--replyArrow :: Widget a-replyArrow =-    Widget Fixed Fixed $ do-        ctx <- getContext-        let bs = ctx^.ctxBorderStyleL-        render $ str [' ', bsCornerTL bs, '▸']
− src/Draw/ManageAttachments.hs 
@@ -1,65 +0,0 @@-module Draw.ManageAttachments-  ( drawManageAttachments-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Center-import qualified Brick.Widgets.FileBrowser as FB-import           Brick.Widgets.List-import           Data.Maybe ( fromJust )--import           Types-import           Types.KeyEvents-import           Events.Keybindings ( getFirstDefaultBinding )-import           Themes-import           Draw.Main ( drawMain )---drawManageAttachments :: ChatState -> [Widget Name]-drawManageAttachments st =-    topLayer : drawMain False st-    where-        topLayer = case appMode st of-            ManageAttachments -> drawAttachmentList st-            ManageAttachmentsBrowseFiles -> drawFileBrowser st-            _ -> error "BUG: drawManageAttachments called in invalid mode"--drawAttachmentList :: ChatState -> Widget Name-drawAttachmentList st =-    let addBinding = ppBinding $ getFirstDefaultBinding AttachmentListAddEvent-        delBinding = ppBinding $ getFirstDefaultBinding AttachmentListDeleteEvent-        escBinding = ppBinding $ getFirstDefaultBinding CancelEvent-        openBinding = ppBinding $ getFirstDefaultBinding AttachmentOpenEvent-    in centerLayer $-       hLimit 60 $-       vLimit 15 $-       joinBorders $-       borderWithLabel (withDefAttr clientEmphAttr $ txt "Attachments") $-       vBox [ renderList renderAttachmentItem True (st^.csEditState.cedAttachmentList)-            , hBorder-            , hCenter $ withDefAttr clientMessageAttr $-                        txt $ addBinding <> ":add " <>-                              delBinding <> ":delete " <>-                              openBinding <> ":open " <>-                              escBinding <> ":close"-            ]--renderAttachmentItem :: Bool -> AttachmentData -> Widget Name-renderAttachmentItem _ d =-    padRight Max $ str $ FB.fileInfoSanitizedFilename $ attachmentDataFileInfo d--drawFileBrowser :: ChatState -> Widget Name-drawFileBrowser st =-    centerLayer $-    hLimit 60 $-    vLimit 20 $-    borderWithLabel (withDefAttr clientEmphAttr $ txt "Attach File") $-    -- invariant: cedFileBrowser is not Nothing if appMode is-    -- ManageAttachmentsBrowseFiles, and that is the only way to reach-    -- this code, ergo the fromJust.-    FB.renderFileBrowser True $ fromJust (st^.csEditState.cedFileBrowser)
− src/Draw/Messages.hs 
@@ -1,204 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module Draw.Messages-  ( nameForUserRef-  , renderSingleMessage-  , unsafeRenderMessageSelection-  , renderLastMessages-  )-where--import           Brick-import           Brick.Widgets.Border-import           Control.Monad.Trans.Reader ( withReaderT )-import qualified Data.Foldable as F-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( (.~), to )-import           Network.Mattermost.Types ( ServerTime(..), userUsername )-import           Prelude ()-import           Prelude.MH--import           Draw.Util-import           Draw.RichText-import           Themes-import           Types-import           Types.DirectionalSeq--maxMessageHeight :: Int-maxMessageHeight = 200---- | nameForUserRef converts the UserRef into a printable name, based--- on the current known user data.-nameForUserRef :: ChatState -> UserRef -> Maybe Text-nameForUserRef st uref =-    case uref of-        NoUser -> Nothing-        UserOverride _ t -> Just t-        UserI _ uId -> displayNameForUserId uId st---- | renderSingleMessage is the main message drawing function.------ The `ind` argument specifies an "indicator boundary".  Showing--- various indicators (e.g. "edited") is not typically done for--- messages that are older than this boundary value.-renderSingleMessage :: ChatState-                    -> HighlightSet-                    -> Maybe ServerTime-                    -> Message-                    -> ThreadState-                    -> Widget Name-renderSingleMessage st hs ind m threadState =-  renderChatMessage st hs ind threadState (withBrackets . renderTime st . withServerTime) m--renderChatMessage :: ChatState-                  -> HighlightSet-                  -> Maybe ServerTime-                  -> ThreadState-                  -> (ServerTime -> Widget Name)-                  -> Message-                  -> Widget Name-renderChatMessage st hs ind threadState renderTimeFunc msg =-    let showOlderEdits = configShowOlderEdits $ st^.csResources.crConfiguration-        parent = case msg^.mInReplyToMsg of-          NotAReply -> Nothing-          InReplyTo pId -> getMessageForPostId st pId-        m = renderMessage MessageData-              { mdMessage           = msg-              , mdUserName          = msg^.mUser.to (nameForUserRef st)-              , mdParentMessage     = parent-              , mdParentUserName    = parent >>= (^.mUser.to (nameForUserRef st))-              , mdEditThreshold     = ind-              , mdHighlightSet      = hs-              , mdShowOlderEdits    = showOlderEdits-              , mdRenderReplyParent = True-              , mdIndentBlocks      = True-              , mdThreadState       = threadState-              , mdShowReactions     = True-              , mdMessageWidthLimit = Nothing-              , mdMyUsername        = userUsername $ myUser st-              }-        fullMsg =-          case msg^.mUser of-            NoUser-              | isGap msg -> withDefAttr gapMessageAttr m-              | otherwise ->-                case msg^.mType of-                    C DateTransition ->-                        withDefAttr dateTransitionAttr (hBorderWithLabel m)-                    C NewMessagesTransition ->-                        withDefAttr newMessageTransitionAttr (hBorderWithLabel m)-                    C Error ->-                        withDefAttr errorMessageAttr m-                    _ ->-                        withDefAttr clientMessageAttr m-            _ | isJoinLeave msg -> withDefAttr clientMessageAttr m-              | otherwise -> m-        maybeRenderTime w =-            let maybePadTime = if threadState == InThreadShowParent-                               then (txt " " <=>) else id-            in hBox [maybePadTime $ renderTimeFunc (msg^.mDate), txt " ", w]-        maybeRenderTimeWith f = if isTransition msg then id else f-    in maybeRenderTimeWith maybeRenderTime fullMsg---- | Render a selected message with focus, including the messages--- before and the messages after it. The foldable parameters exist--- because (depending on the situation) we might use either of the--- message list types for the 'before' and 'after' (i.e. the--- chronological or retrograde message sequences).-unsafeRenderMessageSelection :: (Foldable f, Foldable g)-                             => ((Message, ThreadState), (f (Message, ThreadState), g (Message, ThreadState)))-                             -> (Message -> ThreadState -> Widget Name)-                             -> Widget Name-unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender =-  Widget Greedy Greedy $ do-    ctx <- getContext-    curMsgResult <- withReaderT relaxHeight $ render $-                    forceAttr messageSelectAttr $-                    padRight Max $ doMsgRender curMsg curThreadState--    let targetHeight = ctx^.availHeightL-        upperHeight = targetHeight `div` 2-        lowerHeight = targetHeight - upperHeight--        lowerRender img (m, tState) = render1HLimit doMsgRender Vty.vertJoin targetHeight img tState m-        upperRender img (m, tState) = render1HLimit doMsgRender (flip Vty.vertJoin) targetHeight img tState m--    lowerHalf <- foldM lowerRender Vty.emptyImage after-    upperHalf <- foldM upperRender Vty.emptyImage before--    let curHeight = Vty.imageHeight $ curMsgResult^.imageL-        uncropped = upperHalf Vty.<-> curMsgResult^.imageL Vty.<-> lowerHalf-        img = if | Vty.imageHeight lowerHalf < (lowerHeight - curHeight) ->-                     Vty.cropTop targetHeight uncropped-                 | Vty.imageHeight upperHalf < upperHeight ->-                     Vty.cropBottom targetHeight uncropped-                 | otherwise ->-                     Vty.cropTop upperHeight upperHalf Vty.<-> curMsgResult^.imageL Vty.<->-                        (if curHeight < lowerHeight-                          then Vty.cropBottom (lowerHeight - curHeight) lowerHalf-                          else Vty.cropBottom lowerHeight lowerHalf)-    return $ emptyResult & imageL .~ img--renderLastMessages :: ChatState-                   -> HighlightSet-                   -> Maybe ServerTime-                   -> DirectionalSeq Retrograde (Message, ThreadState)-                   -> Widget Name-renderLastMessages st hs editCutoff msgs =-    Widget Greedy Greedy $ do-        ctx <- getContext-        let targetHeight = ctx^.availHeightL-            doMsgRender = renderSingleMessage st hs editCutoff--            newMessagesTransitions = filterMessages (isNewMessagesTransition . fst) msgs-            newMessageTransition = fst <$> (listToMaybe $ F.toList newMessagesTransitions)--            isBelow m transition = m^.mDate > transition^.mDate--            go :: Vty.Image -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name Vty.Image-            go img ms | messagesLength ms == 0 = return img-            go img ms = do-                let Just (m, threadState) = messagesHead ms-                    newMessagesAbove = maybe False (isBelow m) newMessageTransition-                newImg <- render1HLimit doMsgRender (flip Vty.vertJoin) targetHeight img threadState m-                -- If the new message fills the window, check whether-                -- there is still a "New Messages" transition that is-                -- not displayed. If there is, then we need to replace-                -- the top line of the new image with a "New Messages"-                -- indicator.-                if Vty.imageHeight newImg >= targetHeight && newMessagesAbove-                then do-                    transitionResult <- render $ withDefAttr newMessageTransitionAttr $-                                                 hBorderWithLabel (txt "New Messages ↑")-                    let newImg2 = Vty.vertJoin (transitionResult^.imageL)-                                               (Vty.cropTop (targetHeight - 1) newImg)-                    return newImg2-                else go newImg $ messagesDrop 1 ms--        img <- go Vty.emptyImage msgs-        return $ emptyResult & imageL .~ (Vty.cropTop targetHeight img)--relaxHeight :: Context -> Context-relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))--render1HLimit :: (Message -> ThreadState -> Widget Name)-              -> (Vty.Image -> Vty.Image -> Vty.Image)-              -> Int-              -> Vty.Image-              -> ThreadState-              -> Message-              -> RenderM Name Vty.Image-render1HLimit doMsgRender fjoin lim img threadState msg-  | Vty.imageHeight img >= lim = return img-  | otherwise = fjoin img <$> render1 doMsgRender threadState msg--render1 :: (Message -> ThreadState -> Widget Name)-        -> ThreadState-        -> Message-        -> RenderM Name Vty.Image-render1 doMsgRender threadState msg = case msg^.mDeleted of-    True -> return Vty.emptyImage-    False -> do-        r <- withReaderT relaxHeight $-             render $ padRight Max $-             doMsgRender msg threadState-        return $ r^.imageL
− src/Draw/NotifyPrefs.hs 
@@ -1,35 +0,0 @@-module Draw.NotifyPrefs-  ( drawNotifyPrefs-  )-where--import Prelude ()-import Prelude.MH--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center-import Brick.Forms (renderForm)-import Data.List (intersperse)--import Draw.Util (renderKeybindingHelp)-import Types-import Types.KeyEvents-import Themes--drawNotifyPrefs :: ChatState -> Widget Name-drawNotifyPrefs st =-    let Just form = st^.csNotifyPrefs-        label = forceAttr clientEmphAttr $ str "Notification Preferences"-        formKeys = withDefAttr clientEmphAttr <$> txt <$> ["Tab", "BackTab"]-        bindings = vBox $ hCenter <$> [ renderKeybindingHelp "Save" [FormSubmitEvent] <+> txt "  " <+>-                                        renderKeybindingHelp "Cancel" [CancelEvent]-                                      , hBox ((intersperse (txt "/") formKeys) <> [txt (":Cycle form fields")])-                                      , hBox [withDefAttr clientEmphAttr $ txt "Space", txt ":Toggle form field"]-                                      ]-    in centerLayer $-       vLimit 25 $-       hLimit 39 $-       joinBorders $-       borderWithLabel label $-       (padAll 1 $ renderForm form) <=> hBorder <=> bindings
− src/Draw/PostListOverlay.hs 
@@ -1,117 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module Draw.PostListOverlay where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Center-import           Control.Monad.Trans.Reader ( withReaderT )-import qualified Data.Text as T-import           Lens.Micro.Platform ( (^?), (%~), to )--import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           Constants ( userSigil )-import           Draw.Main-import           Draw.Messages-import           Draw.Util-import           Themes-import           Types---hLimitWithPadding :: Int -> Widget n -> Widget n-hLimitWithPadding pad contents = Widget-  { hSize  = Fixed-  , vSize  = (vSize contents)-  , render =-      withReaderT (& availWidthL  %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents-  }--drawPostListOverlay :: PostListContents -> ChatState -> [Widget Name]-drawPostListOverlay contents st =-  (joinBorders $ drawPostsBox contents st) : (drawMain False st)---- | Draw a PostListOverlay as a floating overlay on top of whatever--- is rendered beneath it-drawPostsBox :: PostListContents -> ChatState -> Widget Name-drawPostsBox contents st =-  centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $-    padRight (Pad 1) messageListContents-  where -- The 'window title' of the overlay-        hs = getHighlightSet st-        contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of-          PostListFlagged -> "Flagged posts"-          PostListPinned cId ->-              let cName = case findChannelById cId (st^.csChannels) of-                      Nothing -> "<UNKNOWN>"-                      Just cc ->-                          case cc^.ccInfo.cdType of-                              Direct ->-                                  case cc^.ccInfo.cdDMUserId >>= flip userById st of-                                      Nothing -> mkChannelName (cc^.ccInfo)-                                      Just u -> userSigil <> u^.uiName-                              _ -> mkChannelName (cc^.ccInfo)-              in "Posts pinned in " <> cName-          PostListSearch terms searching -> "Search results" <> if searching-            then ": " <> terms-            else " (" <> (T.pack . show . length) messages <> "): " <> terms--        messages = insertDateMarkers-                     (filterMessages knownChannel $ st^.csPostListOverlay.postListPosts)-                     (getDateFormat st)-                     (st^.timeZone)--        knownChannel msg =-            case msg^.mChannelId of-                Just cId | Nothing <- st^?csChannels.channelByIdL(cId) -> False-                _ -> True--        -- The overall contents, with a sensible default even if there-        -- are no messages-        messageListContents-          | null messages =-            padTopBottom 1 $-            hCenter $-            withDefAttr clientEmphAttr $-            str $ case contents of-              PostListFlagged -> "You have no flagged messages."-              PostListPinned _ -> "This channel has no pinned messages."-              PostListSearch _ searching ->-                if searching-                  then "Searching ..."-                  else "No search results found"-          | otherwise = vBox renderedMessageList--        -- The render-message function we're using-        renderMessageForOverlay msg tState =-          let renderedMsg = renderSingleMessage st hs Nothing msg tState-          in case msg^.mOriginalPost of-            -- We should factor out some of the channel name logic at-            -- some point, but we can do that later-            Just post-              | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) ->-                 case chan^.ccInfo.cdType of-                  Direct-                    | Just u <- flip userById st =<< chan^.ccInfo.cdDMUserId ->-                        (forceAttr channelNameAttr (txt (userSigil <> u^.uiName)) <=>-                          (str "  " <+> renderedMsg))-                  _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to mkChannelName)) <=>-                         (str "  " <+> renderedMsg))-            _ | CP _ <- msg^.mType -> str "[BUG: unknown channel]"-              | otherwise -> renderedMsg--        -- The full message list, rendered with the current selection-        renderedMessageList =-          let (s, (before, after)) = splitDirSeqOn matchesMessage messagesWithStates-              matchesMessage (m, _) = m^.mMessageId == (MessagePostId <$> st^.csPostListOverlay.postListSelected)-              messagesWithStates = (, InThreadShowParent) <$> messages-          in case s of-            Nothing ->-                map (uncurry renderMessageForOverlay) (reverse (toList messagesWithStates))-            Just curMsg ->-              [unsafeRenderMessageSelection (curMsg, (after, before)) renderMessageForOverlay]
− src/Draw/ReactionEmojiListOverlay.hs 
@@ -1,40 +0,0 @@-module Draw.ReactionEmojiListOverlay-  ( drawReactionEmojiListOverlay-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.List ( listSelectedFocusedAttr )-import qualified Data.Text as T--import           Draw.Main-import           Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import           Types-import           Themes---drawReactionEmojiListOverlay :: ChatState -> [Widget Name]-drawReactionEmojiListOverlay st =-    let overlay = drawListOverlay (st^.csReactionEmojiListOverlay)-                                  (const $ txt "Search Emoji")-                                  (const $ txt "No matching emoji found.")-                                  (const $ txt "Search emoji:")-                                  renderEmoji-                                  Nothing-                                  OverlayCenter-                                  80-    in joinBorders overlay : drawMain False st--renderEmoji :: Bool -> (Bool, T.Text) -> Widget Name-renderEmoji sel (mine, e) =-    let maybeForce = if sel-                     then forceAttr listSelectedFocusedAttr-                     else id-    in maybeForce $-       padRight Max $-       hBox [ if mine then txt " * " else txt "   "-            , withDefAttr emojiAttr $ txt $ ":" <> e <> ":"-            ]
− src/Draw/RichText.hs 
@@ -1,525 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE ParallelListComp #-}-{-# LANGUAGE RecordWildCards #-}-module Draw.RichText-  ( MessageData(..)-  , renderRichText-  , renderMessage-  , renderText-  , renderText'-  , renderElementSeq-  , cursorSentinel-  , addEllipsis-  , findVerbatimChunk-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick ( (<+>), Widget, hLimit, imageL-                       , raw, render, Size(..), Widget(..)-                       )-import qualified Brick as B-import qualified Brick.Widgets.Border as B-import qualified Brick.Widgets.Skylighting as BS-import qualified Data.Foldable as F-import qualified Data.Map.Strict as Map-import qualified Data.Sequence as Seq-import           Data.Sequence ( ViewL(..)-                               , ViewR(..)-                               , (<|)-                               , (|>)-                               , viewl-                               , viewr)-import qualified Data.Sequence as S-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Graphics.Vty as V-import qualified Skylighting.Core as Sky--import           Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )-import           Network.Mattermost.Types ( ServerTime(..) )--import           Constants ( normalChannelSigil, userSigil )-import           Themes-import           Types ( Name, HighlightSet(..) )-import           Types.Messages-import           Types.Posts-import           Types.RichText---emptyHSet :: HighlightSet-emptyHSet = HighlightSet Set.empty Set.empty mempty--omittedUsernameType :: MessageType -> Bool-omittedUsernameType = \case-  CP Join -> True-  CP Leave -> True-  CP TopicChange -> True-  _ -> False---- Add the edit sentinel to the end of the last block in the sequence.--- If the last block is a paragraph, append it to that paragraph.--- Otherwise, append a new block so it appears beneath the last--- block-level element.-addEditSentinel :: ElementData -> Seq RichTextBlock -> Seq RichTextBlock-addEditSentinel d bs =-    case viewr bs of-        EmptyR -> bs-        (rest :> b) -> rest <> appendEditSentinel d b--appendEditSentinel :: ElementData -> RichTextBlock -> Seq RichTextBlock-appendEditSentinel sentinel b =-    let s = Para (S.singleton m)-        m = Element Normal sentinel-    in case b of-        Para is -> S.singleton $ Para (is |> Element Normal ESpace |> m)-        _ -> S.fromList [b, s]---- | A bundled structure that includes all the information necessary--- to render a given message-data MessageData =-    MessageData { mdEditThreshold :: Maybe ServerTime-                -- ^ If specified, any messages edited before this point-                -- in time are not indicated as edited.-                , mdShowOlderEdits :: Bool-                -- ^ Indicates whether "edited" markers should be shown-                -- for old messages (i.e., ignore the mdEditThreshold-                -- value).-                , mdShowReactions :: Bool-                -- ^ Whether to render reactions.-                , mdMessage :: Message-                -- ^ The message to render.-                , mdUserName :: Maybe Text-                -- ^ The username of the message's author, if any. This-                -- is passed here rather than obtaining from the message-                -- because we need to do lookups in the ChatState to-                -- compute this, and we don't pass the ChatState into-                -- renderMessage.-                , mdParentMessage :: Maybe Message-                -- ^ The parent message of this message, if any.-                , mdParentUserName :: Maybe Text-                -- ^ The author of the parent message, if any.-                , mdThreadState :: ThreadState-                -- ^ The thread state of this message.-                , mdRenderReplyParent :: Bool-                -- ^ Whether to render the parent message.-                , mdHighlightSet :: HighlightSet-                -- ^ The highlight set to use to highlight usernames,-                -- channel names, etc.-                , mdIndentBlocks :: Bool-                -- ^ Whether to indent the message underneath the-                -- author's name (True) or just display it to the right-                -- of the author's name (False).-                , mdMessageWidthLimit :: Maybe Int-                -- ^ A width override to use to wrap non-code blocks. If-                -- unspecified, all blocks in the message will be-                -- wrapped and truncated at the width specified by the-                -- rendering context. If specified, all non-code blocks-                -- will be wrapped at this width and code blocks will be-                -- rendered using the context's width.-                , mdMyUsername :: Text-                -- ^ The username of the user running Matterhorn.-                }---- | renderMessage performs markdown rendering of the specified message.-renderMessage :: MessageData -> Widget Name-renderMessage md@MessageData { mdMessage = msg, .. } =-    let msgUsr = case mdUserName of-          Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u-          Nothing -> Nothing-        botElem = if isBotMessage msg then B.txt "[BOT]" else B.emptyWidget-        nameElems = case msgUsr of-          Just un-            | isEmote msg ->-                [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN]" else ""-                , B.txt $ (if msg^.mFlagged then "[!] " else "") <> "*"-                , colorUsername mdMyUsername un un-                , botElem-                , B.txt " "-                ]-            | otherwise ->-                [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN] " else ""-                , colorUsername mdMyUsername un un-                , botElem-                , B.txt $ (if msg^.mFlagged then "[!]" else "") <> ": "-                ]-          Nothing -> []--        -- Use the editing threshold to determine whether to append an-        -- editing indication to this message.-        maybeAugment bs = case msg^.mOriginalPost of-            Nothing -> bs-            Just p ->-                if p^.postEditAtL > p^.postCreateAtL-                then case mdEditThreshold of-                    Just cutoff | p^.postEditAtL >= cutoff ->-                        addEditSentinel (EEditSentinel True) bs-                    _ -> if mdShowOlderEdits-                         then addEditSentinel (EEditSentinel False) bs-                         else bs-                else bs--        augmentedText = maybeAugment $ msg^.mText-        msgWidget =-            vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText :-                   catMaybes [msgAtch, msgReac]-        replyIndent = B.Widget B.Fixed B.Fixed $ do-            ctx <- B.getContext-            -- NB: The amount subtracted here must be the total padding-            -- added below (pad 1 + vBorder)-            w <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) msgWidget-            B.render $ B.vLimit (V.imageHeight $ w^.B.imageL) $-                B.padRight (B.Pad 1) B.vBorder B.<+> (B.Widget B.Fixed B.Fixed $ return w)-        msgAtch = if Seq.null (msg^.mAttachments)-          then Nothing-          else Just $ B.withDefAttr clientMessageAttr $ vBox-                 [ B.txt ("  [attached: `" <> a^.attachmentName <> "`]")-                 | a <- toList (msg^.mAttachments)-                 ]-        msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions)-          then Nothing-          else let renderR e us =-                       let n = Set.size us-                       in if | n == 1    -> " [" <> e <> "]"-                             | n > 1     -> " [" <> e <> " " <> T.pack (show n) <> "]"-                             | otherwise -> ""-                   reactionMsg = Map.foldMapWithKey renderR (msg^.mReactions)-               in Just $ B.withDefAttr emojiAttr $ B.txt ("   " <> reactionMsg)-        withParent p =-            case mdThreadState of-                NoThread -> msgWidget-                InThreadShowParent -> p B.<=> replyIndent-                InThread -> replyIndent-    in if not mdRenderReplyParent-       then msgWidget-       else case msg^.mInReplyToMsg of-          NotAReply -> msgWidget-          InReplyTo _ ->-              case mdParentMessage of-                  Nothing -> withParent (B.str "[loading...]")-                  Just pm ->-                      let parentMsg = renderMessage md-                            { mdShowOlderEdits    = False-                            , mdMessage           = pm-                            , mdUserName          = mdParentUserName-                            , mdParentMessage     = Nothing-                            , mdRenderReplyParent = False-                            , mdIndentBlocks      = False-                            }-                      in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg)--    where-        layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq RichTextBlock-               -> ViewL RichTextBlock -> Widget Name-        layout hs w nameElems bs xs | length xs > 1     = multiLnLayout hs w nameElems bs-        layout hs w nameElems bs (Blockquote {} :< _) = multiLnLayout hs w nameElems bs-        layout hs w nameElems bs (CodeBlock {} :< _)  = multiLnLayout hs w nameElems bs-        layout hs w nameElems bs (HTMLBlock {} :< _)  = multiLnLayout hs w nameElems bs-        layout hs w nameElems bs (List {} :< _)       = multiLnLayout hs w nameElems bs-        layout hs w nameElems bs (Para inlns :< _)-            | F.any breakCheck inlns                    = multiLnLayout hs w nameElems bs-        layout hs w nameElems bs _                      = nameNextToMessage hs w nameElems bs--        multiLnLayout hs w nameElems bs =-            if mdIndentBlocks-               then vBox [ hBox nameElems-                         , hBox [B.txt "  ", renderRichText mdMyUsername hs ((subtract 2) <$> w) bs]-                         ]-               else nameNextToMessage hs w nameElems bs--        nameNextToMessage hs w nameElems bs =-            Widget Fixed Fixed $ do-                nameResult <- render $ hBox nameElems-                let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w-                render $ hBox [raw (nameResult^.imageL), renderRichText mdMyUsername hs newW bs]--        breakCheck e = eData e `elem` [ELineBreak, ESoftBreak]--addEllipsis :: Widget a -> Widget a-addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do-    ctx <- B.getContext-    let aw = ctx^.B.availWidthL-    result <- B.render w-    let withEllipsis = (B.hLimit (aw - 3) $ B.vLimit 1 $ (B.Widget B.Fixed B.Fixed $ return result)) <+>-                       B.str "..."-    if (V.imageHeight (result^.B.imageL) > 1) || (V.imageWidth (result^.B.imageL) == aw) then-        B.render withEllipsis else-        return result---- Cursor sentinel for tracking the user's cursor position in previews.-cursorSentinel :: Char-cursorSentinel = '‸'---- Render markdown with username highlighting-renderRichText :: Text -> HighlightSet -> Maybe Int -> Seq RichTextBlock -> Widget a-renderRichText curUser hSet w =-  B.vBox . toList . fmap (blockToWidget curUser hSet w) . addBlankLines---- Add blank lines only between adjacent elements of the same type, to--- save space-addBlankLines :: Seq RichTextBlock -> Seq RichTextBlock-addBlankLines = go' . viewl-  where go' EmptyL = S.empty-        go' (x :< xs) = go x (viewl xs)-        go a@Para {} (b@Para {} :< rs) =-             a <| blank <| go b (viewl rs)-        go a@Header {} (b@Header {} :< rs) =-             a <| blank <| go b (viewl rs)-        go a@Blockquote {} (b@Blockquote {} :< rs) =-             a <| blank <| go b (viewl rs)-        go a@List {} (b@List {} :< rs) =-             a <| blank <| go b (viewl rs)-        go a@CodeBlock {} (b@CodeBlock {} :< rs) =-             a <| blank <| go b (viewl rs)-        go a@HTMLBlock {} (b@HTMLBlock {} :< rs) =-             a <| blank <| go b (viewl rs)-        go x (y :< rs) = x <| go y (viewl rs)-        go x (EmptyL) = S.singleton x-        blank = Para (S.singleton (Element Normal ESpace))---- Render text to markdown without username highlighting-renderText :: Text -> Widget a-renderText txt = renderText' "" emptyHSet txt--renderText' :: Text -> HighlightSet -> Text -> Widget a-renderText' curUser hSet t = renderRichText curUser hSet Nothing rtBs-  where rtBs = parseMarkdown t--vBox :: F.Foldable f => f (Widget a) -> Widget a-vBox = B.vBox . toList--hBox :: F.Foldable f => f (Widget a) -> Widget a-hBox = B.hBox . toList--header :: Int -> Widget a-header n = B.txt (T.replicate n "#")--maybeHLimit :: Maybe Int -> Widget a -> Widget a-maybeHLimit Nothing w = w-maybeHLimit (Just i) w = hLimit i w--blockToWidget :: Text -> HighlightSet -> Maybe Int -> RichTextBlock -> Widget a-blockToWidget curUser hSet w (Para is) =-    toElementChunk curUser w is hSet-blockToWidget curUser hSet w (Header n is) =-    B.withDefAttr clientHeaderAttr $-        hBox [B.padRight (B.Pad 1) $ header n, toElementChunk curUser (subtract 1 <$> w) is hSet]-blockToWidget curUser hSet w (Blockquote is) =-    maybeHLimit w $-    addQuoting (vBox $ fmap (blockToWidget curUser hSet w) is)-blockToWidget curUser hSet w (List _ l bs) =-    maybeHLimit w $-    blocksToList curUser l w bs hSet-blockToWidget _ hSet _ (CodeBlock ci tx) =-    let f = maybe rawCodeBlockToWidget (codeBlockToWidget (hSyntaxMap hSet)) mSyntax-        mSyntax = do-            lang <- codeBlockLanguage ci-            Sky.lookupSyntax lang (hSyntaxMap hSet)-    in f tx-blockToWidget _ _ w (HTMLBlock t) =-    maybeHLimit w $-    textWithCursor t-blockToWidget _ _ w (HRule) =-    maybeHLimit w $-    B.vLimit 1 (B.fill '*')--quoteChar :: Char-quoteChar = '>'--addQuoting :: B.Widget n -> B.Widget n-addQuoting w =-    B.Widget B.Fixed (B.vSize w) $ do-        ctx <- B.getContext-        childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w--        let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height-            height = V.imageHeight $ childResult^.B.imageL--        B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder-                          , B.Widget B.Fixed B.Fixed $ return childResult-                          ]--codeBlockToWidget :: Sky.SyntaxMap -> Sky.Syntax -> Text -> Widget a-codeBlockToWidget syntaxMap syntax tx =-    let result = Sky.tokenize cfg syntax tx-        cfg = Sky.TokenizerConfig syntaxMap False-    in case result of-        Left _ -> rawCodeBlockToWidget tx-        Right tokLines ->-            let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)-            in (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=>-               (padding <+> BS.renderRawSource textWithCursor tokLines)--rawCodeBlockToWidget :: Text -> Widget a-rawCodeBlockToWidget tx =-    B.withDefAttr codeAttr $-        let padding = B.padLeftRight 1 (B.vLimit (length theLines) B.vBorder)-            theLines = expandEmpty <$> T.lines tx-            expandEmpty "" = " "-            expandEmpty s  = s-        in padding <+> (B.vBox $ textWithCursor <$> theLines)--toElementChunk :: Text -> Maybe Int -> Seq Element -> HighlightSet -> Widget a-toElementChunk curUser w es hSet = B.Widget B.Fixed B.Fixed $ do-  ctx <- B.getContext-  let width = fromMaybe (ctx^.B.availWidthL) w-      ws    = fmap (renderElementSeq curUser) (wrapLine width hSet es)-  B.render (vBox (fmap hBox ws))--blocksToList :: Text -> ListType -> Maybe Int -> Seq (Seq RichTextBlock) -> HighlightSet -> Widget a-blocksToList curUser lt w bs hSet = vBox-  [ B.txt i <+> (vBox (fmap (blockToWidget curUser hSet w) b))-  | b <- F.toList bs-  | i <- is ]-  where is = case lt of-          Bullet _ -> repeat ("• ")-          Numbered Period s ->-            [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]-          Numbered Paren s ->-            [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ]--data SplitState = SplitState-  { splitChunks  :: Seq (Seq Element)-  , splitCurrCol :: Int-  }--wrapLine :: Int -> HighlightSet -> Seq Element -> Seq (Seq Element)-wrapLine maxCols hSet = splitChunks . go (SplitState (S.singleton S.empty) 0)-  where go st (viewl-> e :< es) = go st' es-          where-              HighlightSet { hUserSet = uSet, hChannelSet = cSet } = hSet--              -- Right before we check the width of the token, we see-              -- if the token is a user or channel reference. If so, we-              -- check if it is valid. If it is valid, we leave it in-              -- place; otherwise we translate it into an ordinary text-              -- element so that it does not render highlighted as a-              -- valid user or channel reference.-              newElement = e { eData = newEData }-              newEData = case eData e of-                  EUser u ->-                      if u `Set.member` uSet-                      then EUser u-                      else EText $ userSigil <> u-                  EChannel c ->-                      if c `Set.member` cSet-                      then EChannel c-                      else EText $ normalChannelSigil <> c-                  d -> d--              addHyperlink url el = setElementStyle (Hyperlink url (eStyle el)) el--              st' =-                  case newEData of-                      EHyperlink url (Just labelEs) ->-                          go st $ addHyperlink url <$> labelEs-                      EImage url (Just labelEs) ->-                          go st $ addHyperlink url <$> labelEs-                      _ ->-                          if | newEData == ESoftBreak || newEData == ELineBreak ->-                                 st { splitChunks = splitChunks st |> S.empty-                                    , splitCurrCol = 0-                                    }-                             | available >= eWidth ->-                                 st { splitChunks  = addElement newElement (splitChunks st)-                                    , splitCurrCol = splitCurrCol st + eWidth-                                    }-                             | newEData == ESpace ->-                                 st { splitChunks = splitChunks st |> S.empty-                                    , splitCurrCol = 0-                                    }-                             | otherwise ->-                                 st { splitChunks  = splitChunks st |> S.singleton newElement-                                    , splitCurrCol = eWidth-                                    }-              available = maxCols - splitCurrCol st-              eWidth = elementWidth newElement-              addElement x (viewr-> ls :> l) = ( ls |> (l |> x))-              addElement _ _ = error "[unreachable]"-        go st _                 = st--renderElementSeq :: Text -> Seq Element -> Seq (Widget a)-renderElementSeq curUser es = renderElement curUser <$> es--renderElement :: Text -> Element -> Widget a-renderElement curUser e = addStyle sty widget-    where-        sty = eStyle e-        dat = eData e-        addStyle s = case s of-                Normal                  -> id-                Emph                    -> B.withDefAttr clientEmphAttr-                Strong                  -> B.withDefAttr clientStrongAttr-                Code                    -> B.withDefAttr codeAttr-                Hyperlink (URL url) innerSty ->-                    B.hyperlink url . B.withDefAttr urlAttr .  addStyle innerSty-        rawText = B.txt . removeCursor-        widget = case dat of-            -- Cursor sentinels get parsed as individual text nodes by-            -- Cheapskate, meaning that we get a text node with exactly-            -- one character in it. That's why we compare accordingly-            -- above. In addition, since that character has no width, we-            -- have to replace it with something that has a size (such-            -- as a space) to get Brick's visibility logic to scroll the-            -- viewport to get it into view.-            EText t                      -> if t == T.singleton (cursorSentinel)-                                            then B.visible $ B.txt " "-                                            else rawText t--            ESpace                       -> B.txt " "-            ERawHtml t                   -> rawText t-            EEditSentinel recent         -> let attr = if recent-                                                       then editedRecentlyMarkingAttr-                                                       else editedMarkingAttr-                                            in B.withDefAttr attr $ B.txt editMarking-            EUser u                      -> colorUsername curUser u $ userSigil <> u-            EChannel c                   -> B.withDefAttr channelNameAttr $-                                            B.txt $ normalChannelSigil <> c-            EHyperlink (URL url) Nothing -> rawText url-            EImage (URL url) Nothing     -> rawText url-            EEmoji em                    -> B.withDefAttr emojiAttr $-                                            B.txt $ ":" <> em <> ":"--            -- Hyperlink and image nodes with labels should not appear-            -- at this point because line-wrapping should break them up-            -- into normal text node sequences with hyperlink styles-            -- attached.-            EHyperlink {}                -> rawText "(Report renderElement bug #1)"-            EImage {}                    -> rawText "(Report renderElement bug #2)"--            -- Line breaks should never need to get rendered since the-            -- line-wrapping algorithm removes them.-            ESoftBreak                   -> B.emptyWidget-            ELineBreak                   -> B.emptyWidget--textWithCursor :: Text -> Widget a-textWithCursor t-    | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t-    | otherwise = B.txt t--removeCursor :: Text -> Text-removeCursor = T.filter (/= cursorSentinel)--editMarking :: Text-editMarking = "(edited)"--elementWidth :: Element -> Int-elementWidth e =-    case eData e of-        EText t                      -> B.textWidth t-        ERawHtml t                   -> B.textWidth t-        EUser t                      -> T.length userSigil + B.textWidth t-        EChannel t                   -> T.length normalChannelSigil + B.textWidth t-        EEditSentinel _              -> B.textWidth editMarking-        EImage (URL url) Nothing     -> B.textWidth url-        EImage _ (Just is)           -> sum $ elementWidth <$> is-        EHyperlink (URL url) Nothing -> B.textWidth url-        EHyperlink _ (Just is)       -> sum $ elementWidth <$> is-        EEmoji t                     -> B.textWidth t + 2-        ESpace                       -> 1-        ELineBreak                   -> 0-        ESoftBreak                   -> 0
− src/Draw/ShowHelp.hs 
@@ -1,567 +0,0 @@-module Draw.ShowHelp-  ( drawShowHelp-  , keybindingMarkdownTable-  , keybindingTextTable-  , commandTextTable-  , commandMarkdownTable-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Themes ( themeDescriptions )-import           Brick.Widgets.Border-import           Brick.Widgets.Center ( hCenter )-import           Brick.Widgets.List ( listSelectedFocusedAttr )-import qualified Data.Map as M-import qualified Data.Text as T-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( singular, _Just, _2 )--import           Network.Mattermost.Version ( mmApiVersion )--import           Command-import           Events-import           Events.ChannelSelect-import           Events.Keybindings-import           Events.Main-import           Events.MessageSelect-import           Events.ThemeListOverlay-import           Events.PostListOverlay-import           Events.ShowHelp-import           Events.UrlSelect-import           Events.UserListOverlay-import           Events.ChannelListOverlay-import           Events.ReactionEmojiListOverlay-import           Events.ManageAttachments-import           Events.TabbedWindow-import           Windows.ViewMessage-import           HelpTopics ( helpTopics )-import           Draw.RichText ( renderText )-import           Options ( mhVersion )-import           State.Editing ( editingKeyHandlers )-import           Themes-import           Types-import           Types.KeyEvents ( BindingState(..), Binding(..)-                                 , ppBinding, nonCharKeys, eventToBinding )---drawShowHelp :: HelpTopic -> ChatState -> [Widget Name]-drawShowHelp topic st =-    [helpBox (helpTopicViewportName topic) $ helpTopicDraw topic st]--helpTopicDraw :: HelpTopic -> ChatState -> Widget Name-helpTopicDraw topic st =-    overrideAttr codeAttr helpEmphAttr $-    hCenter $-    hLimit helpContentWidth $-    case helpTopicScreen topic of-        MainHelp -> mainHelp (configUserKeys (st^.csResources.crConfiguration))-        ScriptHelp -> scriptHelp-        ThemeHelp -> themeHelp-        SyntaxHighlightHelp -> syntaxHighlightHelp (configSyntaxDirs $ st^.csResources.crConfiguration)-        KeybindingHelp -> keybindingHelp (configUserKeys (st^.csResources.crConfiguration))--mainHelp :: KeyConfig -> Widget Name-mainHelp kc = summary-  where-    summary = vBox entries-    entries = [ heading $ T.pack mhVersion-              , headingNoPad $ T.pack mmApiVersion-              , heading "Help Topics"-              , drawHelpTopics-              , heading "Commands"-              , padTop (Pad 1) mkCommandHelpText-              , heading "Keybindings"-              ] <>-              (mkKeybindingHelp kc <$> keybindSections)--    mkCommandHelpText :: Widget Name-    mkCommandHelpText =-      let commandNameWidth = 2 + (maximum $ T.length <$> fst <$> commandHelpInfo)-      in vBox [ (emph $ txt $ padTo commandNameWidth info) <+> renderText desc-              | (info, desc) <- commandHelpInfo-              ]--commandHelpInfo :: [(T.Text, T.Text)]-commandHelpInfo = pairs-    where-        pairs = [ (info, desc)-                | Cmd cmd desc args _ <- cs-                , let argSpec = printArgSpec args-                      spc = if T.null argSpec then "" else " "-                      info = T.cons '/' cmd <> spc <> argSpec-                ]-        cs = sortWith commandName commandList--commandTextTable :: T.Text-commandTextTable =-    let commandNameWidth = 4 + (maximum $ T.length <$> fst <$> commandHelpInfo)-    in T.intercalate "\n" $-       [ padTo commandNameWidth info <> desc-       | (info, desc) <- commandHelpInfo-       ]--commandMarkdownTable :: T.Text-commandMarkdownTable =-    T.intercalate "\n" $-    [ "# Commands"-    , ""-    , "| Command | Description |"-    , "| ------- | ----------- |"-    ] <>-    [ "| `" <> info <> "` | " <> desc <> " |"-    | (info, desc) <- commandHelpInfo-    ]--drawHelpTopics :: Widget Name-drawHelpTopics =-    let allHelpTopics = drawTopic <$> helpTopics-        topicNameWidth = 4 + (maximum $ T.length <$> helpTopicName <$> helpTopics)-        drawTopic t = (emph $ txt (padTo topicNameWidth $ helpTopicName t)) <+>-                      txt (helpTopicDescription t)-    in vBox $ (padBottom (Pad 1) $-               para "Learn more about these topics with `/help <topic>`:")-            : allHelpTopics--helpContentWidth :: Int-helpContentWidth = 72--scriptHelp :: Widget Name-scriptHelp = heading "Using Scripts" <=> vBox scriptHelpText-  where scriptHelpText = map paraL-          [ [ "Matterhorn has a special feature that allows you to use "-             , "prewritten shell scripts to preprocess messages. "-             , "For example, this can allow you to run various filters over "-             , "your written text, do certain kinds of automated formatting, "-             , "or just automatically cowsay-ify a message." ]-           , [ "These scripts can be any kind of executable file, "-             , "as long as the file lives in "-             , "*~/.config/matterhorn/scripts* (unless you've explicitly "-             , "moved your XDG configuration directory elsewhere). "-             , "Those executables are given no arguments "-             , "on the command line and are passed your typed message on "-             , "*stdin*; whatever they produce on *stdout* is sent "-             , "as a message. If the script exits successfully, then everything "-             , "that appeared on *stderr* is discarded; if it instead exits with "-             , "a failing exit code, your message is *not* sent, and you are "-             , "presented with whatever was printed on stderr as a "-             , "local error message." ]-           , [ "To run a script, simply type" ]-           , [ "> *> /sh [script-name] [my-message]*" ]-           , [ "And the script named *[script-name]* will be invoked with "-             , "the text of *[my-message]*. If the script does not exist, "-             , "or if it exists but is not marked as executable, you'll be "-             , "presented with an appropriate error message." ]-           , [ "For example, if you want to use a basic script to "-             , "automatically ROT13 your message, you can write a shell "-             , "script using the standard Unix *tr* utility, like this:" ]-           , [ "> *#!/bin/bash -e*"-             , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*" ]-           , [ "Move this script to *~/.config/matterhorn/scripts/rot13* "-             , "and be sure it's executable with" ]-           , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*" ]-           , [ "after which you can send ROT13 messages with the "-             , "Matterhorn command " ]-           , [ "> *> /sh rot13 Hello, world!*" ]-           ]--keybindingMarkdownTable :: KeyConfig -> Text-keybindingMarkdownTable kc = title <> keybindSectionStrings-    where title = "# Keybindings\n"-          keybindSectionStrings = T.concat $ sectionText <$> keybindSections-          sectionText = mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines mkHeading-          mkHeading n =-              "\n# " <> n <>-              "\n| Keybinding | Event Name | Description |" <>-              "\n| ---------- | ---------- | ----------- |"--keybindingTextTable :: KeyConfig -> Text-keybindingTextTable kc = title <> keybindSectionStrings-    where title = "Keybindings\n===========\n"-          keybindSectionStrings = T.concat $ sectionText <$> keybindSections-          sectionText = mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines mkHeading-          keybindingWidth = 15-          eventNameWidth = 30-          mkHeading n =-              "\n" <> n <>-              "\n" <> (T.replicate (T.length n) "=")--keybindingHelp :: KeyConfig -> Widget Name-keybindingHelp kc = vBox $-  [ heading "Configurable Keybindings"-  , padBottom (Pad 1) $ vBox keybindingHelpText-  ] ++ keybindSectionWidgets-    ++-  [ headingNoPad "Keybinding Syntax"-  , vBox validKeys-  ]-  where keybindSectionWidgets = sectionWidget <$> keybindSections-        sectionWidget = mkKeybindEventSectionHelp kc keybindEventHelpWidget vBox headingNoPad--        keybindingHelpText = map paraL-          [ [ "Many of the keybindings used in Matterhorn can be "-            , "modified from within Matterhorn's **config.ini** file. "-            , "To do this, include a section called **[KEYBINDINGS]** "-            , "in your config file and use the event names listed below as "-            , "keys and the desired key sequence as values. "-            , "See the end of this page for documentation on the valid "-            , "syntax for key sequences."-            ]-          , [ "For example, by default, the keybinding to move to the next "-            , "channel in the public channel list is **"-            , nextChanBinding-            , "**, and the corresponding "-            , "previous channel binding is **"-            , prevChanBinding-            , "**. You might want to remap these "-            , "to other keys: say, **C-j** and **C-k**. We can do this with the following "-            , "configuration snippet:"-            ]-          , [ "```ini\n"-            , "[KEYBINDINGS]\n"-            , "focus-next-channel = C-j\n"-            , "focus-prev-channel = C-k\n"-            , "```"-            ]-          , [ "You can remap a command to more than one key sequence, in which "-            , "case any one of the key sequences provided can be used to invoke "-            , "the relevant command. To do this, provide the desired bindings as "-            , "a comma-separated list. Additionally, some key combinations are "-            , "used in multiple modes (such as URL select or help viewing) and "-            , "therefore share the same name, such as **cancel** or **scroll-up**."-            ]-          , [ "Additionally, some keys simply cannot be remapped, mostly in the "-            , "case of editing keybindings. If you feel that a particular key "-            , "event should be rebindable and isn't, then please feel free to "-            , "let us know by posting an issue in the Matterhorn issue tracker."-            ]-          , [ "It is also possible to entirely unbind a key event by setting its "-            , "key to **unbound**, thus avoiding conflicts between default bindings "-            , "and new ones:"-            ]-          , [ "```ini\n"-            , "[KEYBINDINGS]\n"-            , "focus-next-channel = unbound\n"-            , "```"-            ]-          , [ "The rebindable key events, along with their **current** "-            , "values, are as follows:"-            ]-           ]-        nextChanBinding = ppBinding (getFirstDefaultBinding NextChannelEvent)-        prevChanBinding = ppBinding (getFirstDefaultBinding PrevChannelEvent)-        validKeys = map paraL-          [ [ "The syntax used for key sequences consists of zero or more "-            , "single-character modifier characters followed by a keystroke, "-            , "all separated by dashes. The available modifier keys are "-            , "**S** for Shift, **C** for Ctrl, **A** for Alt, and **M** for "-            , "Meta. So, for example, **"-            , ppBinding (Binding [] (Vty.KFun 2))-            , "** is the F2 key pressed with no "-            , "modifier keys; **"-            , ppBinding (Binding [Vty.MCtrl] (Vty.KChar 'x'))-            , "** is Ctrl and X pressed together, "-            , "and **"-            , ppBinding (Binding [Vty.MShift, Vty.MCtrl] (Vty.KChar 'x'))-            , "** is Shift, Ctrl, and X all pressed together. "-            , "Although Matterhorn will pretty-print all key combinations "-            , "with specific capitalization, the parser is **not** case-sensitive "-            , "and will ignore any capitalization."-            ]-          , [ "Your terminal emulator might not recognize some particular "-            , "keypress combinations, or it might reserve certain combinations of "-            , "keys for some terminal-specific operation. Matterhorn does not have a "-            , "reliable way of testing this, so it is up to you to avoid setting "-            , "keybindings that your terminal emulator does not deliver to applications."-            ]-          , [ "Letter keys, number keys, and function keys are specified with "-            , "their obvious name, such as **x** for the X key, **8** for the 8 "-            , "key, and **f5** for the F5 key. Other valid keys include: "-            , T.intercalate ", " [ "**" <> key <> "**" | key <- nonCharKeys ]-            , "."-            ]-          ]--emph :: Widget a -> Widget a-emph = withDefAttr helpEmphAttr--para :: Text -> Widget a-para t = padTop (Pad 1) $ renderText t--paraL :: [Text] -> Widget a-paraL = para . mconcat--heading :: Text -> Widget a-heading = padTop (Pad 1) . headingNoPad--headingNoPad :: Text -> Widget a-headingNoPad t = hCenter $ emph $ renderText t--syntaxHighlightHelp :: [FilePath] -> Widget a-syntaxHighlightHelp dirs = vBox-  [ heading "Syntax Highlighting"--  , para $ "Matterhorn supports syntax highlighting in Markdown code blocks when the " <>-           "name of the code block language follows the block opening sytnax:"-  , para $ "```<language>"-  , para $ "The possible values of `language` are determined by the available syntax " <>-           "definitions. The available definitions are loaded from the following " <>-           "directories according to the configuration setting `syntaxDirectories`. " <>-           "If the setting is omitted, it defaults to the following sequence of directories:"-  , para $ T.pack $ intercalate "\n" $ (\d -> "`" <> d <> "`") <$> dirs-  , para $ "Syntax definitions are in the Kate XML format. Files with an " <>-           "`xml` extension are loaded from each directory, with directories earlier " <>-           "in the list taking precedence over later directories when more than one " <>-           "directory provides a definition file for the same syntax."-  , para $ "To place custom definitions in a directory, place a Kate " <>-           "XML syntax definition in the directory and ensure that a copy of " <>-           "`language.dtd` is also present. The file `language.dtd` can be found in " <>-           "the `syntax/` directory of your Matterhorn distribution."-  ]--themeHelp :: Widget a-themeHelp = vBox-  [ heading "Using Themes"-  , para "Matterhorn provides these built-in color themes:"-  , padTop (Pad 1) $ vBox $ hCenter <$> emph <$>-                            txt <$> internalThemeName <$> internalThemes-  , para $-        "These themes can be selected with the */theme* command. To automatically " <>-        "select a theme at startup, set the *theme* configuration file option to one " <>-        "of the themes listed above."--  , heading "Customizing the Theme"-  , para $-        "Theme customization is also supported. To customize the selected theme, " <>-        "create a theme customization file and set the `themeCustomizationFile` " <>-        "configuration option to the path to the customization file. If the path " <>-        "to the file is relative, Matterhorn will look for it in the same directory " <>-        "as the Matterhorn configuration file."--  , para $-        "Theme customization files are INI-style files that can customize any " <>-        "foreground color, background color, or style of any aspect of the " <>-        "Matterhorn user interface. Here is an example:"--  , para $-        "```\n" <>-        "[default]\n" <>-        "default.fg = blue\n" <>-        "default.bg = black\n" <>-        "\n" <>-        "[other]\n" <>-        attrNameToConfig codeAttr <> ".fg = magenta\n" <>-        attrNameToConfig codeAttr <> ".style = bold\n" <>-        attrNameToConfig clientEmphAttr <> ".fg = cyan\n" <>-        attrNameToConfig clientEmphAttr <> ".style = [bold, underline]\n" <>-        attrNameToConfig listSelectedFocusedAttr <> ".fg = brightGreen\n" <>-        "```"--  , para $-        "In the example above, the theme's default foreground and background colors " <>-        "are both customized to *blue* and *black*, respectively. The *default* section " <>-        "contains only customizations for the *default* attribute. All other customizations " <>-        "go in the *other* section. We can also set the style for attributes; we can either " <>-        "set just one style (as with the bold setting above) or multiple styles at once " <>-        "(as in the bold/underline example).\n"--  , para $-        "Available colors are:\n" <>-        " * black\n" <>-        " * red\n" <>-        " * green\n" <>-        " * yellow\n" <>-        " * blue\n" <>-        " * magenta\n" <>-        " * cyan\n" <>-        " * white\n" <>-        " * brightBlack\n" <>-        " * brightRed\n" <>-        " * brightGreen\n" <>-        " * brightYellow\n" <>-        " * brightBlue\n" <>-        " * brightMagenta\n" <>-        " * brightCyan\n" <>-        " * brightWhite"--  , para $-        "Available styles are:\n" <>-        " * standout\n" <>-        " * underline\n" <>-        " * italic\n" <>-        " * reverseVideo\n" <>-        " * blink\n" <>-        " * dim\n" <>-        " * bold\n"--  , para $-        "It is also possible to specify RGB values using HTML syntax: `#RRGGBB`. " <>-        "Bear in mind that such colors are clamped to the nearest 256-color palette " <>-        "entry, so it is not possible to get the exact color specified.\n\n" <>-        "In addition, a special value of *default* is possible for either color " <>-        "setting of an attribute. This value indicates that the attribute should " <>-        "use the terminal emulator's default foreground or background color of " <>-        "choice rather than a specific ANSI color."--  , heading "Username Highlighting"-  , para $-        "Username colors are chosen by hashing each username and then using the hash " <>-        "to choose a color from a list of predefined username colors. If you would like " <>-        "to change the color in a given entry of this list, we provide the " <>-        "\"username.N\" attributes, where N is the index in the username color list."--  , heading "Theme Attributes"-  , para $-        "This section lists all possible theme attributes for use in customization " <>-        "files along with a description of how each one is used in Matterhorn. Each " <>-        "option listed can be set in the *other* section of the customization file. " <>-        "Each provides three customization settings:"--  , para $-        " * *<option>.fg = <color>*\n" <>-        " * *<option>.bg = <color>*\n" <>-        " * *<option>.style = <style>* or *<option>.style = [<style>, ...]*\n"--  , let names = sort $-                 (\(n, msg) -> (n, attrNameToConfig n, msg)) <$>-                 (M.toList $ themeDescriptions themeDocs)-        mkEntry (n, opt, msg) =-            padTop (Pad 1) $-            vBox [ hBox [ withDefAttr clientEmphAttr $ txt opt-                        , padLeft Max $ forceAttr n $ txt "(demo)"-                        ]-                 , txt msg-                 ]-    in vBox $ mkEntry <$> names-  ]--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)-    , ("Theme List Window", themeListOverlayKeyHandlers)-    , ("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)-    , ("Attachment File Browser", attachmentBrowseKeyHandlers)-    ]--helpBox :: Name -> Widget Name -> Widget Name-helpBox n helpText =-    withDefAttr helpAttr $-    borderWithLabel (emph $ txt "Matterhorn Help") $-    viewport HelpViewport Vertical $-    cached n helpText--kbColumnWidth :: Int-kbColumnWidth = 14--kbDescColumnWidth :: Int-kbDescColumnWidth = 60--mkKeybindingHelp :: KeyConfig -> (Text, [KeyEventHandler]) -> Widget Name-mkKeybindingHelp kc (sectionName, kbs) =-    (heading sectionName) <=>-    (padTop (Pad 1) $ hCenter $ vBox $ snd <$> sortWith fst results)-    where-        results = mkKeybindHelp kc <$> kbs--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--        rendering = (emph $ 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, [KeyEventHandler])-                          -> a-mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) =-  vertCat $ (mkHeading sectionName) :-            (mkKeybindHelpFunc <$> (mkKeybindEventHelp kc <$> kbs))--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 -> emph $ txt s-    in padBottom (Pad 1) $-       vBox [ txtWrap ("; " <> desc)-            , label <+> txt (" = " <> evText)-            ]--keybindEventHelpMarkdown :: (Either Text Text, Text, [Text]) -> Text-keybindEventHelpMarkdown (evName, desc, evs) =-    let quote s = "`" <> s <> "`"-        name = case evName of-            Left s -> s-            Right s -> quote s-    in "| " <> (T.intercalate ", " $ quote <$> evs) <>-       " | " <> name <>-       " | " <> desc <>-       " |"--keybindEventHelpText :: Int -> Int -> (Either Text Text, Text, [Text]) -> Text-keybindEventHelpText width eventNameWidth (evName, desc, evs) =-    let name = case evName of-            Left s -> s-            Right s -> s-    in padTo width (T.intercalate ", " evs) <> " " <>-       padTo eventNameWidth name <> " " <>-       desc--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/Draw/TabbedWindow.hs 
@@ -1,77 +0,0 @@-module Draw.TabbedWindow-  ( drawTabbedWindow-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Center-import           Data.List ( intersperse )-import qualified Graphics.Vty as Vty--import           Draw.Util ( renderKeybindingHelp )-import           Types-import           Themes-import           Types.KeyEvents---- | Render a tabbed window.-drawTabbedWindow :: (Eq a, Show a)-                 => TabbedWindow a-                 -> ChatState-                 -> Widget Name-drawTabbedWindow w cs =-    let cur = getCurrentTabbedWindowEntry w-        tabBody = tweRender cur (twValue w) cs-        title = forceAttr clientEmphAttr $ twtTitle (twTemplate w) (tweValue cur)-    in centerLayer $-       vLimit (twWindowHeight w) $-       hLimit (twWindowWidth w) $-       joinBorders $-       borderWithLabel title $-       (tabBar w <=> tabBody <=> hBorder <=> hCenter keybindingHelp)---- | Keybinding help to show at the bottom of a tabbed window.-keybindingHelp :: Widget Name-keybindingHelp =-    let pairs = [ ("Switch tabs", [SelectNextTabEvent, SelectPreviousTabEvent])-                , ("Scroll", [ScrollUpEvent, ScrollDownEvent, ScrollLeftEvent, ScrollRightEvent, PageLeftEvent, PageRightEvent])-                ]-    in hBox $ intersperse (txt "  ") $ (uncurry renderKeybindingHelp) <$> pairs---- | The scrollable tab bar to show at the top of a tabbed window.-tabBar :: (Eq a, Show a)-       => TabbedWindow a-       -> Widget Name-tabBar w =-    let cur = getCurrentTabbedWindowEntry w-        entries = twtEntries (twTemplate w)-        renderEntry e =-            let useAttr = if isCurrent-                          then withDefAttr tabSelectedAttr-                          else withDefAttr tabUnselectedAttr-                isCurrent = tweValue e == tweValue cur-                makeVisible = if isCurrent then visible else id-                decorateTab v = Widget Fixed Fixed $ do-                    result <- render v-                    let width = Vty.imageWidth (result^.imageL)-                    if isCurrent-                       then-                           render $ padBottom (Pad 1) $ raw $ result^.imageL-                       else-                           render $ vBox [raw $ result^.imageL, hLimit width hBorder]-            in makeVisible $-               decorateTab $-               useAttr $-               padLeftRight 2 $-               txt $-               tweTitle e (tweValue e) isCurrent-        contents = Widget Fixed Fixed $ do-            ctx <- getContext-            let width = ctx^.availWidthL-            render $ hBox $ (intersperse divider $ renderEntry <$> entries) <>-                            [divider, padTop (Pad 1) $ hLimit width hBorder]-        divider = vLimit 1 vBorder <=> joinableBorder (Edges True False False False)-    in vLimit 2 $ viewport TabbedWindowTabBar Horizontal contents
− src/Draw/ThemeListOverlay.hs 
@@ -1,53 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Draw.ThemeListOverlay-  ( drawThemeListOverlay-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import qualified Brick.Widgets.List as L-import           Brick.Widgets.Border ( hBorder )-import           Brick.Widgets.Center ( hCenter )--import           Draw.Main-import           Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import           Themes-import           Types-import           Types.KeyEvents ( ppBinding )-import           Events.Keybindings---drawThemeListOverlay :: ChatState -> [Widget Name]-drawThemeListOverlay st =-    let overlay = drawListOverlay (st^.csThemeListOverlay)-                                  (const $ txt "Themes")-                                  (const $ txt "No matching themes found.")-                                  (const $ txt "Search built-in themes:")-                                  renderInternalTheme-                                  (Just footer)-                                  OverlayUpperRight-                                  50-        footer = hBorder <=>-                 (hCenter $ hBox [ enter-                                 , txt $ ":choose theme  "-                                 , close-                                 , txt ":close"-                                 ])-        enter = emph $ txt $ ppBinding (getFirstDefaultBinding ActivateListItemEvent)-        close = emph $ txt $ ppBinding (getFirstDefaultBinding CancelEvent)-        emph = withDefAttr clientEmphAttr-    in joinBorders overlay : drawMain True st--renderInternalTheme :: Bool -> InternalTheme -> Widget Name-renderInternalTheme foc it =-    (if foc then forceAttr L.listSelectedFocusedAttr else id) $-    (padRight Max $-     withDefAttr clientEmphAttr $-     txt $ internalThemeName it) <=>-    (vLimit 2 $-     (padLeft (Pad 2) $ txtWrap $ internalThemeDesc it) <=> fill ' ')
− src/Draw/URLList.hs 
@@ -1,57 +0,0 @@-module Draw.URLList-  ( renderUrlList-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.List ( renderList )-import qualified Data.Foldable as F-import           Lens.Micro.Platform ( to )--import           Network.Mattermost.Types ( ServerTime(..) )--import           Draw.Messages-import           Draw.Util-import           Draw.RichText-import           Themes-import           Types-import           Types.RichText ( unURL )---renderUrlList :: ChatState -> Widget Name-renderUrlList st =-    header <=> urlDisplay-    where-        header = withDefAttr channelHeaderAttr $ vLimit 1 $-                 (txt $ "URLs: " <> (st^.csCurrentChannel.ccInfo.cdName)) <+>-                 fill ' '--        urlDisplay = if F.length urls == 0-                     then str "No URLs found in this channel."-                     else renderList renderItem True urls--        urls = st^.csUrlList--        me = myUsername st--        renderItem sel link =-          let time = link^.linkTime-          in attr sel $ vLimit 2 $-            (vLimit 1 $-             hBox [ let u = maybe "<server>" id (link^.linkUser.to (nameForUserRef st))-                    in colorUsername me u u-                  , case link^.linkLabel of-                      Nothing -> emptyWidget-                      Just label -> txt ": " <+> hBox (F.toList $ renderElementSeq me label)-                  , fill ' '-                  , renderDate st $ withServerTime time-                  , str " "-                  , renderTime st $ withServerTime time-                  ] ) <=>-            (vLimit 1 (renderText $ unURL $ link^.linkURL))--        attr True = forceAttr urlListSelectedAttr-        attr False = id
− src/Draw/UserListOverlay.hs 
@@ -1,78 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Draw.UserListOverlay-  ( drawUserListOverlay-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import qualified Brick.Widgets.List as L-import qualified Data.Text as T-import qualified Graphics.Vty as V--import           Draw.Main-import           Draw.Util ( userSigilFromInfo )-import           Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )-import           Themes-import           Types---drawUserListOverlay :: ChatState -> [Widget Name]-drawUserListOverlay st =-    let overlay = drawListOverlay (st^.csUserListOverlay) userSearchScopeHeader-                                  userSearchScopeNoResults userSearchScopePrompt-                                  (renderUser (myUsername st))-                                  Nothing-                                  OverlayCenter-                                  80-    in joinBorders overlay : drawMain False st--userSearchScopePrompt :: UserSearchScope -> Widget Name-userSearchScopePrompt scope =-    txt $ case scope of-        ChannelMembers _ _    -> "Search channel members:"-        ChannelNonMembers _ _ -> "Search users:"-        AllUsers Nothing      -> "Search users:"-        AllUsers (Just _)     -> "Search team members:"--userSearchScopeNoResults :: UserSearchScope -> Widget Name-userSearchScopeNoResults scope =-    txt $ case scope of-        ChannelMembers _ _    -> "No users in channel."-        ChannelNonMembers _ _ -> "All users in your team are already in this channel."-        AllUsers _            -> "No users found."--userSearchScopeHeader :: UserSearchScope -> Widget Name-userSearchScopeHeader scope =-    txt $ case scope of-        ChannelMembers {}    -> "Channel Members"-        ChannelNonMembers {} -> "Invite Users to Channel"-        AllUsers Nothing     -> "Users On This Server"-        AllUsers (Just _)    -> "Users In My Team"--renderUser :: Text -> Bool -> UserInfo -> Widget Name-renderUser myUName foc ui =-    (if foc then forceAttr L.listSelectedFocusedAttr else id) $-    vLimit 2 $-    padRight Max $-    hBox $ (padRight (Pad 1) $ colorUsername myUName (ui^.uiName) (T.singleton $ userSigilFromInfo ui))-           : (hLimit usernameWidth $ padRight Max $ colorUsername myUName (ui^.uiName) (ui^.uiName))-           : extras-    where-        sanitize = T.strip . T.replace "\t" " "-        usernameWidth = 20-        extras = padRight (Pad 1) <$> catMaybes [mFullname, mNickname, mEmail]-        mFullname = if (not (T.null (ui^.uiFirstName)) || not (T.null (ui^.uiLastName)))-                    then Just $ txt $ (sanitize $ ui^.uiFirstName) <> " " <> (sanitize $ ui^.uiLastName)-                    else Nothing-        mNickname = case ui^.uiNickName of-                      Just n | n /= (ui^.uiName) -> Just $ txt $ "(" <> n <> ")"-                      _ -> Nothing-        mEmail = if (T.null $ ui^.uiEmail)-                 then Nothing-                 else Just $ modifyDefAttr (`V.withURL` ("mailto:" <> ui^.uiEmail)) $-                             withDefAttr urlAttr (txt ("<" <> ui^.uiEmail <> ">"))
− src/Draw/Util.hs 
@@ -1,100 +0,0 @@-module Draw.Util-  ( withBrackets-  , renderTime-  , renderDate-  , renderKeybindingHelp-  , insertDateMarkers-  , getDateFormat-  , mkChannelName-  , userSigilFromInfo-  , multilineHeightLimit-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Data.List ( intersperse )-import qualified Data.Set as Set-import qualified Data.Text as T-import           Lens.Micro.Platform ( to )-import           Network.Mattermost.Types--import           Constants ( userSigil, normalChannelSigil )-import           Themes-import           TimeUtils-import           Types-import           Types.KeyEvents-import           Events.Keybindings ( getFirstDefaultBinding )---defaultTimeFormat :: Text-defaultTimeFormat = "%R"--defaultDateFormat :: Text-defaultDateFormat = "%Y-%m-%d"--multilineHeightLimit :: Int-multilineHeightLimit = 5--getTimeFormat :: ChatState -> Text-getTimeFormat st =-    maybe defaultTimeFormat id (st^.csResources.crConfiguration.to configTimeFormat)--getDateFormat :: ChatState -> Text-getDateFormat st =-    maybe defaultDateFormat id (st^.csResources.crConfiguration.to configDateFormat)--renderTime :: ChatState -> UTCTime -> Widget Name-renderTime st = renderUTCTime (getTimeFormat st) (st^.timeZone)--renderDate :: ChatState -> UTCTime -> Widget Name-renderDate st = renderUTCTime (getDateFormat st) (st^.timeZone)--renderUTCTime :: Text -> TimeZoneSeries -> UTCTime -> Widget a-renderUTCTime fmt tz t =-    if T.null fmt-    then emptyWidget-    else withDefAttr timeAttr (txt $ localTimeText fmt $ asLocalTime tz t)--renderKeybindingHelp :: Text -> [KeyEvent] -> Widget Name-renderKeybindingHelp label evs =-  let ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (getFirstDefaultBinding ev))-  in hBox $ (intersperse (txt "/") $ ppEv <$> evs) <> [txt (":" <> label)]---- | Generates a local matterhorn-only client message that creates a--- date marker.  The server date is converted to a local time (via--- timezone), and midnight of that timezone used to generate date--- markers.  Note that the actual time of the server and this client--- are still not synchronized, but no manipulations here actually use--- the client time.-insertDateMarkers :: Messages -> Text -> TimeZoneSeries -> Messages-insertDateMarkers ms datefmt tz = foldr (addMessage . dateMsg) ms dateRange-    where dateRange = foldr checkDateChange Set.empty ms-          checkDateChange m = let msgDay = startOfDay (Just tz) (withServerTime (m^.mDate))-                              in if m^.mDeleted then id else Set.insert msgDay-          dateMsg d = let t = localTimeText datefmt $ asLocalTime tz d-                      in newMessageOfType t (C DateTransition) (ServerTime d)---withBrackets :: Widget a -> Widget a-withBrackets w = hBox [str "[", w, str "]"]--userSigilFromInfo :: UserInfo -> Char-userSigilFromInfo u = case u^.uiStatus of-    Offline      -> ' '-    Online       -> '+'-    Away         -> '-'-    DoNotDisturb -> '×'-    Other _      -> '?'--mkChannelName :: ChannelInfo -> Text-mkChannelName c = T.append sigil (c^.cdName)-    where-        sigil = case c^.cdType of-            Private   -> mempty-            Ordinary  -> normalChannelSigil-            Group     -> mempty-            Direct    -> userSigil-            Unknown _ -> mempty
− src/Emoji.hs 
@@ -1,108 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-module Emoji-  ( EmojiCollection-  , loadEmoji-  , emptyEmojiCollection-  , getMatchingEmoji-  , matchesEmoji-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Control.Exception as E-import           Control.Monad.Except-import qualified Data.Aeson as A-import qualified Data.ByteString.Lazy as BSL-import qualified Data.Foldable as F-import qualified Data.Text as T-import qualified Data.Sequence as Seq--import           Network.Mattermost.Types ( Session )-import qualified Network.Mattermost.Endpoints as MM---newtype EmojiData = EmojiData (Seq.Seq T.Text)---- | The collection of all emoji names we loaded from a JSON disk file.--- You might rightly ask: why don't we use a Trie here, for efficient--- lookups? The answer is that we need infix lookups; prefix matches are--- not enough. In practice it seems not to matter that much; despite the--- O(n) search we get good enough performance that we aren't worried--- about this. If at some point this becomes an issue, other data--- structures with good infix lookup performance should be identified--- (full-text search, perhaps?).-newtype EmojiCollection = EmojiCollection [T.Text]--instance A.FromJSON EmojiData where-    parseJSON = A.withArray "EmojiData" $ \v -> do-        aliasVecs <- forM v $ \val ->-            flip (A.withObject "EmojiData Entry") val $ \obj -> do-                as <- obj A..: "aliases"-                forM as $ A.withText "Alias list element" return--        return $ EmojiData $ mconcat $ F.toList aliasVecs--emptyEmojiCollection :: EmojiCollection-emptyEmojiCollection = EmojiCollection mempty---- | Load an EmojiCollection from a JSON disk file.-loadEmoji :: FilePath -> IO (Either String EmojiCollection)-loadEmoji path = runExceptT $ do-    result <- lift $ E.try $ BSL.readFile path-    case result of-        Left (e::E.SomeException) -> throwError $ show e-        Right bs -> do-            EmojiData es <- ExceptT $ return $ A.eitherDecode bs-            return $ EmojiCollection $ T.toLower <$> F.toList es---- | Look up matching emoji in the collection using the provided search--- string. This does a case-insensitive infix match. The search string--- may be provided with or without leading and trailing colons.-lookupEmoji :: EmojiCollection -> T.Text -> [T.Text]-lookupEmoji (EmojiCollection es) search =-    filter (matchesEmoji search) es---- | Match a search string against an emoji.-matchesEmoji :: T.Text-             -- ^ The search string (will be converted to lowercase and-             -- colons will be removed)-             -> T.Text-             -- ^ The emoji string (assumed to be lowercase and without-             -- leading/trailing colons)-             -> Bool-matchesEmoji searchString e =-    sanitizeEmojiSearch searchString `T.isInfixOf` e--sanitizeEmojiSearch :: T.Text -> T.Text-sanitizeEmojiSearch = stripColons . T.toLower . T.strip---- | Perform an emoji search against both the local EmojiCollection as--- well as the server's custom emoji. Return the results, sorted. If the--- empty string is specified, all local and all custom emoji will be--- included in the returned list.-getMatchingEmoji :: Session -> EmojiCollection -> T.Text -> IO [T.Text]-getMatchingEmoji session em rawSearchString = do-    let localAlts = lookupEmoji em rawSearchString-        sanitized = sanitizeEmojiSearch rawSearchString-    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-stripColons t =-    stripHeadColon $ stripTailColon t-    where-        stripHeadColon v = if ":" `T.isPrefixOf` v-                           then T.tail v-                           else v-        stripTailColon v = if ":" `T.isSuffixOf` v-                           then T.init v-                           else v
− src/Events.hs 
@@ -1,383 +0,0 @@-module Events-  ( onEvent-  , globalKeybindings-  , globalKeyHandlers-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Text as T-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( (.=), preuse, _2, singular, _Just )--import qualified Network.Mattermost.Endpoints as MM-import           Network.Mattermost.Exceptions ( mattermostErrorMessage )-import           Network.Mattermost.Lenses-import           Network.Mattermost.Types-import           Network.Mattermost.WebSocket--import           Connection-import           Constants ( userSigil, normalChannelSigil )-import           HelpTopics-import           State.Channels-import           State.Common-import           State.Flagging-import           State.Help-import           State.Messages-import           State.Reactions-import           State.Users-import           Types-import           Types.Common--import           Events.ChannelSelect-import           Events.DeleteChannelConfirm-import           Events.Keybindings-import           Events.LeaveChannelConfirm-import           Events.Main-import           Events.MessageSelect-import           Events.ThemeListOverlay-import           Events.PostListOverlay-import           Events.ShowHelp-import           Events.UrlSelect-import           Events.UserListOverlay-import           Events.ChannelListOverlay-import           Events.ReactionEmojiListOverlay-import           Events.TabbedWindow-import           Events.ManageAttachments-import           Events.EditNotifyPrefs---onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState)-onEvent st ev = runMHEvent st $ do-    onBrickEvent ev-    doPendingUserFetches-    doPendingUserStatusFetches--onBrickEvent :: BrickEvent Name MHEvent -> MH ()-onBrickEvent (AppEvent e) =-    onAppEvent e-onBrickEvent (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) = do-    vty <- mh getVtyHandle-    liftIO $ Vty.refresh vty-onBrickEvent (VtyEvent e) =-    onVtyEvent e-onBrickEvent _ =-    return ()--onAppEvent :: MHEvent -> MH ()-onAppEvent RefreshWebsocketEvent =-    connectWebsockets-onAppEvent WebsocketDisconnect = do-    csConnectionStatus .= Disconnected-    disconnectChannels-onAppEvent WebsocketConnect = do-    csConnectionStatus .= Connected-    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) =-    csWorkerIsBusy .= Just n-onAppEvent (WSEvent we) =-    handleWSEvent we-onAppEvent (WSActionResponse r) =-    handleWSActionResponse r-onAppEvent (RespEvent f) = f-onAppEvent (WebsocketParseError e) = do-    let msg = "A websocket message could not be parsed:\n  " <>-              T.pack e <>-              "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues"-    mhError $ GenericError msg-onAppEvent (IEvent e) = do-    handleIEvent e--handleIEvent :: InternalEvent -> MH ()-handleIEvent (DisplayError e) =-    postErrorMessage' $ formatError e-handleIEvent (LoggingStarted path) =-    postInfoMessage $ "Logging to " <> T.pack path-handleIEvent (LogDestination dest) =-    case dest of-        Nothing ->-            postInfoMessage "Logging is currently disabled. Enable it with /log-start."-        Just path ->-            postInfoMessage $ T.pack $ "Logging to " <> path-handleIEvent (LogSnapshotSucceeded path) =-    postInfoMessage $ "Log snapshot written to " <> T.pack path-handleIEvent (LoggingStopped path) =-    postInfoMessage $ "Stopped logging to " <> T.pack path-handleIEvent (LogStartFailed path err) =-    postErrorMessage' $ "Could not start logging to " <> T.pack path <>-                        ", error: " <> T.pack err-handleIEvent (LogSnapshotFailed path err) =-    postErrorMessage' $ "Could not write log snapshot to " <> T.pack path <>-                        ", error: " <> T.pack err--formatError :: MHError -> T.Text-formatError (GenericError msg) =-    msg-formatError (NoSuchChannel chan) =-    T.pack $ "No such channel: " <> show chan-formatError (NoSuchUser user) =-    T.pack $ "No such user: " <> show user-formatError (AmbiguousName name) =-    (T.pack $ "The input " <> show name <> " matches both channels ") <>-    "and users. Try using '" <> userSigil <> "' or '" <>-    normalChannelSigil <> "' to disambiguate."-formatError (ServerError e) =-    mattermostErrorMessage e-formatError (ClipboardError msg) =-    msg-formatError (ConfigOptionMissing opt) =-    T.pack $ "Config option " <> show opt <> " missing"-formatError (ProgramExecutionFailed progName logPath) =-    T.pack $ "An error occurred when running " <> show progName <>-             "; see " <> show logPath <> " for details."-formatError (NoSuchScript name) =-    "No script named " <> name <> " was found"-formatError (NoSuchHelpTopic topic) =-    let knownTopics = ("  - " <>) <$> helpTopicName <$> helpTopics-    in "Unknown help topic: `" <> topic <> "`. " <>-       (T.unlines $ "Available topics are:" : knownTopics)-formatError (AsyncErrEvent e) =-    "An unexpected error has occurred! The exception encountered was:\n  " <>-    T.pack (show e) <>-    "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues"--onVtyEvent :: Vty.Event -> MH ()-onVtyEvent e = do-    case e of-        (Vty.EvResize _ _) ->-            -- On resize, invalidate the entire rendering cache since-            -- many things depend on the window size.-            ---            -- Note: we fall through after this because it is sometimes-            -- important for modes to have their own additional logic-            -- to run when a resize occurs, so we don't want to stop-            -- processing here.-            mh invalidateCache-        _ -> return ()--    void $ handleKeyboardEvent globalKeybindings handleGlobalEvent e--handleGlobalEvent :: Vty.Event -> MH ()-handleGlobalEvent e = do-    mode <- gets appMode-    case mode of-        Main                       -> onEventMain e-        ShowHelp _ _               -> void $ onEventShowHelp e-        ChannelSelect              -> void $ onEventChannelSelect e-        UrlSelect                  -> void $ onEventUrlSelect e-        LeaveChannelConfirm        -> onEventLeaveChannelConfirm e-        MessageSelect              -> onEventMessageSelect e-        MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e-        DeleteChannelConfirm       -> onEventDeleteChannelConfirm e-        ThemeListOverlay           -> onEventThemeListOverlay e-        PostListOverlay _          -> onEventPostListOverlay e-        UserListOverlay            -> onEventUserListOverlay e-        ChannelListOverlay         -> onEventChannelListOverlay e-        ReactionEmojiListOverlay   -> onEventReactionEmojiListOverlay e-        ViewMessage                -> void $ handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e-        ManageAttachments          -> onEventManageAttachments e-        ManageAttachmentsBrowseFiles -> onEventManageAttachments e-        EditNotifyPrefs            -> void $ onEventEditNotifyPrefs e--globalKeybindings :: KeyConfig -> KeyHandlerMap-globalKeybindings = mkKeybindings globalKeyHandlers--globalKeyHandlers :: [KeyEventHandler]-globalKeyHandlers =-    [ mkKb ShowHelpEvent-        "Show this help screen"-        (showHelpScreen mainHelpTopic)-    ]--handleWSActionResponse :: WebsocketActionResponse -> MH ()-handleWSActionResponse r =-    case warStatus r of-        WebsocketActionStatusOK -> return ()--handleWSEvent :: WebsocketEvent -> MH ()-handleWSEvent we = do-    myId <- gets myUserId-    myTId <- gets myTeamId-    case weEvent we of-        WMPosted-            | Just p <- wepPost (weData we) ->-                when (wepTeamId (weData we) == Just myTId ||-                      wepTeamId (weData we) == Nothing) $ do-                    let wasMentioned = maybe False (Set.member myId) $ wepMentions (weData we)-                    addNewPostedMessage $ RecentPost p wasMentioned-                    cId <- use csCurrentChannelId-                    when (postChannelId p /= cId) $-                        showChannelInSidebar (p^.postChannelIdL) False-            | otherwise -> return ()--        WMPostEdited-            | Just p <- wepPost (weData we) -> do-                editMessage p-                cId <- use csCurrentChannelId-                when (postChannelId p == cId) (updateViewed False)-                when (postChannelId p /= cId) $-                    showChannelInSidebar (p^.postChannelIdL) False-            | otherwise -> return ()--        WMPostDeleted-            | Just p <- wepPost (weData we) -> do-                deleteMessage p-                cId <- use csCurrentChannelId-                when (postChannelId p == cId) (updateViewed False)-                when (postChannelId p /= cId) $-                    showChannelInSidebar (p^.postChannelIdL) False-            | otherwise -> return ()--        WMStatusChange-            | Just status <- wepStatus (weData we)-            , Just uId <- wepUserId (weData we) ->-                setUserStatus uId status-            | otherwise -> return ()--        WMUserAdded-            | Just cId <- webChannelId (weBroadcast we) ->-                when (wepUserId (weData we) == Just myId &&-                      wepTeamId (weData we) == Just myTId) $-                    handleChannelInvite cId-            | otherwise -> return ()--        WMNewUser-            | Just uId <- wepUserId $ weData we ->-                handleNewUsers (Seq.singleton uId) (return ())-            | otherwise -> return ()--        WMUserRemoved-            | Just cId <- wepChannelId (weData we) ->-                when (webUserId (weBroadcast we) == Just myId) $-                    removeChannelFromState cId-            | otherwise -> return ()--        WMTyping-            | Just uId <- wepUserId $ weData we-            , Just cId <- webChannelId (weBroadcast we) -> handleTypingUser uId cId-            | otherwise -> return ()--        WMChannelDeleted-            | Just cId <- wepChannelId (weData we) ->-                when (webTeamId (weBroadcast we) == Just myTId) $-                    removeChannelFromState cId-            | otherwise -> return ()--        WMDirectAdded-            | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId-            | otherwise -> return ()--        -- An 'ephemeral message' is just Mattermost's version of our-        -- 'client message'. This can be a little bit wacky, e.g.-        -- if the user types '/shortcuts' in the browser, we'll get-        -- an ephemeral message even in MatterHorn with the browser-        -- shortcuts, but it's probably a good idea to handle these-        -- messages anyway.-        WMEphemeralMessage-            | Just p <- wepPost $ weData we -> postInfoMessage (sanitizeUserText $ p^.postMessageL)-            | otherwise -> return ()--        WMPreferenceChanged-            | Just prefs <- wepPreferences (weData we) ->-                mapM_ applyPreferenceChange prefs-            | otherwise -> return ()--        WMPreferenceDeleted-            | Just pref <- wepPreferences (weData we)-            , Just fps <- mapM preferenceToFlaggedPost pref ->-              forM_ fps $ \f ->-                  updateMessageFlag (flaggedPostId f) False-            | otherwise -> return ()--        WMReactionAdded-            | Just r <- wepReaction (weData we)-            , Just cId <- webChannelId (weBroadcast we) -> addReactions cId [r]-            | otherwise -> return ()--        WMReactionRemoved-            | Just r <- wepReaction (weData we)-            , Just cId <- webChannelId (weBroadcast we) -> removeReaction r cId-            | otherwise -> return ()--        WMChannelViewed-            | Just cId <- wepChannelId $ weData we -> refreshChannelById cId-            | otherwise -> return ()--        WMChannelUpdated-            | Just cId <- webChannelId $ weBroadcast we -> do-                mChan <- preuse (csChannel(cId))-                when (isJust mChan) $ do-                    refreshChannelById cId-                    updateSidebar-            | otherwise -> return ()--        WMGroupAdded-            | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId-            | otherwise -> return ()--        WMChannelMemberUpdated-            | Just channelMember <- wepChannelMember $ weData we ->-                  when (channelMemberUserId channelMember == myId) $-                      updateChannelNotifyProps-                      (channelMemberChannelId channelMember)-                      (channelMemberNotifyProps channelMember)-            | otherwise -> return ()--        -- We are pretty sure we should do something about these:-        WMAddedToTeam -> return ()--        -- We aren't sure whether there is anything we should do about-        -- these yet:-        WMUpdateTeam -> return ()-        WMTeamDeleted -> return ()-        WMUserUpdated -> return ()-        WMLeaveTeam -> return ()--        -- We deliberately ignore these events:-        WMChannelCreated -> return ()-        WMEmojiAdded -> return ()-        WMWebRTC -> return ()-        WMHello -> return ()-        WMAuthenticationChallenge -> return ()-        WMUserRoleUpdated -> return ()-        WMPluginStatusesChanged -> return ()-        WMPluginEnabled -> return ()-        WMPluginDisabled -> return ()-        WMUnknownEvent {} -> return ()---- | Refresh client-accessible server configuration information. This--- is usually triggered when a reconnect event for the WebSocket to the--- server occurs.-refreshClientConfig :: MH ()-refreshClientConfig = do-    session <- getSession-    doAsyncWith Preempt $ do-        cfg <- MM.mmGetClientConfiguration (Just "old") session-        return $ Just $ do-            csClientConfig .= Just cfg-            updateSidebar
− src/Events/ChannelListOverlay.hs 
@@ -1,35 +0,0 @@-module Events.ChannelListOverlay-  ( onEventChannelListOverlay-  , channelListOverlayKeybindings-  , channelListOverlayKeyHandlers-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.ChannelListOverlay-import           State.ListOverlay-import           Types---onEventChannelListOverlay :: Vty.Event -> MH ()-onEventChannelListOverlay =-    void . onEventListOverlay csChannelListOverlay channelListOverlayKeybindings---- | The keybindings we want to use while viewing a channel list overlay-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-    , mkKb PageDownEvent "Page down in the channel list" channelListPageDown-    , mkKb PageUpEvent "Page up in the channel list" channelListPageUp-    , mkKb ActivateListItemEvent "Join the selected channel" (listOverlayActivateCurrent csChannelListOverlay)-    ]
− src/Events/ChannelSelect.hs 
@@ -1,45 +0,0 @@-module Events.ChannelSelect where--import           Prelude ()-import           Prelude.MH--import           Brick.Widgets.Edit ( handleEditorEvent )-import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.Channels-import           State.ChannelSelect-import           State.Editing ( editingKeybindings )-import           Types-import qualified Zipper as Z---onEventChannelSelect :: Vty.Event -> MH Bool-onEventChannelSelect =-  handleKeyboardEvent channelSelectKeybindings $ \e -> do-      handled <- handleKeyboardEvent (editingKeybindings (csChannelSelectState.channelSelectInput)) (const $ return ()) e-      when (not handled) $-          mhHandleEventLensed (csChannelSelectState.channelSelectInput) handleEditorEvent e--      updateChannelSelectMatches--channelSelectKeybindings :: KeyConfig -> KeyHandlerMap-channelSelectKeybindings = mkKeybindings channelSelectKeyHandlers--channelSelectKeyHandlers :: [KeyEventHandler]-channelSelectKeyHandlers =-    [ staticKb "Switch to selected channel"-         (Vty.EvKey Vty.KEnter []) $ do-             matches <- use (csChannelSelectState.channelSelectMatches)-             case Z.focus matches of-                 Nothing -> return ()-                 Just match -> do-                     setMode Main-                     setFocus $ channelListEntryChannelId $ matchEntry match--    , 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/DeleteChannelConfirm.hs 
@@ -1,20 +0,0 @@-module Events.DeleteChannelConfirm where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           Types-import           State.Channels---onEventDeleteChannelConfirm :: Vty.Event -> MH ()-onEventDeleteChannelConfirm (Vty.EvKey k []) = do-    case k of-        Vty.KChar c | c `elem` ("yY"::String) ->-            deleteCurrentChannel-        _ -> return ()-    setMode Main-onEventDeleteChannelConfirm _ = do-    setMode Main
− src/Events/EditNotifyPrefs.hs 
@@ -1,48 +0,0 @@-module Events.EditNotifyPrefs-    ( onEventEditNotifyPrefs-    , editNotifyPrefsKeybindings-    , editNotifyPrefsKeyHandlers-    )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Forms (handleFormEvent, formState)-import           Data.Maybe (fromJust)-import qualified Graphics.Vty as V-import qualified Network.Mattermost.Endpoints as MM--import           Lens.Micro.Platform (_Just, (.=), singular)--import           Types-import           Types.KeyEvents-import           Events.Keybindings-import           State.NotifyPrefs-import           State.Async--onEventEditNotifyPrefs :: V.Event -> MH Bool-onEventEditNotifyPrefs =-    let fallback e = do-            form <- use (csNotifyPrefs.singular _Just)-            updatedForm <- mh $ handleFormEvent (VtyEvent e) form-            csNotifyPrefs .= Just updatedForm-    in handleKeyboardEvent editNotifyPrefsKeybindings fallback--editNotifyPrefsKeybindings :: KeyConfig -> KeyHandlerMap-editNotifyPrefsKeybindings = mkKeybindings editNotifyPrefsKeyHandlers--editNotifyPrefsKeyHandlers :: [KeyEventHandler]-editNotifyPrefsKeyHandlers =-    [ mkKb CancelEvent "Close channel notification preferences" exitEditNotifyPrefsMode-    , mkKb FormSubmitEvent "Save channel notification preferences" $ do-        st <- use id-        let form = fromJust $ st^.csNotifyPrefs-            cId = st^.csCurrentChannelId--        doAsyncChannelMM Preempt cId-          (\s _ -> MM.mmUpdateChannelNotifications cId (myUserId st) (formState form) s)-          (\_ _ -> Nothing)-        exitEditNotifyPrefsMode-    ]
− src/Events/Keybindings.hs 
@@ -1,322 +0,0 @@-module Events.Keybindings-  ( defaultBindings-  , lookupKeybinding-  , getFirstDefaultBinding--  , mkKb-  , staticKb-  , mkKeybindings--  , handleKeyboardEvent--  , EventHandler(..)-  , KeyHandler(..)-  , KeyEventHandler(..)-  , KeyEventTrigger(..)-  , KeyHandlerMap(..)--  -- Re-exports:-  , KeyEvent (..)-  , KeyConfig-  , allEvents-  , parseBinding-  , keyEventName-  , keyEventFromName--  , ensureKeybindingConsistency-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.Text as T-import qualified Data.Map.Strict as M-import qualified Graphics.Vty as Vty--import           Types-import           Types.KeyEvents----- * Keybindings---- | 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 -> KeyHandlerMap -> Maybe KeyHandler-lookupKeybinding e (KeyHandlerMap m) = M.lookup e m---- | 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 = mkKeyMap (configUserKeys conf)-  case lookupKeybinding e keyMap of-    Just kh -> (ehAction $ kehHandler $ khHandler kh) >> return True-    Nothing -> fallthrough e >> return False--mkHandler :: Text -> MH () -> EventHandler-mkHandler msg action =-    EH { ehDescription = msg-       , ehAction = action-       }--mkKb :: KeyEvent -> Text -> MH () -> KeyEventHandler-mkKb ev msg action =-    KEH { kehHandler = mkHandler msg action-        , kehEventTrigger = ByEvent ev-        }--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)--getFirstDefaultBinding :: KeyEvent -> Binding-getFirstDefaultBinding ev =-    case defaultBindings ev of-        [] -> error $ "BUG: event " <> show ev <> " has no default bindings!"-        (b:_) -> b--defaultBindings :: KeyEvent -> [Binding]-defaultBindings ev =-  let meta binding = binding { kbMods = Vty.MMeta : kbMods binding }-      ctrl binding = binding { kbMods = Vty.MCtrl : kbMods binding }-      shift binding = binding { kbMods = Vty.MShift : kbMods binding }-      kb k = Binding { kbMods = [], kbKey = k }-      key c = Binding { kbMods = [], kbKey = Vty.KChar c }-      fn n = Binding { kbMods = [], kbKey = Vty.KFun n }-  in case ev of-        VtyRefreshEvent               -> [ ctrl (key 'l') ]-        ShowHelpEvent                 -> [ fn 1 ]-        EnterSelectModeEvent          -> [ ctrl (key 's') ]-        ReplyRecentEvent              -> [ ctrl (key 'r') ]-        ToggleMessagePreviewEvent     -> [ meta (key 'p') ]-        InvokeEditorEvent             -> [ meta (key 'k') ]-        EnterFastSelectModeEvent      -> [ ctrl (key 'g') ]-        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  -> [ ]-        LastChannelEvent              -> [ meta (key 's') ]-        EnterOpenURLModeEvent         -> [ ctrl (key 'o') ]-        ClearUnreadEvent              -> [ meta (key 'l') ]-        ToggleMultiLineEvent          -> [ meta (key 'e') ]-        EnterFlaggedPostsEvent        -> [ meta (key '8') ]-        ToggleChannelListVisibleEvent -> [ fn 2 ]-        SelectNextTabEvent            -> [ key '\t' ]-        SelectPreviousTabEvent        -> [ kb Vty.KBackTab ]-        LoadMoreEvent                 -> [ ctrl (key 'b') ]-        ScrollUpEvent                 -> [ kb Vty.KUp ]-        ScrollDownEvent               -> [ kb Vty.KDown ]-        ScrollLeftEvent               -> [ kb Vty.KLeft ]-        ScrollRightEvent              -> [ kb Vty.KRight ]-        PageUpEvent                   -> [ kb Vty.KPageUp ]-        PageDownEvent                 -> [ kb Vty.KPageDown ]-        PageLeftEvent                 -> [ shift (kb Vty.KLeft) ]-        PageRightEvent                -> [ shift (kb Vty.KRight) ]-        ScrollTopEvent                -> [ kb Vty.KHome ]-        ScrollBottomEvent             -> [ kb Vty.KEnd ]-        SelectOldestMessageEvent      -> [ shift (kb Vty.KHome) ]-        SelectUpEvent                 -> [ key 'k', kb Vty.KUp ]-        SelectDownEvent               -> [ key 'j', kb Vty.KDown ]-        ActivateListItemEvent         -> [ kb Vty.KEnter ]-        SearchSelectUpEvent           -> [ ctrl (key 'p'), kb Vty.KUp ]-        SearchSelectDownEvent         -> [ ctrl (key 'n'), kb Vty.KDown ]-        ViewMessageEvent              -> [ key 'v' ]-        FillGapEvent                  -> [ kb Vty.KEnter ]-        FlagMessageEvent              -> [ key 'f' ]-        PinMessageEvent               -> [ key 'p' ]-        YankMessageEvent              -> [ key 'y' ]-        YankWholeMessageEvent         -> [ key 'Y' ]-        DeleteMessageEvent            -> [ key 'd' ]-        EditMessageEvent              -> [ key 'e' ]-        ReplyMessageEvent             -> [ key 'r' ]-        ReactToMessageEvent           -> [ key 'a' ]-        OpenMessageURLEvent           -> [ key 'o' ]-        AttachmentListAddEvent        -> [ key 'a' ]-        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') ]-        FormSubmitEvent               -> [ kb Vty.KEnter ]---- | Given a configuration, we want to check it for internal consistency--- (i.e. that a given keybinding isn't associated with multiple events--- which both need to get generated in the same UI mode) and also for--- 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 -> KeyHandlerMap)] -> Either String ()-ensureKeybindingConsistency kc modeMaps = mapM_ checkGroup allBindings-  where-    -- This is a list of lists, grouped by keybinding, of all the-    -- keybinding/event associations that are going to be used with the-    -- provided key configuration.-    allBindings = groupWith fst $ concat-      [ case M.lookup ev kc of-          Nothing -> zip (defaultBindings ev) (repeat (False, ev))-          Just (BindingList bs) -> zip bs (repeat (True, ev))-          Just Unbound -> []-      | ev <- allEvents-      ]--    -- The invariant here is that each call to checkGroup is made with a-    -- list where the first element of every list is the same binding.-    -- The Bool value in these is True if the event was associated with-    -- the binding by the user, and False if it's a Matterhorn default.-    checkGroup :: [(Binding, (Bool, KeyEvent))] -> Either String ()-    checkGroup [] = error "[ensureKeybindingConsistency: unreachable]"-    checkGroup evs@((b, _):_) = do--      -- We find out which modes an event can be used in and then invert-      -- the map, so this is a map from mode to the events contains-      -- which are bound by the binding included above.-      let modesFor :: M.Map String [(Bool, KeyEvent)]-          modesFor = M.unionsWith (++)-            [ M.fromList [ (m, [(i, ev)]) | m <- modeMap ev ]-            | (_, (i, ev)) <- evs-            ]--      -- If there is ever a situation where the same key is bound to two-      -- events which can appear in the same mode, then we want to throw-      -- an error, and also be informative about why. It is still okay-      -- to bind the same key to two events, so long as those events-      -- never appear in the same UI mode.-      forM_ (M.assocs modesFor) $ \ (_, vs) ->-         when (length vs > 1) $-           Left $ concat $-             "Multiple overlapping events bound to `" :-             T.unpack (ppBinding b) :-             "`:\n" :-             concat [ [ " - `"-                      , T.unpack (keyEventName ev)-                      , "` "-                      , if isFromUser-                          then "(via user override)"-                          else "(matterhorn default)"-                      , "\n"-                      ]-                    | (isFromUser, ev) <- vs-                    ]--      -- Check for overlap a set of built-in keybindings when we're in a-      -- mode where the user is typing. (These are perfectly fine when-      -- we're in other modes.)-      when ("main" `M.member` modesFor && isBareBinding b) $ do-        Left $ concat $-          [ "The keybinding `"-          , T.unpack (ppBinding b)-          , "` is bound to the "-          , case map (ppEvent . snd . snd) evs of-              [] -> error "unreachable"-              [e] -> "event " ++ e-              es  -> "events " ++ intercalate " and " es-          , "\n"-          , "This is probably not what you want, as it will interfere "-          , "with the ability to write messages!\n"-          ]--    -- Events get some nice formatting!-    ppEvent ev = "`" ++ T.unpack (keyEventName ev) ++ "`"--    -- This check should get more nuanced, but as a first approximation,-    -- we shouldn't bind to any bare character key in the main mode.-    isBareBinding (Binding [] (Vty.KChar {})) = True-    isBareBinding _ = False--    -- 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 matches kh = ByEvent ev == (kehEventTrigger $ khHandler kh)-      in [ mode-         | (mode, mkBindings) <- modeMaps-         , let KeyHandlerMap m = mkBindings kc-           in not $ null $ M.filter matches m-         ]
− src/Events/LeaveChannelConfirm.hs 
@@ -1,19 +0,0 @@-module Events.LeaveChannelConfirm where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           State.Channels-import           Types---onEventLeaveChannelConfirm :: Vty.Event -> MH ()-onEventLeaveChannelConfirm (Vty.EvKey k []) = do-    case k of-        Vty.KChar c | c `elem` ("yY"::String) ->-            leaveCurrentChannel-        _ -> return ()-    setMode Main-onEventLeaveChannelConfirm _ = return ()
− src/Events/Main.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module Events.Main where--import           Prelude ()-import           Prelude.MH--import           Brick.Widgets.Edit-import qualified Graphics.Vty as Vty--import           Command-import           Events.Keybindings-import           State.Attachments-import           State.ChannelSelect-import           State.Channels-import           State.Editing-import           State.MessageSelect-import           State.PostListOverlay ( enterFlaggedPostListMode )-import           State.UrlSelect-import           Types---onEventMain :: Vty.Event -> MH ()-onEventMain =-  void . handleKeyboardEvent mainKeybindings (\ ev -> do-      resetReturnChannel-      case ev of-          (Vty.EvPaste bytes) -> handlePaste bytes-          _ -> handleEditingInput ev-  )--mainKeybindings :: KeyConfig -> KeyHandlerMap-mainKeybindings = mkKeybindings mainKeyHandlers--mainKeyHandlers :: [KeyEventHandler]-mainKeyHandlers =-    [ mkKb EnterSelectModeEvent-        "Select a message to edit/reply/delete"-        beginMessageSelect--    , mkKb ReplyRecentEvent-        "Reply to the most recent message"-        replyToLatestMessage--    , mkKb ToggleMessagePreviewEvent "Toggle message preview"-        toggleMessagePreview--    , mkKb ToggleChannelListVisibleEvent "Toggle channel list visibility"-        toggleChannelListVisibility--    , mkKb-        InvokeEditorEvent-        "Invoke `$EDITOR` to edit the current message"-        invokeExternalEditor--    , mkKb-        EnterFastSelectModeEvent-        "Enter fast channel selection mode"-         beginChannelSelect--    , mkKb-        QuitEvent-        "Quit"-        requestQuit--    , staticKb "Tab-complete forward"-         (Vty.EvKey (Vty.KChar '\t') []) $-         tabComplete Forwards--    , staticKb "Tab-complete backward"-         (Vty.EvKey (Vty.KBackTab) []) $-         tabComplete Backwards--    , mkKb-        ScrollUpEvent-        "Scroll up in the channel input history" $ do-             -- Up in multiline mode does the usual thing; otherwise we-             -- navigate the history.-             isMultiline <- use (csEditState.cedEphemeral.eesMultiline)-             case isMultiline of-                 True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent-                                           (Vty.EvKey Vty.KUp [])-                 False -> channelHistoryBackward--    , mkKb-        ScrollDownEvent-        "Scroll down in the channel input history" $ do-             -- Down in multiline mode does the usual thing; otherwise-             -- we navigate the history.-             isMultiline <- use (csEditState.cedEphemeral.eesMultiline)-             case isMultiline of-                 True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent-                                           (Vty.EvKey Vty.KDown [])-                 False -> channelHistoryForward--    , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do-             beginMessageSelect--    , mkKb SelectOldestMessageEvent "Scroll to top of channel message list" $ do-             beginMessageSelect-             messageSelectFirst--    , mkKb NextChannelEvent "Change to the next channel in the channel list"-         nextChannel--    , mkKb PrevChannelEvent "Change to the previous channel in the channel list"-         prevChannel--    , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages or return to the channel marked '~'"-         nextUnreadChannel--    , mkKb ShowAttachmentListEvent "Show the attachment list"-         showAttachmentList--    , mkKb NextUnreadUserOrChannelEvent-         "Change to the next channel with unread messages preferring direct messages"-         nextUnreadUserOrChannel--    , mkKb LastChannelEvent "Change to the most recently-focused channel"-         recentChannel--    , staticKb "Send the current message"-         (Vty.EvKey Vty.KEnter []) $ do-             isMultiline <- use (csEditState.cedEphemeral.eesMultiline)-             case isMultiline of-                 -- Normally, this event causes the current message to-                 -- be sent. But in multiline mode we want to insert a-                 -- newline instead.-                 True -> handleEditingInput (Vty.EvKey Vty.KEnter [])-                 False -> do-                     cId <- use csCurrentChannelId-                     content <- getEditorContent-                     handleInputSubmission cId content--    , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel"-           startUrlSelect--    , mkKb ClearUnreadEvent "Clear the current channel's unread / edited indicators" $-           clearChannelUnreadStatus =<< use csCurrentChannelId--    , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode"-           toggleMultilineEditing--    , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order"-         cancelAutocompleteOrReplyOrEdit--    , mkKb EnterFlaggedPostsEvent "View currently flagged posts"-         enterFlaggedPostListMode-    ]
− src/Events/ManageAttachments.hs 
@@ -1,182 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ScopedTypeVariables #-}-module Events.ManageAttachments-  ( onEventManageAttachments-  , attachmentListKeybindings-  , attachmentBrowseKeyHandlers-  , attachmentBrowseKeybindings-  , attachmentListKeyHandlers-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Control.Exception as E-import qualified Brick.Widgets.FileBrowser as FB-import qualified Brick.Widgets.List as L-import qualified Data.ByteString as BS-import qualified Data.Text as T-import qualified Data.Vector as Vector-import qualified Graphics.Vty as V-import           Lens.Micro.Platform ( (?=), (%=), to )--import           Types-import           Types.KeyEvents-import           Events.Keybindings-import           State.Attachments-import           State.Common---onEventManageAttachments :: V.Event -> MH ()-onEventManageAttachments e = do-    mode <- gets appMode-    case mode of-        ManageAttachments -> void $ onEventAttachmentList e-        ManageAttachmentsBrowseFiles -> onEventBrowseFile e-        _ -> error "BUG: onEventManageAttachments called in invalid mode"--onEventAttachmentList :: V.Event -> MH Bool-onEventAttachmentList =-    handleKeyboardEvent attachmentListKeybindings $-        mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent--attachmentListKeybindings :: KeyConfig -> KeyHandlerMap-attachmentListKeybindings = mkKeybindings attachmentListKeyHandlers--attachmentListKeyHandlers :: [KeyEventHandler]-attachmentListKeyHandlers =-    [ mkKb CancelEvent "Close attachment list"-          (setMode Main)-    , mkKb SelectUpEvent "Move cursor up" $-          mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KUp [])-    , mkKb SelectDownEvent "Move cursor down" $-          mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KDown [])-    , mkKb AttachmentListAddEvent "Add a new attachment to the attachment list"-          showAttachmentFileBrowser-    , mkKb AttachmentOpenEvent "Open the selected attachment using the URL open command"-          openSelectedAttachment-    , mkKb AttachmentListDeleteEvent "Delete the selected attachment from the attachment list"-          deleteSelectedAttachment-    ]--attachmentBrowseKeybindings :: KeyConfig -> KeyHandlerMap-attachmentBrowseKeybindings = mkKeybindings attachmentBrowseKeyHandlers--attachmentBrowseKeyHandlers :: [KeyEventHandler]-attachmentBrowseKeyHandlers =-    [ mkKb CancelEvent "Cancel attachment file browse"-      cancelAttachmentBrowse-    , mkKb AttachmentOpenEvent "Open the selected file using the URL open command"-          openSelectedBrowserEntry-    ]--withFileBrowser :: ((FB.FileBrowser Name) -> MH ()) -> MH ()-withFileBrowser f = do-    use (csEditState.cedFileBrowser) >>= \case-        Nothing -> do-            -- The widget has not been created yet.  This should-            -- normally not occur, because the ManageAttachments-            -- events should not fire when there is no FileBrowser-            -- Widget active to cause Brick to generate these events.-            -- This could therefore be implemented as an `error "BUG:-            -- ..."` handler, but the more benign approach is to-            -- simply create an available FileBrowser at this stage.-            new_b <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing-            csEditState.cedFileBrowser ?= new_b-            f new_b-        Just b -> f b--openSelectedAttachment :: MH ()-openSelectedAttachment = do-    cur <- use (csEditState.cedAttachmentList.to L.listSelectedElement)-    case cur of-        Nothing -> return ()-        Just (_, entry) -> void $ openURL (OpenLocalFile $ FB.fileInfoFilePath $-                                           attachmentDataFileInfo entry)--openSelectedBrowserEntry :: MH ()-openSelectedBrowserEntry = withFileBrowser $ \b ->-    case FB.fileBrowserCursor b of-        Nothing -> return ()-        Just entry -> void $ openURL (OpenLocalFile $ FB.fileInfoFilePath entry)--onEventBrowseFile :: V.Event -> MH ()-onEventBrowseFile e = do-    withFileBrowser $ \b -> do-        case FB.fileBrowserIsSearching b of-            False ->-                void $ handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e-            True ->-                handleFileBrowserEvent e--    -- n.b. the FileBrowser may have been updated above, so re-acquire it-    withFileBrowser $ \b -> do-        case FB.fileBrowserException b of-            Nothing -> return ()-            Just ex -> do-                mhLog LogError $ T.pack $ "FileBrowser exception: " <> show ex--cancelAttachmentBrowse :: MH ()-cancelAttachmentBrowse = do-    es <- use (csEditState.cedAttachmentList.L.listElementsL)-    case length es of-        0 -> setMode Main-        _ -> setMode ManageAttachments--handleFileBrowserEvent :: V.Event -> MH ()-handleFileBrowserEvent e = do-  let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev))-  mhHandleEventLensed (csEditState.cedFileBrowser) fbHandle e--  withFileBrowser $ \b -> do-    -- TODO: Check file browser exception state-    let entries = FB.fileBrowserSelection b-    forM_ entries $ \entry -> do-        -- Is the entry already present? If so, ignore the selection.-        es <- use (csEditState.cedAttachmentList.L.listElementsL)-        let matches = (== (FB.fileInfoFilePath entry)) .-                      FB.fileInfoFilePath .-                      attachmentDataFileInfo-        case Vector.find matches es of-            Just _ -> return ()-            Nothing -> do-                let path = FB.fileInfoFilePath entry-                readResult <- liftIO $ E.try $ BS.readFile path-                case readResult of-                    Left (_::E.SomeException) ->-                        -- TODO: report the error-                        return ()-                    Right bytes -> do-                        let a = AttachmentData { attachmentDataFileInfo = entry-                                               , attachmentDataBytes = bytes-                                               }-                        oldIdx <- use (csEditState.cedAttachmentList.L.listSelectedL)-                        let newIdx = if Vector.null es-                                     then Just 0-                                     else oldIdx-                        csEditState.cedAttachmentList %= L.listReplace (Vector.snoc es a) newIdx--    when (not $ null entries) $ setMode Main--deleteSelectedAttachment :: MH ()-deleteSelectedAttachment = do-    es <- use (csEditState.cedAttachmentList.L.listElementsL)-    mSel <- use (csEditState.cedAttachmentList.to L.listSelectedElement)-    case mSel of-        Nothing ->-            return ()-        Just (pos, _) -> do-            oldIdx <- use (csEditState.cedAttachmentList.L.listSelectedL)-            let idx = if Vector.length es == 1-                      then Nothing-                      else case oldIdx of-                          Nothing -> Just 0-                          Just old -> if pos >= old-                                      then Just $ pos - 1-                                      else Just pos-            csEditState.cedAttachmentList %= L.listReplace (deleteAt pos es) idx--deleteAt :: Int -> Vector.Vector a -> Vector.Vector a-deleteAt p as | p < 0 || p >= length as = as-              | otherwise = Vector.take p as <> Vector.drop (p + 1) as
− src/Events/MessageSelect.hs 
@@ -1,85 +0,0 @@-module Events.MessageSelect where--import           Prelude ()-import           Prelude.MH--import qualified Data.Text as T-import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.MessageSelect-import           State.ReactionEmojiListOverlay-import           Types---messagesPerPageOperation :: Int-messagesPerPageOperation = 10--onEventMessageSelect :: Vty.Event -> MH ()-onEventMessageSelect =-  void . handleKeyboardEvent messageSelectKeybindings (const $ return ())--onEventMessageSelectDeleteConfirm :: Vty.Event -> MH ()-onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do-    deleteSelectedMessage-    setMode Main-onEventMessageSelectDeleteConfirm _ =-    setMode Main--messageSelectKeybindings :: KeyConfig -> KeyHandlerMap-messageSelectKeybindings = mkKeybindings messageSelectKeyHandlers--messageSelectKeyHandlers :: [KeyEventHandler]-messageSelectKeyHandlers =-    [ mkKb CancelEvent "Cancel message selection" $-        setMode Main--    , mkKb SelectUpEvent "Select the previous message" messageSelectUp-    , mkKb SelectDownEvent "Select the next message" messageSelectDown-    , mkKb ScrollTopEvent "Scroll to top and select the oldest message"-        messageSelectFirst-    , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message"-        messageSelectLast-    , mkKb-        PageUpEvent-        (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages")-        (messageSelectUpBy messagesPerPageOperation)-    , mkKb-        PageDownEvent-        (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages")-        (messageSelectDownBy messagesPerPageOperation)--    , mkKb OpenMessageURLEvent "Open all URLs in the selected message"-        openSelectedMessageURLs--    , mkKb ReplyMessageEvent "Begin composing a reply to the selected message"-         beginReplyCompose--    , mkKb EditMessageEvent "Begin editing the selected message"-         beginEditMessage--    , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)"-         beginConfirmDeleteSelectedMessage--    , mkKb YankMessageEvent "Copy a verbatim section or message to the clipboard"-         yankSelectedMessageVerbatim--    , mkKb YankWholeMessageEvent "Copy an entire message to the clipboard"-         yankSelectedMessage--    , mkKb PinMessageEvent "Toggle whether the selected message is pinned"-         pinSelectedMessage--    , mkKb FlagMessageEvent "Flag the selected message"-         flagSelectedMessage--    , mkKb ViewMessageEvent "View the selected message"-         viewSelectedMessage--    , mkKb FillGapEvent "Fetch messages for the selected gap"-         fillSelectedGap--    , mkKb ReactToMessageEvent "Post a reaction to the selected message"-         enterReactionEmojiListOverlayMode--    ]
− src/Events/PostListOverlay.hs 
@@ -1,28 +0,0 @@-module Events.PostListOverlay where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           Types-import           Events.Keybindings-import           State.PostListOverlay---onEventPostListOverlay :: Vty.Event -> MH ()-onEventPostListOverlay =-  void . handleKeyboardEvent postListOverlayKeybindings (const $ return ())---- | The keybindings we want to use while viewing a post list overlay-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-  , mkKb FlagMessageEvent "Toggle the selected message flag" postListUnflagSelected-  , mkKb ActivateListItemEvent "Jump to and select current message" postListJumpToCurrent-  ]
− src/Events/ReactionEmojiListOverlay.hs 
@@ -1,35 +0,0 @@-module Events.ReactionEmojiListOverlay-  ( onEventReactionEmojiListOverlay-  , reactionEmojiListOverlayKeybindings-  , reactionEmojiListOverlayKeyHandlers-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.ReactionEmojiListOverlay-import           State.ListOverlay-import           Types---onEventReactionEmojiListOverlay :: Vty.Event -> MH ()-onEventReactionEmojiListOverlay =-    void . onEventListOverlay csReactionEmojiListOverlay reactionEmojiListOverlayKeybindings---- | The keybindings we want to use while viewing an emoji list overlay-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-    , mkKb PageDownEvent "Page down in the emoji list" reactionEmojiListPageDown-    , mkKb PageUpEvent "Page up in the emoji list" reactionEmojiListPageUp-    , mkKb ActivateListItemEvent "Post the selected emoji reaction" (listOverlayActivateCurrent csReactionEmojiListOverlay)-    ]
− src/Events/ShowHelp.hs 
@@ -1,44 +0,0 @@-module Events.ShowHelp where--import           Prelude ()-import           Prelude.MH--import           Brick-import qualified Graphics.Vty as Vty--import           Constants-import           Events.Keybindings-import           Types---onEventShowHelp :: Vty.Event -> MH Bool-onEventShowHelp =-  handleKeyboardEvent helpKeybindings $ \ e -> case e of-    Vty.EvKey _ _ -> popMode-    _ -> return ()--helpKeybindings :: KeyConfig -> KeyHandlerMap-helpKeybindings = mkKeybindings helpKeyHandlers--helpKeyHandlers :: [KeyEventHandler]-helpKeyHandlers =-    [ mkKb ScrollUpEvent "Scroll up" $-        mh $ vScrollBy (viewportScroll HelpViewport) (-1)-    , mkKb ScrollDownEvent "Scroll down" $-        mh $ vScrollBy (viewportScroll HelpViewport) 1-    , mkKb PageUpEvent "Page up" $-        mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount)-    , mkKb PageDownEvent "Page down" $-        mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount)-    , mkKb CancelEvent "Return to the previous interface" $-        popMode-    , mkKb ScrollBottomEvent "Scroll to the end of the help" $-        mh $ vScrollToEnd (viewportScroll HelpViewport)-    , mkKb ScrollTopEvent "Scroll to the beginning of the help" $-        mh $ vScrollToBeginning (viewportScroll HelpViewport)-    ]--popMode :: MH ()-popMode = do-    ShowHelp _ prevMode <- gets appMode-    setMode prevMode
− src/Events/TabbedWindow.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module Events.TabbedWindow-  ( handleTabbedWindowEvent-  , tabbedWindowKeybindings-  , tabbedWindowKeyHandlers-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( Lens', (.=) )--import           Types-import           Types.KeyEvents-import           Events.Keybindings--handleTabbedWindowEvent :: (Show a, Eq a)-                        => Lens' ChatState (TabbedWindow a)-                        -> Vty.Event-                        -> MH Bool-handleTabbedWindowEvent target e = do-    w <- use target-    handleKeyboardEvent (tabbedWindowKeybindings target) (forwardEvent w) e--forwardEvent :: (Show a, Eq a)-             => TabbedWindow a-             -> Vty.Event-             -> MH ()-forwardEvent w e = do-    let cur = getCurrentTabbedWindowEntry w-    tweHandleEvent cur (twValue w) e--tabbedWindowKeybindings :: (Show a, Eq a)-                        => Lens' ChatState (TabbedWindow a)-                        -> KeyConfig-                        -> 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)--    , mkKb SelectNextTabEvent "Select next tab" $ do-        w' <- tabbedWindowNextTab =<< use target-        target .= w'--    , mkKb SelectPreviousTabEvent "Select previous tab" $ do-        w' <- tabbedWindowPreviousTab =<< use target-        target .= w'-    ]
− src/Events/ThemeListOverlay.hs 
@@ -1,30 +0,0 @@-module Events.ThemeListOverlay where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.ThemeListOverlay-import           State.ListOverlay-import           Types---onEventThemeListOverlay :: Vty.Event -> MH ()-onEventThemeListOverlay =-    void . onEventListOverlay csThemeListOverlay themeListOverlayKeybindings---- | The keybindings we want to use while viewing a user list overlay-themeListOverlayKeybindings :: KeyConfig -> KeyHandlerMap-themeListOverlayKeybindings = mkKeybindings themeListOverlayKeyHandlers--themeListOverlayKeyHandlers :: [KeyEventHandler]-themeListOverlayKeyHandlers =-    [ mkKb CancelEvent "Close the theme list" (exitListOverlay csThemeListOverlay)-    , mkKb SearchSelectUpEvent "Select the previous theme" themeListSelectUp-    , mkKb SearchSelectDownEvent "Select the next theme" themeListSelectDown-    , mkKb PageDownEvent "Page down in the theme list" themeListPageDown-    , mkKb PageUpEvent "Page up in the theme list" themeListPageUp-    , mkKb ActivateListItemEvent "Switch to the selected color theme" (listOverlayActivateCurrent csThemeListOverlay)-    ]
− src/Events/UrlSelect.hs 
@@ -1,40 +0,0 @@-module Events.UrlSelect where--import           Prelude ()-import           Prelude.MH--import           Brick.Widgets.List-import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.UrlSelect-import           Types---onEventUrlSelect :: Vty.Event -> MH Bool-onEventUrlSelect =-  handleKeyboardEvent urlSelectKeybindings $ \ ev ->-    mhHandleEventLensed csUrlList handleListEvent ev--urlSelectKeybindings :: KeyConfig -> KeyHandlerMap-urlSelectKeybindings = mkKeybindings urlSelectKeyHandlers--urlSelectKeyHandlers :: [KeyEventHandler]-urlSelectKeyHandlers =-    [ staticKb "Open the selected URL, if any"-         (Vty.EvKey Vty.KEnter []) $ do-             openSelectedURL-             setMode Main--    , mkKb CancelEvent "Cancel URL selection" stopUrlSelect--    , mkKb SelectUpEvent "Move cursor up" $-        mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KUp [])--    , mkKb SelectDownEvent "Move cursor down" $-        mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KDown [])--    , staticKb "Cancel URL selection"-         (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect--    ]
− src/Events/UserListOverlay.hs 
@@ -1,30 +0,0 @@-module Events.UserListOverlay where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty--import           Events.Keybindings-import           State.UserListOverlay-import           State.ListOverlay-import           Types---onEventUserListOverlay :: Vty.Event -> MH ()-onEventUserListOverlay =-    void . onEventListOverlay csUserListOverlay userListOverlayKeybindings---- | The keybindings we want to use while viewing a user list overlay-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-    , mkKb PageDownEvent "Page down in the user list" userListPageDown-    , mkKb PageUpEvent "Page up in the user list" userListPageUp-    , mkKb ActivateListItemEvent "Interact with the selected user" (listOverlayActivateCurrent csUserListOverlay)-    ]
− src/FilePaths.hs 
@@ -1,167 +0,0 @@-{-# LANGUAGE TupleSections #-}-module FilePaths-  ( historyFilePath-  , historyFileName--  , lastRunStateFilePath-  , lastRunStateFileName--  , configFileName--  , xdgName-  , locateConfig-  , xdgSyntaxDir-  , syntaxDirName-  , userEmojiJsonPath-  , bundledEmojiJsonPath-  , emojiJsonFilename--  , Script(..)-  , locateScriptPath-  , getAllScripts-  )-where--import Prelude ()-import Prelude.MH--import Data.Text ( unpack )-import System.Directory ( doesFileExist-                        , doesDirectoryExist-                        , getDirectoryContents-                        , getPermissions-                        , executable-                        )-import System.Environment ( getExecutablePath )-import System.Environment.XDG.BaseDir ( getUserConfigFile-                                      , getAllConfigFiles-                                      , getUserConfigDir-                                      )-import System.FilePath ( (</>), takeBaseName, takeDirectory, splitPath, joinPath )---xdgName :: String-xdgName = "matterhorn"--historyFileName :: FilePath-historyFileName = "history.txt"--lastRunStateFileName :: Text -> FilePath-lastRunStateFileName teamId = "last_run_state_" ++ unpack teamId ++ ".json"--configFileName :: FilePath-configFileName = "config.ini"--historyFilePath :: IO FilePath-historyFilePath = getUserConfigFile xdgName historyFileName--lastRunStateFilePath :: Text -> IO FilePath-lastRunStateFilePath teamId =-  getUserConfigFile xdgName (lastRunStateFileName teamId)---- | Get the XDG path to the user-specific syntax definition directory.--- The path does not necessarily exist.-xdgSyntaxDir :: IO FilePath-xdgSyntaxDir = (</> syntaxDirName) <$> getUserConfigDir xdgName---- | Get the XDG path to the user-specific emoji JSON file. The path--- does not necessarily exist.-userEmojiJsonPath :: IO FilePath-userEmojiJsonPath = (</> emojiJsonFilename) <$> getUserConfigDir xdgName---- | Get the emoji JSON path relative to the development binary location--- or the release binary location.-bundledEmojiJsonPath :: IO FilePath-bundledEmojiJsonPath = do-    selfPath <- getExecutablePath-    let distDir = "dist-newstyle/"-        pathBits = splitPath selfPath--    return $ if distDir `elem` pathBits-             then-                 -- We're in development, so use the development-                 -- executable path to locate the emoji path in the-                 -- development tree.-                 (joinPath $ takeWhile (/= distDir) pathBits) </> emojiDirName </> emojiJsonFilename-             else-                 -- In this case we assume the binary is being run from-                 -- a release, in which case the syntax directory is a-                 -- sibling of the executable path.-                 takeDirectory selfPath </> emojiDirName </> emojiJsonFilename--emojiJsonFilename :: FilePath-emojiJsonFilename = "emoji.json"--emojiDirName :: FilePath-emojiDirName = "emoji"--syntaxDirName :: FilePath-syntaxDirName = "syntax"---- | Find a specified configuration file by looking in all of the--- supported locations.-locateConfig :: FilePath -> IO (Maybe FilePath)-locateConfig filename = do-  xdgLocations <- getAllConfigFiles xdgName filename-  let confLocations = ["./" <> filename] ++-                      xdgLocations ++-                      ["/etc/matterhorn/" <> filename]-  results <- forM confLocations $ \fp -> (fp,) <$> doesFileExist fp-  return $ listToMaybe $ fst <$> filter snd results--scriptDirName :: FilePath-scriptDirName = "scripts"--data Script-  = ScriptPath FilePath-  | NonexecScriptPath FilePath-  | ScriptNotFound-    deriving (Eq, Read, Show)--toScript :: FilePath -> IO (Script)-toScript fp = do-  perm <- getPermissions fp-  return $ if executable perm-    then ScriptPath fp-    else NonexecScriptPath fp--isExecutable :: FilePath -> IO Bool-isExecutable fp = do-  perm <- getPermissions fp-  return (executable perm)--locateScriptPath :: FilePath -> IO Script-locateScriptPath name-  | head name == '.' = return ScriptNotFound-  | otherwise = do-    xdgLocations <- getAllConfigFiles xdgName scriptDirName-    let cmdLocations = [ xdgLoc ++ "/" ++ name-                       | xdgLoc <- xdgLocations-                       ] ++ [ "/etc/matterhorn/scripts/" <> name ]-    existingFiles <- filterM doesFileExist cmdLocations-    executables <- mapM toScript existingFiles-    return $ case executables of-      (path:_) -> path-      _        -> ScriptNotFound---- | This returns a list of valid scripts, and a list of non-executable---   scripts.-getAllScripts :: IO ([FilePath], [FilePath])-getAllScripts = do-  xdgLocations <- getAllConfigFiles xdgName scriptDirName-  let cmdLocations = xdgLocations ++ ["/etc/matterhorn/scripts"]-  let getCommands dir = do-        exists <- doesDirectoryExist dir-        if exists-          then map ((dir ++ "/") ++) `fmap` getDirectoryContents dir-          else return []-  let isNotHidden f = case f of-        ('.':_) -> False-        []      -> False-        _       -> True-  allScripts <- concat `fmap` mapM getCommands cmdLocations-  execs <- filterM isExecutable allScripts-  nonexecs <- filterM (fmap not . isExecutable) allScripts-  return ( filter isNotHidden $ map takeBaseName execs-         , filter isNotHidden $ map takeBaseName nonexecs-         )
− src/HelpTopics.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module HelpTopics-  ( helpTopics-  , lookupHelpTopic-  , themeHelpTopic-  , mainHelpTopic-  )-where--import Prelude ()-import Prelude.MH--import Types---helpTopics :: [HelpTopic]-helpTopics =-    [ mainHelpTopic-    , scriptHelpTopic-    , themeHelpTopic-    , keybindingHelpTopic-    , syntaxHighlightingHelpTopic-    ]--mainHelpTopic :: HelpTopic-mainHelpTopic =-    HelpTopic "main" "This help page" MainHelp HelpText--scriptHelpTopic :: HelpTopic-scriptHelpTopic =-    HelpTopic "scripts" "Help on available scripts" ScriptHelp ScriptHelpText--themeHelpTopic :: HelpTopic-themeHelpTopic =-    HelpTopic "themes" "Help on color themes" ThemeHelp ThemeHelpText--keybindingHelpTopic :: HelpTopic-keybindingHelpTopic =-    HelpTopic "keybindings" "Help on overriding keybindings"-      KeybindingHelp KeybindingHelpText--syntaxHighlightingHelpTopic :: HelpTopic-syntaxHighlightingHelpTopic =-    HelpTopic "syntax" "Help on syntax highlighing"-      SyntaxHighlightHelp SyntaxHighlightHelpText--lookupHelpTopic :: Text -> Maybe HelpTopic-lookupHelpTopic topic =-    listToMaybe $ filter ((== topic) . helpTopicName) helpTopics
− src/IOUtil.hs 
@@ -1,20 +0,0 @@-module IOUtil-  ( convertIOException-  )-where--import Prelude ()-import Prelude.MH--import Control.Exception-import Control.Monad.Trans.Except-import System.IO.Error ( ioeGetErrorString )---convertIOException :: IO a -> ExceptT String IO a-convertIOException act = do-    result <- liftIO $ (Right <$> act) `catch`-                       (\(e::IOError) -> return $ Left $ ioeGetErrorString e)-    case result of-        Left e -> throwE e-        Right v -> return v
− src/InputHistory.hs 
@@ -1,76 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module InputHistory-  ( InputHistory-  , newHistory-  , readHistory-  , writeHistory-  , addHistoryEntry-  , getHistoryEntry-  , removeChannelHistory-  )-where--import           Prelude ()-import           Prelude.MH--import           Control.Monad.Trans.Except-import qualified Data.HashMap.Strict as HM-import qualified Data.Vector as V-import           Lens.Micro.Platform ( (.~), (^?), (%~), at, ix, makeLenses )-import           System.Directory ( createDirectoryIfMissing )-import           System.FilePath ( dropFileName )-import qualified System.IO.Strict as S-import qualified System.Posix.Files as P-import qualified System.Posix.Types as P--import           Network.Mattermost.Types ( ChannelId )--import           FilePaths-import           IOUtil---data InputHistory =-    InputHistory { _historyEntries :: HashMap ChannelId (V.Vector Text)-                 }-                 deriving (Show)--makeLenses ''InputHistory--newHistory :: InputHistory-newHistory = InputHistory mempty--removeChannelHistory :: ChannelId -> InputHistory -> InputHistory-removeChannelHistory cId ih = ih & historyEntries.at cId .~ Nothing--historyFileMode :: P.FileMode-historyFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode--writeHistory :: InputHistory -> IO ()-writeHistory ih = do-    historyFile <- historyFilePath-    createDirectoryIfMissing True $ dropFileName historyFile-    let entries = (\(cId, z) -> (cId, V.toList z)) <$>-                  (HM.toList $ ih^.historyEntries)-    writeFile historyFile $ show entries-    P.setFileMode historyFile historyFileMode--readHistory :: IO (Either String InputHistory)-readHistory = runExceptT $ do-    contents <- convertIOException (S.readFile =<< historyFilePath)-    case reads contents of-        [(val, "")] -> do-            let entries = (\(cId, es) -> (cId, V.fromList es)) <$> val-            return $ InputHistory $ HM.fromList entries-        _ -> throwE "Failed to parse history file"--addHistoryEntry :: Text -> ChannelId -> InputHistory -> InputHistory-addHistoryEntry e cId ih = ih & historyEntries.at cId %~ insertEntry-    where-    insertEntry Nothing  = Just $ V.singleton e-    insertEntry (Just v) =-      Just $ V.cons e (V.filter (/= e) v)--getHistoryEntry :: ChannelId -> Int -> InputHistory -> Maybe Text-getHistoryEntry cId i ih = do-    es <- ih^.historyEntries.at cId-    es ^? ix i
− src/KeyMap.hs 
@@ -1,28 +0,0 @@-module KeyMap-  ( keybindingModeMap-  )-where--import           Prelude ()-import           Prelude.MH--import           Events.Keybindings-import           Events.ChannelSelect-import           Events.Main-import           Events.MessageSelect-import           Events.PostListOverlay-import           Events.ShowHelp-import           Events.UrlSelect-import           Events.ManageAttachments--keybindingModeMap :: [(String, KeyConfig -> KeyHandlerMap)]-keybindingModeMap =-    [ ("main", mainKeybindings)-    , ("help screen", helpKeybindings)-    , ("channel select", channelSelectKeybindings)-    , ("url select", urlSelectKeybindings)-    , ("message select", messageSelectKeybindings)-    , ("post list overlay", postListOverlayKeybindings)-    , ("attachment list", attachmentListKeybindings)-    , ("attachment file browse", attachmentBrowseKeybindings)-    ]
− src/LastRunState.hs 
@@ -1,99 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module LastRunState-  ( LastRunState-  , lrsHost-  , lrsPort-  , lrsUserId-  , lrsSelectedChannelId-  , writeLastRunState-  , readLastRunState-  , isValidLastRunState-  )-where--import           Prelude ()-import           Prelude.MH--import           Control.Monad.Trans.Except-import qualified Data.Aeson as A-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import           Lens.Micro.Platform ( makeLenses )-import           System.Directory ( createDirectoryIfMissing )-import           System.FilePath ( dropFileName )-import qualified System.Posix.Files as P-import qualified System.Posix.Types as P--import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           FilePaths-import           IOUtil-import           Types----- | Run state of the program. This is saved in a file on program exit and--- | looked up from the file on program startup.-data LastRunState = LastRunState-  { _lrsHost              :: Hostname  -- ^ Host of the server-  , _lrsPort              :: Port      -- ^ Post of the server-  , _lrsUserId            :: UserId    -- ^ ID of the logged-in user-  , _lrsSelectedChannelId :: ChannelId -- ^ ID of the last selected channel-  }--instance A.ToJSON LastRunState where-  toJSON lrs = A.object [ "host"           A..= _lrsHost lrs-                        , "port"           A..= _lrsPort lrs-                        , "user_id"        A..= _lrsUserId lrs-                        , "sel_channel_id" A..= _lrsSelectedChannelId lrs-                        ]--instance A.FromJSON LastRunState where-  parseJSON = A.withObject "LastRunState" $ \v ->-    LastRunState-    <$> v A..: "host"-    <*> v A..: "port"-    <*> v A..: "user_id"-    <*> v A..: "sel_channel_id"--makeLenses ''LastRunState--toLastRunState :: ChatState -> LastRunState-toLastRunState cs = LastRunState-  { _lrsHost              = cs^.csResources.crConn.cdHostnameL-  , _lrsPort              = cs^.csResources.crConn.cdPortL-  , _lrsUserId            = myUserId cs-  , _lrsSelectedChannelId = cs^.csCurrentChannelId-  }--lastRunStateFileMode :: P.FileMode-lastRunStateFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode---- | Writes the run state to a file. The file is specific to the current team.--- | Writes only if the current channel is an ordrinary or a private channel.-writeLastRunState :: ChatState -> IO ()-writeLastRunState cs =-  when (cs^.csCurrentChannel.ccInfo.cdType `elem` [Ordinary, Private]) $ do-    let runState = toLastRunState cs-        tId      = myTeamId cs--    lastRunStateFile <- lastRunStateFilePath $ unId $ toId tId-    createDirectoryIfMissing True $ dropFileName lastRunStateFile-    BS.writeFile lastRunStateFile $ LBS.toStrict $ A.encode runState-    P.setFileMode lastRunStateFile lastRunStateFileMode---- | Reads the last run state from a file given the current team ID.-readLastRunState :: TeamId -> IO (Either String LastRunState)-readLastRunState tId = runExceptT $ do-  contents <- convertIOException $-    lastRunStateFilePath (unId $ toId tId) >>= BS.readFile-  case A.eitherDecodeStrict' contents of-    Right val -> return val-    Left err -> throwE $ "Failed to parse lastRunState file: " ++ err---- | Checks if the given last run state is valid for the current server and user.-isValidLastRunState :: ChatResources -> User -> LastRunState -> Bool-isValidLastRunState cr me rs =-     rs^.lrsHost   == cr^.crConn.cdHostnameL-  && rs^.lrsPort   == cr^.crConn.cdPortL-  && rs^.lrsUserId == me^.userIdL
− src/Login.hs 
@@ -1,594 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RankNTypes #-}--- | This module provides the login interface for Matterhorn.------ * Overview------ The interface provides a set of form fields for the user to use to--- enter their server information and credentials. The user enters--- this information and presses Enter, and then this module--- attempts to connect to the server. The module's main function,--- interactiveGetLoginSession, returns the result of that connection--- attempt, if any.------ * Details------ The interactiveGetLoginSession function takes the Matterhorn--- configuration's initial connection information as input. If the--- configuration provided a complete set of values needed to make a--- login attempt, this module goes ahead and immediately makes a login--- attempt before even showing the user the login form. This case is--- the case where the configuration provided all four values needed:--- server host name, port, username, and password. When the interface--- immediately makes a login attempt under these conditions, this is--- referred to as an "initial" attempt in various docstrings below.--- Otherwise, the user is prompted to fill out the form to enter any--- missing values. On pressing Enter, a login attempt is made.------ A status message about whether a connection is underway is shown in--- both cases: in the case where the user has edited the credentials and--- pressed Enter, and in the case where the original credentials--- provided to interactiveGetLoginSession caused an initial connection--- attempt.------ The "initial" login case is special because in addition to not--- showing the form, we want to ensure that the "connecting to..."--- status message that is shown is shown long enough for the user to--- see what is happening (rather than just flashing by in the case--- of a fast server connection). For this usability reason, we have--- a "startup timer" thread: the thread waits a specified number--- of milliseconds (see 'startupTimerMilliseconds' below) and then--- notifies the interface that it has timed out. If there is an initial--- connection attempt underway that succeeds *before* the timer--- fires, we wait until the timer fires before quitting the Login--- application and returning control to Matterhorn. This ensures that--- the "connecting to..." message stays on the screen long enough to not--- be jarring, and to show the user what is happening. If the connection--- fails before the timer fires, we just resume normal operation and--- show the login form so the user can intervene.-module Login-  ( LoginAttempt(..)-  , interactiveGetLoginSession-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.BChan-import           Brick.Focus-import           Brick.Forms-import           Brick.Widgets.Border-import           Brick.Widgets.Center-import           Brick.Widgets.Edit-import           Control.Concurrent ( forkIO, threadDelay )-import           Control.Exception ( SomeException, catch, try )-import           Data.Char (isHexDigit)-import           Data.List (tails, inits)-import           System.IO.Error ( catchIOError )-import qualified Data.Text as T-import           Graphics.Vty hiding (mkVty)-import           Lens.Micro.Platform ( (.~), Lens', makeLenses )-import qualified System.IO.Error as Err-import           Network.URI ( URI(..), URIAuth(..), parseURI )--import           Network.Mattermost ( ConnectionData )-import           Network.Mattermost.Types.Internal ( Token(..) )-import           Network.Mattermost.Types ( Session(..), User, Login(..), ConnectionPoolConfig(..)-                                          , initConnectionData, ConnectionType(..), UserParam(..) )-import           Network.Mattermost.Exceptions ( LoginFailureException(..) )-import           Network.Mattermost.Endpoints ( mmGetUser, mmGetLimitedClientConfiguration, mmLogin )--import           Draw.RichText-import           Themes ( clientEmphAttr )-import           Types ( ConnectionInfo(..)-                       , ciPassword, ciUsername, ciHostname, ciUrlPath-                       , ciPort, ciType, AuthenticationException(..)-                       , LogManager, LogCategory(..), ioLogWithManager-                       , ciAccessToken-                       )----- | Resource names for the login interface.-data Name =-      Server-    | Username-    | Password-    | AccessToken-    deriving (Ord, Eq, Show)---- | The result of an authentication attempt.-data LoginAttempt =-    AttemptFailed AuthenticationException-    -- ^ The attempt failed with the corresponding error.-    | AttemptSucceeded ConnectionInfo ConnectionData Session User (Maybe Text) --team-    -- ^ The attempt succeeded.---- | The state of the login interface: whether a login attempt is--- currently in progress.-data LoginState =-    Idle-    -- ^ No login attempt is in progress.-    | Connecting Bool Text-    -- ^ A login attempt to the specified host is in progress. The-    -- boolean flag indicates whether this login was user initiated-    -- (False) or triggered immediately when starting the interface-    -- (True). This "initial" flag is used to determine whether the-    -- login form is shown while the connection attempt is underway.-    deriving (Eq)---- | Requests that we can make to the login worker thead.-data LoginRequest =-    DoLogin Bool ConnectionInfo-    -- ^ Request a login using the specified connection information.-    -- The boolean flag is the "initial" flag value corresponding to the-    -- "Connecting" constructor flag of the "LoginState" type.---- | The messages that the login worker thread can send to the user--- interface event handler.-data LoginEvent =-    StartConnect Bool Text-    -- ^ A connection to the specified host has begun. The boolean-    -- value is whether this was an "initial" connection attempt (see-    -- LoginState).-    | LoginResult LoginAttempt-    -- ^ A login attempt finished with the specified result.-    | StartupTimeout-    -- ^ The startup timer thread fired.---- | The login application state.-data State =-    State { _loginForm :: Form ConnectionInfo LoginEvent Name-          , _lastAttempt :: Maybe LoginAttempt-          , _currentState :: LoginState-          , _reqChan :: BChan LoginRequest-          , _timeoutFired :: Bool-          }--makeLenses ''State---- | The HTTP connection pool settings for the login worker thread.-poolCfg :: ConnectionPoolConfig-poolCfg = ConnectionPoolConfig { cpIdleConnTimeout = 60-                               , cpStripesCount = 1-                               , cpMaxConnCount = 5-                               }---- | Run an IO action and convert various kinds of thrown exceptions--- into a returned AuthenticationException.-convertLoginExceptions :: IO a -> IO (Either AuthenticationException a)-convertLoginExceptions act =-    (Right <$> act)-        `catch` (\e -> return $ Left $ ResolveError e)-        `catch` (\e -> return $ Left $ ConnectError e)-        `catchIOError` (\e -> return $ Left $ AuthIOError e)-        `catch` (\e -> return $ Left $ OtherAuthError e)---- | The login worker thread.-loginWorker :: (ConnectionData -> ConnectionData)-            -- ^ The function used to set the logger on the-            -- ConnectionData that results from a successful login-            -- attempt.-            -> LogManager-            -- ^ The log manager used to do logging.-            -> BChan LoginRequest-            -- ^ The channel on which we'll await requests.-            -> BChan LoginEvent-            -- ^ The channel to which we'll send login attempt results.-            -> IO ()-loginWorker setLogger logMgr requestChan respChan = forever $ do-    req <- readBChan requestChan-    case req of-        DoLogin initial connInfo -> do-            writeBChan respChan $ StartConnect initial $ connInfo^.ciHostname-            let doLog = ioLogWithManager logMgr Nothing LogGeneral--            doLog $ "Attempting authentication to " <> connInfo^.ciHostname--            cdResult <- findConnectionData connInfo-            case cdResult of-              Left e ->-                do writeBChan respChan $ LoginResult $ AttemptFailed $ OtherAuthError e-              Right (cd_, mbTeam) -> do-                  let cd = setLogger cd_-                      token = connInfo^.ciAccessToken-                  case T.null token of-                      False -> do-                          let sess = Session cd $ Token $ T.unpack token--                          userResult <- try $ mmGetUser UserMe sess-                          writeBChan respChan $ case userResult of-                              Left (e::SomeException) ->-                                  LoginResult $ AttemptFailed $ OtherAuthError e-                              Right user ->-                                  LoginResult $ AttemptSucceeded connInfo cd sess user mbTeam-                      True -> do-                          let login = Login { username = connInfo^.ciUsername-                                            , password = connInfo^.ciPassword-                                            }--                          result <- convertLoginExceptions $ mmLogin cd login-                          case result of-                              Left e -> do-                                  doLog $ "Error authenticating to " <> connInfo^.ciHostname <> ": " <> (T.pack $ show e)-                                  writeBChan respChan $ LoginResult $ AttemptFailed e-                              Right (Left e) -> do-                                  doLog $ "Error authenticating to " <> connInfo^.ciHostname <> ": " <> (T.pack $ show e)-                                  writeBChan respChan $ LoginResult $ AttemptFailed $ LoginError e-                              Right (Right (sess, user)) -> do-                                  doLog $ "Authenticated successfully to " <> connInfo^.ciHostname <> " as " <> connInfo^.ciUsername-                                  writeBChan respChan $ LoginResult $ AttemptSucceeded connInfo cd sess user mbTeam------ | Searches prefixes of the given URL to determine Mattermost API URL--- path and team name-findConnectionData :: ConnectionInfo -> IO (Either SomeException (ConnectionData, Maybe Text))-findConnectionData connInfo = startSearch-  where-    components = filter (not . T.null) (T.split ('/'==) (connInfo^.ciUrlPath))--    -- the candidates list is never empty because inits never returns an-    -- empty list-    primary:alternatives =-        reverse-        [ (T.intercalate "/" l, listToMaybe r)-        | (l,r) <- zip (inits components) (tails components)-        ]--    tryCandidate :: (Text, Maybe Text)-                 -> IO (Either SomeException (ConnectionData, Maybe Text))-    tryCandidate (path, team) =-       do cd  <- initConnectionData (connInfo^.ciHostname)-                                    (fromIntegral (connInfo^.ciPort))-                                    path (connInfo^.ciType) poolCfg-          res <- try (mmGetLimitedClientConfiguration cd)-          pure $! case res of-                    Left e  -> Left e-                    Right{} -> Right (cd, team)--    -- This code prefers to report the error from the URL corresponding-    -- to what the user actually provided. Errors from derived URLs are-    -- lost in favor of this first error.-    startSearch =-      do res1 <- tryCandidate primary-         case res1 of-           Left e -> search e alternatives-           Right cd -> pure (Right cd)--    search e [] = pure (Left e)-    search e (x:xs) =-      do res <- tryCandidate x-         case res of-           Left {}  -> search e xs-           Right cd -> pure (Right cd)----- | The amount of time that the startup timer thread will wait before--- firing.-startupTimerMilliseconds :: Int-startupTimerMilliseconds = 750---- | The startup timer thread.-startupTimer :: BChan LoginEvent -> IO ()-startupTimer respChan = do-    threadDelay $ startupTimerMilliseconds * 1000-    writeBChan respChan StartupTimeout---- | The main function of this module: interactively present a login--- interface, get the user's input, and attempt to log into the user's--- specified mattermost server.------ This always returns the final terminal state handle. If the user--- makes no login attempt, this returns Nothing. Otherwise it returns--- Just the result of the latest attempt.-interactiveGetLoginSession :: Vty-                           -- ^ The initial terminal state handle to use.-                           -> IO Vty-                           -- ^ An action to build a new state handle-                           -- if one is needed. (In practice this-                           -- never fires since the login app doesn't-                           -- use suspendAndResume, but we need it to-                           -- satisfy the Brick API.)-                           -> (ConnectionData -> ConnectionData)-                           -- ^ The function to set the logger on-                           -- connection handles.-                           -> LogManager-                           -- ^ The log manager used to do logging.-                           -> ConnectionInfo-                           -- ^ Initial connection info to use to-                           -- populate the login form. If the connection-                           -- info provided here is fully populated, an-                           -- initial connection attempt is made without-                           -- first getting the user to hit Enter.-                           -> IO (Maybe LoginAttempt, Vty)-interactiveGetLoginSession vty mkVty setLogger logMgr initialConfig = do-    requestChan <- newBChan 10-    respChan <- newBChan 10--    void $ forkIO $ loginWorker setLogger logMgr requestChan respChan-    void $ forkIO $ startupTimer respChan--    let initialState = mkState initialConfig requestChan--    startState <- case (populatedConnectionInfo initialConfig) of-        True -> do-            writeBChan requestChan $ DoLogin True initialConfig-            return $ initialState & currentState .~ Connecting True (initialConfig^.ciHostname)-        False -> do-            return initialState--    (finalSt, finalVty) <- customMainWithVty vty mkVty (Just respChan) app startState--    return (finalSt^.lastAttempt, finalVty)---- | Is the specified ConnectionInfo sufficiently populated for us to--- bother attempting to use it to connect?-populatedConnectionInfo :: ConnectionInfo -> Bool-populatedConnectionInfo ci =-    and [ not $ T.null $ ci^.ciHostname-        , or [ and [ not $ T.null $ ci^.ciUsername-                   , not $ T.null $ ci^.ciPassword-                   ]-             , not $ T.null $ ci^.ciAccessToken-             ]-        , ci^.ciPort > 0-        ]---- | Make an initial login application state.-mkState :: ConnectionInfo -> BChan LoginRequest -> State-mkState cInfo chan = state-    where-        state = State { _loginForm = form { formFocus = focusSetCurrent initialFocus (formFocus form)-                                          }-                      , _currentState = Idle-                      , _lastAttempt = Nothing-                      , _reqChan = chan-                      , _timeoutFired = False-                      }-        form = mkForm cInfo-        initialFocus = if | T.null (cInfo^.ciHostname) -> Server-                          | T.null (cInfo^.ciUsername) -> Username-                          | T.null (cInfo^.ciPassword) -> Password-                          | otherwise                  -> Server--app :: App State LoginEvent Name-app = App-  { appDraw         = credsDraw-  , appChooseCursor = showFirstCursor-  , appHandleEvent  = onEvent-  , appStartEvent   = return-  , appAttrMap      = const colorTheme-  }--onEvent :: State -> BrickEvent Name LoginEvent -> EventM Name (Next State)-onEvent st (VtyEvent (EvKey KEsc [])) = do-    halt $ st & lastAttempt .~ Nothing-onEvent st (AppEvent (StartConnect initial host)) = do-    continue $ st & currentState .~ Connecting initial host-                  & lastAttempt .~ Nothing-onEvent st (AppEvent StartupTimeout) = do-    -- If the startup timer fired and we have already succeeded, halt.-    case st^.lastAttempt of-        Just (AttemptSucceeded {}) -> halt st-        _ -> continue $ st & timeoutFired .~ True-onEvent st (AppEvent (LoginResult attempt)) = do-    let st' = st & lastAttempt .~ Just attempt-                 & currentState .~ Idle--    case attempt of-        AttemptSucceeded {} -> do-            -- If the startup timer already fired, halt. Otherwise wait-            -- until that timer fires.-            case st^.timeoutFired of-                True -> halt st'-                False -> continue st'-        AttemptFailed {} -> continue st'--onEvent st (VtyEvent (EvKey KEnter [])) = do-    -- Ignore the keypress if we are already attempting a connection, or-    -- if have already successfully connected but are waiting on the-    -- startup timer.-    case st^.currentState of-        Connecting {} -> return ()-        Idle ->-            case st^.lastAttempt of-                Just (AttemptSucceeded {}) -> return ()-                _ -> do-                    let ci = formState $ st^.loginForm-                    when (populatedConnectionInfo ci) $ do-                        liftIO $ writeBChan (st^.reqChan) $ DoLogin False ci--    continue st-onEvent st e = do-    f' <- handleFormEvent e (st^.loginForm)-    continue $ st & loginForm .~ f'--mkForm :: ConnectionInfo -> Form ConnectionInfo e Name-mkForm =-    let label s w = padBottom (Pad 1) $-                    (vLimit 1 $ hLimit 22 $ str s <+> fill ' ') <+> w-        above s w = hCenter (str s) <=> w-    in newForm [ label "Server URL:"     @@= editServer-               , (above "Provide a username and password:" .-                  label "Username:")     @@= editTextField ciUsername Username (Just 1)-               , label "Password:"       @@= editPasswordField ciPassword Password-               , (above "Or provide a Session or Personal Access Token:" .-                  label "Access Token:") @@= editPasswordField ciAccessToken AccessToken-               ]--serverLens :: Lens' ConnectionInfo (Text, Int, Text, ConnectionType)-serverLens f ci = fmap (\(x,y,z,w) -> ci { _ciHostname = x, _ciPort = y, _ciUrlPath = z, _ciType = w})-                       (f (ci^.ciHostname, ci^.ciPort, ci^.ciUrlPath, ci^.ciType))---- | Validate a server URI @hostname[:port][/path]@. Result is either an error message--- indicating why validation failed or a tuple of (hostname, port, path)-validServer :: [Text] -> Either String (Text, Int, Text, ConnectionType)-validServer ts =--  do t <- case ts of-            []  -> Left "No input"-            [t] -> Right t-            _   -> Left "Too many lines"--     let inputWithScheme-           | "://" `T.isInfixOf` t = t-           | otherwise = "https://" <> t--     uri <- case parseURI (T.unpack inputWithScheme) of-              Nothing  -> Left "Unable to parse URI"-              Just uri -> Right uri--     auth <- case uriAuthority uri of-               Nothing   -> Left "Missing authority part"-               Just auth -> Right auth--     ty <- case uriScheme uri of-             "http:"           -> Right ConnectHTTP-             "https:"          -> Right (ConnectHTTPS True)-             "https-insecure:" -> Right (ConnectHTTPS False)-             _                 -> Left "Unknown scheme"--     port <- case (ty, uriPort auth) of-               (ConnectHTTP   , "") -> Right 80-               (ConnectHTTPS{}, "") -> Right 443-               (_, ':':portStr)-                 | Just port <- readMaybe portStr -> Right port-               _ -> Left "Invalid port"--     let host-           | not (null (uriRegName auth))-           , '[' == head (uriRegName auth)-           , ']' == last (uriRegName auth)-           = init (tail (uriRegName auth))-           | otherwise = uriRegName auth--     if null (uriRegName auth) then Left "Missing server name" else Right ()-     if null (uriQuery uri) then Right () else Left "Unexpected URI query"-     if null (uriFragment uri) then Right () else Left "Unexpected URI fragment"-     if null (uriUserInfo auth) then Right () else Left "Unexpected credentials"--     Right (T.pack host, port, T.pack (uriPath uri), ty)---renderServer :: (Text, Int, Text, ConnectionType) -> Text-renderServer (h,p,u,t) = scheme <> hStr <> portStr <> uStr-  where-    hStr-      | T.all (\x -> isHexDigit x || ':'==x) h-      , T.any (':'==) h = "[" <> h <> "]"-      | otherwise = h--    scheme =-      case t of-        ConnectHTTP        -> "http://"-        ConnectHTTPS True  -> ""-        ConnectHTTPS False -> "https-insecure://"--    uStr-      | T.null u = u-      | otherwise = T.cons '/' (T.dropWhile ('/'==) u)--    portStr =-      case t of-        ConnectHTTP    | p ==  80 -> T.empty-        ConnectHTTPS{} | p == 443 -> T.empty-        _                         -> T.pack (':':show p)--editServer :: ConnectionInfo -> FormFieldState ConnectionInfo e Name-editServer =-    let val ts = case validServer ts of-                   Left{} -> Nothing-                   Right x-> Just x-        limit = Just 1-        renderTxt [""] = str "(Paste your Mattermost URL here)"-        renderTxt ts = txt (T.unlines ts)-    in editField serverLens Server limit renderServer val renderTxt id--errorAttr :: AttrName-errorAttr = "errorMessage"--colorTheme :: AttrMap-colorTheme = attrMap defAttr-  [ (editAttr, black `on` white)-  , (editFocusedAttr, black `on` yellow)-  , (errorAttr, fg red)-  , (focusedFormInputAttr, black `on` yellow)-  , (invalidFormInputAttr, white `on` red)-  , (clientEmphAttr, fg white `withStyle` bold)-  ]--credsDraw :: State -> [Widget Name]-credsDraw st =-    [ center $ vBox [ if shouldShowForm st then credentialsForm st else emptyWidget-                    , currentStateDisplay st-                    , lastAttemptDisplay (st^.lastAttempt)-                    ]-    ]---- | Whether the login form should be displayed.-shouldShowForm :: State -> Bool-shouldShowForm st =-    case st^.currentState of-        -- If we're connecting, only show the form if the connection-        -- attempt is not an initial one.-        Connecting initial _ -> not initial--        -- If we're idle, we want to show the form - unless we have-        -- already connected and are waiting for the startup timer to-        -- fire.-        Idle -> case st^.lastAttempt of-            Just (AttemptSucceeded {}) -> st^.timeoutFired-            _ -> True---- | The "current state" of the login process. Show a connecting status--- message if a connection is underway, or if one is already established--- and the startup timer has not fired.-currentStateDisplay :: State -> Widget Name-currentStateDisplay st =-    let msg host = padTop (Pad 1) $ hCenter $-                   txt "Connecting to " <+> withDefAttr clientEmphAttr (txt host) <+> txt "..."-    in case st^.currentState of-          Idle -> case st^.lastAttempt of-              Just (AttemptSucceeded ci _ _ _ _) -> msg (ci^.ciHostname)-              _ -> emptyWidget-          (Connecting _ host) -> msg host--lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name-lastAttemptDisplay Nothing = emptyWidget-lastAttemptDisplay (Just (AttemptSucceeded {})) = emptyWidget-lastAttemptDisplay (Just (AttemptFailed e)) =-    hCenter $ hLimit uiWidth $-    padTop (Pad 1) $ renderError $ renderText $-    "Error: " <> renderAuthError e--renderAuthError :: AuthenticationException -> Text-renderAuthError (ConnectError _) =-    "Could not connect to server"-renderAuthError (ResolveError _) =-    "Could not resolve server hostname"-renderAuthError (AuthIOError err)-  | Err.isDoesNotExistErrorType (Err.ioeGetErrorType err) =-    "Unable to connect to the network"-  | otherwise = "GetAddrInfo: " <> T.pack (Err.ioeGetErrorString err)-renderAuthError (OtherAuthError e) =-    T.pack $ show e-renderAuthError (LoginError (LoginFailureException msg)) =-    T.pack msg--renderError :: Widget a -> Widget a-renderError = withDefAttr errorAttr--uiWidth :: Int-uiWidth = 60--credentialsForm :: State -> Widget Name-credentialsForm st =-    hCenter $ hLimit uiWidth $ vLimit 15 $-    border $-    vBox [ renderText "Please enter your Mattermost credentials to log in."-         , padTop (Pad 1) $ renderForm (st^.loginForm)-         , hCenter $ renderText "Press Enter to log in or Esc to exit."-         ]
− src/Main.hs 
@@ -1,60 +0,0 @@-module Main where--import Prelude ()-import Prelude.MH-import qualified Data.Text.IO as T--import System.Exit ( exitFailure, exitSuccess )--import Config-import Options-import App-import Events.Keybindings ( ensureKeybindingConsistency )-import KeyMap ( keybindingModeMap )-import Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable-                     , commandMarkdownTable, commandTextTable )---main :: IO ()-main = do-    opts <- grabOptions--    configResult <- if optIgnoreConfig opts-                    then return $ Right defaultConfig-                    else fmap snd <$> findConfig (optConfLocation opts)--    config <- case configResult of-        Left err -> do-            putStrLn $ "Error loading config: " <> err-            exitFailure-        Right c -> return c--    let keyConfig = configUserKeys config-        format = optPrintFormat opts--    printedCommands <- case optPrintCommands opts of-        False -> return False-        True -> do-            case format of-                Markdown -> T.putStrLn commandMarkdownTable-                Plain -> T.putStrLn commandTextTable-            return True--    printedKeybindings <- case optPrintKeybindings opts of-        False -> return False-        True -> do-            case format of-                Markdown -> T.putStrLn $ keybindingMarkdownTable keyConfig-                Plain -> T.putStrLn $ keybindingTextTable keyConfig-            return True--    when (printedKeybindings || printedCommands) exitSuccess--    case ensureKeybindingConsistency keyConfig keybindingModeMap of-        Right () -> return ()-        Left err -> do-            putStrLn $ "Configuration error: " <> err-            exitFailure--    finalSt <- runMatterhorn opts config-    closeMatterhorn finalSt
+ src/Matterhorn/App.hs view
@@ -0,0 +1,115 @@+module Matterhorn.App+  ( runMatterhorn+  , closeMatterhorn+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Control.Monad.Trans.Except ( runExceptT )+import qualified Graphics.Vty as Vty+import           Text.Aspell ( stopAspell )+import           GHC.Conc (getNumProcessors, setNumCapabilities)+import           System.Posix.IO ( stdInput )++import           Network.Mattermost++import           Matterhorn.Config+import           Matterhorn.Draw+import qualified Matterhorn.Events as Events+import           Matterhorn.IOUtil+import           Matterhorn.InputHistory+import           Matterhorn.LastRunState+import           Matterhorn.Options hiding ( ShowHelp )+import           Matterhorn.State.Setup+import           Matterhorn.State.Setup.Threads.Logging ( shutdownLogManager )+import           Matterhorn.Types+++app :: App ChatState MHEvent Name+app = App+  { appDraw         = draw+  , appChooseCursor = \s cs -> case appMode s of+      Main                          -> showFirstCursor s cs+      ChannelSelect                 -> showFirstCursor s cs+      UserListOverlay               -> showFirstCursor s cs+      ReactionEmojiListOverlay      -> showFirstCursor s cs+      ChannelListOverlay            -> showFirstCursor s cs+      ManageAttachmentsBrowseFiles  -> showFirstCursor s cs+      ThemeListOverlay              -> showFirstCursor s cs+      ChannelTopicWindow            -> showCursorNamed ChannelTopicEditor cs+      LeaveChannelConfirm           -> Nothing+      DeleteChannelConfirm          -> Nothing+      MessageSelect                 -> Nothing+      MessageSelectDeleteConfirm    -> Nothing+      PostListOverlay _             -> Nothing+      ManageAttachments             -> Nothing+      ViewMessage                   -> Nothing+      ShowHelp _ _                  -> Nothing+      UrlSelect                     -> Nothing+      EditNotifyPrefs               -> Nothing+  , appHandleEvent  = Events.onEvent+  , appStartEvent   = return+  , appAttrMap      = (^.csResources.crTheme)+  }++applicationMaxCPUs :: Int+applicationMaxCPUs = 2++setupCpuUsage :: Config -> IO ()+setupCpuUsage config = do+    actualNumCpus <- getNumProcessors++    let requestedCPUs = case configCpuUsagePolicy config of+            SingleCPU -> 1+            MultipleCPUs -> min applicationMaxCPUs actualNumCpus++    setNumCapabilities requestedCPUs++runMatterhorn :: Options -> Config -> IO ChatState+runMatterhorn opts config = do+    setupCpuUsage config++    let mkVty = do+          mEraseChar <- Vty.getTtyEraseChar stdInput+          let addEraseChar cfg = case mEraseChar of+                  Nothing -> cfg+                  Just ch -> cfg { Vty.inputMap = (Nothing, [ch], Vty.EvKey Vty.KBS []) : Vty.inputMap cfg }++          vty <- Vty.mkVty $ addEraseChar Vty.defaultConfig+          let output = Vty.outputIface vty+          Vty.setMode output Vty.BracketedPaste True+          Vty.setMode output Vty.Hyperlink $ configHyperlinkingMode config+          return vty++    (st, vty) <- setupState mkVty (optLogLocation opts) config+    finalSt <- customMain vty mkVty (Just $ st^.csResources.crEventQueue) app st++    case finalSt^.csEditState.cedSpellChecker of+        Nothing -> return ()+        Just (s, _) -> stopAspell s++    return finalSt++-- | Cleanup resources and save data for restoring on program restart.+closeMatterhorn :: ChatState -> IO ()+closeMatterhorn finalSt = do+  logIfError (mmCloseSession $ getResourceSession $ finalSt^.csResources)+      "Error in closing session"++  logIfError (writeHistory (finalSt^.csEditState.cedInputHistory))+      "Error in writing history"++  logIfError (writeLastRunState finalSt)+      "Error in writing last run state"++  shutdownLogManager $ finalSt^.csResources.crLogManager++  where+    logIfError action msg = do+      done <- runExceptT $ convertIOException $ action+      case done of+        Left err -> putStrLn $ msg <> ": " <> err+        Right _  -> return ()
+ src/Matterhorn/Clipboard.hs view
@@ -0,0 +1,31 @@+module Matterhorn.Clipboard+  ( copyToClipboard+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Exception ( try )+import qualified Data.Text as T+import           System.Hclip ( setClipboard, ClipboardException(..) )++import           Matterhorn.Types+++copyToClipboard :: Text -> MH ()+copyToClipboard txt = do+  result <- liftIO (try (setClipboard (T.unpack txt)))+  case result of+    Left e -> do+      let errMsg = case e of+            UnsupportedOS _ ->+              "Matterhorn does not support yanking on this operating system."+            NoTextualData ->+              "Textual data is required to set the clipboard."+            MissingCommands cmds ->+              "Could not set clipboard due to missing one of the " <>+              "required program(s): " <> (T.pack $ show cmds)+      mhError $ ClipboardError errMsg+    Right () ->+      return ()
+ src/Matterhorn/Command.hs view
@@ -0,0 +1,338 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.Command+  ( commandList+  , dispatchCommand+  , printArgSpec+  , toggleMessagePreview+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( invalidateCache )+import qualified Control.Exception as Exn+import qualified Data.Char as Char+import qualified Data.Text as T+import           Lens.Micro.Platform ( (%=) )++import qualified Network.Mattermost.Endpoints as MM+import qualified Network.Mattermost.Exceptions as MM+import qualified Network.Mattermost.Types as MM++import           Matterhorn.Connection ( connectWebsockets )+import           Matterhorn.Constants ( userSigil, normalChannelSigil )+import           Matterhorn.HelpTopics+import           Matterhorn.Scripts+import           Matterhorn.State.Help+import           Matterhorn.State.Editing+import           Matterhorn.State.Channels+import           Matterhorn.State.ChannelTopicWindow+import           Matterhorn.State.ChannelSelect+import           Matterhorn.State.Logging+import           Matterhorn.State.PostListOverlay+import           Matterhorn.State.UserListOverlay+import           Matterhorn.State.ChannelListOverlay+import           Matterhorn.State.ThemeListOverlay+import           Matterhorn.State.Messages+import           Matterhorn.State.NotifyPrefs+import           Matterhorn.State.Common ( postInfoMessage )+import           Matterhorn.State.Users+import           Matterhorn.Themes ( attrForUsername )+import           Matterhorn.Types+++-- | This function skips any initial whitespace and returns the first+-- 'token' (i.e. any sequence of non-whitespace characters) as well as+-- the trailing rest of the string, after any whitespace. This is used+-- for tokenizing the first bits of command input while leaving the+-- subsequent chunks unchanged, preserving newlines and other+-- important formatting.+unwordHead :: Text -> Maybe (Text, Text)+unwordHead t =+  let t' = T.dropWhile Char.isSpace t+      (w, rs)  = T.break Char.isSpace t'+  in if T.null w+       then Nothing+       else Just (w, T.dropWhile Char.isSpace rs)++printArgSpec :: CmdArgs a -> Text+printArgSpec NoArg = ""+printArgSpec (LineArg ts) = "<" <> ts <> ">"+printArgSpec (TokenArg t NoArg) = "<" <> t <> ">"+printArgSpec (UserArg rs) = "<" <> userSigil <> "user>" <> addSpace (printArgSpec rs)+printArgSpec (ChannelArg rs) = "<" <> normalChannelSigil <> "channel>" <> addSpace (printArgSpec rs)+printArgSpec (TokenArg t rs) = "<" <> t <> ">" <> addSpace (printArgSpec rs)++addSpace :: Text -> Text+addSpace "" = ""+addSpace t = " " <> t++matchArgs :: CmdArgs a -> Text -> Either Text a+matchArgs NoArg t = case unwordHead t of+  Nothing -> return ()+  Just (a, as)+    | not (T.all Char.isSpace as) -> Left ("Unexpected arguments '" <> t <> "'")+    | otherwise -> Left ("Unexpected argument '" <> a <> "'")+matchArgs (LineArg _) t = return t+matchArgs spec@(UserArg rs) t = case unwordHead t of+  Nothing -> case rs of+    NoArg -> Left ("Missing argument: " <> printArgSpec spec)+    _     -> Left ("Missing arguments: " <> printArgSpec spec)+  Just (a, as) -> (,) <$> pure a <*> matchArgs rs as+matchArgs spec@(ChannelArg rs) t = case unwordHead t of+  Nothing -> case rs of+    NoArg -> Left ("Missing argument: " <> printArgSpec spec)+    _     -> Left ("Missing arguments: " <> printArgSpec spec)+  Just (a, as) -> (,) <$> pure a <*> matchArgs rs as+matchArgs spec@(TokenArg _ rs) t = case unwordHead t of+  Nothing -> case rs of+    NoArg -> Left ("Missing argument: " <> printArgSpec spec)+    _     -> Left ("Missing arguments: " <> printArgSpec spec)+  Just (a, as) -> (,) <$> pure a <*> matchArgs rs as++commandList :: [Cmd]+commandList =+  [ Cmd "quit" "Exit Matterhorn" NoArg $ \ () -> requestQuit++  , Cmd "right" "Focus on the next channel" NoArg $ \ () ->+      nextChannel++  , Cmd "left" "Focus on the previous channel" NoArg $ \ () ->+      prevChannel++  , Cmd "create-channel" "Create a new public channel"+    (LineArg "channel name") $ \ name ->+      createOrdinaryChannel True name++  , Cmd "create-private-channel" "Create a new private channel"+    (LineArg "channel name") $ \ name ->+      createOrdinaryChannel False name++  , Cmd "delete-channel" "Delete the current channel"+    NoArg $ \ () ->+      beginCurrentChannelDeleteConfirm++  , Cmd "hide" "Hide the current DM or group channel from the channel list"+    NoArg $ \ () -> do+      hideDMChannel =<< use csCurrentChannelId++  , Cmd "reconnect" "Force a reconnection attempt to the server"+    NoArg $ \ () ->+      connectWebsockets++  , Cmd "members" "Show the current channel's members"+    NoArg $ \ () ->+      enterChannelMembersUserList++  , Cmd "leave" "Leave a normal channel or hide a DM channel" NoArg $ \ () ->+      startLeaveCurrentChannel++  , Cmd "join" "Find a channel to join" NoArg $ \ () ->+      enterChannelListOverlayMode++  , Cmd "join" "Join the specified channel" (ChannelArg NoArg) $ \(n, ()) ->+      joinChannelByName n++  , Cmd "theme" "List the available themes" NoArg $ \ () ->+      enterThemeListMode++  , Cmd "theme" "Set the color theme"+    (TokenArg "theme" NoArg) $ \ (themeName, ()) ->+      setTheme themeName++  , Cmd "topic" "Set the current channel's topic (header) interactively"+    NoArg $ \ () ->+      openChannelTopicWindow++  , Cmd "topic" "Set the current channel's topic (header)"+    (LineArg "topic") $ \ p ->+      if not (T.null p) then setChannelTopic p else return ()++  , Cmd "add-user" "Search for a user to add to the current channel"+    NoArg $ \ () ->+        enterChannelInviteUserList++  , Cmd "msg" "Search for a user to enter a private chat"+    NoArg $ \ () ->+        enterDMSearchUserList++  , Cmd "msg" "Chat with the specified user"+    (UserArg NoArg) $ \ (name, ()) ->+        changeChannelByName name++  , Cmd "username-attribute" "Display the attribute used to color the specified username"+    (UserArg NoArg) $ \ (name, ()) ->+        displayUsernameAttribute name++  , Cmd "msg" "Go to a user's channel and send the specified message or command"+    (UserArg $ LineArg "message or command") $ \ (name, msg) -> do+        withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do+            case foundUser of+                Just user -> createOrFocusDMChannel user $ Just $ \cId ->+                    handleInputSubmission cId msg+                Nothing -> mhError $ NoSuchUser name++  , Cmd "log-start" "Begin logging debug information to the specified path"+    (TokenArg "path" NoArg) $ \ (path, ()) ->+        startLogging $ T.unpack path++  , Cmd "log-snapshot" "Dump the current debug log buffer to the specified path"+    (TokenArg "path" NoArg) $ \ (path, ()) ->+        logSnapshot $ T.unpack path++  , Cmd "log-stop" "Stop logging"+    NoArg $ \ () ->+        stopLogging++  , Cmd "log-mark" "Add a custom marker message to the Matterhorn debug log"+    (LineArg "message") $ \ markMsg ->+        mhLog LogUserMark markMsg++  , Cmd "log-status" "Show current debug logging status"+    NoArg $ \ () ->+        getLogDestination++  , Cmd "add-user" "Add a user to the current channel"+    (UserArg NoArg) $ \ (uname, ()) ->+        addUserByNameToCurrentChannel uname++  , Cmd "remove-user" "Remove a user from the current channel"+    (UserArg NoArg) $ \ (uname, ()) ->+        removeUserFromCurrentChannel uname++  , Cmd "user" "Show users to initiate a private DM chat channel"+    -- n.b. this is identical to "msg", but is provided as an+    -- alternative mental model for useability.+    NoArg $ \ () ->+        enterDMSearchUserList++  , Cmd "message-preview" "Toggle preview of the current message" NoArg $ \_ ->+        toggleMessagePreview++  , Cmd "toggle-channel-list" "Toggle channel list visibility" NoArg $ \_ ->+        toggleChannelListVisibility++  , Cmd "toggle-message-timestamps" "Toggle message timestamps" NoArg $ \_ ->+        toggleMessageTimestamps++  , Cmd "toggle-expanded-topics" "Toggle expanded channel topics" NoArg $ \_ ->+        toggleExpandedChannelTopics++  , Cmd "focus" "Focus on a channel or user"+    (ChannelArg NoArg) $ \ (name, ()) ->+        changeChannelByName name++  , Cmd "focus" "Select from available channels" NoArg $ \ () ->+        beginChannelSelect++  , Cmd "help" "Show the main help screen" NoArg $ \ _ ->+        showHelpScreen mainHelpTopic++  , Cmd "shortcuts" "Show keyboard shortcuts" NoArg $ \ _ ->+        showHelpScreen mainHelpTopic++  , Cmd "help" "Show help about a particular topic"+      (TokenArg "topic" NoArg) $ \ (topicName, ()) ->+          case lookupHelpTopic topicName of+              Nothing -> mhError $ NoSuchHelpTopic topicName+              Just topic -> showHelpScreen topic++  , Cmd "sh" "List the available shell scripts" NoArg $ \ () ->+      listScripts++  , Cmd "group-msg" "Create a group chat"+    (LineArg (userSigil <> "user [" <> userSigil <> "user ...]")) createGroupChannel++  , Cmd "sh" "Run a prewritten shell script"+    (TokenArg "script" (LineArg "message")) $ \ (script, text) -> do+        cId <- use csCurrentChannelId+        findAndRunScript cId script text++  , Cmd "flags" "Open a window of your flagged posts" NoArg $ \ () ->+      enterFlaggedPostListMode++  , Cmd "pinned-posts" "Open a window of this channel's pinned posts" NoArg $ \ () ->+      enterPinnedPostListMode++  , Cmd "search" "Search for posts with given terms" (LineArg "terms") $+      enterSearchResultPostListMode++  , Cmd "notify-prefs" "Edit the current channel's notification preferences" NoArg $ \_ ->+          enterEditNotifyPrefsMode++  ]++displayUsernameAttribute :: Text -> MH ()+displayUsernameAttribute name = do+    let an = attrForUsername trimmed+        trimmed = trimUserSigil name+    postInfoMessage $ "The attribute used for " <> userSigil <> trimmed <>+                      " is " <> (attrNameToConfig an)++execMMCommand :: Text -> Text -> MH ()+execMMCommand name rest = do+  cId      <- use csCurrentChannelId+  session  <- getSession+  em       <- use (csEditState.cedEditMode)+  tId      <- gets myTeamId+  let mc = MM.MinCommand+             { MM.minComChannelId = cId+             , MM.minComCommand   = "/" <> name <> " " <> rest+             , MM.minComParentId  = case em of+                 Replying _ p -> Just $ MM.getId p+                 Editing p _  -> MM.postRootId p+                 _            -> Nothing+             , MM.minComRootId  = case em of+                 Replying _ p -> MM.postRootId p <|> (Just $ MM.postId p)+                 Editing p _  -> MM.postRootId p+                 _            -> Nothing+             , MM.minComTeamId = tId+             }+      runCmd = liftIO $ do+        void $ MM.mmExecuteCommand mc session+      handleHTTP (MM.HTTPResponseException err) =+        return (Just (T.pack err))+        -- XXX: this might be a bit brittle in the future, because it+        -- assumes the shape of an error message. We might want to+        -- think about a better way of discovering this error and+        -- reporting it accordingly?+      handleCmdErr (MM.MattermostServerError err) =+        let (_, msg) = T.breakOn ": " err in+          return (Just (T.drop 2 msg))+      handleMMErr (MM.MattermostError+                     { MM.mattermostErrorMessage = msg }) =+        return (Just msg)+  errMsg <- liftIO $ (runCmd >> return Nothing) `Exn.catch` handleHTTP+                                                `Exn.catch` handleCmdErr+                                                `Exn.catch` handleMMErr+  case errMsg of+    Nothing -> return ()+    Just err ->+      mhError $ GenericError ("Error running command: " <> err)++dispatchCommand :: Text -> MH ()+dispatchCommand cmd =+  case unwordHead cmd of+    Just (x, xs)+      | matchingCmds <- [ c+                        | c@(Cmd name _ _ _) <- commandList+                        , name == x+                        ] -> go [] matchingCmds+      where go [] [] = do+              execMMCommand x xs+            go errs [] = do+              let msg = ("error running command /" <> x <> ":\n" <>+                         mconcat [ "    " <> e | e <- errs ])+              mhError $ GenericError msg+            go errs (Cmd _ _ spec exe : cs) =+              case matchArgs spec xs of+                Left e -> go (e:errs) cs+                Right args -> exe args+    _ -> return ()++toggleMessagePreview :: MH ()+toggleMessagePreview = do+    mh invalidateCache+    csShowMessagePreview %= not
+ src/Matterhorn/Command.hs-boot view
@@ -0,0 +1,9 @@+module Matterhorn.Command where++import Data.Text ( Text )++import Matterhorn.Types ( MH, Cmd, CmdArgs )++commandList :: [Cmd]+printArgSpec :: CmdArgs a -> Text+dispatchCommand :: Text -> MH ()
+ src/Matterhorn/Config.hs view
@@ -0,0 +1,365 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.Config+  ( Config(..)+  , PasswordSource(..)+  , findConfig+  , defaultConfig+  , configConnectionType+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Class ( lift )+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+import           System.Directory ( makeAbsolute, getHomeDirectory )+import           System.Environment ( getExecutablePath )+import           System.FilePath ( (</>), takeDirectory, splitPath, joinPath )+import           System.Process ( readProcess )+import           Network.Mattermost.Types (ConnectionType(..))+import           Network.URI ( isIPv4address, isIPv6address )++import           Matterhorn.Config.Schema+import           Matterhorn.FilePaths+import           Matterhorn.IOUtil+import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+++defaultPort :: Int+defaultPort = 443++bundledSyntaxPlaceholderName :: String+bundledSyntaxPlaceholderName = "BUNDLED_SYNTAX"++userSyntaxPlaceholderName :: String+userSyntaxPlaceholderName = "USER_SYNTAX"++defaultSkylightingPaths :: IO [FilePath]+defaultSkylightingPaths = do+    xdg <- xdgSyntaxDir+    adjacent <- getBundledSyntaxPath+    return [xdg, adjacent]++getBundledSyntaxPath :: IO FilePath+getBundledSyntaxPath = do+    selfPath <- getExecutablePath+    let distDir = "dist-newstyle/"+        pathBits = splitPath selfPath++    return $ if distDir `elem` pathBits+             then+                 -- We're in development, so use the development+                 -- executable path to locate the XML path in the+                 -- development tree.+                 (joinPath $ takeWhile (/= distDir) pathBits) </> syntaxDirName+             else+                 -- In this case we assume the binary is being run from+                 -- a release, in which case the syntax directory is a+                 -- sibling of the executable path.+                 takeDirectory selfPath </> syntaxDirName++fromIni :: IniParser Config+fromIni = do+  conf <- section "mattermost" $ do+    configUser           <- fieldMbOf "user" stringField+    configHost           <- fieldMbOf "host" hostField+    configTeam           <- fieldMbOf "team" stringField+    configPort           <- fieldDefOf "port" number (configPort defaultConfig)+    configUrlPath        <- fieldMbOf "urlPath" stringField+    configChannelListWidth <- fieldDefOf "channelListWidth" number+                              (configChannelListWidth defaultConfig)+    configCpuUsagePolicy <- fieldDefOf "cpuUsagePolicy" cpuUsagePolicy+                            (configCpuUsagePolicy defaultConfig)+    configLogMaxBufferSize <- fieldDefOf "logMaxBufferSize" number+                              (configLogMaxBufferSize defaultConfig)+    configTimeFormat     <- fieldMbOf "timeFormat" stringField+    configDateFormat     <- fieldMbOf "dateFormat" stringField+    configTheme          <- fieldMbOf "theme" stringField+    configThemeCustomizationFile <- fieldMbOf "themeCustomizationFile" stringField+    configAspellDictionary <- fieldMbOf "aspellDictionary" stringField+    configURLOpenCommand <- fieldMbOf "urlOpenCommand" stringField+    configURLOpenCommandInteractive <- fieldFlagDef "urlOpenCommandIsInteractive" False+    configSmartBacktick  <- fieldFlagDef "smartbacktick"+      (configSmartBacktick defaultConfig)+    configSmartEditing <- fieldFlagDef "smartediting"+      (configSmartEditing defaultConfig)+    configShowOlderEdits <- fieldFlagDef "showOlderEdits"+      (configShowOlderEdits defaultConfig)+    configShowBackground <- fieldDefOf "showBackgroundActivity" backgroundField+      (configShowBackground defaultConfig)+    configShowMessagePreview <- fieldFlagDef "showMessagePreview"+      (configShowMessagePreview defaultConfig)+    configShowChannelList <- fieldFlagDef "showChannelList"+      (configShowChannelList defaultConfig)+    configShowExpandedChannelTopics <- fieldFlagDef "showExpandedChannelTopics"+      (configShowExpandedChannelTopics defaultConfig)+    configShowTypingIndicator <- fieldFlagDef "showTypingIndicator"+      (configShowTypingIndicator defaultConfig)+    configEnableAspell <- fieldFlagDef "enableAspell"+      (configEnableAspell defaultConfig)+    configSyntaxDirs <- fieldDefOf "syntaxDirectories" syntaxDirsField []+    configActivityNotifyCommand <- fieldMb "activityNotifyCommand"+    configShowMessageTimestamps <- fieldFlagDef "showMessageTimestamps"+      (configShowMessageTimestamps defaultConfig)+    configActivityBell <- fieldFlagDef "activityBell"+      (configActivityBell defaultConfig)+    configHyperlinkingMode <- fieldFlagDef "hyperlinkURLs"+      (configHyperlinkingMode defaultConfig)+    configPass <- (Just . PasswordCommand <$> field "passcmd") <!>+                  (Just . PasswordString  <$> field "pass") <!>+                  pure Nothing+    configChannelListOrientation <- fieldDefOf "channelListOrientation"+        channelListOrientationField+        (configChannelListOrientation defaultConfig)+    configToken <- (Just . TokenCommand  <$> field "tokencmd") <!>+                  pure Nothing+    configUnsafeUseHTTP <-+      fieldFlagDef "unsafeUseUnauthenticatedConnection" False+    configValidateServerCertificate <-+      fieldFlagDef "validateServerCertificate" True+    configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number+      (configDirectChannelExpirationDays defaultConfig)+    configDefaultAttachmentPath <- fieldMbOf "defaultAttachmentPath" filePathField++    let configAbsPath = Nothing+        configUserKeys = mempty+    return Config { .. }+  keys <- sectionMb "keybindings" $ do+      fmap (M.fromList . catMaybes) $ forM allEvents $ \ ev -> do+          kb <- fieldMbOf (keyEventName ev) parseBindingList+          case kb of+              Nothing      -> return Nothing+              Just binding -> return (Just (ev, binding))+  return conf { configUserKeys = fromMaybe mempty keys }++channelListOrientationField :: Text -> Either String ChannelListOrientation+channelListOrientationField t =+    case T.toLower t of+        "left" -> return ChannelListLeft+        "right" -> return ChannelListRight+        _ -> Left $ "Invalid value for channelListOrientation: " <> show t++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+        f part | part == "~/" = homeDir <> "/"+               | otherwise    = part+    in joinPath $ f <$> parts++backgroundField :: Text -> Either String BackgroundInfo+backgroundField t =+    case t of+        "Disabled" -> Right Disabled+        "Active" -> Right Active+        "ActiveCount" -> Right ActiveCount+        _ -> Left ("Invalid value " <> show t+                  <> "; must be one of: Disabled, Active, ActiveCount")++cpuUsagePolicy :: Text -> Either String CPUUsagePolicy+cpuUsagePolicy t =+    case T.toLower t of+        "single" -> return SingleCPU+        "multiple" -> return MultipleCPUs+        _ -> Left $ "Invalid CPU usage policy value: " <> show t++stringField :: Text -> Either e Text+stringField t =+    case isQuoted t of+        True -> Right $ parseQuotedString t+        False -> Right t++filePathField :: Text -> Either e FilePath+filePathField t = let path = T.unpack t in Right path++parseQuotedString :: Text -> Text+parseQuotedString t =+    let body = T.drop 1 $ T.init t+        unescapeQuotes s | T.null s = s+                         | "\\\"" `T.isPrefixOf` s = "\"" <> unescapeQuotes (T.drop 2 s)+                         | otherwise = (T.singleton $ T.head s) <> unescapeQuotes (T.drop 1 s)+    in unescapeQuotes body++isQuoted :: Text -> Bool+isQuoted t =+    let quote = "\""+    in (quote `T.isPrefixOf` t) &&+       (quote `T.isSuffixOf` t)++defaultConfig :: Config+defaultConfig =+    Config { configAbsPath                     = Nothing+           , configUser                        = Nothing+           , configHost                        = Nothing+           , configTeam                        = Nothing+           , configPort                        = defaultPort+           , configUrlPath                     = Nothing+           , configPass                        = Nothing+           , configToken                       = Nothing+           , configTimeFormat                  = Nothing+           , configDateFormat                  = Nothing+           , configTheme                       = Nothing+           , configThemeCustomizationFile      = Nothing+           , configSmartBacktick               = True+           , configSmartEditing                = True+           , configURLOpenCommand              = Nothing+           , configURLOpenCommandInteractive   = False+           , configActivityNotifyCommand       = Nothing+           , configActivityBell                = False+           , configShowMessageTimestamps       = True+           , configShowBackground              = Disabled+           , configShowMessagePreview          = False+           , configShowChannelList             = True+           , configShowExpandedChannelTopics   = True+           , configEnableAspell                = False+           , configAspellDictionary            = Nothing+           , configUnsafeUseHTTP               = False+           , configValidateServerCertificate   = True+           , configChannelListWidth            = 20+           , configLogMaxBufferSize            = 200+           , configShowOlderEdits              = True+           , configUserKeys                    = mempty+           , configShowTypingIndicator         = False+           , configHyperlinkingMode            = True+           , configSyntaxDirs                  = []+           , configDirectChannelExpirationDays = 7+           , configCpuUsagePolicy              = MultipleCPUs+           , configDefaultAttachmentPath       = Nothing+           , configChannelListOrientation      = ChannelListLeft+           }++findConfig :: Maybe FilePath -> IO (Either String ([String], Config))+findConfig Nothing = runExceptT $ do+    cfg <- lift $ locateConfig configFileName+    (warns, config) <-+      case cfg of+        Nothing -> return ([], defaultConfig)+        Just path -> getConfig path+    config' <- fixupPaths config+    return (warns, config')+findConfig (Just path) =+    runExceptT $ do (warns, config) <- getConfig path+                    config' <- fixupPaths config+                    return (warns, config')++-- | Fix path references in the configuration:+--+-- * Rewrite the syntax directory path list with 'fixupSyntaxDirs'+-- * Expand "~" encountered in any setting that contains a path value+fixupPaths :: Config -> ExceptT String IO Config+fixupPaths initial = do+    new <- fixupSyntaxDirs initial+    homeDir <- liftIO getHomeDirectory+    let fixP = expandTilde homeDir+        fixPText = T.pack . expandTilde homeDir . T.unpack+    return $ new { configThemeCustomizationFile = fixPText <$> configThemeCustomizationFile new+                 , configSyntaxDirs             = fixP <$> configSyntaxDirs new+                 , configURLOpenCommand         = fixPText <$> configURLOpenCommand new+                 , configActivityNotifyCommand  = fixPText <$> configActivityNotifyCommand new+                 , configDefaultAttachmentPath  = fixP <$> configDefaultAttachmentPath new+                 }++-- | If the configuration has no syntax directories specified (the+-- default if the user did not provide the setting), fill in the+-- list with the defaults. Otherwise replace any bundled directory+-- placeholders in the config's syntax path list.+fixupSyntaxDirs :: Config -> ExceptT String IO Config+fixupSyntaxDirs c =+    if configSyntaxDirs c == []+    then do+        dirs <- liftIO defaultSkylightingPaths+        return $ c { configSyntaxDirs = dirs }+    else do+        newDirs <- forM (configSyntaxDirs c) $ \dir ->+            if | dir == bundledSyntaxPlaceholderName -> liftIO getBundledSyntaxPath+               | dir == userSyntaxPlaceholderName    -> liftIO xdgSyntaxDir+               | otherwise                           -> return dir++        return $ c { configSyntaxDirs = newDirs }++getConfig :: FilePath -> ExceptT String IO ([String], Config)+getConfig fp = do+    absPath <- convertIOException $ makeAbsolute fp+    t <- (convertIOException $ T.readFile absPath) `catchE`+         (\e -> throwE $ "Could not read " <> show absPath <> ": " <> e)++    -- HACK ALERT FIXME:+    --+    -- The config parser library we use, config-ini (as of 0.2.4.0)+    -- cannot handle configuration files without trailing newlines.+    -- Since that's not a really good reason for this function to raise+    -- an exception (and is fixable on the fly), we have the following+    -- check. This check is admittedly not a great thing to have to do,+    -- and we should definitely get rid of it when config-ini fixes this+    -- issue.+    let t' = if "\n" `T.isSuffixOf` t then t else t <> "\n"++    case parseIniFile t' fromIni of+        Left err -> do+            throwE $ "Unable to parse " ++ absPath ++ ":" ++ fatalString err+        Right (warns, conf) -> do+            actualPass <- case configPass conf of+                Just (PasswordCommand cmdString) -> do+                    let (cmd:rest) = T.unpack <$> T.words cmdString+                    output <- convertIOException (readProcess cmd rest "") `catchE`+                              (\e -> throwE $ "Could not execute password command: " <> e)+                    return $ Just $ T.pack (takeWhile (/= '\n') output)+                Just (PasswordString pass) -> return $ Just pass+                Nothing -> return Nothing++            actualToken <- case configToken conf of+                Just (TokenCommand cmdString) -> do+                    let (cmd:rest) = T.unpack <$> T.words cmdString+                    output <- convertIOException (readProcess cmd rest "") `catchE`+                              (\e -> throwE $ "Could not execute token command: " <> e)+                    return $ Just $ T.pack (takeWhile (/= '\n') output)+                Just (TokenString _) -> error $ "BUG: getConfig: token in the Config was already a TokenString"+                Nothing -> return Nothing++            let conf' = conf+                  { configPass = PasswordString <$> actualPass+                  , configToken = TokenString <$> actualToken+                  , configAbsPath = Just absPath+                  }+            return (map warningString warns, conf')++configConnectionType :: Config -> ConnectionType+configConnectionType config+  | configUnsafeUseHTTP config = ConnectHTTP+  | otherwise = ConnectHTTPS (configValidateServerCertificate config)
+ src/Matterhorn/Config/Schema.hs view
@@ -0,0 +1,203 @@+{- |++This module provides an INI schema validator that is able to track unused+sections and fields in order to report warning messages to the user.+++ -}+module Matterhorn.Config.Schema+  ( IniParser+  , parseIniFile+  , (<!>)++  , Fatal(..)+  , fatalString++  , Warning(..)+  , warningString++  , section+  , sectionMb+  , fieldMbOf+  , fieldMb+  , field+  , fieldDefOf+  , fieldFlagDef++  -- * Re-exports+  , number+  , string+  , listWithSeparator+  ) where++import           Prelude ()+import           Matterhorn.Prelude++import           Data.Map (Map)+import qualified Data.Map as Map+import           Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Text as T+import           Control.Monad+import           Data.Ini.Config (flag, number, listWithSeparator, string)+import           Data.Ini.Config.Raw+++------------------------------------------------------------------------++newtype Parser e t a = Parser { unParser :: e -> Map NormalizedText (NonEmpty t) -> Either Fatal (Map NormalizedText (NonEmpty t), [Warning], a) }++instance Functor (Parser e t) where+  fmap = liftM++instance Applicative (Parser e t) where+  pure x = Parser $ \_ s -> Right (s, [], x)+  (<*>) = ap++instance Monad (Parser e t) where+  m >>= f = Parser $ \e s0 ->+              do (s1, ws1, x1) <- unParser m e s0+                 (s2, ws2, x2) <- unParser (f x1) e s1+                 Right (s2, ws1++ws2, x2)++++(<!>) :: Parser e t a -> Parser e t a -> Parser e t a+p <!> q = Parser $ \e s ->+  case unParser p e s of+    Right r -> Right r+    Left {} -> unParser q e s++getenv :: Parser e t e+getenv = Parser $ \e s -> Right (s, [], e)++request :: Text -> Parser e t (Maybe t)+request name = Parser $ \_ s ->+  let name' = normalize name in+  Right $!+  case Map.lookup name' s of+    Nothing                 -> (s , [], Nothing)+    Just (x NonEmpty.:| xs) -> (s', [], Just x)+      where+        s' = case NonEmpty.nonEmpty xs of+               Nothing -> Map.delete name' s+               Just ne -> Map.insert name' ne s++fatal :: Fatal -> Parser e t a+fatal e = Parser $ \_ _ -> Left e++warnings :: [Warning] -> IniParser ()+warnings ws = Parser $ \_ s -> Right (s, ws, ())++------------------------------------------------------------------------++type IniParser = Parser RawIni IniSection++type SectionParser = Parser IniSection IniValue++data Fatal+  = NoSection Text+  | MissingField IniSection Text+  | BadField IniSection IniValue String+  | ParseError String+  deriving Show++data Warning+  = UnusedSection IniSection+  | UnusedField IniSection IniValue+  deriving Show++------------------------------------------------------------------------++fatalString :: Fatal -> String+fatalString (NoSection name) = "No top-level section named " ++ show name+fatalString (MissingField sec name) = "Missing field " ++ show name ++ " in section " ++ show (isName sec)+fatalString (BadField sec val err) =+  "Line " ++ show (vLineNo val) +++  " in section " ++ show (isName sec) +++  ": " ++ err+fatalString (ParseError err) = err++warningString :: Warning -> String+warningString (UnusedSection sec) = "Unused section " ++ show (isName sec)+warningString (UnusedField sec val) =+  "Line " ++ show (vLineNo val) +++  " in section " ++ show (isName sec) +++  ": unused field"++------------------------------------------------------------------------++parseIniFile :: Text -> IniParser a -> Either Fatal ([Warning], a)+parseIniFile text parser =+  case parseRawIni text of+    Left e -> Left (ParseError e)+    Right ini ->+      let entries = Map.fromListWith (<>)+                       [ (k, pure v) | (k,v) <- toList (fromRawIni ini) ]+      in+      case unParser parser ini entries of+        Left e -> Left e+        Right (entries', ws, x) -> Right (ws ++ unused, x)+          where+            unused = [ UnusedSection e | e <- concatMap toList entries' ]++------------------------------------------------------------------------++section :: Text -> SectionParser a -> IniParser a+section name parser =+  do mb <- sectionMb name parser+     case mb of+       Nothing -> fatal (NoSection name)+       Just x  -> pure x++sectionMb :: Text -> SectionParser a -> IniParser (Maybe a)+sectionMb name parser =+  do mb <- request name+     case mb of+       Nothing -> pure Nothing+       Just sec ->+         let entries = Map.fromListWith (<>)+                       [ (k, pure v) | (k,v) <- toList (isVals sec) ]+         in+         case unParser parser sec entries of+           Left e -> fatal e+           Right (entries', ws, result) ->+             do warnings (ws ++ [ UnusedField sec v | v <- concatMap toList entries' ])+                pure (Just result)++------------------------------------------------------------------------++field :: Text -> SectionParser Text+field name =+  do mb <- fieldMb name+     case mb of+       Just x -> pure x+       Nothing ->+         do s <- getenv+            fatal (MissingField s name)++fieldMbOf :: Text -> (Text -> Either String a) -> SectionParser (Maybe a)+fieldMbOf name validate =+  do mb <- request name+     case mb of+       Nothing -> pure Nothing+       Just val ->+         case validate (getVal val) of+           Left e ->+             do sec <- getenv+                fatal (BadField sec val e)+           Right x -> pure (Just x)++fieldMb :: Text -> SectionParser (Maybe Text)+fieldMb name = fmap getVal <$> request name++fieldDefOf :: Text -> (Text -> Either String a) -> a -> SectionParser a+fieldDefOf name validate def = fromMaybe def <$> fieldMbOf name validate++fieldFlagDef :: Text -> Bool -> SectionParser Bool+fieldFlagDef name def = fieldDefOf name flag def++------------------------------------------------------------------------++getVal :: IniValue -> Text+getVal = T.strip . vValue
+ src/Matterhorn/Connection.hs view
@@ -0,0 +1,104 @@+module Matterhorn.Connection where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Concurrent ( forkIO, threadDelay, killThread )+import qualified Control.Concurrent.STM as STM+import           Control.Exception ( SomeException, catch, AsyncException(..), throwIO )+import qualified Data.HashMap.Strict as HM+import           Data.Int (Int64)+import           Data.Semigroup ( Max(..) )+import qualified Data.Text as T+import           Data.Time ( UTCTime(..), secondsToDiffTime, getCurrentTime+                           , diffUTCTime )+import           Data.Time.Calendar ( Day(..) )+import           Lens.Micro.Platform ( (.=) )++import           Network.Mattermost.Types ( ChannelId )+import qualified Network.Mattermost.WebSocket as WS++import           Matterhorn.Constants+import           Matterhorn.Types+++connectWebsockets :: MH ()+connectWebsockets = do+  logger <- mhGetIOLogger++  -- If we have an old websocket thread, kill it.+  mOldTid <- use (csResources.crWebsocketThreadId)+  case mOldTid of+      Nothing -> return ()+      Just oldTid -> liftIO $ do+          logger LogWebsocket "Terminating previous websocket thread"+          killThread oldTid++  st <- use id+  session <- getSession++  tid <- liftIO $ do+    let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg)+        shunt (Right (Right e)) = writeBChan (st^.csResources.crEventQueue) (WSEvent e)+        shunt (Right (Left e)) = writeBChan (st^.csResources.crEventQueue) (WSActionResponse e)+        runWS = WS.mmWithWebSocket session shunt $ \ws -> do+                  writeBChan (st^.csResources.crEventQueue) WebsocketConnect+                  processWebsocketActions st ws 1 HM.empty+    logger LogWebsocket "Starting new websocket thread"+    forkIO $ runWS `catch` ignoreThreadKilled+                   `catch` handleTimeout logger 1 st+                   `catch` handleError logger 5 st++  csResources.crWebsocketThreadId .= Just tid++ignoreThreadKilled :: AsyncException -> IO ()+ignoreThreadKilled ThreadKilled = return ()+ignoreThreadKilled e = throwIO e++-- | Take websocket actions from the websocket action channel in the+-- ChatState and send them to the server over the websocket.+--+-- Takes and propagates the action sequence number which is incremented+-- for each successful send.+--+-- Keeps and propagates a map of channel id to last user_typing+-- notification send time so that the new user_typing actions are+-- throttled to be send only once in two seconds.+processWebsocketActions :: ChatState -> WS.MMWebSocket -> Int64 -> HashMap ChannelId (Max UTCTime) -> IO ()+processWebsocketActions st ws s userTypingLastNotifTimeMap = do+  action <- STM.atomically $ STM.readTChan (st^.csResources.crWebsocketActionChan)+  if (shouldSendAction action)+    then do+      WS.mmSendWSAction (st^.csResources.crConn) ws $ convert action+      now <- getCurrentTime+      processWebsocketActions st ws (s + 1) $ userTypingLastNotifTimeMap' action now+    else do+      processWebsocketActions st ws s userTypingLastNotifTimeMap+  where+    convert (UserTyping _ cId pId) = WS.UserTyping s cId pId++    shouldSendAction (UserTyping ts cId _) =+      diffUTCTime ts (userTypingLastNotifTime cId) >= (userTypingExpiryInterval / 2 - 0.5)++    userTypingLastNotifTime cId = getMax $ HM.lookupDefault (Max zeroTime) cId userTypingLastNotifTimeMap++    zeroTime = UTCTime (ModifiedJulianDay 0) (secondsToDiffTime 0)++    userTypingLastNotifTimeMap' (UserTyping _ cId _) now =+      HM.insertWith (<>) cId (Max now) userTypingLastNotifTimeMap++handleTimeout :: (LogCategory -> Text -> IO ()) -> Int -> ChatState -> WS.MMWebSocketTimeoutException -> IO ()+handleTimeout logger seconds st e = do+    logger LogWebsocket $ T.pack $ "Websocket timeout exception: " <> show e+    reconnectAfter seconds st++handleError :: (LogCategory -> Text -> IO ()) -> Int -> ChatState -> SomeException -> IO ()+handleError logger seconds st e = do+    logger LogWebsocket $ T.pack $ "Websocket error: " <> show e+    reconnectAfter seconds st++reconnectAfter :: Int -> ChatState -> IO ()+reconnectAfter seconds st = do+  writeBChan (st^.csResources.crEventQueue) WebsocketDisconnect+  threadDelay (seconds * 1000 * 1000)+  writeBChan (st^.csResources.crEventQueue) RefreshWebsocketEvent
+ src/Matterhorn/Constants.hs view
@@ -0,0 +1,35 @@+module Matterhorn.Constants+  ( pageAmount+  , userTypingExpiryInterval+  , numScrollbackPosts+  , previewMaxHeight+  , normalChannelSigil+  , userSigil+  )+where++import Prelude ()+import Matterhorn.Prelude+++-- | The number of rows to consider a "page" when scrolling+pageAmount :: Int+pageAmount = 15++-- | The expiry interval in seconds for user typing notifications.+userTypingExpiryInterval :: NominalDiffTime+userTypingExpiryInterval = 5++numScrollbackPosts :: Int+numScrollbackPosts = 100++-- | The maximum height of the message preview, in lines.+previewMaxHeight :: Int+previewMaxHeight = 5++-- Sigils+normalChannelSigil :: Text+normalChannelSigil = "~"++userSigil :: Text+userSigil = "@"
+ src/Matterhorn/Draw.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE PackageImports #-}+module Matterhorn.Draw (draw) where++import Prelude ()+import Matterhorn.Prelude++import Brick++import Lens.Micro.Platform ( _2, singular, _Just )++import Matterhorn.Draw.ChannelTopicWindow+import Matterhorn.Draw.DeleteChannelConfirm+import Matterhorn.Draw.LeaveChannelConfirm+import Matterhorn.Draw.Main+import Matterhorn.Draw.ThemeListOverlay+import Matterhorn.Draw.PostListOverlay+import Matterhorn.Draw.ShowHelp+import Matterhorn.Draw.UserListOverlay+import Matterhorn.Draw.ChannelListOverlay+import Matterhorn.Draw.ReactionEmojiListOverlay+import Matterhorn.Draw.TabbedWindow+import Matterhorn.Draw.ManageAttachments+import Matterhorn.Draw.NotifyPrefs+import Matterhorn.Types+++draw :: ChatState -> [Widget Name]+draw st =+    case appMode st of+        Main                         -> mainLayers+        UrlSelect                    -> mainLayers+        ChannelSelect                -> mainLayers+        MessageSelect                -> mainLayers+        MessageSelectDeleteConfirm   -> mainLayers+        ShowHelp topic _             -> drawShowHelp topic st+        ThemeListOverlay             -> drawThemeListOverlay st : mainLayers+        LeaveChannelConfirm          -> drawLeaveChannelConfirm st : mainLayersMonochrome+        DeleteChannelConfirm         -> drawDeleteChannelConfirm st : mainLayersMonochrome+        PostListOverlay contents     -> drawPostListOverlay contents st : mainLayersMonochrome+        UserListOverlay              -> drawUserListOverlay st : mainLayersMonochrome+        ChannelListOverlay           -> drawChannelListOverlay st : mainLayersMonochrome+        ReactionEmojiListOverlay     -> drawReactionEmojiListOverlay st : mainLayersMonochrome+        ViewMessage                  -> drawTabbedWindow messageViewWindow st : mainLayersMonochrome+        ManageAttachments            -> drawManageAttachments st : mainLayersMonochrome+        ManageAttachmentsBrowseFiles -> drawManageAttachments st : mainLayersMonochrome+        EditNotifyPrefs              -> drawNotifyPrefs st : mainLayersMonochrome+        ChannelTopicWindow           -> drawChannelTopicWindow st : mainLayersMonochrome+    where+        mainLayers = drawMain True st+        mainLayersMonochrome = drawMain False st+        messageViewWindow = st^.csViewedMessage.singular _Just._2
+ src/Matterhorn/Draw/Autocomplete.hs view
@@ -0,0 +1,205 @@+module Matterhorn.Draw.Autocomplete+  ( autocompleteLayer+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.List ( renderList, listElementsL, listSelectedFocusedAttr+                                    , listSelectedElement+                                    )+import qualified Data.Text as T++import           Network.Mattermost.Types ( User(..), Channel(..) )++import           Matterhorn.Constants ( normalChannelSigil )+import           Matterhorn.Draw.Util+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Types.Common ( sanitizeUserText )+++autocompleteLayer :: ChatState -> Widget Name+autocompleteLayer st =+    case st^.csEditState.cedAutocomplete of+        Nothing ->+            emptyWidget+        Just ac ->+            renderAutocompleteBox st ac++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+        maxListHeight = 5+        visibleHeight = min maxListHeight numResults+        numResults = length elements+        elements = matchList^.listElementsL+        label = withDefAttr clientMessageAttr $+                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+        footer = case renderAutocompleteFooterFor curChan =<< selElem of+            Just w -> hBorderWithLabel w+            _ -> hBorder+        curUser = myUsername st++    in if numResults == 0+       then emptyWidget+       else Widget Greedy Greedy $ do+           ctx <- getContext+           let rowOffset = ctx^.availHeightL - 3 - editorOffset - visibleHeight+               editorOffset = if st^.csEditState.cedEphemeral.eesMultiline+                              then multilineHeightLimit+                              else 0+           render $ translateBy (Location (0, rowOffset)) $+                    vBox [ hBorderWithLabel label+                         , vLimit visibleHeight $+                           renderList (renderAutocompleteAlternative curUser) True matchList+                         , footer+                         ]++renderAutocompleteFooterFor :: ClientChannel -> AutocompleteAlternative -> Maybe (Widget Name)+renderAutocompleteFooterFor _ (SpecialMention MentionChannel) = Nothing+renderAutocompleteFooterFor _ (SpecialMention MentionAll) = Nothing+renderAutocompleteFooterFor ch (UserCompletion _ False) =+    Just $ hBox [ txt $ "("+                , withDefAttr clientEmphAttr (txt userNotInChannelMarker)+                , txt ": not a member of "+                , withDefAttr channelNameAttr (txt $ normalChannelSigil <> ch^.ccInfo.cdName)+                , txt ")"+                ]+renderAutocompleteFooterFor _ (ChannelCompletion False ch) =+    Just $ hBox [ txt $ "("+                , withDefAttr clientEmphAttr (txt userNotInChannelMarker)+                , txt ": you are not a member of "+                , withDefAttr channelNameAttr (txt $ normalChannelSigil <> sanitizeUserText (channelName ch))+                , txt ")"+                ]+renderAutocompleteFooterFor _ (CommandCompletion src _ _ _) =+    case src of+        Server ->+            Just $ hBox [ txt $ "("+                        , withDefAttr clientEmphAttr (txt serverCommandMarker)+                        , txt ": command provided by the server)"+                        ]+        Client -> Nothing+renderAutocompleteFooterFor _ _ =+    Nothing++serverCommandMarker :: Text+serverCommandMarker = "*"++renderAutocompleteAlternative :: Text -> Bool -> AutocompleteAlternative -> Widget Name+renderAutocompleteAlternative _ sel (EmojiCompletion e) =+    padRight Max $ renderEmojiCompletion sel e+renderAutocompleteAlternative _ sel (SpecialMention m) =+    padRight Max $ renderSpecialMention m sel+renderAutocompleteAlternative curUser sel (UserCompletion u inChan) =+    padRight Max $ renderUserCompletion curUser u inChan sel+renderAutocompleteAlternative _ sel (ChannelCompletion inChan c) =+    padRight Max $ renderChannelCompletion c inChan sel+renderAutocompleteAlternative _ _ (SyntaxCompletion t) =+    padRight Max $ txt t+renderAutocompleteAlternative _ _ (CommandCompletion src n args desc) =+    padRight Max $ renderCommandCompletion src n args desc++renderSpecialMention :: SpecialMention -> Bool -> Widget Name+renderSpecialMention m sel =+    let usernameWidth = 18+        padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ')+        maybeForce = if sel+                     then forceAttr listSelectedFocusedAttr+                     else id+        t = autocompleteAlternativeReplacement $ SpecialMention m+        desc = case m of+            MentionChannel -> "Notifies all users in this channel"+            MentionAll     -> "Mentions all users in this channel"+    in maybeForce $+       hBox [ txt "  "+            , padTo usernameWidth $ withDefAttr clientEmphAttr $ txt t+            , txt desc+            ]++renderEmojiCompletion :: Bool -> T.Text -> Widget Name+renderEmojiCompletion sel e =+    let maybeForce = if sel+                     then forceAttr listSelectedFocusedAttr+                     else id+    in maybeForce $+       padLeft (Pad 2) $+       withDefAttr emojiAttr $+       txt $+       autocompleteAlternativeReplacement $ EmojiCompletion e++renderUserCompletion :: Text -> User -> Bool -> Bool -> Widget Name+renderUserCompletion curUser u inChan selected =+    let usernameWidth = 18+        fullNameWidth = 25+        padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ')+        username = userUsername u+        fullName = (sanitizeUserText $ userFirstName u) <> " " <>+                   (sanitizeUserText $ userLastName u)+        nickname = sanitizeUserText $ userNickname u+        maybeForce = if selected+                     then forceAttr listSelectedFocusedAttr+                     else id+        memberDisplay = if inChan+                        then txt "  "+                        else withDefAttr clientEmphAttr $+                             txt $ userNotInChannelMarker <> " "+    in maybeForce $+       hBox [ memberDisplay+            , padTo usernameWidth $ colorUsername curUser username ("@" <> username)+            , padTo fullNameWidth $ txt fullName+            , txt nickname+            ]++renderChannelCompletion :: Channel -> Bool -> Bool -> Widget Name+renderChannelCompletion c inChan selected =+    let urlNameWidth = 30+        displayNameWidth = 30+        padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ')+        maybeForce = if selected+                     then forceAttr listSelectedFocusedAttr+                     else id+        memberDisplay = if inChan+                        then txt "  "+                        else withDefAttr clientEmphAttr $+                             txt $ userNotInChannelMarker <> " "+    in maybeForce $+       hBox [ memberDisplay+            , padTo urlNameWidth $+              withDefAttr channelNameAttr $+              txt $ normalChannelSigil <> (sanitizeUserText $ channelName c)+            , padTo displayNameWidth $+              withDefAttr channelNameAttr $+              txt $ sanitizeUserText $ channelDisplayName c+            , txt $ sanitizeUserText $ channelPurpose c+            ]++renderCommandCompletion :: CompletionSource -> Text -> Text -> Text -> Widget Name+renderCommandCompletion src name args desc =+    (txt $ " " <> srcTxt <> " ") <+>+    withDefAttr clientMessageAttr+        (txt $ "/" <> name <> if T.null args then "" else " " <> args) <+>+    (txt $ " - " <> desc)+    where+        srcTxt = case src of+            Server -> serverCommandMarker+            Client -> " "
+ src/Matterhorn/Draw/Buttons.hs view
@@ -0,0 +1,29 @@+module Matterhorn.Draw.Buttons+  ( drawButton+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Focus+import           Brick.Widgets.Center++import qualified Data.Text as T++import           Matterhorn.Themes+++buttonWidth :: Int+buttonWidth = 10++drawButton :: (Eq n) => FocusRing n -> n -> T.Text -> Widget n+drawButton f n label =+    let attr = if focusGetCurrent f == Just n+               then buttonFocusedAttr+               else buttonAttr+    in withDefAttr attr $+       hLimit buttonWidth $+       hCenter $+       txt label
+ src/Matterhorn/Draw/ChannelList.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}++-- | This module provides the Drawing functionality for the+-- ChannelList sidebar.  The sidebar is divided vertically into groups+-- and each group is rendered separately.+--+-- There are actually two UI modes handled by this code:+--+--   * Normal display of the channels, with various markers to+--     indicate the current channel, channels with unread messages,+--     user state (for Direct Message channels), etc.+--+--   * ChannelSelect display where the user is typing match characters+--     into a prompt at the ChannelList sidebar is showing only those+--     channels matching the entered text (and highlighting the+--     matching portion).++module Matterhorn.Draw.ChannelList (renderChannelList, renderChannelListHeader) where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Center (hCenter)+import qualified Data.Text as T+import           Lens.Micro.Platform (non)++import qualified Network.Mattermost.Types as MM++import           Matterhorn.Constants ( userSigil )+import           Matterhorn.Draw.Util+import           Matterhorn.State.Channels+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Types.Common ( sanitizeUserText )+import qualified Matterhorn.Zipper as Z++-- | Internal record describing each channel entry and its associated+-- attributes.  This is the object passed to the rendering function so+-- that it can determine how to render each channel.+data ChannelListEntryData =+    ChannelListEntryData { entrySigil       :: Text+                         , entryLabel       :: Text+                         , entryHasUnread   :: Bool+                         , entryMentions    :: Int+                         , entryIsRecent    :: Bool+                         , entryIsReturn    :: Bool+                         , entryIsCurrent   :: Bool+                         , entryIsMuted     :: Bool+                         , entryUserStatus  :: Maybe UserStatus+                         }++renderChannelListHeader :: ChatState -> Widget Name+renderChannelListHeader st =+    vBox [ teamHeader+         , selfHeader+         , unreadCountHeader+         ]+    where+        myUsername_ = myUsername st+        teamHeader = hCenter $+                     withDefAttr clientEmphAttr $+                     txt $ "Team: " <> teamNameStr+        selfHeader = hCenter $+                     colorUsername myUsername_ myUsername_+                         (T.singleton statusSigil <> " " <> userSigil <> myUsername_)+        teamNameStr = sanitizeUserText $ MM.teamDisplayName $ st^.csMyTeam+        statusSigil = maybe ' ' userSigilFromInfo me+        me = userById (myUserId st) st+        unreadCountHeader = hCenter $ txt $ "Unread: " <> (T.pack $ show unreadCount)+        unreadCount = sum $ (channelListGroupUnread . fst) <$> Z.toList (st^.csFocus)++renderChannelList :: ChatState -> Widget Name+renderChannelList st =+    viewport ChannelList Vertical body+    where+        myUsername_ = myUsername st+        renderEntry s e = renderChannelListEntry myUsername_ $ mkChannelEntryData s e+        body = case appMode st of+            ChannelSelect ->+                let zipper = st^.csChannelSelectState.channelSelectMatches+                    matches = if Z.isEmpty zipper+                              then [hCenter $ txt "No matches"]+                              else (renderChannelListGroup st+                                       (renderChannelSelectListEntry (Z.focus zipper)) <$>+                                   Z.toList zipper)+                in vBox $+                   renderChannelListHeader st :+                   matches+            _ ->+                cached ChannelSidebar $+                vBox $+                renderChannelListHeader st :+                (renderChannelListGroup st renderEntry <$> Z.toList (st^.csFocus))++renderChannelListGroupHeading :: ChannelListGroup -> Widget Name+renderChannelListGroupHeading g =+    let (unread, label) = case g of+            ChannelGroupPublicChannels u -> (u, "Public Channels")+            ChannelGroupPrivateChannels u -> (u, "Private Channels")+            ChannelGroupDirectMessages u -> (u, "Direct Messages")+        addUnread = if unread > 0+                    then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*"))+                    else id+        labelWidget = addUnread $ withDefAttr channelListHeaderAttr $ txt label+    in hBorderWithLabel labelWidget++renderChannelListGroup :: ChatState+                       -> (ChatState -> e -> Widget Name)+                       -> (ChannelListGroup, [e])+                       -> Widget Name+renderChannelListGroup st renderEntry (group, es) =+    let heading = renderChannelListGroupHeading group+        entryWidgets = renderEntry st <$> es+    in if null entryWidgets+       then emptyWidget+       else vBox (heading : entryWidgets)++mkChannelEntryData :: ChatState+                   -> ChannelListEntry+                   -> ChannelListEntryData+mkChannelEntryData st e =+    ChannelListEntryData { entrySigil       = sigilWithSpace+                         , entryLabel       = name+                         , entryHasUnread   = unread+                         , entryMentions    = mentions+                         , entryIsRecent    = recent+                         , entryIsReturn    = ret+                         , entryIsCurrent   = current+                         , entryIsMuted     = muted+                         , entryUserStatus  = status+                         }+    where+        cId = channelListEntryChannelId e+        Just chan = findChannelById cId (st^.csChannels)+        unread = hasUnread' chan+        recent = isRecentChannel st cId+        ret = isReturnChannel st cId+        current = isCurrentChannel st cId+        muted = isMuted chan+        (name, normalSigil, addSpace, status) = case e of+            CLChannel _ ->+                (chan^.ccInfo.cdDisplayName, Nothing, False, Nothing)+            CLGroupDM _ ->+                (chan^.ccInfo.cdDisplayName, Just " ", True, Nothing)+            CLUserDM _ uId ->+                let Just u = userById uId st+                    uname = if useNickname st+                            then u^.uiNickName.non (u^.uiName)+                            else u^.uiName+                in (uname, Just $ T.singleton $ userSigilFromInfo u,+                    True, Just $ u^.uiStatus)+        sigilWithSpace = sigil <> if addSpace then " " else ""+        prevEditSigil = "»"+        sigil = if current+                then fromMaybe "" normalSigil+                else case chan^.ccEditState.eesInputHistoryPosition of+                    Just _ -> prevEditSigil+                    Nothing ->+                        case chan^.ccEditState.eesLastInput of+                            ("", _) -> fromMaybe "" normalSigil+                            _       -> prevEditSigil+        mentions = chan^.ccInfo.cdMentionCount++-- | Render an individual Channel List entry (in Normal mode) with+-- appropriate visual decorations.+renderChannelListEntry :: Text -> ChannelListEntryData -> Widget Name+renderChannelListEntry myUName entry = body+    where+    body = decorate $ decorateEntry entry $ decorateMentions entry $ padRight Max $+           entryWidget $ entrySigil entry <> entryLabel entry+    decorate = if | entryIsCurrent entry ->+                      visible . forceAttr currentChannelNameAttr+                  | entryMentions entry > 0 && not (entryIsMuted entry) ->+                      forceAttr mentionsChannelAttr+                  | entryHasUnread entry ->+                      forceAttr unreadChannelAttr+                  | otherwise -> id+    entryWidget = case entryUserStatus entry of+                    Just Offline -> withDefAttr clientMessageAttr . txt+                    Just _       -> colorUsername myUName (entryLabel entry)+                    Nothing      -> txt++-- | Render an individual entry when in Channel Select mode,+-- highlighting the matching portion, or completely suppressing the+-- entry if it doesn't match.+renderChannelSelectListEntry :: Maybe ChannelSelectMatch+                             -> ChatState+                             -> ChannelSelectMatch+                             -> Widget Name+renderChannelSelectListEntry curMatch st match =+    let ChannelSelectMatch preMatch inMatch postMatch _ entry = match+        maybeSelect = if (Just entry) == (matchEntry <$> curMatch)+                      then visible . withDefAttr currentChannelNameAttr+                      else id+        entryData = mkChannelEntryData st entry+        decorate = if | entryMentions entryData > 0 && not (entryIsMuted entryData) ->+                          withDefAttr mentionsChannelAttr+                      | entryHasUnread entryData ->+                          withDefAttr unreadChannelAttr+                      | otherwise -> id+    in decorate $ maybeSelect $+       decorateEntry entryData $ decorateMentions entryData $+       padRight Max $+         hBox [ txt $ entrySigil entryData <> preMatch+              , forceAttr channelSelectMatchAttr $ txt inMatch+              , txt postMatch+              ]++-- If this channel is the return channel, add a decoration to denote+-- that.+--+-- Otherwise, if this channel is the most recently viewed channel (prior+-- to the currently viewed channel), add a decoration to denote that.+decorateEntry :: ChannelListEntryData -> Widget n -> Widget n+decorateEntry entry =+    if entryIsReturn entry+    then (<+> (withDefAttr recentMarkerAttr $ str returnChannelSigil))+    else if entryIsRecent entry+         then (<+> (withDefAttr recentMarkerAttr $ str recentChannelSigil))+         else id++decorateMentions :: ChannelListEntryData -> Widget n -> Widget n+decorateMentions entry+  | entryMentions entry > 9 =+      (<+> str "(9+)")+  | entryMentions entry > 0 =+      (<+> str ("(" <> show (entryMentions entry) <> ")"))+  | entryIsMuted entry =+      (<+> str "(m)")+  | otherwise = id++recentChannelSigil :: String+recentChannelSigil = "<"++returnChannelSigil :: String+returnChannelSigil = "~"
+ src/Matterhorn/Draw/ChannelListOverlay.hs view
@@ -0,0 +1,53 @@+module Matterhorn.Draw.ChannelListOverlay+  ( drawChannelListOverlay+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import qualified Data.Text as T+import           Text.Wrap ( defaultWrapSettings, preserveIndentation )++import           Network.Mattermost.Types+import           Network.Mattermost.Lenses++import           Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )+import           Matterhorn.Types+import           Matterhorn.Types.Common ( sanitizeUserText )+import           Matterhorn.Themes+++drawChannelListOverlay :: ChatState -> Widget Name+drawChannelListOverlay st =+    let overlay = drawListOverlay (st^.csChannelListOverlay) channelSearchScopeHeader+                                  channelSearchScopeNoResults channelSearchScopePrompt+                                  renderChannel+                                  Nothing+                                  OverlayCenter+                                  80+    in joinBorders overlay++channelSearchScopePrompt :: ChannelSearchScope -> Widget Name+channelSearchScopePrompt scope =+    txt $ case scope of+        AllChannels -> "Search channels:"++channelSearchScopeNoResults :: ChannelSearchScope -> Widget Name+channelSearchScopeNoResults scope =+    txt $ case scope of+        AllChannels -> "No matching channels found."++channelSearchScopeHeader :: ChannelSearchScope -> Widget Name+channelSearchScopeHeader scope =+    withDefAttr clientEmphAttr $ txt $ case scope of+        AllChannels -> "Join a Channel"++renderChannel :: Bool -> Channel -> Widget Name+renderChannel _ chan =+    let baseStr = (sanitizeUserText $ chan^.channelNameL) <> " (" <>+                  (sanitizeUserText $ chan^.channelDisplayNameL) <> ")"+        s = "  " <> (T.strip $ sanitizeUserText $ chan^.channelPurposeL)+    in (vLimit 1 $ padRight Max $ withDefAttr clientEmphAttr $ txt baseStr) <=>+       (vLimit 1 $ txtWrapWith (defaultWrapSettings { preserveIndentation = True }) s)
+ src/Matterhorn/Draw/ChannelTopicWindow.hs view
@@ -0,0 +1,56 @@+module Matterhorn.Draw.ChannelTopicWindow+  ( drawChannelTopicWindow+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Focus+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import           Brick.Widgets.Edit++import           Control.Arrow ( (>>>) )+import qualified Data.Text as T+import           Data.Text.Zipper ( insertChar, gotoEOL )++import           Matterhorn.Types+import           Matterhorn.Draw.Buttons+import           Matterhorn.Draw.RichText+import           Matterhorn.Themes+++drawChannelTopicWindow :: ChatState -> Widget Name+drawChannelTopicWindow st =+    centerLayer $+    hLimit maxWindowWidth $+    joinBorders $+    borderWithLabel (withDefAttr clientEmphAttr $ txt "Edit Channel Topic") $+    vBox [ vLimit editorHeight $+           withFocusRing foc (renderEditor drawTopicEditorTxt) ed+         , hBorderWithLabel (withDefAttr clientEmphAttr $ txt "Preview")+         , vLimit previewHeight $+           viewport ChannelTopicEditorPreview Vertical $+           renderText' (Just baseUrl) "" hSet topicTxtWithCursor+         , hBorder+         , hBox [ padRight Max $+                  padLeft (Pad 1) $+                  drawButton foc ChannelTopicSaveButton "Save"+                , padRight (Pad 1) $+                  drawButton foc ChannelTopicCancelButton "Cancel"+                ]+         ]+    where+        baseUrl = serverBaseUrl st+        editorHeight = 5+        previewHeight = 5+        maxWindowWidth = 70+        foc = st^.csChannelTopicDialog.channelTopicDialogFocus+        ed = st^.csChannelTopicDialog.channelTopicDialogEditor+        hSet = getHighlightSet st+        topicTxtWithCursor = T.unlines $+                             getEditContents $+                             applyEdit (gotoEOL >>> insertChar cursorSentinel) ed+        drawTopicEditorTxt = txt . T.unlines
+ src/Matterhorn/Draw/DeleteChannelConfirm.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.Draw.DeleteChannelConfirm+    ( drawDeleteChannelConfirm+    )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center++import Matterhorn.Themes+import Matterhorn.Types+++drawDeleteChannelConfirm :: ChatState -> Widget Name+drawDeleteChannelConfirm st =+    let cName = st^.csCurrentChannel.ccInfo.cdName+    in centerLayer $ hLimit 50 $ vLimit 15 $+       withDefAttr dialogAttr $+       borderWithLabel (txt "Confirm Delete Channel") $+       vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to delete this channel?"+            , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName+            , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to delete the channel"+            , hCenter $ txt "or any other key to cancel."+            ]
+ src/Matterhorn/Draw/LeaveChannelConfirm.hs view
@@ -0,0 +1,28 @@+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.Draw.LeaveChannelConfirm+    ( drawLeaveChannelConfirm+    )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center++import Matterhorn.Themes+import Matterhorn.Types+++drawLeaveChannelConfirm :: ChatState -> Widget Name+drawLeaveChannelConfirm st =+    let cName = st^.csCurrentChannel.ccInfo.cdName+    in centerLayer $ hLimit 50 $ vLimit 15 $+       withDefAttr dialogAttr $+       borderWithLabel (txt "Confirm Leave Channel") $+       vBox [ padBottom (Pad 1) $ hCenter $ txt "Are you sure you want to leave this channel?"+            , padBottom (Pad 1) $ hCenter $ withDefAttr dialogEmphAttr $ txt cName+            , hCenter $ txt "Press " <+> (withDefAttr dialogEmphAttr $ txt "Y") <+> txt " to leave the channel"+            , hCenter $ txt "or any other key to cancel."+            ]
+ src/Matterhorn/Draw/ListOverlay.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Matterhorn.Draw.ListOverlay+  ( drawListOverlay+  , OverlayPosition(..)+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import           Brick.Widgets.Edit+import qualified Brick.Widgets.List as L+import           Control.Monad.Trans.Reader ( withReaderT )+import qualified Data.Foldable as F+import qualified Data.Text as T+import           Graphics.Vty ( imageWidth, translateX)+import           Lens.Micro.Platform ( (%~), (.~), to )++import           Matterhorn.Themes+import           Matterhorn.Types+++hLimitWithPadding :: Int -> Widget n -> Widget n+hLimitWithPadding pad contents = Widget+  { hSize  = Fixed+  , vSize  = (vSize contents)+  , render =+      withReaderT (& availWidthL  %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents+  }++data OverlayPosition =+    OverlayCenter+    | OverlayUpperRight+    deriving (Eq, Show)++-- | Draw a ListOverlayState. This draws a bordered box with the+-- overlay's search input and results list inside the box. The provided+-- functions determine how to render the overlay in various states.+drawListOverlay :: ListOverlayState a b+                -- ^ The overlay state+                -> (b -> Widget Name)+                -- ^ The function to build the window title from the+                -- current search scope+                -> (b -> Widget Name)+                -- ^ The function to generate a message for the search+                -- scope indicating that no results were found+                -> (b -> Widget Name)+                -- ^ The function to generate the editor prompt for the+                -- search scope+                -> (Bool -> a -> Widget Name)+                -- ^ The function to render an item from the overlay's+                -- list+                -> Maybe (Widget Name)+                -- ^ The footer widget to render underneath the search+                -- results+                -> OverlayPosition+                -- ^ How to position the overlay layer+                -> Int+                -- ^ The maximum window width in columns+                -> Widget Name+drawListOverlay st scopeHeader scopeNoResults scopePrompt renderItem footer layerPos maxWinWidth =+  positionLayer $ hLimitWithPadding 10 $ vLimit 25 $+  hLimit maxWinWidth $+  borderWithLabel title body+  where+      title = withDefAttr clientEmphAttr $+              hBox [ scopeHeader scope+                   , case st^.listOverlayRecordCount of+                         Nothing -> emptyWidget+                         Just c -> txt " (" <+> str (show c) <+> txt ")"+                   ]+      positionLayer = case layerPos of+          OverlayCenter -> centerLayer+          OverlayUpperRight -> upperRightLayer+      body = vBox [ (padRight (Pad 1) promptMsg) <+>+                    renderEditor (txt . T.unlines) True (st^.listOverlaySearchInput)+                  , cursorPositionBorder+                  , showResults+                  , fromMaybe emptyWidget footer+                  ]+      plural 1 = ""+      plural _ = "s"+      cursorPositionBorder =+          if st^.listOverlaySearching+          then hBorderWithLabel $ txt "[Searching...]"+          else case st^.listOverlaySearchResults.L.listSelectedL of+              Nothing -> hBorder+              Just _ ->+                  let showingFirst = "Showing first " <> show numSearchResults <>+                                     " result" <> plural numSearchResults+                      showingAll = "Showing all " <> show numSearchResults <>+                                   " result" <> plural numSearchResults+                      showing = "Showing " <> show numSearchResults <>+                                " result" <> plural numSearchResults+                      msg = case getEditContents (st^.listOverlaySearchInput) of+                          [""] ->+                              case st^.listOverlayRecordCount of+                                  Nothing -> showing+                                  Just total -> if numSearchResults < total+                                                then showingFirst+                                                else showingAll+                          _ -> showing+                  in hBorderWithLabel $ str $ "[" <> msg <> "]"++      scope = st^.listOverlaySearchScope+      promptMsg = scopePrompt scope++      showMessage = center . withDefAttr clientEmphAttr++      showResults+        | numSearchResults == 0 = showMessage $ scopeNoResults scope+        | otherwise = renderedUserList++      renderedUserList = L.renderList renderItem True (st^.listOverlaySearchResults)+      numSearchResults = F.length $ st^.listOverlaySearchResults.L.listElementsL++upperRightLayer :: Widget a -> Widget a+upperRightLayer w =+    Widget (hSize w) (vSize w) $ do+        result <- render w+        c <- getContext+        let rWidth = result^.imageL.to imageWidth+            leftPaddingAmount = max 0 $ c^.availWidthL - rWidth+            paddedImage = translateX leftPaddingAmount $ result^.imageL+            off = Location (leftPaddingAmount, 0)+        if leftPaddingAmount == 0 then+            return result else+            return $ addResultOffset off+                   $ result & imageL .~ paddedImage
+ src/Matterhorn/Draw/Main.hs view
@@ -0,0 +1,721 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.Draw.Main (drawMain) where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Border.Style+import           Brick.Widgets.Center ( hCenter )+import           Brick.Widgets.List ( listElements )+import           Brick.Widgets.Edit ( editContentsL, renderEditor, getEditContents )+import           Control.Arrow ( (>>>) )+import           Data.Char ( isSpace, isPunctuation )+import           Data.List ( intersperse )+import qualified Data.Map as M+import qualified Data.Sequence as Seq+import qualified Data.Set as S+import qualified Data.Text as T+import           Data.Text.Zipper ( cursorPosition, insertChar, getText, gotoEOL )+import           Data.Time.Calendar ( fromGregorian )+import           Data.Time.Clock ( UTCTime(..) )+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( (.~), (^?!), to, view, folding )++import           Network.Mattermost.Types ( ChannelId, Type(Direct, Private, Group)+                                          , ServerTime(..), UserId+                                          )+++import           Matterhorn.Constants+import           Matterhorn.Draw.ChannelList ( renderChannelList, renderChannelListHeader )+import           Matterhorn.Draw.Messages+import           Matterhorn.Draw.Autocomplete+import           Matterhorn.Draw.URLList+import           Matterhorn.Draw.Util+import           Matterhorn.Draw.RichText+import           Matterhorn.Events.Keybindings+import           Matterhorn.Events.MessageSelect+import           Matterhorn.State.MessageSelect+import           Matterhorn.Themes+import           Matterhorn.TimeUtils ( justAfter, justBefore )+import           Matterhorn.Types+import           Matterhorn.Types.RichText ( parseMarkdown, TeamBaseURL )+import           Matterhorn.Types.KeyEvents+++previewFromInput :: TeamBaseURL -> Maybe MessageType -> UserId -> Text -> Maybe Message+previewFromInput _ _ _ s | s == T.singleton cursorSentinel = Nothing+previewFromInput baseUrl overrideTy uId s =+    -- If it starts with a slash but not /me, this has no preview+    -- representation+    let isCommand = "/" `T.isPrefixOf` s+        isEmoteCmd = "/me " `T.isPrefixOf` s+        content = if isEmoteCmd+                  then T.stripStart $ T.drop 3 s+                  else s+        msgTy = fromMaybe (if isEmoteCmd then CP Emote else CP NormalPost) overrideTy+    in if isCommand && not isEmoteCmd+       then Nothing+       else Just $ Message { _mText          = parseMarkdown (Just baseUrl) content+                           , _mMarkdownSource = content+                           , _mUser          = UserI False uId+                           , _mDate          = ServerTime $ UTCTime (fromGregorian 1970 1 1) 0+                           -- The date is not used for preview+                           -- rendering, but we need to provide one.+                           -- Ideally we'd just use today's date, but+                           -- the rendering function is pure so we+                           -- can't.+                           , _mType          = msgTy+                           , _mPending       = False+                           , _mDeleted       = False+                           , _mAttachments   = mempty+                           , _mInReplyToMsg  = NotAReply+                           , _mMessageId     = Nothing+                           , _mReactions     = mempty+                           , _mOriginalPost  = Nothing+                           , _mFlagged       = False+                           , _mPinned        = False+                           , _mChannelId     = Nothing+                           }++-- | Tokens in spell check highlighting.+data Token =+    Ignore Text+    -- ^ This bit of text is to be ignored for the purposes of+    -- spell-checking.+    | Check Text+    -- ^ This bit of text should be checked against the spell checker's+    -- misspelling list.+    deriving (Show)++drawEditorContents :: ChatState -> HighlightSet -> [Text] -> Widget Name+drawEditorContents st hs =+    let noHighlight = txt . T.unlines+    in case st^.csEditState.cedSpellChecker of+        Nothing -> noHighlight+        Just _ ->+            case S.null (st^.csEditState.cedMisspellings) of+                True -> noHighlight+                False -> doHighlightMisspellings+                           hs+                           (st^.csEditState.cedMisspellings)++-- | This function takes a set of misspellings from the spell+-- checker, the editor lines, and builds a rendering of the text with+-- misspellings highlighted.+--+-- This function processes each line of text from the editor as follows:+--+-- * Tokenize the line based on our rules for what constitutes+--   whitespace. We do this because we need to check "words" in the+--   user's input against the list of misspellings returned by the spell+--   checker. But to do this we need to ignore the same things that+--   Aspell ignores, and it ignores whitespace and lots of puncutation.+--   We also do this because once we have identified the misspellings+--   present in the input, we need to reconstruct the user's input and+--   that means preserving whitespace so that the input looks as it was+--   originally typed.+--+-- * Once we have a list of tokens -- the whitespace tokens to be+--   preserved but ignored and the tokens to be checked -- we check+--   each non-whitespace token for presence in the list of misspellings+--   reported by the checker.+--+-- * Having indicated which tokens correspond to misspelled words, we+--   then need to coallesce adjacent tokens that are of the same+--   "misspelling status", i.e., two neighboring tokens (of whitespace+--   or check type) need to be coallesced if they both correspond to+--   text that is a misspelling or if they both are NOT a misspelling.+--   We do this so that the final Brick widget is optimal in that it+--   uses a minimal number of box cells to display substrings that have+--   the same attribute.+--+-- * Finally we build a widget out of these coallesced tokens and apply+--   the misspellingAttr attribute to the misspelled tokens.+--+-- Note that since we have to come to our own conclusion about which+-- words are worth checking in the checker's output, sometimes our+-- algorithm will differ from aspell in what is considered "part of a+-- word" and what isn't. In particular, Aspell is smart about sometimes+-- noticing that "'" is an apostrophe and at other times that it is+-- a single quote as part of a quoted string. As a result there will+-- be cases where Markdown formatting characters interact poorly+-- with Aspell's checking to result in misspellings that are *not*+-- highlighted.+--+-- One way to deal with this would be to *not* parse the user's input+-- as done here, complete with all its Markdown metacharacters, but to+-- instead 1) parse the input as Markdown, 2) traverse the Markdown AST+-- and extract the words from the relevant subtrees, and 3) spell-check+-- those words. The reason we don't do it that way in the first place is+-- because 1) the user's input might not be valid markdown and 2) even+-- if we did that, we'd still have to do this tokenization operation to+-- annotate misspellings and reconstruct the user's raw input.+doHighlightMisspellings :: HighlightSet -> S.Set Text -> [Text] -> Widget Name+doHighlightMisspellings hSet misspellings contents =+    -- Traverse the input, gathering non-whitespace into tokens and+    -- checking if they appear in the misspelling collection+    let whitelist = S.union (hUserSet hSet) (hChannelSet hSet)++        handleLine t | t == "" = txt " "+        handleLine t =+            -- For annotated tokens, coallesce tokens of the same type+            -- and add attributes for misspellings.+            let mkW (Left tok) =+                    let s = getTokenText tok+                    in if T.null s+                       then emptyWidget+                       else withDefAttr misspellingAttr $ txt $ getTokenText tok+                mkW (Right tok) =+                    let s = getTokenText tok+                    in if T.null s+                       then emptyWidget+                       else txt s++                go :: Either Token Token -> [Either Token Token] -> [Either Token Token]+                go lst [] = [lst]+                go lst (tok:toks) =+                    case (lst, tok) of+                        (Left a, Left b)   -> go (Left $ combineTokens a b) toks+                        (Right a, Right b) -> go (Right $ combineTokens a b) toks+                        _                  -> lst : go tok toks++            in hBox $ mkW <$> (go (Right $ Ignore "") $ annotatedTokens t)++        combineTokens (Ignore a) (Ignore b) = Ignore $ a <> b+        combineTokens (Check a) (Check b) = Check $ a <> b+        combineTokens (Ignore a) (Check b) = Check $ a <> b+        combineTokens (Check a) (Ignore b) = Check $ a <> b++        getTokenText (Ignore a) = a+        getTokenText (Check a) = a++        annotatedTokens t =+            -- For every token, check on whether it is a misspelling.+            -- The result is Either Token Token where the Left is a+            -- misspelling and the Right is not.+            checkMisspelling <$> tokenize t (Ignore "")++        checkMisspelling t@(Ignore _) = Right t+        checkMisspelling t@(Check s) =+            if s `S.member` whitelist+            then Right t+            else if s `S.member` misspellings+                 then Left t+                 else Right t++        ignoreChar c = isSpace c || isPunctuation c || c == '`' || c == '/' ||+                       T.singleton c == userSigil || T.singleton c == normalChannelSigil++        tokenize t curTok+            | T.null t = [curTok]+            | ignoreChar $ T.head t =+                case curTok of+                    Ignore s -> tokenize (T.tail t) (Ignore $ s <> (T.singleton $ T.head t))+                    Check s -> Check s : tokenize (T.tail t) (Ignore $ T.singleton $ T.head t)+            | otherwise =+                case curTok of+                    Ignore s -> Ignore s : tokenize (T.tail t) (Check $ T.singleton $ T.head t)+                    Check s -> tokenize (T.tail t) (Check $ s <> (T.singleton $ T.head t))++    in vBox $ handleLine <$> contents++renderUserCommandBox :: ChatState -> HighlightSet -> Widget Name+renderUserCommandBox st hs =+    let prompt = txt $ case st^.csEditState.cedEditMode of+            Replying _ _ -> "reply> "+            Editing _ _  ->  "edit> "+            NewPost      ->      "> "+        inputBox = renderEditor (drawEditorContents st hs) True (st^.csEditState.cedEditor)+        curContents = getEditContents $ st^.csEditState.cedEditor+        multilineContent = length curContents > 1+        multilineHints =+            hBox [ borderElem bsHorizontal+                 , str $ "[" <> (show $ (+1) $ fst $ cursorPosition $+                                        st^.csEditState.cedEditor.editContentsL) <>+                         "/" <> (show $ length curContents) <> "]"+                 , hBorderWithLabel $ withDefAttr clientEmphAttr $+                   txt $ "In multi-line mode. Press " <> multiLineToggleKey <>+                         " to finish."+                 ]++        replyDisplay = case st^.csEditState.cedEditMode of+            Replying msg _ ->+                let msgWithoutParent = msg & mInReplyToMsg .~ NotAReply+                in hBox [ replyArrow+                        , addEllipsis $ renderMessage MessageData+                          { mdMessage           = msgWithoutParent+                          , mdUserName          = msgWithoutParent^.mUser.to (nameForUserRef st)+                          , mdParentMessage     = Nothing+                          , mdParentUserName    = Nothing+                          , mdHighlightSet      = hs+                          , mdEditThreshold     = Nothing+                          , mdShowOlderEdits    = False+                          , mdRenderReplyParent = True+                          , mdIndentBlocks      = False+                          , mdThreadState       = NoThread+                          , mdShowReactions     = True+                          , mdMessageWidthLimit = Nothing+                          , mdMyUsername        = myUsername st+                          , mdWrapNonhighlightedCodeBlocks = True+                          }+                        ]+            _ -> emptyWidget++        multiLineToggleKey = ppBinding $ getFirstDefaultBinding ToggleMultiLineEvent++        commandBox = case st^.csEditState.cedEphemeral.eesMultiline of+            False ->+                let linesStr = "line" <> if numLines == 1 then "" else "s"+                    numLines = length curContents+                in vLimit 1 $ hBox $+                   prompt : if multilineContent+                            then [ withDefAttr clientEmphAttr $+                                   str $ "[" <> show numLines <> " " <> linesStr <>+                                         "; Enter: send, " <> T.unpack multiLineToggleKey <>+                                         ": edit, Backspace: cancel] "+                                 , txt $ head curContents+                                 , showCursor MessageInput (Location (0,0)) $ str " "+                                 ]+                            else [inputBox]+            True -> vLimit multilineHeightLimit inputBox <=> multilineHints+    in replyDisplay <=> commandBox++renderChannelHeader :: ChatState -> HighlightSet -> ClientChannel -> Widget Name+renderChannelHeader st hs chan =+    let chnType = chan^.ccInfo.cdType+        topicStr = chan^.ccInfo.cdHeader+        userHeader u = let s = T.intercalate " " $ filter (not . T.null) parts+                           parts = [ chanName+                                   , if (all T.null names)+                                     then mempty+                                     else "is"+                                   ] <> names <> [+                                     if T.null (u^.uiEmail)+                                     then mempty+                                     else "(" <> u^.uiEmail <> ")"+                                   ]+                           names = [ u^.uiFirstName+                                   , nick+                                   , u^.uiLastName+                                   ]+                           quote n = "\"" <> n <> "\""+                           nick = maybe "" quote $ u^.uiNickName+                       in s+        firstTopicLine = case T.lines topicStr of+            [h] -> h+            (h:_:_) -> h+            _ -> ""+        maybeTopic = if T.null topicStr+                     then ""+                     else " - " <> if st^.csShowExpandedChannelTopics+                                   then topicStr+                                   else firstTopicLine+        channelNameString = case chnType of+            Direct ->+                case chan^.ccInfo.cdDMUserId >>= flip userById st of+                    Nothing -> chanName+                    Just u -> userHeader u+            Private ->+                channelNamePair <> " (Private)"+            Group ->+                channelNamePair <> " (Private group)"+            _ ->+                channelNamePair+        channelNamePair = chanName <> " - " <> (chan^.ccInfo.cdDisplayName)+        chanName = mkChannelName st (chan^.ccInfo)+        baseUrl = serverBaseUrl st++    in renderText' (Just baseUrl) (myUsername st)+         hs+         (channelNameString <> maybeTopic)++renderCurrentChannelDisplay :: ChatState -> HighlightSet -> Widget Name+renderCurrentChannelDisplay st hs = header <=> hBorder <=> messages+    where+    header =+        if st^.csShowChannelList+        then channelHeader+        else headerWithStatus++    headerWithStatus =+        -- Render the channel list header next to the channel header+        -- itself. We want them to be separated by a vertical border,+        -- but we want the border to be as high as the tallest of the+        -- two. To make that work we need to render the two and then+        -- render a border between them that is the same height as the+        -- taller of the two. We can't do that without making a custom+        -- widget which is why we take this approach here rather than+        -- just putting them all in an hBox.+        Widget Fixed Fixed $ do+            ctx <- getContext+            statusBox <- render $+                hLimit (configChannelListWidth $ st^.csResources.crConfiguration) $+                       (renderChannelListHeader st)++            let channelHeaderWidth = ctx^.availWidthL -+                                     (Vty.imageWidth $ statusBox^.imageL) - 1++            channelHeaderResult <- render $ hLimit channelHeaderWidth channelHeader++            let maxHeight = max (Vty.imageHeight $ statusBox^.imageL)+                                (Vty.imageHeight $ channelHeaderResult^.imageL)+                statusBoxWidget = Widget Fixed Fixed $ return statusBox+                headerWidget = Widget Fixed Fixed $ return channelHeaderResult+                borderWidget = vLimit maxHeight vBorder++            render $ if appMode st == ChannelSelect+                        then headerWidget+                        else hBox $ case st^.csChannelListOrientation of+                            ChannelListLeft ->+                                [ statusBoxWidget+                                , borderWidget+                                , headerWidget+                                ]+                            ChannelListRight ->+                                [ headerWidget+                                , borderWidget+                                , statusBoxWidget+                                ]++    channelHeader =+        withDefAttr channelHeaderAttr $+        padRight Max $+        renderChannelHeader st hs chan++    messages = padTop Max chatText++    chatText = case appMode st of+        MessageSelect ->+            renderMessagesWithSelect (st^.csMessageSelect) channelMessages+        MessageSelectDeleteConfirm ->+            renderMessagesWithSelect (st^.csMessageSelect) channelMessages+        _ ->+            cached (ChannelMessages cId) $+            renderLastMessages st hs editCutoff $+            retrogradeMsgsWithThreadStates $+            reverseMessages channelMessages++    renderMessagesWithSelect (MessageSelectState selMsgId) msgs =+        -- In this case, we want to fill the message list with messages+        -- but use the post ID as a cursor. To do this efficiently we+        -- only want to render enough messages to fill the screen.+        --+        -- If the message area is H rows high, this actually renders at+        -- most 2H rows' worth of messages and then does the appropriate+        -- cropping. This way we can simplify the math needed to figure+        -- out how to crop while bounding the number of messages we+        -- render around the cursor.+        --+        -- First, we sanity-check the application state because under+        -- some conditions, the selected message might be gone (e.g.+        -- deleted).+        let (s, (before, after)) = splitDirSeqOn (\(m, _) -> m^.mMessageId == selMsgId) msgsWithStates+            msgsWithStates = chronologicalMsgsWithThreadStates msgs+        in case s of+             Nothing ->+                 renderLastMessages st hs editCutoff before+             Just m ->+                 unsafeRenderMessageSelection (m, (before, after)) (renderSingleMessage st hs Nothing)++    cutoff = getNewMessageCutoff cId st+    editCutoff = getEditedMessageCutoff cId st+    channelMessages =+        insertTransitions (getMessageListing cId st)+                          cutoff+                          (getDateFormat st)+                          (st ^. timeZone)++    cId = st^.csCurrentChannelId+    chan = st^.csCurrentChannel++getMessageListing :: ChannelId -> ChatState -> Messages+getMessageListing cId st =+    st ^?! csChannels.folding (findChannelById cId) . ccContents . cdMessages . to (filterMessages isShown)+    where isShown m+            | st^.csResources.crUserPreferences.userPrefShowJoinLeave = True+            | otherwise = not $ isJoinLeave m++insertTransitions :: Messages -> Maybe NewMessageIndicator -> Text -> TimeZoneSeries -> Messages+insertTransitions ms cutoff = insertDateMarkers $ foldr addMessage ms newMessagesT+    where anyNondeletedNewMessages t =+              isJust $ findLatestUserMessage (not . view mDeleted) (messagesAfter t ms)+          newMessagesT = case cutoff of+              Nothing -> []+              Just Hide -> []+              Just (NewPostsAfterServerTime t)+                  | anyNondeletedNewMessages t -> [newMessagesMsg $ justAfter t]+                  | otherwise -> []+              Just (NewPostsStartingAt t)+                  | anyNondeletedNewMessages (justBefore t) -> [newMessagesMsg $ justBefore t]+                  | otherwise -> []+          newMessagesMsg d = newMessageOfType (T.pack "New Messages")+                             (C NewMessagesTransition) d++renderChannelSelectPrompt :: ChatState -> Widget Name+renderChannelSelectPrompt st =+    let e = st^.csChannelSelectState.channelSelectInput+    in withDefAttr channelSelectPromptAttr $+       (txt "Switch to channel [use ^ and $ to anchor]: ") <+>+       (renderEditor (txt . T.concat) True e)++drawMain :: Bool -> ChatState -> [Widget Name]+drawMain useColor st =+    let maybeColor = if useColor then id else forceAttr "invalid"+    in maybeColor <$>+           [ connectionLayer st+           , autocompleteLayer st+           , joinBorders $ mainInterface st+           ]++connectionLayer :: ChatState -> Widget Name+connectionLayer st =+    case st^.csConnectionStatus of+        Connected -> emptyWidget+        Disconnected ->+            Widget Fixed Fixed $ do+                ctx <- getContext+                let aw = ctx^.availWidthL+                    w = length msg + 2+                    msg = "NOT CONNECTED"+                render $ translateBy (Location (max 0 (aw - w), 0)) $+                         withDefAttr errorMessageAttr $+                         border $ str msg++messageSelectBottomBar :: ChatState -> Widget Name+messageSelectBottomBar st =+    case getSelectedMessage st of+        Nothing -> emptyWidget+        Just postMsg ->+            let optionList = if null usableOptions+                             then txt "(no actions available for this message)"+                             else hBox $ intersperse (txt " ") usableOptions+                usableOptions = catMaybes $ mkOption <$> options+                mkOption (f, k, desc) = if f postMsg+                                        then Just $ withDefAttr messageSelectStatusAttr (txt k) <+>+                                                    txt (":" <> desc)+                                        else Nothing+                numURLs = Seq.length $ msgURLs postMsg+                s = if numURLs == 1 then "" else "s"+                hasURLs = numURLs > 0+                openUrlsMsg = "open " <> (T.pack $ show numURLs) <> " URL" <> s+                hasVerb = isJust (findVerbatimChunk (postMsg^.mText))+                -- make sure these keybinding pieces are up-to-date!+                ev e =+                  let keyconf = st^.csResources.crConfiguration.to configUserKeys+                      KeyHandlerMap keymap = messageSelectKeybindings keyconf+                  in T.intercalate ","+                       [ ppBinding (eventToBinding k)+                       | KH { khKey     = k+                            , khHandler = h+                            } <- M.elems keymap+                       , kehEventTrigger h == ByEvent e+                       ]+                options = [ ( not . isGap+                            , ev YankWholeMessageEvent+                            , "yank-all"+                            )+                          , ( \m -> isFlaggable m && not (m^.mFlagged)+                            , ev FlagMessageEvent+                            , "flag"+                            )+                          , ( \m -> isFlaggable m && m^.mFlagged+                            , ev FlagMessageEvent+                            , "unflag"+                            )+                          , ( \m -> isPinnable m && not (m^.mPinned)+                            , ev PinMessageEvent+                            , "pin"+                            )+                          , ( \m -> isPinnable m && m^.mPinned+                            , ev PinMessageEvent+                            , "unpin"+                            )+                          , ( isReplyable+                            , ev ReplyMessageEvent+                            , "reply"+                            )+                          , ( not . isGap+                            , ev ViewMessageEvent+                            , "view"+                            )+                          , ( isGap+                            , ev FillGapEvent+                            , "load messages"+                            )+                          , ( \m -> isMine st m && isEditable m+                            , ev EditMessageEvent+                            , "edit"+                            )+                          , ( \m -> isMine st m && isDeletable m+                            , ev DeleteMessageEvent+                            , "delete"+                            )+                          , ( const hasURLs+                            , ev OpenMessageURLEvent+                            , openUrlsMsg+                            )+                          , ( const hasVerb+                            , ev YankMessageEvent+                            , "yank-code"+                            )+                          , ( isReactable+                            , ev ReactToMessageEvent+                            , "react"+                            )+                          ]++            in hBox [ borderElem bsHorizontal+                    , txt "["+                    , txt "Message select: "+                    , optionList+                    , txt "]"+                    , hBorder+                    ]++maybePreviewViewport :: Widget Name -> Widget Name+maybePreviewViewport w =+    Widget Greedy Fixed $ do+        result <- render w+        case (Vty.imageHeight $ result^.imageL) > previewMaxHeight of+            False -> return result+            True ->+                render $ vLimit previewMaxHeight $ viewport MessagePreviewViewport Vertical $+                         (Widget Fixed Fixed $ return result)++inputPreview :: ChatState -> HighlightSet -> Widget Name+inputPreview st hs | not $ st^.csShowMessagePreview = emptyWidget+                   | otherwise = thePreview+    where+    uId = myUserId st+    -- Insert a cursor sentinel into the input text just before+    -- rendering the preview. We use the inserted sentinel (which is+    -- not rendered) to get brick to ensure that the line the cursor is+    -- on is visible in the preview viewport. We put the sentinel at+    -- the *end* of the line because it will still influence markdown+    -- parsing and can create undesirable/confusing churn in the+    -- rendering while the cursor moves around. If the cursor is at the+    -- end of whatever line the user is editing, that is very unlikely+    -- to be a problem.+    curContents = getText $ (gotoEOL >>> insertChar cursorSentinel) $+                  st^.csEditState.cedEditor.editContentsL+    curStr = T.intercalate "\n" curContents+    overrideTy = case st^.csEditState.cedEditMode of+        Editing _ ty -> Just ty+        _ -> Nothing+    baseUrl = serverBaseUrl st+    previewMsg = previewFromInput baseUrl overrideTy uId curStr+    thePreview = let noPreview = str "(No preview)"+                     msgPreview = case previewMsg of+                       Nothing -> noPreview+                       Just pm -> if T.null curStr+                                  then noPreview+                                  else prview pm $ getParentMessage st pm+                     prview m p = renderMessage MessageData+                                  { mdMessage           = m+                                  , mdUserName          = m^.mUser.to (nameForUserRef st)+                                  , mdParentMessage     = p+                                  , mdParentUserName    = p >>= (^.mUser.to (nameForUserRef st))+                                  , mdHighlightSet      = hs+                                  , mdEditThreshold     = Nothing+                                  , mdShowOlderEdits    = False+                                  , mdRenderReplyParent = True+                                  , mdIndentBlocks      = True+                                  , mdThreadState       = NoThread+                                  , mdShowReactions     = True+                                  , mdMessageWidthLimit = Nothing+                                  , mdMyUsername        = myUsername st+                                  , mdWrapNonhighlightedCodeBlocks = True+                                  }+                 in (maybePreviewViewport msgPreview) <=>+                    hBorderWithLabel (withDefAttr clientEmphAttr $ str "[Preview ↑]")++userInputArea :: ChatState -> HighlightSet -> Widget Name+userInputArea st hs =+    case appMode st of+        ChannelSelect -> renderChannelSelectPrompt st+        UrlSelect     -> hCenter $ hBox [ txt "Press "+                                        , withDefAttr clientEmphAttr $ txt "Enter"+                                        , txt " to open the selected URL or "+                                        , withDefAttr clientEmphAttr $ txt "Escape"+                                        , txt " to cancel."+                                        ]+        MessageSelectDeleteConfirm -> renderDeleteConfirm+        _             -> renderUserCommandBox st hs++renderDeleteConfirm :: Widget Name+renderDeleteConfirm =+    hCenter $ txt "Are you sure you want to delete the selected message? (y/n)"++mainInterface :: ChatState -> Widget Name+mainInterface st =+    vBox [ body+         , bottomBorder+         , inputPreview st hs+         , userInputArea st hs+         ]+    where+    body = if st^.csShowChannelList || appMode st == ChannelSelect+           then case st^.csChannelListOrientation of+               ChannelListLeft ->+                   hBox [channelList, vBorder, mainDisplay]+               ChannelListRight ->+                   hBox [mainDisplay, vBorder, channelList]+           else mainDisplay+    channelList = hLimit channelListWidth (renderChannelList st)+    hs = getHighlightSet st+    channelListWidth = configChannelListWidth $ st^.csResources.crConfiguration+    mainDisplay = case appMode st of+        UrlSelect -> renderUrlList st+        _         -> maybeSubdue $ renderCurrentChannelDisplay st hs++    bottomBorder = case appMode st of+        MessageSelect -> messageSelectBottomBar st+        _ -> maybeSubdue $ hBox+             [ showAttachmentCount+             , hBorder+             , showTypingUsers+             , showBusy+             ]++    showAttachmentCount =+        let count = length $ listElements $ st^.csEditState.cedAttachmentList+        in if count == 0+           then emptyWidget+           else hBox [ borderElem bsHorizontal+                     , withDefAttr clientMessageAttr $+                       txt $ "(" <> (T.pack $ show count) <> " attachment" <>+                             (if count == 1 then "" else "s") <> "; "+                     , withDefAttr clientEmphAttr $+                       txt $ ppBinding (getFirstDefaultBinding ShowAttachmentListEvent)+                     , txt " to manage)"+                     ]++    showTypingUsers =+        let format = renderText' Nothing (myUsername st) hs+        in case allTypingUsers (st^.csCurrentChannel.ccInfo.cdTypingUsers) of+            [] -> emptyWidget+            [uId] | Just un <- usernameForUserId uId st ->+               format $ "[" <> userSigil <> un <> " is typing]"+            [uId1, uId2] | Just un1 <- usernameForUserId uId1 st+                         , Just un2 <- usernameForUserId uId2 st ->+               format $ "[" <> userSigil <> un1 <> " and " <> userSigil <> un2 <> " are typing]"+            _ -> format "[several people are typing]"++    showBusy = case st^.csWorkerIsBusy of+                 Just (Just n) -> hLimit 2 hBorder <+> txt (T.pack $ "*" <> show n)+                 Just Nothing -> hLimit 2 hBorder <+> txt "*"+                 Nothing -> emptyWidget++    maybeSubdue = if appMode st == ChannelSelect+                  then forceAttr ""+                  else id++replyArrow :: Widget a+replyArrow =+    Widget Fixed Fixed $ do+        ctx <- getContext+        let bs = ctx^.ctxBorderStyleL+        render $ str [' ', bsCornerTL bs, '▸']
+ src/Matterhorn/Draw/ManageAttachments.hs view
@@ -0,0 +1,64 @@+module Matterhorn.Draw.ManageAttachments+  ( drawManageAttachments+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import qualified Brick.Widgets.FileBrowser as FB+import           Brick.Widgets.List+import           Data.Maybe ( fromJust )++import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+import           Matterhorn.Events.Keybindings ( getFirstDefaultBinding )+import           Matterhorn.Themes+++drawManageAttachments :: ChatState -> Widget Name+drawManageAttachments st =+    topLayer+    where+        topLayer = case appMode st of+            ManageAttachments -> drawAttachmentList st+            ManageAttachmentsBrowseFiles -> drawFileBrowser st+            _ -> error "BUG: drawManageAttachments called in invalid mode"++drawAttachmentList :: ChatState -> Widget Name+drawAttachmentList st =+    let addBinding = ppBinding $ getFirstDefaultBinding AttachmentListAddEvent+        delBinding = ppBinding $ getFirstDefaultBinding AttachmentListDeleteEvent+        escBinding = ppBinding $ getFirstDefaultBinding CancelEvent+        openBinding = ppBinding $ getFirstDefaultBinding AttachmentOpenEvent+    in centerLayer $+       hLimit 60 $+       vLimit 15 $+       joinBorders $+       borderWithLabel (withDefAttr clientEmphAttr $ txt "Attachments") $+       vBox [ renderList renderAttachmentItem True (st^.csEditState.cedAttachmentList)+            , hBorder+            , hCenter $ withDefAttr clientMessageAttr $+                        txt $ addBinding <> ":add " <>+                              delBinding <> ":delete " <>+                              openBinding <> ":open " <>+                              escBinding <> ":close"+            ]++renderAttachmentItem :: Bool -> AttachmentData -> Widget Name+renderAttachmentItem _ d =+    padRight Max $ str $ FB.fileInfoSanitizedFilename $ attachmentDataFileInfo d++drawFileBrowser :: ChatState -> Widget Name+drawFileBrowser st =+    centerLayer $+    hLimit 60 $+    vLimit 20 $+    borderWithLabel (withDefAttr clientEmphAttr $ txt "Attach File") $+    -- invariant: cedFileBrowser is not Nothing if appMode is+    -- ManageAttachmentsBrowseFiles, and that is the only way to reach+    -- this code, ergo the fromJust.+    FB.renderFileBrowser True $ fromJust (st^.csEditState.cedFileBrowser)
+ src/Matterhorn/Draw/Messages.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.Draw.Messages+  ( nameForUserRef+  , renderSingleMessage+  , unsafeRenderMessageSelection+  , renderLastMessages+  )+where++import           Brick+import           Brick.Widgets.Border+import           Control.Monad.Trans.Reader ( withReaderT )+import qualified Data.Foldable as F+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( (.~), to )+import           Network.Mattermost.Types ( ServerTime(..), userUsername )+import           Prelude ()+import           Matterhorn.Prelude++import           Matterhorn.Draw.Util+import           Matterhorn.Draw.RichText+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Types.DirectionalSeq++maxMessageHeight :: Int+maxMessageHeight = 200++-- | nameForUserRef converts the UserRef into a printable name, based+-- on the current known user data.+nameForUserRef :: ChatState -> UserRef -> Maybe Text+nameForUserRef st uref =+    case uref of+        NoUser -> Nothing+        UserOverride _ t -> Just t+        UserI _ uId -> displayNameForUserId uId st++-- | renderSingleMessage is the main message drawing function.+--+-- The `ind` argument specifies an "indicator boundary".  Showing+-- various indicators (e.g. "edited") is not typically done for+-- messages that are older than this boundary value.+renderSingleMessage :: ChatState+                    -> HighlightSet+                    -> Maybe ServerTime+                    -> Message+                    -> ThreadState+                    -> Widget Name+renderSingleMessage st hs ind m threadState =+  renderChatMessage st hs ind threadState (withBrackets . renderTime st . withServerTime) m++renderChatMessage :: ChatState+                  -> HighlightSet+                  -> Maybe ServerTime+                  -> ThreadState+                  -> (ServerTime -> Widget Name)+                  -> Message+                  -> Widget Name+renderChatMessage st hs ind threadState renderTimeFunc msg =+    let showOlderEdits = configShowOlderEdits config+        showTimestamp = configShowMessageTimestamps config+        config = st^.csResources.crConfiguration+        parent = case msg^.mInReplyToMsg of+          NotAReply -> Nothing+          InReplyTo pId -> getMessageForPostId st pId+        m = renderMessage MessageData+              { mdMessage           = msg+              , mdUserName          = msg^.mUser.to (nameForUserRef st)+              , mdParentMessage     = parent+              , mdParentUserName    = parent >>= (^.mUser.to (nameForUserRef st))+              , mdEditThreshold     = ind+              , mdHighlightSet      = hs+              , mdShowOlderEdits    = showOlderEdits+              , mdRenderReplyParent = True+              , mdIndentBlocks      = True+              , mdThreadState       = threadState+              , mdShowReactions     = True+              , mdMessageWidthLimit = Nothing+              , mdMyUsername        = userUsername $ myUser st+              , mdWrapNonhighlightedCodeBlocks = True+              }+        fullMsg =+          case msg^.mUser of+            NoUser+              | isGap msg -> withDefAttr gapMessageAttr m+              | otherwise ->+                case msg^.mType of+                    C DateTransition ->+                        withDefAttr dateTransitionAttr (hBorderWithLabel m)+                    C NewMessagesTransition ->+                        withDefAttr newMessageTransitionAttr (hBorderWithLabel m)+                    C Error ->+                        withDefAttr errorMessageAttr m+                    _ ->+                        withDefAttr clientMessageAttr m+            _ | isJoinLeave msg -> withDefAttr clientMessageAttr m+              | otherwise -> m+        maybeRenderTime w =+            if showTimestamp+            then let maybePadTime = if threadState == InThreadShowParent+                                    then (txt " " <=>) else id+                 in hBox [maybePadTime $ renderTimeFunc (msg^.mDate), txt " ", w]+            else w+        maybeRenderTimeWith f = if isTransition msg then id else f+    in maybeRenderTimeWith maybeRenderTime fullMsg++-- | Render a selected message with focus, including the messages+-- before and the messages after it. The foldable parameters exist+-- because (depending on the situation) we might use either of the+-- message list types for the 'before' and 'after' (i.e. the+-- chronological or retrograde message sequences).+unsafeRenderMessageSelection :: (Foldable f, Foldable g)+                             => ((Message, ThreadState), (f (Message, ThreadState), g (Message, ThreadState)))+                             -> (Message -> ThreadState -> Widget Name)+                             -> Widget Name+unsafeRenderMessageSelection ((curMsg, curThreadState), (before, after)) doMsgRender =+  Widget Greedy Greedy $ do+    ctx <- getContext+    curMsgResult <- withReaderT relaxHeight $ render $+                    forceAttr messageSelectAttr $+                    padRight Max $ doMsgRender curMsg curThreadState++    let targetHeight = ctx^.availHeightL+        upperHeight = targetHeight `div` 2+        lowerHeight = targetHeight - upperHeight++        lowerRender img (m, tState) = render1HLimit doMsgRender Vty.vertJoin targetHeight img tState m+        upperRender img (m, tState) = render1HLimit doMsgRender (flip Vty.vertJoin) targetHeight img tState m++    lowerHalf <- foldM lowerRender Vty.emptyImage after+    upperHalf <- foldM upperRender Vty.emptyImage before++    let curHeight = Vty.imageHeight $ curMsgResult^.imageL+        uncropped = upperHalf Vty.<-> curMsgResult^.imageL Vty.<-> lowerHalf+        img = if | Vty.imageHeight lowerHalf < (lowerHeight - curHeight) ->+                     Vty.cropTop targetHeight uncropped+                 | Vty.imageHeight upperHalf < upperHeight ->+                     Vty.cropBottom targetHeight uncropped+                 | otherwise ->+                     Vty.cropTop upperHeight upperHalf Vty.<-> curMsgResult^.imageL Vty.<->+                        (if curHeight < lowerHeight+                          then Vty.cropBottom (lowerHeight - curHeight) lowerHalf+                          else Vty.cropBottom lowerHeight lowerHalf)+    return $ emptyResult & imageL .~ img++renderLastMessages :: ChatState+                   -> HighlightSet+                   -> Maybe ServerTime+                   -> DirectionalSeq Retrograde (Message, ThreadState)+                   -> Widget Name+renderLastMessages st hs editCutoff msgs =+    Widget Greedy Greedy $ do+        ctx <- getContext+        let targetHeight = ctx^.availHeightL+            doMsgRender = renderSingleMessage st hs editCutoff++            newMessagesTransitions = filterMessages (isNewMessagesTransition . fst) msgs+            newMessageTransition = fst <$> (listToMaybe $ F.toList newMessagesTransitions)++            isBelow m transition = m^.mDate > transition^.mDate++            go :: Vty.Image -> DirectionalSeq Retrograde (Message, ThreadState) -> RenderM Name Vty.Image+            go img ms | messagesLength ms == 0 = return img+            go img ms = do+                let Just (m, threadState) = messagesHead ms+                    newMessagesAbove = maybe False (isBelow m) newMessageTransition+                newImg <- render1HLimit doMsgRender (flip Vty.vertJoin) targetHeight img threadState m+                -- If the new message fills the window, check whether+                -- there is still a "New Messages" transition that is+                -- not displayed. If there is, then we need to replace+                -- the top line of the new image with a "New Messages"+                -- indicator.+                if Vty.imageHeight newImg >= targetHeight && newMessagesAbove+                then do+                    transitionResult <- render $ withDefAttr newMessageTransitionAttr $+                                                 hBorderWithLabel (txt "New Messages ↑")+                    let newImg2 = Vty.vertJoin (transitionResult^.imageL)+                                               (Vty.cropTop (targetHeight - 1) newImg)+                    return newImg2+                else go newImg $ messagesDrop 1 ms++        img <- go Vty.emptyImage msgs+        return $ emptyResult & imageL .~ (Vty.cropTop targetHeight img)++relaxHeight :: Context -> Context+relaxHeight c = c & availHeightL .~ (max maxMessageHeight (c^.availHeightL))++render1HLimit :: (Message -> ThreadState -> Widget Name)+              -> (Vty.Image -> Vty.Image -> Vty.Image)+              -> Int+              -> Vty.Image+              -> ThreadState+              -> Message+              -> RenderM Name Vty.Image+render1HLimit doMsgRender fjoin lim img threadState msg+  | Vty.imageHeight img >= lim = return img+  | otherwise = fjoin img <$> render1 doMsgRender threadState msg++render1 :: (Message -> ThreadState -> Widget Name)+        -> ThreadState+        -> Message+        -> RenderM Name Vty.Image+render1 doMsgRender threadState msg = case msg^.mDeleted of+    True -> return Vty.emptyImage+    False -> do+        r <- withReaderT relaxHeight $+             render $ padRight Max $+             doMsgRender msg threadState+        return $ r^.imageL
+ src/Matterhorn/Draw/NotifyPrefs.hs view
@@ -0,0 +1,35 @@+module Matterhorn.Draw.NotifyPrefs+  ( drawNotifyPrefs+  )+where++import Prelude ()+import Matterhorn.Prelude++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+import Brick.Forms (renderForm)+import Data.List (intersperse)++import Matterhorn.Draw.Util (renderKeybindingHelp)+import Matterhorn.Types+import Matterhorn.Types.KeyEvents+import Matterhorn.Themes++drawNotifyPrefs :: ChatState -> Widget Name+drawNotifyPrefs st =+    let Just form = st^.csNotifyPrefs+        label = forceAttr clientEmphAttr $ str "Notification Preferences"+        formKeys = withDefAttr clientEmphAttr <$> txt <$> ["Tab", "BackTab"]+        bindings = vBox $ hCenter <$> [ renderKeybindingHelp "Save" [FormSubmitEvent] <+> txt "  " <+>+                                        renderKeybindingHelp "Cancel" [CancelEvent]+                                      , hBox ((intersperse (txt "/") formKeys) <> [txt (":Cycle form fields")])+                                      , hBox [withDefAttr clientEmphAttr $ txt "Space", txt ":Toggle form field"]+                                      ]+    in centerLayer $+       vLimit 25 $+       hLimit 39 $+       joinBorders $+       borderWithLabel label $+       (padAll 1 $ renderForm form) <=> hBorder <=> bindings
+ src/Matterhorn/Draw/PostListOverlay.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++module Matterhorn.Draw.PostListOverlay where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import           Control.Monad.Trans.Reader ( withReaderT )+import qualified Data.Text as T+import           Lens.Micro.Platform ( (^?), (%~), to )++import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.Constants ( userSigil )+import           Matterhorn.Draw.Messages+import           Matterhorn.Draw.Util+import           Matterhorn.Themes+import           Matterhorn.Types+++hLimitWithPadding :: Int -> Widget n -> Widget n+hLimitWithPadding pad contents = Widget+  { hSize  = Fixed+  , vSize  = (vSize contents)+  , render =+      withReaderT (& availWidthL  %~ (\ n -> n - (2 * pad))) $ render $ cropToContext contents+  }++drawPostListOverlay :: PostListContents -> ChatState -> Widget Name+drawPostListOverlay contents st = joinBorders $ drawPostsBox contents st++-- | Draw a PostListOverlay as a floating overlay on top of whatever+-- is rendered beneath it+drawPostsBox :: PostListContents -> ChatState -> Widget Name+drawPostsBox contents st =+  centerLayer $ hLimitWithPadding 10 $ borderWithLabel contentHeader $+    padRight (Pad 1) messageListContents+  where -- The 'window title' of the overlay+        hs = getHighlightSet st+        contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of+          PostListFlagged -> "Flagged posts"+          PostListPinned cId ->+              let cName = case findChannelById cId (st^.csChannels) of+                      Nothing -> "<UNKNOWN>"+                      Just cc -> mkChannelName st (cc^.ccInfo)+              in "Posts pinned in " <> cName+          PostListSearch terms searching -> "Search results" <> if searching+            then ": " <> terms+            else " (" <> (T.pack . show . length) messages <> "): " <> terms++        messages = insertDateMarkers+                     (filterMessages knownChannel $ st^.csPostListOverlay.postListPosts)+                     (getDateFormat st)+                     (st^.timeZone)++        knownChannel msg =+            case msg^.mChannelId of+                Just cId | Nothing <- st^?csChannels.channelByIdL(cId) -> False+                _ -> True++        -- The overall contents, with a sensible default even if there+        -- are no messages+        messageListContents+          | null messages =+            padTopBottom 1 $+            hCenter $+            withDefAttr clientEmphAttr $+            str $ case contents of+              PostListFlagged -> "You have no flagged messages."+              PostListPinned _ -> "This channel has no pinned messages."+              PostListSearch _ searching ->+                if searching+                  then "Searching ..."+                  else "No search results found"+          | otherwise = vBox renderedMessageList++        -- The render-message function we're using+        renderMessageForOverlay msg tState =+          let renderedMsg = renderSingleMessage st hs Nothing msg tState+          in case msg^.mOriginalPost of+            -- We should factor out some of the channel name logic at+            -- some point, but we can do that later+            Just post+              | Just chan <- st^?csChannels.channelByIdL(post^.postChannelIdL) ->+                 case chan^.ccInfo.cdType of+                  Direct+                    | Just u <- flip userById st =<< chan^.ccInfo.cdDMUserId ->+                        (forceAttr channelNameAttr (txt (userSigil <> u^.uiName)) <=>+                          (str "  " <+> renderedMsg))+                  _ -> (forceAttr channelNameAttr (txt (chan^.ccInfo.to (mkChannelName st))) <=>+                         (str "  " <+> renderedMsg))+            _ | CP _ <- msg^.mType -> str "[BUG: unknown channel]"+              | otherwise -> renderedMsg++        -- The full message list, rendered with the current selection+        renderedMessageList =+          let (s, (before, after)) = splitDirSeqOn matchesMessage messagesWithStates+              matchesMessage (m, _) = m^.mMessageId == (MessagePostId <$> st^.csPostListOverlay.postListSelected)+              messagesWithStates = (, InThreadShowParent) <$> messages+          in case s of+            Nothing ->+                map (uncurry renderMessageForOverlay) (reverse (toList messagesWithStates))+            Just curMsg ->+              [unsafeRenderMessageSelection (curMsg, (after, before)) renderMessageForOverlay]
+ src/Matterhorn/Draw/ReactionEmojiListOverlay.hs view
@@ -0,0 +1,39 @@+module Matterhorn.Draw.ReactionEmojiListOverlay+  ( drawReactionEmojiListOverlay+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.List ( listSelectedFocusedAttr )+import qualified Data.Text as T++import           Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )+import           Matterhorn.Types+import           Matterhorn.Themes+++drawReactionEmojiListOverlay :: ChatState -> Widget Name+drawReactionEmojiListOverlay st =+    let overlay = drawListOverlay (st^.csReactionEmojiListOverlay)+                                  (const $ txt "Search Emoji")+                                  (const $ txt "No matching emoji found.")+                                  (const $ txt "Search emoji:")+                                  renderEmoji+                                  Nothing+                                  OverlayCenter+                                  80+    in joinBorders overlay++renderEmoji :: Bool -> (Bool, T.Text) -> Widget Name+renderEmoji sel (mine, e) =+    let maybeForce = if sel+                     then forceAttr listSelectedFocusedAttr+                     else id+    in maybeForce $+       padRight Max $+       hBox [ if mine then txt " * " else txt "   "+            , withDefAttr emojiAttr $ txt $ ":" <> e <> ":"+            ]
+ src/Matterhorn/Draw/RichText.hs view
@@ -0,0 +1,619 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE RecordWildCards #-}+module Matterhorn.Draw.RichText+  ( MessageData(..)+  , renderRichText+  , renderMessage+  , renderText+  , renderText'+  , renderElementSeq+  , cursorSentinel+  , addEllipsis+  , findVerbatimChunk+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick ( (<+>), Widget, hLimit, imageL+                       , raw, render, Size(..), Widget(..)+                       )+import qualified Brick as B+import qualified Brick.Widgets.Border as B+import qualified Brick.Widgets.Skylighting as BS+import           Control.Monad.Reader+import qualified Data.Foldable as F+import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import           Data.Sequence ( ViewL(..)+                               , ViewR(..)+                               , (<|)+                               , (|>)+                               , viewl+                               , viewr)+import qualified Data.Sequence as S+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Graphics.Vty as V+import qualified Skylighting.Core as Sky++import           Network.Mattermost.Lenses ( postEditAtL, postCreateAtL )+import           Network.Mattermost.Types ( ServerTime(..), PostId )++import           Matterhorn.Constants ( normalChannelSigil, userSigil )+import           Matterhorn.Themes+import           Matterhorn.Types ( Name, HighlightSet(..) )+import           Matterhorn.Types.Messages+import           Matterhorn.Types.Posts+import           Matterhorn.Types.RichText+++emptyHSet :: HighlightSet+emptyHSet = HighlightSet Set.empty Set.empty mempty++omittedUsernameType :: MessageType -> Bool+omittedUsernameType = \case+  CP Join -> True+  CP Leave -> True+  CP TopicChange -> True+  _ -> False++-- Add the edit sentinel to the end of the last block in the sequence.+-- If the last block is a paragraph, append it to that paragraph.+-- Otherwise, append a new block so it appears beneath the last+-- block-level element.+addEditSentinel :: ElementData -> Seq RichTextBlock -> Seq RichTextBlock+addEditSentinel d bs =+    case viewr bs of+        EmptyR -> bs+        (rest :> b) -> rest <> appendEditSentinel d b++appendEditSentinel :: ElementData -> RichTextBlock -> Seq RichTextBlock+appendEditSentinel sentinel b =+    let s = Para (S.singleton m)+        m = Element Normal sentinel+    in case b of+        Para is -> S.singleton $ Para (is |> Element Normal ESpace |> m)+        _ -> S.fromList [b, s]++-- | A bundled structure that includes all the information necessary+-- to render a given message+data MessageData =+    MessageData { mdEditThreshold :: Maybe ServerTime+                -- ^ If specified, any messages edited before this point+                -- in time are not indicated as edited.+                , mdShowOlderEdits :: Bool+                -- ^ Indicates whether "edited" markers should be shown+                -- for old messages (i.e., ignore the mdEditThreshold+                -- value).+                , mdShowReactions :: Bool+                -- ^ Whether to render reactions.+                , mdMessage :: Message+                -- ^ The message to render.+                , mdUserName :: Maybe Text+                -- ^ The username of the message's author, if any. This+                -- is passed here rather than obtaining from the message+                -- because we need to do lookups in the ChatState to+                -- compute this, and we don't pass the ChatState into+                -- renderMessage.+                , mdParentMessage :: Maybe Message+                -- ^ The parent message of this message, if any.+                , mdParentUserName :: Maybe Text+                -- ^ The author of the parent message, if any.+                , mdThreadState :: ThreadState+                -- ^ The thread state of this message.+                , mdRenderReplyParent :: Bool+                -- ^ Whether to render the parent message.+                , mdHighlightSet :: HighlightSet+                -- ^ The highlight set to use to highlight usernames,+                -- channel names, etc.+                , mdIndentBlocks :: Bool+                -- ^ Whether to indent the message underneath the+                -- author's name (True) or just display it to the right+                -- of the author's name (False).+                , mdMessageWidthLimit :: Maybe Int+                -- ^ A width override to use to wrap non-code blocks+                -- and code blocks without syntax highlighting. If+                -- unspecified, all blocks in the message will be+                -- wrapped and truncated at the width specified by the+                -- rendering context. If specified, all non-code blocks+                -- will be wrapped at this width and highlighted code+                -- blocks will be rendered using the context's width.+                , mdMyUsername :: Text+                -- ^ The username of the user running Matterhorn.+                , mdWrapNonhighlightedCodeBlocks :: Bool+                -- ^ Whether to wrap text in non-highlighted code+                -- blocks.+                }++-- | renderMessage performs markdown rendering of the specified message.+renderMessage :: MessageData -> Widget Name+renderMessage md@MessageData { mdMessage = msg, .. } =+    let msgUsr = case mdUserName of+          Just u -> if omittedUsernameType (msg^.mType) then Nothing else Just u+          Nothing -> Nothing+        botElem = if isBotMessage msg then B.txt "[BOT]" else B.emptyWidget+        nameElems = case msgUsr of+          Just un+            | isEmote msg ->+                [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN]" else ""+                , B.txt $ (if msg^.mFlagged then "[!] " else "") <> "*"+                , colorUsername mdMyUsername un un+                , botElem+                , B.txt " "+                ]+            | otherwise ->+                [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN] " else ""+                , colorUsername mdMyUsername un un+                , botElem+                , B.txt $ (if msg^.mFlagged then "[!]" else "") <> ": "+                ]+          Nothing -> []++        -- Use the editing threshold to determine whether to append an+        -- editing indication to this message.+        maybeAugment bs = case msg^.mOriginalPost of+            Nothing -> bs+            Just p ->+                if p^.postEditAtL > p^.postCreateAtL+                then case mdEditThreshold of+                    Just cutoff | p^.postEditAtL >= cutoff ->+                        addEditSentinel (EEditSentinel True) bs+                    _ -> if mdShowOlderEdits+                         then addEditSentinel (EEditSentinel False) bs+                         else bs+                else bs++        augmentedText = maybeAugment $ msg^.mText+        msgWidget =+            vBox $ (layout mdHighlightSet mdMessageWidthLimit nameElems augmentedText . viewl) augmentedText :+                   catMaybes [msgAtch, msgReac]+        replyIndent = B.Widget B.Fixed B.Fixed $ do+            ctx <- B.getContext+            -- NB: The amount subtracted here must be the total padding+            -- added below (pad 1 + vBorder)+            w <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) msgWidget+            B.render $ B.vLimit (V.imageHeight $ w^.B.imageL) $+                B.padRight (B.Pad 1) B.vBorder B.<+> (B.Widget B.Fixed B.Fixed $ return w)+        msgAtch = if Seq.null (msg^.mAttachments)+          then Nothing+          else Just $ B.withDefAttr clientMessageAttr $ vBox+                 [ B.txt ("  [attached: `" <> a^.attachmentName <> "`]")+                 | a <- toList (msg^.mAttachments)+                 ]+        msgReac = if Map.null (msg^.mReactions) || (not mdShowReactions)+          then Nothing+          else let renderR e us =+                       let n = Set.size us+                       in if | n == 1    -> " [" <> e <> "]"+                             | n > 1     -> " [" <> e <> " " <> T.pack (show n) <> "]"+                             | otherwise -> ""+                   reactionMsg = Map.foldMapWithKey renderR (msg^.mReactions)+               in Just $ B.withDefAttr emojiAttr $ B.txt ("   " <> reactionMsg)+        withParent p =+            case mdThreadState of+                NoThread -> msgWidget+                InThreadShowParent -> p B.<=> replyIndent+                InThread -> replyIndent+    in if not mdRenderReplyParent+       then msgWidget+       else case msg^.mInReplyToMsg of+          NotAReply -> msgWidget+          InReplyTo _ ->+              case mdParentMessage of+                  Nothing -> withParent (B.str "[loading...]")+                  Just pm ->+                      let parentMsg = renderMessage md+                            { mdShowOlderEdits    = False+                            , mdMessage           = pm+                            , mdUserName          = mdParentUserName+                            , mdParentMessage     = Nothing+                            , mdRenderReplyParent = False+                            , mdIndentBlocks      = False+                            }+                      in withParent (addEllipsis $ B.forceAttr replyParentAttr parentMsg)++    where+        layout :: HighlightSet -> Maybe Int -> [Widget Name] -> Seq RichTextBlock+               -> ViewL RichTextBlock -> Widget Name+        layout hs w nameElems bs xs | length xs > 1     = multiLnLayout hs w nameElems bs+        layout hs w nameElems bs (Blockquote {} :< _) = multiLnLayout hs w nameElems bs+        layout hs w nameElems bs (CodeBlock {} :< _)  = multiLnLayout hs w nameElems bs+        layout hs w nameElems bs (HTMLBlock {} :< _)  = multiLnLayout hs w nameElems bs+        layout hs w nameElems bs (List {} :< _)       = multiLnLayout hs w nameElems bs+        layout hs w nameElems bs (Para inlns :< _)+            | F.any breakCheck inlns                    = multiLnLayout hs w nameElems bs+        layout hs w nameElems bs _                      = nameNextToMessage hs w nameElems bs++        multiLnLayout hs w nameElems bs =+            if mdIndentBlocks+               then vBox [ hBox nameElems+                         , hBox [B.txt "  ", renderRichText mdMyUsername hs ((subtract 2) <$> w) mdWrapNonhighlightedCodeBlocks bs]+                         ]+               else nameNextToMessage hs w nameElems bs++        nameNextToMessage hs w nameElems bs =+            Widget Fixed Fixed $ do+                nameResult <- render $ hBox nameElems+                let newW = subtract (V.imageWidth (nameResult^.imageL)) <$> w+                render $ hBox [raw (nameResult^.imageL), renderRichText mdMyUsername hs newW mdWrapNonhighlightedCodeBlocks bs]++        breakCheck e = eData e `elem` [ELineBreak, ESoftBreak]++addEllipsis :: Widget a -> Widget a+addEllipsis w = B.Widget (B.hSize w) (B.vSize w) $ do+    ctx <- B.getContext+    let aw = ctx^.B.availWidthL+    result <- B.render w+    let withEllipsis = (B.hLimit (aw - 3) $ B.vLimit 1 $ (B.Widget B.Fixed B.Fixed $ return result)) <+>+                       B.str "..."+    if (V.imageHeight (result^.B.imageL) > 1) || (V.imageWidth (result^.B.imageL) == aw) then+        B.render withEllipsis else+        return result++-- Cursor sentinel for tracking the user's cursor position in previews.+cursorSentinel :: Char+cursorSentinel = '‸'++-- Render markdown with username highlighting+renderRichText :: Text -> HighlightSet -> Maybe Int -> Bool -> Seq RichTextBlock -> Widget a+renderRichText curUser hSet w wrap bs =+    runReader (do+              blocks <- mapM blockToWidget (addBlankLines bs)+              return $ B.vBox $ toList blocks)+              (DrawCfg { drawCurUser = curUser+                       , drawHighlightSet = hSet+                       , drawLineWidth = w+                       , drawDoLineWrapping = wrap+                       })++-- Add blank lines only between adjacent elements of the same type, to+-- save space+addBlankLines :: Seq RichTextBlock -> Seq RichTextBlock+addBlankLines = go' . viewl+  where go' EmptyL = S.empty+        go' (x :< xs) = go x (viewl xs)+        go a@Para {} (b@Para {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@Header {} (b@Header {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@Blockquote {} (b@Blockquote {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@List {} (b@List {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@CodeBlock {} (b@CodeBlock {} :< rs) =+             a <| blank <| go b (viewl rs)+        go a@HTMLBlock {} (b@HTMLBlock {} :< rs) =+             a <| blank <| go b (viewl rs)+        go x (y :< rs) = x <| go y (viewl rs)+        go x (EmptyL) = S.singleton x+        blank = Para (S.singleton (Element Normal ESpace))++-- Render text to markdown without username highlighting or permalink detection+renderText :: Text -> Widget a+renderText txt = renderText' Nothing "" emptyHSet txt++renderText' :: Maybe TeamBaseURL -> Text -> HighlightSet -> Text -> Widget a+renderText' baseUrl curUser hSet t = renderRichText curUser hSet Nothing True rtBs+  where rtBs = parseMarkdown baseUrl t++vBox :: F.Foldable f => f (Widget a) -> Widget a+vBox = B.vBox . toList++hBox :: F.Foldable f => f (Widget a) -> Widget a+hBox = B.hBox . toList++header :: Int -> Widget a+header n = B.txt (T.replicate n "#")++maybeHLimit :: Maybe Int -> Widget a -> Widget a+maybeHLimit Nothing w = w+maybeHLimit (Just i) w = hLimit i w++type M a = Reader DrawCfg a++data DrawCfg =+    DrawCfg { drawCurUser :: Text+            , drawHighlightSet :: HighlightSet+            , drawLineWidth :: Maybe Int+            , drawDoLineWrapping :: Bool+            }++blockToWidget :: RichTextBlock -> M (Widget a)+blockToWidget (Para is) =+    toElementChunk is+blockToWidget (Header n is) = do+    headerTxt <- withReader (\c -> c { drawLineWidth = subtract 1 <$> drawLineWidth c }) $+                 toElementChunk is+    return $ B.withDefAttr clientHeaderAttr $+        hBox [ B.padRight (B.Pad 1) $ header n+             , headerTxt+             ]+blockToWidget (Blockquote is) = do+    w <- asks drawLineWidth+    bs <- mapM blockToWidget is+    return $ maybeHLimit w $ addQuoting $ vBox bs+blockToWidget (List _ l bs) = do+    w <- asks drawLineWidth+    lst <- blocksToList l bs+    return $ maybeHLimit w lst+blockToWidget (CodeBlock ci tx) = do+    hSet <- asks drawHighlightSet++    let f = maybe rawCodeBlockToWidget+                  (codeBlockToWidget (hSyntaxMap hSet))+                  mSyntax+        mSyntax = do+            lang <- codeBlockLanguage ci+            Sky.lookupSyntax lang (hSyntaxMap hSet)+    f tx+blockToWidget (HTMLBlock t) = do+    w <- asks drawLineWidth+    return $ maybeHLimit w $ textWithCursor t+blockToWidget (HRule) = do+    w <- asks drawLineWidth+    return $ maybeHLimit w $ B.vLimit 1 (B.fill '*')++quoteChar :: Char+quoteChar = '>'++addQuoting :: B.Widget n -> B.Widget n+addQuoting w =+    B.Widget B.Fixed (B.vSize w) $ do+        ctx <- B.getContext+        childResult <- B.render $ B.hLimit (ctx^.B.availWidthL - 2) w++        let quoteBorder = B.raw $ V.charFill (ctx^.B.attrL) quoteChar 1 height+            height = V.imageHeight $ childResult^.B.imageL++        B.render $ B.hBox [ B.padRight (B.Pad 1) quoteBorder+                          , B.Widget B.Fixed B.Fixed $ return childResult+                          ]++codeBlockToWidget :: Sky.SyntaxMap -> Sky.Syntax -> Text -> M (Widget a)+codeBlockToWidget syntaxMap syntax tx = do+    let result = Sky.tokenize cfg syntax tx+        cfg = Sky.TokenizerConfig syntaxMap False+    case result of+        Left _ -> rawCodeBlockToWidget tx+        Right tokLines -> do+            let padding = B.padLeftRight 1 (B.vLimit (length tokLines) B.vBorder)+            return $ (B.txt $ "[" <> Sky.sName syntax <> "]") B.<=>+                     (padding <+> BS.renderRawSource textWithCursor tokLines)++rawCodeBlockToWidget :: Text -> M (Widget a)+rawCodeBlockToWidget tx = do+    wrap <- asks drawDoLineWrapping++    let hPolicy = if wrap then Greedy else Fixed+    return $ B.withDefAttr codeAttr $+        Widget hPolicy Fixed $ do+            c <- B.getContext+            let theLines = expandEmpty <$> T.lines tx+                expandEmpty "" = " "+                expandEmpty s  = s+                wrapFunc = if wrap then wrappedTextWithCursor+                                   else textWithCursor+            renderedText <- render (B.hLimit (c^.B.availWidthL - 3) $ B.vBox $+                                    wrapFunc <$> theLines)++            let textHeight = V.imageHeight $ renderedText^.imageL+                padding = B.padLeftRight 1 (B.vLimit textHeight B.vBorder)++            render $ padding <+> (Widget Fixed Fixed $ return renderedText)++toElementChunk :: Seq Element -> M (Widget a)+toElementChunk es = do+    w <- asks drawLineWidth+    hSet <- asks drawHighlightSet+    curUser <- asks drawCurUser++    return $ B.Widget B.Fixed B.Fixed $ do+        ctx <- B.getContext+        let width = fromMaybe (ctx^.B.availWidthL) w+            ws    = fmap (renderElementSeq curUser) (wrapLine width hSet es)+        B.render (vBox (fmap hBox ws))++blocksToList :: ListType -> Seq (Seq RichTextBlock) -> M (Widget a)+blocksToList lt bs = do+    let is = case lt of+          Bullet _ -> repeat ("• ")+          Numbered Period s ->+            [ T.pack (show (n :: Int)) <> ". " | n <- [s..] ]+          Numbered Paren s ->+            [ T.pack (show (n :: Int)) <> ") " | n <- [s..] ]++    results <- forM (zip is $ F.toList bs) $ \(i, b) -> do+        blocks <- mapM blockToWidget b+        return $ B.txt i <+> vBox blocks++    return $ vBox results++data SplitState = SplitState+  { splitChunks  :: Seq (Seq Element)+  , splitCurrCol :: Int+  }++wrapLine :: Int -> HighlightSet -> Seq Element -> Seq (Seq Element)+wrapLine maxCols hSet = splitChunks . go (SplitState (S.singleton S.empty) 0)+  where go st (viewl-> e :< es) = go st' es+          where+              HighlightSet { hUserSet = uSet, hChannelSet = cSet } = hSet++              -- Right before we check the width of the token, we see+              -- if the token is a user or channel reference. If so, we+              -- check if it is valid. If it is valid, we leave it in+              -- place; otherwise we translate it into an ordinary text+              -- element so that it does not render highlighted as a+              -- valid user or channel reference.+              newElement = e { eData = newEData }+              newEData = case eData e of+                  EUser u ->+                      if u `Set.member` uSet+                      then EUser u+                      else EText $ userSigil <> u+                  EChannel c ->+                      if c `Set.member` cSet+                      then EChannel c+                      else EText $ normalChannelSigil <> c+                  d -> d++              addHyperlink url el = setElementStyle (Hyperlink url (eStyle el)) el++              linkOpenBracket = Element Normal (EText "<")+              linkCloseBracket = Element Normal (EText ">")+              addOpenBracket l =+                  case Seq.viewl l of+                      EmptyL -> l+                      h :< t ->+                          let h' = Element Normal+                                           (ENonBreaking $ Seq.fromList [linkOpenBracket, h])+                          in h' <| t+              addCloseBracket l =+                  case Seq.viewr l of+                      EmptyR -> l+                      h :> t ->+                          let t' = Element Normal+                                           (ENonBreaking $ Seq.fromList [t, linkCloseBracket])+                          in h |> t'+              decorateLinkLabel = addOpenBracket .  addCloseBracket++              st' =+                  case newEData of+                      EHyperlink url (Just labelEs) ->+                          go st $ addHyperlink url <$> decorateLinkLabel labelEs+                      EHyperlink url Nothing ->+                          go st $ addHyperlink url <$> decorateLinkLabel (Seq.fromList [Element Normal $ EText $ unURL url])+                      EPermalink _tName _pId (Just labelEs) ->+                          go st $ setElementStyle Permalink <$> decorateLinkLabel labelEs+                      EImage url (Just labelEs) ->+                          go st $ addHyperlink url <$> decorateLinkLabel labelEs+                      _ ->+                          if | newEData == ESoftBreak || newEData == ELineBreak ->+                                 st { splitChunks = splitChunks st |> S.empty+                                    , splitCurrCol = 0+                                    }+                             | available >= eWidth ->+                                 st { splitChunks  = addElement newElement (splitChunks st)+                                    , splitCurrCol = splitCurrCol st + eWidth+                                    }+                             | newEData == ESpace ->+                                 st { splitChunks = splitChunks st |> S.empty+                                    , splitCurrCol = 0+                                    }+                             | otherwise ->+                                 st { splitChunks  = splitChunks st |> S.singleton newElement+                                    , splitCurrCol = eWidth+                                    }+              available = maxCols - splitCurrCol st+              eWidth = elementWidth newElement+              addElement x (viewr-> ls :> l) = ( ls |> (l |> x))+              addElement _ _ = error "[unreachable]"+        go st _                 = st++renderElementSeq :: Text -> Seq Element -> Seq (Widget a)+renderElementSeq curUser es = renderElement curUser <$> es++renderElement :: Text -> Element -> Widget a+renderElement curUser e = addStyle sty widget+    where+        sty = eStyle e+        dat = eData e+        addStyle s = case s of+                Normal                  -> id+                Emph                    -> B.withDefAttr clientEmphAttr+                Strikethrough           -> B.withDefAttr strikeThroughAttr+                Strong                  -> B.withDefAttr clientStrongAttr+                Code                    -> B.withDefAttr codeAttr+                Permalink               -> B.withDefAttr permalinkAttr+                Hyperlink (URL url) innerSty ->+                    B.hyperlink url . B.withDefAttr urlAttr .  addStyle innerSty+        rawText = B.txt . removeCursor+        widget = case dat of+            -- Cursor sentinels get parsed as individual text nodes by+            -- Cheapskate, meaning that we get a text node with exactly+            -- one character in it. That's why we compare accordingly+            -- above. In addition, since that character has no width, we+            -- have to replace it with something that has a size (such+            -- as a space) to get Brick's visibility logic to scroll the+            -- viewport to get it into view.+            EText t                      -> if t == T.singleton (cursorSentinel)+                                            then B.visible $ B.txt " "+                                            else textWithCursor t++            ESpace                       -> B.txt " "+            EPermalink _ pId mLabel      -> drawPermalink curUser pId mLabel+            ENonBreaking es              -> hBox $ renderElement curUser <$> es+            ERawHtml t                   -> textWithCursor t+            EEditSentinel recent         -> let attr = if recent+                                                       then editedRecentlyMarkingAttr+                                                       else editedMarkingAttr+                                            in B.withDefAttr attr $ B.txt editMarking+            EUser u                      -> colorUsername curUser u $ userSigil <> u+            EChannel c                   -> B.withDefAttr channelNameAttr $+                                            B.txt $ normalChannelSigil <> c+            EHyperlink (URL url) Nothing -> rawText url+            EImage (URL url) Nothing     -> rawText url+            EEmoji em                    -> B.withDefAttr emojiAttr $+                                            B.txt $ ":" <> em <> ":"++            -- Hyperlink and image nodes with labels should not appear+            -- at this point because line-wrapping should break them up+            -- into normal text node sequences with hyperlink styles+            -- attached.+            EHyperlink {}                -> rawText "(Report renderElement bug #1)"+            EImage {}                    -> rawText "(Report renderElement bug #2)"++            -- Line breaks should never need to get rendered since the+            -- line-wrapping algorithm removes them.+            ESoftBreak                   -> B.emptyWidget+            ELineBreak                   -> B.emptyWidget++drawPermalink :: Text -> PostId -> Maybe (Seq Element) -> Widget a+drawPermalink _ _ Nothing =+    B.txt permalinkPlaceholder+drawPermalink curUser _ (Just label) =+    hBox $ F.toList $ B.txt "<" <| (renderElementSeq curUser label |> B.txt ">")++permalinkPlaceholder :: Text+permalinkPlaceholder = "<post link>"++textWithCursor :: Text -> Widget a+textWithCursor t+    | T.any (== cursorSentinel) t = B.visible $ B.txt $ removeCursor t+    | otherwise = B.txt t++wrappedTextWithCursor :: Text -> Widget a+wrappedTextWithCursor t+    | T.any (== cursorSentinel) t = B.visible $ B.txtWrap $ removeCursor t+    | otherwise = B.txtWrap t++removeCursor :: Text -> Text+removeCursor = T.filter (/= cursorSentinel)++editMarking :: Text+editMarking = "(edited)"++elementWidth :: Element -> Int+elementWidth e =+    case eData e of+        ENonBreaking es              -> sum $ elementWidth <$> es+        EText t                      -> B.textWidth t+        ERawHtml t                   -> B.textWidth t+        EUser t                      -> T.length userSigil + B.textWidth t+        EChannel t                   -> T.length normalChannelSigil + B.textWidth t+        EEditSentinel _              -> B.textWidth editMarking+        EImage (URL url) Nothing     -> B.textWidth url+        EImage _ (Just is)           -> sum $ elementWidth <$> is+        EHyperlink (URL url) Nothing -> B.textWidth url+        EHyperlink _ (Just is)       -> sum $ elementWidth <$> is+        EEmoji t                     -> B.textWidth t + 2+        EPermalink _ _ Nothing       -> T.length permalinkPlaceholder+        EPermalink _ _ (Just label)  -> 2 + (sum $ elementWidth <$> label)+        ESpace                       -> 1+        ELineBreak                   -> 0+        ESoftBreak                   -> 0
+ src/Matterhorn/Draw/ShowHelp.hs view
@@ -0,0 +1,566 @@+module Matterhorn.Draw.ShowHelp+  ( drawShowHelp+  , keybindingMarkdownTable+  , keybindingTextTable+  , commandTextTable+  , commandMarkdownTable+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Themes ( themeDescriptions )+import           Brick.Widgets.Center ( hCenter )+import           Brick.Widgets.List ( listSelectedFocusedAttr )+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( singular, _Just, _2 )++import           Network.Mattermost.Version ( mmApiVersion )++import           Matterhorn.Command+import           Matterhorn.Events+import           Matterhorn.Events.ChannelSelect+import           Matterhorn.Events.Keybindings+import           Matterhorn.Events.Main+import           Matterhorn.Events.MessageSelect+import           Matterhorn.Events.ThemeListOverlay+import           Matterhorn.Events.PostListOverlay+import           Matterhorn.Events.ShowHelp+import           Matterhorn.Events.UrlSelect+import           Matterhorn.Events.UserListOverlay+import           Matterhorn.Events.ChannelListOverlay+import           Matterhorn.Events.ReactionEmojiListOverlay+import           Matterhorn.Events.ManageAttachments+import           Matterhorn.Events.TabbedWindow+import           Matterhorn.Windows.ViewMessage+import           Matterhorn.HelpTopics ( helpTopics )+import           Matterhorn.Draw.RichText ( renderText )+import           Matterhorn.Options ( mhVersion )+import           Matterhorn.State.Editing ( editingKeyHandlers )+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents ( BindingState(..), Binding(..)+                                 , ppBinding, nonCharKeys, eventToBinding )+++drawShowHelp :: HelpTopic -> ChatState -> [Widget Name]+drawShowHelp topic st =+    [helpBox (helpTopicViewportName topic) $ helpTopicDraw topic st]++helpTopicDraw :: HelpTopic -> ChatState -> Widget Name+helpTopicDraw topic st =+    overrideAttr codeAttr helpEmphAttr $+    hCenter $+    hLimit helpContentWidth $+    case helpTopicScreen topic of+        MainHelp -> mainHelp (configUserKeys (st^.csResources.crConfiguration))+        ScriptHelp -> scriptHelp+        ThemeHelp -> themeHelp+        SyntaxHighlightHelp -> syntaxHighlightHelp (configSyntaxDirs $ st^.csResources.crConfiguration)+        KeybindingHelp -> keybindingHelp (configUserKeys (st^.csResources.crConfiguration))++mainHelp :: KeyConfig -> Widget Name+mainHelp kc = summary+  where+    summary = vBox entries+    entries = [ heading $ T.pack mhVersion+              , headingNoPad $ T.pack mmApiVersion+              , heading "Help Topics"+              , drawHelpTopics+              , heading "Commands"+              , padTop (Pad 1) mkCommandHelpText+              , heading "Keybindings"+              ] <>+              (mkKeybindingHelp kc <$> keybindSections)++    mkCommandHelpText :: Widget Name+    mkCommandHelpText =+      let commandNameWidth = 2 + (maximum $ T.length <$> fst <$> commandHelpInfo)+      in vBox [ (emph $ txt $ padTo commandNameWidth info) <+> renderText desc+              | (info, desc) <- commandHelpInfo+              ]++commandHelpInfo :: [(T.Text, T.Text)]+commandHelpInfo = pairs+    where+        pairs = [ (info, desc)+                | Cmd cmd desc args _ <- cs+                , let argSpec = printArgSpec args+                      spc = if T.null argSpec then "" else " "+                      info = T.cons '/' cmd <> spc <> argSpec+                ]+        cs = sortWith commandName commandList++commandTextTable :: T.Text+commandTextTable =+    let commandNameWidth = 4 + (maximum $ T.length <$> fst <$> commandHelpInfo)+    in T.intercalate "\n" $+       [ padTo commandNameWidth info <> desc+       | (info, desc) <- commandHelpInfo+       ]++commandMarkdownTable :: T.Text+commandMarkdownTable =+    T.intercalate "\n" $+    [ "# Commands"+    , ""+    , "| Command | Description |"+    , "| ------- | ----------- |"+    ] <>+    [ "| `" <> info <> "` | " <> desc <> " |"+    | (info, desc) <- commandHelpInfo+    ]++drawHelpTopics :: Widget Name+drawHelpTopics =+    let allHelpTopics = drawTopic <$> helpTopics+        topicNameWidth = 4 + (maximum $ T.length <$> helpTopicName <$> helpTopics)+        drawTopic t = (emph $ txt (padTo topicNameWidth $ helpTopicName t)) <+>+                      txt (helpTopicDescription t)+    in vBox $ (padBottom (Pad 1) $+               para "Learn more about these topics with `/help <topic>`:")+            : allHelpTopics++helpContentWidth :: Int+helpContentWidth = 72++scriptHelp :: Widget Name+scriptHelp = heading "Using Scripts" <=> vBox scriptHelpText+  where scriptHelpText = map paraL+          [ [ "Matterhorn has a special feature that allows you to use "+             , "prewritten shell scripts to preprocess messages. "+             , "For example, this can allow you to run various filters over "+             , "your written text, do certain kinds of automated formatting, "+             , "or just automatically cowsay-ify a message." ]+           , [ "These scripts can be any kind of executable file, "+             , "as long as the file lives in "+             , "*~/.config/matterhorn/scripts* (unless you've explicitly "+             , "moved your XDG configuration directory elsewhere). "+             , "Those executables are given no arguments "+             , "on the command line and are passed your typed message on "+             , "*stdin*; whatever they produce on *stdout* is sent "+             , "as a message. If the script exits successfully, then everything "+             , "that appeared on *stderr* is discarded; if it instead exits with "+             , "a failing exit code, your message is *not* sent, and you are "+             , "presented with whatever was printed on stderr as a "+             , "local error message." ]+           , [ "To run a script, simply type" ]+           , [ "> *> /sh [script-name] [my-message]*" ]+           , [ "And the script named *[script-name]* will be invoked with "+             , "the text of *[my-message]*. If the script does not exist, "+             , "or if it exists but is not marked as executable, you'll be "+             , "presented with an appropriate error message." ]+           , [ "For example, if you want to use a basic script to "+             , "automatically ROT13 your message, you can write a shell "+             , "script using the standard Unix *tr* utility, like this:" ]+           , [ "> *#!/bin/bash -e*"+             , "> *tr '[A-Za-z]' '[N-ZA-Mn-za-m]'*" ]+           , [ "Move this script to *~/.config/matterhorn/scripts/rot13* "+             , "and be sure it's executable with" ]+           , [ "> *$ chmod u+x ~/.config/matterhorn/scripts/rot13*" ]+           , [ "after which you can send ROT13 messages with the "+             , "Matterhorn command " ]+           , [ "> *> /sh rot13 Hello, world!*" ]+           ]++keybindingMarkdownTable :: KeyConfig -> Text+keybindingMarkdownTable kc = title <> keybindSectionStrings+    where title = "# Keybindings\n"+          keybindSectionStrings = T.concat $ sectionText <$> keybindSections+          sectionText = mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines mkHeading+          mkHeading n =+              "\n# " <> n <>+              "\n| Keybinding | Event Name | Description |" <>+              "\n| ---------- | ---------- | ----------- |"++keybindingTextTable :: KeyConfig -> Text+keybindingTextTable kc = title <> keybindSectionStrings+    where title = "Keybindings\n===========\n"+          keybindSectionStrings = T.concat $ sectionText <$> keybindSections+          sectionText = mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines mkHeading+          keybindingWidth = 15+          eventNameWidth = 30+          mkHeading n =+              "\n" <> n <>+              "\n" <> (T.replicate (T.length n) "=")++keybindingHelp :: KeyConfig -> Widget Name+keybindingHelp kc = vBox $+  [ heading "Configurable Keybindings"+  , padBottom (Pad 1) $ vBox keybindingHelpText+  ] ++ keybindSectionWidgets+    +++  [ headingNoPad "Keybinding Syntax"+  , vBox validKeys+  ]+  where keybindSectionWidgets = sectionWidget <$> keybindSections+        sectionWidget = mkKeybindEventSectionHelp kc keybindEventHelpWidget vBox headingNoPad++        keybindingHelpText = map paraL+          [ [ "Many of the keybindings used in Matterhorn can be "+            , "modified from within Matterhorn's **config.ini** file. "+            , "To do this, include a section called **[KEYBINDINGS]** "+            , "in your config file and use the event names listed below as "+            , "keys and the desired key sequence as values. "+            , "See the end of this page for documentation on the valid "+            , "syntax for key sequences."+            ]+          , [ "For example, by default, the keybinding to move to the next "+            , "channel in the public channel list is **"+            , nextChanBinding+            , "**, and the corresponding "+            , "previous channel binding is **"+            , prevChanBinding+            , "**. You might want to remap these "+            , "to other keys: say, **C-j** and **C-k**. We can do this with the following "+            , "configuration snippet:"+            ]+          , [ "```ini\n"+            , "[KEYBINDINGS]\n"+            , "focus-next-channel = C-j\n"+            , "focus-prev-channel = C-k\n"+            , "```"+            ]+          , [ "You can remap a command to more than one key sequence, in which "+            , "case any one of the key sequences provided can be used to invoke "+            , "the relevant command. To do this, provide the desired bindings as "+            , "a comma-separated list. Additionally, some key combinations are "+            , "used in multiple modes (such as URL select or help viewing) and "+            , "therefore share the same name, such as **cancel** or **scroll-up**."+            ]+          , [ "Additionally, some keys simply cannot be remapped, mostly in the "+            , "case of editing keybindings. If you feel that a particular key "+            , "event should be rebindable and isn't, then please feel free to "+            , "let us know by posting an issue in the Matterhorn issue tracker."+            ]+          , [ "It is also possible to entirely unbind a key event by setting its "+            , "key to **unbound**, thus avoiding conflicts between default bindings "+            , "and new ones:"+            ]+          , [ "```ini\n"+            , "[KEYBINDINGS]\n"+            , "focus-next-channel = unbound\n"+            , "```"+            ]+          , [ "The rebindable key events, along with their **current** "+            , "values, are as follows:"+            ]+           ]+        nextChanBinding = ppBinding (getFirstDefaultBinding NextChannelEvent)+        prevChanBinding = ppBinding (getFirstDefaultBinding PrevChannelEvent)+        validKeys = map paraL+          [ [ "The syntax used for key sequences consists of zero or more "+            , "single-character modifier characters followed by a keystroke, "+            , "all separated by dashes. The available modifier keys are "+            , "**S** for Shift, **C** for Ctrl, **A** for Alt, and **M** for "+            , "Meta. So, for example, **"+            , ppBinding (Binding [] (Vty.KFun 2))+            , "** is the F2 key pressed with no "+            , "modifier keys; **"+            , ppBinding (Binding [Vty.MCtrl] (Vty.KChar 'x'))+            , "** is Ctrl and X pressed together, "+            , "and **"+            , ppBinding (Binding [Vty.MShift, Vty.MCtrl] (Vty.KChar 'x'))+            , "** is Shift, Ctrl, and X all pressed together. "+            , "Although Matterhorn will pretty-print all key combinations "+            , "with specific capitalization, the parser is **not** case-sensitive "+            , "and will ignore any capitalization."+            ]+          , [ "Your terminal emulator might not recognize some particular "+            , "keypress combinations, or it might reserve certain combinations of "+            , "keys for some terminal-specific operation. Matterhorn does not have a "+            , "reliable way of testing this, so it is up to you to avoid setting "+            , "keybindings that your terminal emulator does not deliver to applications."+            ]+          , [ "Letter keys, number keys, and function keys are specified with "+            , "their obvious name, such as **x** for the X key, **8** for the 8 "+            , "key, and **f5** for the F5 key. Other valid keys include: "+            , T.intercalate ", " [ "**" <> key <> "**" | key <- nonCharKeys ]+            , "."+            ]+          ]++emph :: Widget a -> Widget a+emph = withDefAttr helpEmphAttr++para :: Text -> Widget a+para t = padTop (Pad 1) $ renderText t++paraL :: [Text] -> Widget a+paraL = para . mconcat++heading :: Text -> Widget a+heading = padTop (Pad 1) . headingNoPad++headingNoPad :: Text -> Widget a+headingNoPad t = hCenter $ emph $ renderText t++syntaxHighlightHelp :: [FilePath] -> Widget a+syntaxHighlightHelp dirs = vBox+  [ heading "Syntax Highlighting"++  , para $ "Matterhorn supports syntax highlighting in Markdown code blocks when the " <>+           "name of the code block language follows the block opening sytnax:"+  , para $ "```<language>"+  , para $ "The possible values of `language` are determined by the available syntax " <>+           "definitions. The available definitions are loaded from the following " <>+           "directories according to the configuration setting `syntaxDirectories`. " <>+           "If the setting is omitted, it defaults to the following sequence of directories:"+  , para $ T.pack $ intercalate "\n" $ (\d -> "`" <> d <> "`") <$> dirs+  , para $ "Syntax definitions are in the Kate XML format. Files with an " <>+           "`xml` extension are loaded from each directory, with directories earlier " <>+           "in the list taking precedence over later directories when more than one " <>+           "directory provides a definition file for the same syntax."+  , para $ "To place custom definitions in a directory, place a Kate " <>+           "XML syntax definition in the directory and ensure that a copy of " <>+           "`language.dtd` is also present. The file `language.dtd` can be found in " <>+           "the `syntax/` directory of your Matterhorn distribution."+  ]++themeHelp :: Widget a+themeHelp = vBox+  [ heading "Using Themes"+  , para "Matterhorn provides these built-in color themes:"+  , padTop (Pad 1) $ vBox $ hCenter <$> emph <$>+                            txt <$> internalThemeName <$> internalThemes+  , para $+        "These themes can be selected with the */theme* command. To automatically " <>+        "select a theme at startup, set the *theme* configuration file option to one " <>+        "of the themes listed above."++  , heading "Customizing the Theme"+  , para $+        "Theme customization is also supported. To customize the selected theme, " <>+        "create a theme customization file and set the `themeCustomizationFile` " <>+        "configuration option to the path to the customization file. If the path " <>+        "to the file is relative, Matterhorn will look for it in the same directory " <>+        "as the Matterhorn configuration file."++  , para $+        "Theme customization files are INI-style files that can customize any " <>+        "foreground color, background color, or style of any aspect of the " <>+        "Matterhorn user interface. Here is an example:"++  , para $+        "```\n" <>+        "[default]\n" <>+        "default.fg = blue\n" <>+        "default.bg = black\n" <>+        "\n" <>+        "[other]\n" <>+        attrNameToConfig codeAttr <> ".fg = magenta\n" <>+        attrNameToConfig codeAttr <> ".style = bold\n" <>+        attrNameToConfig clientEmphAttr <> ".fg = cyan\n" <>+        attrNameToConfig clientEmphAttr <> ".style = [bold, underline]\n" <>+        attrNameToConfig listSelectedFocusedAttr <> ".fg = brightGreen\n" <>+        "```"++  , para $+        "In the example above, the theme's default foreground and background colors " <>+        "are both customized to *blue* and *black*, respectively. The *default* section " <>+        "contains only customizations for the *default* attribute. All other customizations " <>+        "go in the *other* section. We can also set the style for attributes; we can either " <>+        "set just one style (as with the bold setting above) or multiple styles at once " <>+        "(as in the bold/underline example).\n"++  , para $+        "Available colors are:\n" <>+        " * black\n" <>+        " * red\n" <>+        " * green\n" <>+        " * yellow\n" <>+        " * blue\n" <>+        " * magenta\n" <>+        " * cyan\n" <>+        " * white\n" <>+        " * brightBlack\n" <>+        " * brightRed\n" <>+        " * brightGreen\n" <>+        " * brightYellow\n" <>+        " * brightBlue\n" <>+        " * brightMagenta\n" <>+        " * brightCyan\n" <>+        " * brightWhite"++  , para $+        "Available styles are:\n" <>+        " * standout\n" <>+        " * underline\n" <>+        " * italic\n" <>+        " * strikethrough\n" <>+        " * reverseVideo\n" <>+        " * blink\n" <>+        " * dim\n" <>+        " * bold\n"++  , para $+        "It is also possible to specify RGB values using HTML syntax: `#RRGGBB`. " <>+        "Bear in mind that such colors are clamped to the nearest 256-color palette " <>+        "entry, so it is not possible to get the exact color specified.\n\n" <>+        "In addition, a special value of *default* is possible for either color " <>+        "setting of an attribute. This value indicates that the attribute should " <>+        "use the terminal emulator's default foreground or background color of " <>+        "choice rather than a specific ANSI color."++  , heading "Username Highlighting"+  , para $+        "Username colors are chosen by hashing each username and then using the hash " <>+        "to choose a color from a list of predefined username colors. If you would like " <>+        "to change the color in a given entry of this list, we provide the " <>+        "\"username.N\" attributes, where N is the index in the username color list."++  , heading "Theme Attributes"+  , para $+        "This section lists all possible theme attributes for use in customization " <>+        "files along with a description of how each one is used in Matterhorn. Each " <>+        "option listed can be set in the *other* section of the customization file. " <>+        "Each provides three customization settings:"++  , para $+        " * *<option>.fg = <color>*\n" <>+        " * *<option>.bg = <color>*\n" <>+        " * *<option>.style = <style>* or *<option>.style = [<style>, ...]*\n"++  , let names = sort $+                 (\(n, msg) -> (n, attrNameToConfig n, msg)) <$>+                 (M.toList $ themeDescriptions themeDocs)+        mkEntry (n, opt, msg) =+            padTop (Pad 1) $+            vBox [ hBox [ withDefAttr clientEmphAttr $ txt opt+                        , padLeft Max $ forceAttr n $ txt "(demo)"+                        ]+                 , txt msg+                 ]+    in vBox $ mkEntry <$> names+  ]++keybindSections :: [(Text, [KeyEventHandler])]+keybindSections =+    [ ("Global Keybindings", globalKeyHandlers)+    , ("Help Page", helpKeyHandlers)+    , ("Main Interface", mainKeyHandlers)+    , ("Text Editing", editingKeyHandlers (csEditState.cedEditor))+    , ("Channel Select Mode", channelSelectKeyHandlers)+    , ("Message Select Mode", messageSelectKeyHandlers)+    , ("User Listings", userListOverlayKeyHandlers)+    , ("URL Select Mode", urlSelectKeyHandlers)+    , ("Theme List Window", themeListOverlayKeyHandlers)+    , ("Channel Search Window", channelListOverlayKeyHandlers)+    , ("Message Viewer: Common", tabbedWindowKeyHandlers (csViewedMessage.singular _Just._2))+    , ("Message Viewer: Message tab", viewMessageKeyHandlers)+    , ("Message Viewer: Reactions tab", viewMessageReactionsKeyHandlers)+    , ("Attachment List", attachmentListKeyHandlers)+    , ("Attachment File Browser", attachmentBrowseKeyHandlers)+    , ("Flagged Messages", postListOverlayKeyHandlers)+    , ("Reaction Emoji Search Window", reactionEmojiListOverlayKeyHandlers)+    ]++helpBox :: Name -> Widget Name -> Widget Name+helpBox n helpText =+    withDefAttr helpAttr $+    viewport HelpViewport Vertical $+    cached n helpText++kbColumnWidth :: Int+kbColumnWidth = 14++kbDescColumnWidth :: Int+kbDescColumnWidth = 60++mkKeybindingHelp :: KeyConfig -> (Text, [KeyEventHandler]) -> Widget Name+mkKeybindingHelp kc (sectionName, kbs) =+    (heading sectionName) <=>+    (padTop (Pad 1) $ hCenter $ vBox $ snd <$> sortWith fst results)+    where+        results = mkKeybindHelp kc <$> kbs++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++        rendering = (emph $ 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, [KeyEventHandler])+                          -> a+mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) =+  vertCat $ (mkHeading sectionName) :+            (mkKeybindHelpFunc <$> (mkKeybindEventHelp kc <$> kbs))++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 -> emph $ txt s+    in padBottom (Pad 1) $+       vBox [ txtWrap ("; " <> desc)+            , label <+> txt (" = " <> evText)+            ]++keybindEventHelpMarkdown :: (Either Text Text, Text, [Text]) -> Text+keybindEventHelpMarkdown (evName, desc, evs) =+    let quote s = "`" <> s <> "`"+        name = case evName of+            Left s -> s+            Right s -> quote s+    in "| " <> (T.intercalate ", " $ quote <$> evs) <>+       " | " <> name <>+       " | " <> desc <>+       " |"++keybindEventHelpText :: Int -> Int -> (Either Text Text, Text, [Text]) -> Text+keybindEventHelpText width eventNameWidth (evName, desc, evs) =+    let name = case evName of+            Left s -> s+            Right s -> s+    in padTo width (T.intercalate ", " evs) <> " " <>+       padTo eventNameWidth name <> " " <>+       desc++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/Matterhorn/Draw/TabbedWindow.hs view
@@ -0,0 +1,77 @@+module Matterhorn.Draw.TabbedWindow+  ( drawTabbedWindow+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import           Data.List ( intersperse )+import qualified Graphics.Vty as Vty++import           Matterhorn.Draw.Util ( renderKeybindingHelp )+import           Matterhorn.Types+import           Matterhorn.Themes+import           Matterhorn.Types.KeyEvents++-- | Render a tabbed window.+drawTabbedWindow :: (Eq a, Show a)+                 => TabbedWindow a+                 -> ChatState+                 -> Widget Name+drawTabbedWindow w cs =+    let cur = getCurrentTabbedWindowEntry w+        tabBody = tweRender cur (twValue w) cs+        title = forceAttr clientEmphAttr $ twtTitle (twTemplate w) (tweValue cur)+    in centerLayer $+       vLimit (twWindowHeight w) $+       hLimit (twWindowWidth w) $+       joinBorders $+       borderWithLabel title $+       (tabBar w <=> tabBody <=> hBorder <=> hCenter keybindingHelp)++-- | Keybinding help to show at the bottom of a tabbed window.+keybindingHelp :: Widget Name+keybindingHelp =+    let pairs = [ ("Switch tabs", [SelectNextTabEvent, SelectPreviousTabEvent])+                , ("Scroll", [ScrollUpEvent, ScrollDownEvent, ScrollLeftEvent, ScrollRightEvent, PageLeftEvent, PageRightEvent])+                ]+    in hBox $ intersperse (txt "  ") $ (uncurry renderKeybindingHelp) <$> pairs++-- | The scrollable tab bar to show at the top of a tabbed window.+tabBar :: (Eq a, Show a)+       => TabbedWindow a+       -> Widget Name+tabBar w =+    let cur = getCurrentTabbedWindowEntry w+        entries = twtEntries (twTemplate w)+        renderEntry e =+            let useAttr = if isCurrent+                          then withDefAttr tabSelectedAttr+                          else withDefAttr tabUnselectedAttr+                isCurrent = tweValue e == tweValue cur+                makeVisible = if isCurrent then visible else id+                decorateTab v = Widget Fixed Fixed $ do+                    result <- render v+                    let width = Vty.imageWidth (result^.imageL)+                    if isCurrent+                       then+                           render $ padBottom (Pad 1) $ raw $ result^.imageL+                       else+                           render $ vBox [raw $ result^.imageL, hLimit width hBorder]+            in makeVisible $+               decorateTab $+               useAttr $+               padLeftRight 2 $+               txt $+               tweTitle e (tweValue e) isCurrent+        contents = Widget Fixed Fixed $ do+            ctx <- getContext+            let width = ctx^.availWidthL+            render $ hBox $ (intersperse divider $ renderEntry <$> entries) <>+                            [divider, padTop (Pad 1) $ hLimit width hBorder]+        divider = vLimit 1 vBorder <=> joinableBorder (Edges True False False False)+    in vLimit 2 $ viewport TabbedWindowTabBar Horizontal contents
+ src/Matterhorn/Draw/ThemeListOverlay.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Matterhorn.Draw.ThemeListOverlay+  ( drawThemeListOverlay+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import qualified Brick.Widgets.List as L+import           Brick.Widgets.Border ( hBorder )+import           Brick.Widgets.Center ( hCenter )++import           Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents ( ppBinding )+import           Matterhorn.Events.Keybindings+++drawThemeListOverlay :: ChatState -> Widget Name+drawThemeListOverlay st =+    let overlay = drawListOverlay (st^.csThemeListOverlay)+                                  (const $ txt "Themes")+                                  (const $ txt "No matching themes found.")+                                  (const $ txt "Search built-in themes:")+                                  renderInternalTheme+                                  (Just footer)+                                  OverlayUpperRight+                                  50+        footer = hBorder <=>+                 (hCenter $ hBox [ enter+                                 , txt $ ":choose theme  "+                                 , close+                                 , txt ":close"+                                 ])+        enter = emph $ txt $ ppBinding (getFirstDefaultBinding ActivateListItemEvent)+        close = emph $ txt $ ppBinding (getFirstDefaultBinding CancelEvent)+        emph = withDefAttr clientEmphAttr+    in joinBorders overlay++renderInternalTheme :: Bool -> InternalTheme -> Widget Name+renderInternalTheme foc it =+    (if foc then forceAttr L.listSelectedFocusedAttr else id) $+    (padRight Max $+     withDefAttr clientEmphAttr $+     txt $ internalThemeName it) <=>+    (vLimit 2 $+     (padLeft (Pad 2) $ txtWrap $ internalThemeDesc it) <=> fill ' ')
+ src/Matterhorn/Draw/URLList.hs view
@@ -0,0 +1,64 @@+module Matterhorn.Draw.URLList+  ( renderUrlList+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border ( hBorder )+import           Brick.Widgets.List ( renderList )+import qualified Data.Foldable as F+import           Lens.Micro.Platform ( to )++import           Network.Mattermost.Types ( ServerTime(..), idString )++import           Matterhorn.Draw.Messages+import           Matterhorn.Draw.Util+import           Matterhorn.Draw.RichText+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Types.RichText ( unURL, TeamURLName(..) )+++renderUrlList :: ChatState -> Widget Name+renderUrlList st =+    header <=> urlDisplay+    where+        header = (withDefAttr channelHeaderAttr $ vLimit 1 $+                 (renderText' Nothing "" (getHighlightSet st) $+                  "URLs: " <> (mkChannelName st (st^.csCurrentChannel.ccInfo))) <+>+                 fill ' ') <=> hBorder++        urlDisplay = if F.length urls == 0+                     then str "No URLs found in this channel."+                     else renderList renderItem True urls++        urls = st^.csUrlList++        me = myUsername st++        renderItem sel link =+          let time = link^.linkTime+          in attr sel $ vLimit 2 $+            (vLimit 1 $+             hBox [ let u = maybe "<server>" id (link^.linkUser.to (nameForUserRef st))+                    in colorUsername me u u+                  , case link^.linkLabel of+                      Nothing -> emptyWidget+                      Just label -> txt ": " <+> hBox (F.toList $ renderElementSeq me label)+                  , fill ' '+                  , renderDate st $ withServerTime time+                  , str " "+                  , renderTime st $ withServerTime time+                  ] ) <=>+            (vLimit 1 (renderLinkTarget (link^.linkTarget)))++        renderLinkTarget (LinkPermalink (TeamURLName tName) pId) =+            renderText $ "Team: " <> tName <> ", post " <> idString pId+        renderLinkTarget (LinkURL url) = renderText $ unURL url+        renderLinkTarget (LinkFileId _) = txt " "++        attr True = forceAttr urlListSelectedAttr+        attr False = id
+ src/Matterhorn/Draw/UserListOverlay.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Matterhorn.Draw.UserListOverlay+  ( drawUserListOverlay+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import qualified Brick.Widgets.List as L+import qualified Data.Text as T+import qualified Graphics.Vty as V++import           Matterhorn.Draw.Util ( userSigilFromInfo )+import           Matterhorn.Draw.ListOverlay ( drawListOverlay, OverlayPosition(..) )+import           Matterhorn.Themes+import           Matterhorn.Types+++drawUserListOverlay :: ChatState -> Widget Name+drawUserListOverlay st =+    let overlay = drawListOverlay (st^.csUserListOverlay) userSearchScopeHeader+                                  userSearchScopeNoResults userSearchScopePrompt+                                  (renderUser (myUsername st))+                                  Nothing+                                  OverlayCenter+                                  80+    in joinBorders overlay++userSearchScopePrompt :: UserSearchScope -> Widget Name+userSearchScopePrompt scope =+    txt $ case scope of+        ChannelMembers _ _    -> "Search channel members:"+        ChannelNonMembers _ _ -> "Search users:"+        AllUsers Nothing      -> "Search users:"+        AllUsers (Just _)     -> "Search team members:"++userSearchScopeNoResults :: UserSearchScope -> Widget Name+userSearchScopeNoResults scope =+    txt $ case scope of+        ChannelMembers _ _    -> "No users in channel."+        ChannelNonMembers _ _ -> "All users in your team are already in this channel."+        AllUsers _            -> "No users found."++userSearchScopeHeader :: UserSearchScope -> Widget Name+userSearchScopeHeader scope =+    txt $ case scope of+        ChannelMembers {}    -> "Channel Members"+        ChannelNonMembers {} -> "Invite Users to Channel"+        AllUsers Nothing     -> "Users On This Server"+        AllUsers (Just _)    -> "Users In My Team"++renderUser :: Text -> Bool -> UserInfo -> Widget Name+renderUser myUName foc ui =+    (if foc then forceAttr L.listSelectedFocusedAttr else id) $+    vLimit 2 $+    padRight Max $+    hBox $ (padRight (Pad 1) $ colorUsername myUName (ui^.uiName) (T.singleton $ userSigilFromInfo ui))+           : (hLimit usernameWidth $ padRight Max $ colorUsername myUName (ui^.uiName) (ui^.uiName))+           : extras+    where+        sanitize = T.strip . T.replace "\t" " "+        usernameWidth = 20+        extras = padRight (Pad 1) <$> catMaybes [mFullname, mNickname, mEmail]+        mFullname = if (not (T.null (ui^.uiFirstName)) || not (T.null (ui^.uiLastName)))+                    then Just $ txt $ (sanitize $ ui^.uiFirstName) <> " " <> (sanitize $ ui^.uiLastName)+                    else Nothing+        mNickname = case ui^.uiNickName of+                      Just n | n /= (ui^.uiName) -> Just $ txt $ "(" <> n <> ")"+                      _ -> Nothing+        mEmail = if (T.null $ ui^.uiEmail)+                 then Nothing+                 else Just $ modifyDefAttr (`V.withURL` ("mailto:" <> ui^.uiEmail)) $+                             withDefAttr urlAttr (txt ("<" <> ui^.uiEmail <> ">"))
+ src/Matterhorn/Draw/Util.hs view
@@ -0,0 +1,103 @@+module Matterhorn.Draw.Util+  ( withBrackets+  , renderTime+  , renderDate+  , renderKeybindingHelp+  , insertDateMarkers+  , getDateFormat+  , mkChannelName+  , userSigilFromInfo+  , multilineHeightLimit+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Data.List ( intersperse )+import qualified Data.Set as Set+import qualified Data.Text as T+import           Lens.Micro.Platform ( to )+import           Network.Mattermost.Types++import           Matterhorn.Constants ( userSigil, normalChannelSigil )+import           Matterhorn.Themes+import           Matterhorn.TimeUtils+import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+import           Matterhorn.Events.Keybindings ( getFirstDefaultBinding )+++defaultTimeFormat :: Text+defaultTimeFormat = "%R"++defaultDateFormat :: Text+defaultDateFormat = "%Y-%m-%d"++multilineHeightLimit :: Int+multilineHeightLimit = 5++getTimeFormat :: ChatState -> Text+getTimeFormat st =+    maybe defaultTimeFormat id (st^.csResources.crConfiguration.to configTimeFormat)++getDateFormat :: ChatState -> Text+getDateFormat st =+    maybe defaultDateFormat id (st^.csResources.crConfiguration.to configDateFormat)++renderTime :: ChatState -> UTCTime -> Widget Name+renderTime st = renderUTCTime (getTimeFormat st) (st^.timeZone)++renderDate :: ChatState -> UTCTime -> Widget Name+renderDate st = renderUTCTime (getDateFormat st) (st^.timeZone)++renderUTCTime :: Text -> TimeZoneSeries -> UTCTime -> Widget a+renderUTCTime fmt tz t =+    if T.null fmt+    then emptyWidget+    else withDefAttr timeAttr (txt $ localTimeText fmt $ asLocalTime tz t)++renderKeybindingHelp :: Text -> [KeyEvent] -> Widget Name+renderKeybindingHelp label evs =+  let ppEv ev = withDefAttr clientEmphAttr $ txt (ppBinding (getFirstDefaultBinding ev))+  in hBox $ (intersperse (txt "/") $ ppEv <$> evs) <> [txt (":" <> label)]++-- | Generates a local matterhorn-only client message that creates a+-- date marker.  The server date is converted to a local time (via+-- timezone), and midnight of that timezone used to generate date+-- markers.  Note that the actual time of the server and this client+-- are still not synchronized, but no manipulations here actually use+-- the client time.+insertDateMarkers :: Messages -> Text -> TimeZoneSeries -> Messages+insertDateMarkers ms datefmt tz = foldr (addMessage . dateMsg) ms dateRange+    where dateRange = foldr checkDateChange Set.empty ms+          checkDateChange m = let msgDay = startOfDay (Just tz) (withServerTime (m^.mDate))+                              in if m^.mDeleted then id else Set.insert msgDay+          dateMsg d = let t = localTimeText datefmt $ asLocalTime tz d+                      in newMessageOfType t (C DateTransition) (ServerTime d)+++withBrackets :: Widget a -> Widget a+withBrackets w = hBox [str "[", w, str "]"]++userSigilFromInfo :: UserInfo -> Char+userSigilFromInfo u = case u^.uiStatus of+    Offline      -> ' '+    Online       -> '+'+    Away         -> '-'+    DoNotDisturb -> '×'+    Other _      -> '?'++mkChannelName :: ChatState -> ChannelInfo -> Text+mkChannelName st c = T.append sigil t+    where+        t = case c^.cdDMUserId >>= flip userById st of+            Nothing -> c^.cdName+            Just u -> u^.uiName+        sigil = case c^.cdType of+            Private   -> mempty+            Ordinary  -> normalChannelSigil+            Group     -> mempty+            Direct    -> userSigil+            Unknown _ -> mempty
+ src/Matterhorn/Emoji.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Matterhorn.Emoji+  ( EmojiCollection+  , loadEmoji+  , emptyEmojiCollection+  , getMatchingEmoji+  , matchesEmoji+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Control.Exception as E+import           Control.Monad.Except+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Foldable as F+import qualified Data.Text as T+import qualified Data.Sequence as Seq++import           Network.Mattermost.Types ( Session )+import qualified Network.Mattermost.Endpoints as MM+++newtype EmojiData = EmojiData (Seq.Seq T.Text)++-- | The collection of all emoji names we loaded from a JSON disk file.+-- You might rightly ask: why don't we use a Trie here, for efficient+-- lookups? The answer is that we need infix lookups; prefix matches are+-- not enough. In practice it seems not to matter that much; despite the+-- O(n) search we get good enough performance that we aren't worried+-- about this. If at some point this becomes an issue, other data+-- structures with good infix lookup performance should be identified+-- (full-text search, perhaps?).+newtype EmojiCollection = EmojiCollection [T.Text]++instance A.FromJSON EmojiData where+    parseJSON = A.withArray "EmojiData" $ \v -> do+        aliasVecs <- forM v $ \val ->+            flip (A.withObject "EmojiData Entry") val $ \obj -> do+                as <- obj A..: "aliases"+                forM as $ A.withText "Alias list element" return++        return $ EmojiData $ mconcat $ F.toList aliasVecs++emptyEmojiCollection :: EmojiCollection+emptyEmojiCollection = EmojiCollection mempty++-- | Load an EmojiCollection from a JSON disk file.+loadEmoji :: FilePath -> IO (Either String EmojiCollection)+loadEmoji path = runExceptT $ do+    result <- lift $ E.try $ BSL.readFile path+    case result of+        Left (e::E.SomeException) -> throwError $ show e+        Right bs -> do+            EmojiData es <- ExceptT $ return $ A.eitherDecode bs+            return $ EmojiCollection $ T.toLower <$> F.toList es++-- | Look up matching emoji in the collection using the provided search+-- string. This does a case-insensitive infix match. The search string+-- may be provided with or without leading and trailing colons.+lookupEmoji :: EmojiCollection -> T.Text -> [T.Text]+lookupEmoji (EmojiCollection es) search =+    filter (matchesEmoji search) es++-- | Match a search string against an emoji.+matchesEmoji :: T.Text+             -- ^ The search string (will be converted to lowercase and+             -- colons will be removed)+             -> T.Text+             -- ^ The emoji string (assumed to be lowercase and without+             -- leading/trailing colons)+             -> Bool+matchesEmoji searchString e =+    sanitizeEmojiSearch searchString `T.isInfixOf` e++sanitizeEmojiSearch :: T.Text -> T.Text+sanitizeEmojiSearch = stripColons . T.toLower . T.strip++-- | Perform an emoji search against both the local EmojiCollection as+-- well as the server's custom emoji. Return the results, sorted. If the+-- empty string is specified, all local and all custom emoji will be+-- included in the returned list.+getMatchingEmoji :: Session -> EmojiCollection -> T.Text -> IO [T.Text]+getMatchingEmoji session em rawSearchString = do+    let localAlts = lookupEmoji em rawSearchString+        sanitized = sanitizeEmojiSearch rawSearchString+    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+stripColons t =+    stripHeadColon $ stripTailColon t+    where+        stripHeadColon v = if ":" `T.isPrefixOf` v+                           then T.tail v+                           else v+        stripTailColon v = if ":" `T.isSuffixOf` v+                           then T.init v+                           else v
+ src/Matterhorn/Events.hs view
@@ -0,0 +1,387 @@+module Matterhorn.Events+  ( onEvent+  , globalKeybindings+  , globalKeyHandlers+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( (.=), preuse, _2, singular, _Just )++import qualified Network.Mattermost.Endpoints as MM+import           Network.Mattermost.Exceptions ( mattermostErrorMessage )+import           Network.Mattermost.Lenses+import           Network.Mattermost.Types+import           Network.Mattermost.WebSocket++import           Matterhorn.Connection+import           Matterhorn.Constants ( userSigil, normalChannelSigil )+import           Matterhorn.HelpTopics+import           Matterhorn.State.Channels+import           Matterhorn.State.Common+import           Matterhorn.State.Flagging+import           Matterhorn.State.Help+import           Matterhorn.State.Messages+import           Matterhorn.State.Reactions+import           Matterhorn.State.Users+import           Matterhorn.Types+import           Matterhorn.Types.Common++import           Matterhorn.Events.ChannelSelect+import           Matterhorn.Events.ChannelTopicWindow+import           Matterhorn.Events.DeleteChannelConfirm+import           Matterhorn.Events.Keybindings+import           Matterhorn.Events.LeaveChannelConfirm+import           Matterhorn.Events.Main+import           Matterhorn.Events.MessageSelect+import           Matterhorn.Events.ThemeListOverlay+import           Matterhorn.Events.PostListOverlay+import           Matterhorn.Events.ShowHelp+import           Matterhorn.Events.UrlSelect+import           Matterhorn.Events.UserListOverlay+import           Matterhorn.Events.ChannelListOverlay+import           Matterhorn.Events.ReactionEmojiListOverlay+import           Matterhorn.Events.TabbedWindow+import           Matterhorn.Events.ManageAttachments+import           Matterhorn.Events.EditNotifyPrefs+++onEvent :: ChatState -> BrickEvent Name MHEvent -> EventM Name (Next ChatState)+onEvent st ev = runMHEvent st $ do+    onBrickEvent ev+    doPendingUserFetches+    doPendingUserStatusFetches++onBrickEvent :: BrickEvent Name MHEvent -> MH ()+onBrickEvent (AppEvent e) =+    onAppEvent e+onBrickEvent (VtyEvent (Vty.EvKey (Vty.KChar 'l') [Vty.MCtrl])) = do+    vty <- mh getVtyHandle+    liftIO $ Vty.refresh vty+onBrickEvent (VtyEvent e) =+    onVtyEvent e+onBrickEvent _ =+    return ()++onAppEvent :: MHEvent -> MH ()+onAppEvent RefreshWebsocketEvent =+    connectWebsockets+onAppEvent WebsocketDisconnect = do+    csConnectionStatus .= Disconnected+    disconnectChannels+onAppEvent WebsocketConnect = do+    csConnectionStatus .= Connected+    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) =+    csWorkerIsBusy .= Just n+onAppEvent (WSEvent we) =+    handleWSEvent we+onAppEvent (WSActionResponse r) =+    handleWSActionResponse r+onAppEvent (RespEvent f) = f+onAppEvent (WebsocketParseError e) = do+    let msg = "A websocket message could not be parsed:\n  " <>+              T.pack e <>+              "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues"+    mhError $ GenericError msg+onAppEvent (IEvent e) = do+    handleIEvent e++handleIEvent :: InternalEvent -> MH ()+handleIEvent (DisplayError e) =+    postErrorMessage' $ formatError e+handleIEvent (LoggingStarted path) =+    postInfoMessage $ "Logging to " <> T.pack path+handleIEvent (LogDestination dest) =+    case dest of+        Nothing ->+            postInfoMessage "Logging is currently disabled. Enable it with /log-start."+        Just path ->+            postInfoMessage $ T.pack $ "Logging to " <> path+handleIEvent (LogSnapshotSucceeded path) =+    postInfoMessage $ "Log snapshot written to " <> T.pack path+handleIEvent (LoggingStopped path) =+    postInfoMessage $ "Stopped logging to " <> T.pack path+handleIEvent (LogStartFailed path err) =+    postErrorMessage' $ "Could not start logging to " <> T.pack path <>+                        ", error: " <> T.pack err+handleIEvent (LogSnapshotFailed path err) =+    postErrorMessage' $ "Could not write log snapshot to " <> T.pack path <>+                        ", error: " <> T.pack err++formatError :: MHError -> T.Text+formatError (GenericError msg) =+    msg+formatError (NoSuchChannel chan) =+    T.pack $ "No such channel: " <> show chan+formatError (NoSuchUser user) =+    T.pack $ "No such user: " <> show user+formatError (AmbiguousName name) =+    (T.pack $ "The input " <> show name <> " matches both channels ") <>+    "and users. Try using '" <> userSigil <> "' or '" <>+    normalChannelSigil <> "' to disambiguate."+formatError (ServerError e) =+    mattermostErrorMessage e+formatError (ClipboardError msg) =+    msg+formatError (ConfigOptionMissing opt) =+    T.pack $ "Config option " <> show opt <> " missing"+formatError (ProgramExecutionFailed progName logPath) =+    T.pack $ "An error occurred when running " <> show progName <>+             "; see " <> show logPath <> " for details."+formatError (NoSuchScript name) =+    "No script named " <> name <> " was found"+formatError (NoSuchHelpTopic topic) =+    let knownTopics = ("  - " <>) <$> helpTopicName <$> helpTopics+    in "Unknown help topic: `" <> topic <> "`. " <>+       (T.unlines $ "Available topics are:" : knownTopics)+formatError (AsyncErrEvent e) =+    "An unexpected error has occurred! The exception encountered was:\n  " <>+    T.pack (show e) <>+    "\nPlease report this error at https://github.com/matterhorn-chat/matterhorn/issues"++onVtyEvent :: Vty.Event -> MH ()+onVtyEvent e = do+    case e of+        (Vty.EvResize _ _) ->+            -- On resize, invalidate the entire rendering cache since+            -- many things depend on the window size.+            --+            -- Note: we fall through after this because it is sometimes+            -- important for modes to have their own additional logic+            -- to run when a resize occurs, so we don't want to stop+            -- processing here.+            mh invalidateCache+        _ -> return ()++    void $ handleKeyboardEvent globalKeybindings handleGlobalEvent e++handleGlobalEvent :: Vty.Event -> MH ()+handleGlobalEvent e = do+    mode <- gets appMode+    case mode of+        Main                       -> onEventMain e+        ShowHelp _ _               -> void $ onEventShowHelp e+        ChannelSelect              -> void $ onEventChannelSelect e+        UrlSelect                  -> void $ onEventUrlSelect e+        LeaveChannelConfirm        -> onEventLeaveChannelConfirm e+        MessageSelect              -> onEventMessageSelect e+        MessageSelectDeleteConfirm -> onEventMessageSelectDeleteConfirm e+        DeleteChannelConfirm       -> onEventDeleteChannelConfirm e+        ThemeListOverlay           -> onEventThemeListOverlay e+        PostListOverlay _          -> onEventPostListOverlay e+        UserListOverlay            -> onEventUserListOverlay e+        ChannelListOverlay         -> onEventChannelListOverlay e+        ReactionEmojiListOverlay   -> onEventReactionEmojiListOverlay e+        ViewMessage                -> void $ handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e+        ManageAttachments          -> onEventManageAttachments e+        ManageAttachmentsBrowseFiles -> onEventManageAttachments e+        EditNotifyPrefs            -> void $ onEventEditNotifyPrefs e+        ChannelTopicWindow         -> onEventChannelTopicWindow e++globalKeybindings :: KeyConfig -> KeyHandlerMap+globalKeybindings = mkKeybindings globalKeyHandlers++globalKeyHandlers :: [KeyEventHandler]+globalKeyHandlers =+    [ mkKb ShowHelpEvent+        "Show this help screen"+        (showHelpScreen mainHelpTopic)+    ]++handleWSActionResponse :: WebsocketActionResponse -> MH ()+handleWSActionResponse r =+    case warStatus r of+        WebsocketActionStatusOK -> return ()++handleWSEvent :: WebsocketEvent -> MH ()+handleWSEvent we = do+    myId <- gets myUserId+    myTId <- gets myTeamId+    case weEvent we of+        WMPosted+            | Just p <- wepPost (weData we) ->+                when (wepTeamId (weData we) == Just myTId ||+                      wepTeamId (weData we) == Nothing) $ do+                    let wasMentioned = maybe False (Set.member myId) $ wepMentions (weData we)+                    addNewPostedMessage $ RecentPost p wasMentioned+                    cId <- use csCurrentChannelId+                    when (postChannelId p /= cId) $+                        showChannelInSidebar (p^.postChannelIdL) False+            | otherwise -> return ()++        WMPostEdited+            | Just p <- wepPost (weData we) -> do+                editMessage p+                cId <- use csCurrentChannelId+                when (postChannelId p == cId) (updateViewed False)+                when (postChannelId p /= cId) $+                    showChannelInSidebar (p^.postChannelIdL) False+            | otherwise -> return ()++        WMPostDeleted+            | Just p <- wepPost (weData we) -> do+                deleteMessage p+                cId <- use csCurrentChannelId+                when (postChannelId p == cId) (updateViewed False)+                when (postChannelId p /= cId) $+                    showChannelInSidebar (p^.postChannelIdL) False+            | otherwise -> return ()++        WMStatusChange+            | Just status <- wepStatus (weData we)+            , Just uId <- wepUserId (weData we) ->+                setUserStatus uId status+            | otherwise -> return ()++        WMUserAdded+            | Just cId <- webChannelId (weBroadcast we) ->+                when (wepUserId (weData we) == Just myId &&+                      wepTeamId (weData we) == Just myTId) $+                    handleChannelInvite cId+            | otherwise -> return ()++        WMNewUser+            | Just uId <- wepUserId $ weData we ->+                handleNewUsers (Seq.singleton uId) (return ())+            | otherwise -> return ()++        WMUserRemoved+            | Just cId <- wepChannelId (weData we) ->+                when (webUserId (weBroadcast we) == Just myId) $+                    removeChannelFromState cId+            | otherwise -> return ()++        WMTyping+            | Just uId <- wepUserId $ weData we+            , Just cId <- webChannelId (weBroadcast we) -> handleTypingUser uId cId+            | otherwise -> return ()++        WMChannelDeleted+            | Just cId <- wepChannelId (weData we) ->+                when (webTeamId (weBroadcast we) == Just myTId) $+                    removeChannelFromState cId+            | otherwise -> return ()++        WMDirectAdded+            | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId+            | otherwise -> return ()++        -- An 'ephemeral message' is just Mattermost's version of our+        -- 'client message'. This can be a little bit wacky, e.g.+        -- if the user types '/shortcuts' in the browser, we'll get+        -- an ephemeral message even in MatterHorn with the browser+        -- shortcuts, but it's probably a good idea to handle these+        -- messages anyway.+        WMEphemeralMessage+            | Just p <- wepPost $ weData we -> postInfoMessage (sanitizeUserText $ p^.postMessageL)+            | otherwise -> return ()++        WMPreferenceChanged+            | Just prefs <- wepPreferences (weData we) ->+                mapM_ applyPreferenceChange prefs+            | otherwise -> return ()++        WMPreferenceDeleted+            | Just pref <- wepPreferences (weData we)+            , Just fps <- mapM preferenceToFlaggedPost pref ->+              forM_ fps $ \f ->+                  updateMessageFlag (flaggedPostId f) False+            | otherwise -> return ()++        WMReactionAdded+            | Just r <- wepReaction (weData we)+            , Just cId <- webChannelId (weBroadcast we) -> addReactions cId [r]+            | otherwise -> return ()++        WMReactionRemoved+            | Just r <- wepReaction (weData we)+            , Just cId <- webChannelId (weBroadcast we) -> removeReaction r cId+            | otherwise -> return ()++        WMChannelViewed+            | Just cId <- wepChannelId $ weData we -> refreshChannelById cId+            | otherwise -> return ()++        WMChannelUpdated+            | Just cId <- webChannelId $ weBroadcast we -> do+                mChan <- preuse (csChannel(cId))+                when (isJust mChan) $ do+                    refreshChannelById cId+                    updateSidebar+            | otherwise -> return ()++        WMGroupAdded+            | Just cId <- webChannelId (weBroadcast we) -> handleChannelInvite cId+            | otherwise -> return ()++        WMChannelMemberUpdated+            | Just channelMember <- wepChannelMember $ weData we ->+                  when (channelMemberUserId channelMember == myId) $+                      updateChannelNotifyProps+                      (channelMemberChannelId channelMember)+                      (channelMemberNotifyProps channelMember)+            | otherwise -> return ()++        -- We are pretty sure we should do something about these:+        WMAddedToTeam -> return ()++        -- We aren't sure whether there is anything we should do about+        -- these yet:+        WMUpdateTeam -> return ()+        WMTeamDeleted -> return ()+        WMUserUpdated -> return ()+        WMLeaveTeam -> return ()++        -- We deliberately ignore these events:+        WMChannelCreated -> return ()+        WMEmojiAdded -> return ()+        WMWebRTC -> return ()+        WMHello -> return ()+        WMAuthenticationChallenge -> return ()+        WMUserRoleUpdated -> return ()+        WMPluginStatusesChanged -> return ()+        WMPluginEnabled -> return ()+        WMPluginDisabled -> return ()+        WMUnknownEvent {} ->+            mhLog LogWebsocket $ T.pack $+                "Websocket event not handled due to unknown event type: " <> show we++-- | Refresh client-accessible server configuration information. This+-- is usually triggered when a reconnect event for the WebSocket to the+-- server occurs.+refreshClientConfig :: MH ()+refreshClientConfig = do+    session <- getSession+    doAsyncWith Preempt $ do+        cfg <- MM.mmGetClientConfiguration (Just "old") session+        return $ Just $ do+            csClientConfig .= Just cfg+            updateSidebar
+ src/Matterhorn/Events/ChannelListOverlay.hs view
@@ -0,0 +1,35 @@+module Matterhorn.Events.ChannelListOverlay+  ( onEventChannelListOverlay+  , channelListOverlayKeybindings+  , channelListOverlayKeyHandlers+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.ChannelListOverlay+import           Matterhorn.State.ListOverlay+import           Matterhorn.Types+++onEventChannelListOverlay :: Vty.Event -> MH ()+onEventChannelListOverlay =+    void . onEventListOverlay csChannelListOverlay channelListOverlayKeybindings++-- | The keybindings we want to use while viewing a channel list overlay+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+    , mkKb PageDownEvent "Page down in the channel list" channelListPageDown+    , mkKb PageUpEvent "Page up in the channel list" channelListPageUp+    , mkKb ActivateListItemEvent "Join the selected channel" (listOverlayActivateCurrent csChannelListOverlay)+    ]
+ src/Matterhorn/Events/ChannelSelect.hs view
@@ -0,0 +1,45 @@+module Matterhorn.Events.ChannelSelect where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Widgets.Edit ( handleEditorEvent )+import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.Channels+import           Matterhorn.State.ChannelSelect+import           Matterhorn.State.Editing ( editingKeybindings )+import           Matterhorn.Types+import qualified Matterhorn.Zipper as Z+++onEventChannelSelect :: Vty.Event -> MH Bool+onEventChannelSelect =+  handleKeyboardEvent channelSelectKeybindings $ \e -> do+      handled <- handleKeyboardEvent (editingKeybindings (csChannelSelectState.channelSelectInput)) (const $ return ()) e+      when (not handled) $+          mhHandleEventLensed (csChannelSelectState.channelSelectInput) handleEditorEvent e++      updateChannelSelectMatches++channelSelectKeybindings :: KeyConfig -> KeyHandlerMap+channelSelectKeybindings = mkKeybindings channelSelectKeyHandlers++channelSelectKeyHandlers :: [KeyEventHandler]+channelSelectKeyHandlers =+    [ staticKb "Switch to selected channel"+         (Vty.EvKey Vty.KEnter []) $ do+             matches <- use (csChannelSelectState.channelSelectMatches)+             case Z.focus matches of+                 Nothing -> return ()+                 Just match -> do+                     setMode Main+                     setFocus $ channelListEntryChannelId $ matchEntry match++    , 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/Matterhorn/Events/ChannelTopicWindow.hs view
@@ -0,0 +1,48 @@+module Matterhorn.Events.ChannelTopicWindow+  ( onEventChannelTopicWindow+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Focus+import           Brick.Widgets.Edit ( handleEditorEvent, getEditContents )+import qualified Data.Text as T+import           Lens.Micro.Platform ( (%=) )+import qualified Graphics.Vty as Vty++import           Matterhorn.Types+import           Matterhorn.State.Channels ( setChannelTopic )+++onEventChannelTopicWindow :: Vty.Event -> MH ()+onEventChannelTopicWindow (Vty.EvKey (Vty.KChar '\t') []) =+    csChannelTopicDialog.channelTopicDialogFocus %= focusNext+onEventChannelTopicWindow (Vty.EvKey Vty.KBackTab []) =+    csChannelTopicDialog.channelTopicDialogFocus %= focusPrev+onEventChannelTopicWindow e@(Vty.EvKey Vty.KEnter []) = do+    f <- use (csChannelTopicDialog.channelTopicDialogFocus)+    case focusGetCurrent f of+        Just ChannelTopicSaveButton -> do+            ed <- use (csChannelTopicDialog.channelTopicDialogEditor)+            let topic = T.unlines $ getEditContents ed+            setChannelTopic topic+            setMode Main+        Just ChannelTopicEditor ->+            mhHandleEventLensed (csChannelTopicDialog.channelTopicDialogEditor)+                                handleEditorEvent e+        Just ChannelTopicCancelButton ->+            setMode Main+        _ ->+            setMode Main+onEventChannelTopicWindow (Vty.EvKey Vty.KEsc []) = do+    setMode Main+onEventChannelTopicWindow e = do+    f <- use (csChannelTopicDialog.channelTopicDialogFocus)+    case focusGetCurrent f of+        Just ChannelTopicEditor ->+            mhHandleEventLensed (csChannelTopicDialog.channelTopicDialogEditor)+                                handleEditorEvent e+        _ ->+            return ()
+ src/Matterhorn/Events/DeleteChannelConfirm.hs view
@@ -0,0 +1,20 @@+module Matterhorn.Events.DeleteChannelConfirm where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.Types+import           Matterhorn.State.Channels+++onEventDeleteChannelConfirm :: Vty.Event -> MH ()+onEventDeleteChannelConfirm (Vty.EvKey k []) = do+    case k of+        Vty.KChar c | c `elem` ("yY"::String) ->+            deleteCurrentChannel+        _ -> return ()+    setMode Main+onEventDeleteChannelConfirm _ = do+    setMode Main
+ src/Matterhorn/Events/EditNotifyPrefs.hs view
@@ -0,0 +1,48 @@+module Matterhorn.Events.EditNotifyPrefs+    ( onEventEditNotifyPrefs+    , editNotifyPrefsKeybindings+    , editNotifyPrefsKeyHandlers+    )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Forms (handleFormEvent, formState)+import           Data.Maybe (fromJust)+import qualified Graphics.Vty as V+import qualified Network.Mattermost.Endpoints as MM++import           Lens.Micro.Platform (_Just, (.=), singular)++import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+import           Matterhorn.Events.Keybindings+import           Matterhorn.State.NotifyPrefs+import           Matterhorn.State.Async++onEventEditNotifyPrefs :: V.Event -> MH Bool+onEventEditNotifyPrefs =+    let fallback e = do+            form <- use (csNotifyPrefs.singular _Just)+            updatedForm <- mh $ handleFormEvent (VtyEvent e) form+            csNotifyPrefs .= Just updatedForm+    in handleKeyboardEvent editNotifyPrefsKeybindings fallback++editNotifyPrefsKeybindings :: KeyConfig -> KeyHandlerMap+editNotifyPrefsKeybindings = mkKeybindings editNotifyPrefsKeyHandlers++editNotifyPrefsKeyHandlers :: [KeyEventHandler]+editNotifyPrefsKeyHandlers =+    [ mkKb CancelEvent "Close channel notification preferences" exitEditNotifyPrefsMode+    , mkKb FormSubmitEvent "Save channel notification preferences" $ do+        st <- use id+        let form = fromJust $ st^.csNotifyPrefs+            cId = st^.csCurrentChannelId++        doAsyncChannelMM Preempt cId+          (\s _ -> MM.mmUpdateChannelNotifications cId (myUserId st) (formState form) s)+          (\_ _ -> Nothing)+        exitEditNotifyPrefsMode+    ]
+ src/Matterhorn/Events/Keybindings.hs view
@@ -0,0 +1,323 @@+module Matterhorn.Events.Keybindings+  ( defaultBindings+  , lookupKeybinding+  , getFirstDefaultBinding++  , mkKb+  , staticKb+  , mkKeybindings++  , handleKeyboardEvent++  , EventHandler(..)+  , KeyHandler(..)+  , KeyEventHandler(..)+  , KeyEventTrigger(..)+  , KeyHandlerMap(..)++  -- Re-exports:+  , KeyEvent (..)+  , KeyConfig+  , allEvents+  , parseBinding+  , keyEventName+  , keyEventFromName++  , ensureKeybindingConsistency+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Text as T+import qualified Data.Map.Strict as M+import qualified Graphics.Vty as Vty++import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+++-- * Keybindings++-- | 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 -> KeyHandlerMap -> Maybe KeyHandler+lookupKeybinding e (KeyHandlerMap m) = M.lookup e m++-- | 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 = mkKeyMap (configUserKeys conf)+  case lookupKeybinding e keyMap of+    Just kh -> (ehAction $ kehHandler $ khHandler kh) >> return True+    Nothing -> fallthrough e >> return False++mkHandler :: Text -> MH () -> EventHandler+mkHandler msg action =+    EH { ehDescription = msg+       , ehAction = action+       }++mkKb :: KeyEvent -> Text -> MH () -> KeyEventHandler+mkKb ev msg action =+    KEH { kehHandler = mkHandler msg action+        , kehEventTrigger = ByEvent ev+        }++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)++getFirstDefaultBinding :: KeyEvent -> Binding+getFirstDefaultBinding ev =+    case defaultBindings ev of+        [] -> error $ "BUG: event " <> show ev <> " has no default bindings!"+        (b:_) -> b++defaultBindings :: KeyEvent -> [Binding]+defaultBindings ev =+  let meta binding = binding { kbMods = Vty.MMeta : kbMods binding }+      ctrl binding = binding { kbMods = Vty.MCtrl : kbMods binding }+      shift binding = binding { kbMods = Vty.MShift : kbMods binding }+      kb k = Binding { kbMods = [], kbKey = k }+      key c = Binding { kbMods = [], kbKey = Vty.KChar c }+      fn n = Binding { kbMods = [], kbKey = Vty.KFun n }+  in case ev of+        VtyRefreshEvent               -> [ ctrl (key 'l') ]+        ShowHelpEvent                 -> [ fn 1 ]+        EnterSelectModeEvent          -> [ ctrl (key 's') ]+        ReplyRecentEvent              -> [ ctrl (key 'r') ]+        ToggleMessagePreviewEvent     -> [ meta (key 'p') ]+        InvokeEditorEvent             -> [ meta (key 'k') ]+        EnterFastSelectModeEvent      -> [ ctrl (key 'g') ]+        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  -> [ ]+        LastChannelEvent              -> [ meta (key 's') ]+        EnterOpenURLModeEvent         -> [ ctrl (key 'o') ]+        ClearUnreadEvent              -> [ meta (key 'l') ]+        ToggleMultiLineEvent          -> [ meta (key 'e') ]+        EnterFlaggedPostsEvent        -> [ meta (key '8') ]+        ToggleChannelListVisibleEvent -> [ fn 2 ]+        ToggleExpandedChannelTopicsEvent -> [ fn 3 ]+        SelectNextTabEvent            -> [ key '\t' ]+        SelectPreviousTabEvent        -> [ kb Vty.KBackTab ]+        LoadMoreEvent                 -> [ ctrl (key 'b') ]+        ScrollUpEvent                 -> [ kb Vty.KUp ]+        ScrollDownEvent               -> [ kb Vty.KDown ]+        ScrollLeftEvent               -> [ kb Vty.KLeft ]+        ScrollRightEvent              -> [ kb Vty.KRight ]+        PageUpEvent                   -> [ kb Vty.KPageUp ]+        PageDownEvent                 -> [ kb Vty.KPageDown ]+        PageLeftEvent                 -> [ shift (kb Vty.KLeft) ]+        PageRightEvent                -> [ shift (kb Vty.KRight) ]+        ScrollTopEvent                -> [ kb Vty.KHome ]+        ScrollBottomEvent             -> [ kb Vty.KEnd ]+        SelectOldestMessageEvent      -> [ shift (kb Vty.KHome) ]+        SelectUpEvent                 -> [ key 'k', kb Vty.KUp ]+        SelectDownEvent               -> [ key 'j', kb Vty.KDown ]+        ActivateListItemEvent         -> [ kb Vty.KEnter ]+        SearchSelectUpEvent           -> [ ctrl (key 'p'), kb Vty.KUp ]+        SearchSelectDownEvent         -> [ ctrl (key 'n'), kb Vty.KDown ]+        ViewMessageEvent              -> [ key 'v' ]+        FillGapEvent                  -> [ kb Vty.KEnter ]+        FlagMessageEvent              -> [ key 'f' ]+        PinMessageEvent               -> [ key 'p' ]+        YankMessageEvent              -> [ key 'y' ]+        YankWholeMessageEvent         -> [ key 'Y' ]+        DeleteMessageEvent            -> [ key 'd' ]+        EditMessageEvent              -> [ key 'e' ]+        ReplyMessageEvent             -> [ key 'r' ]+        ReactToMessageEvent           -> [ key 'a' ]+        OpenMessageURLEvent           -> [ key 'o' ]+        AttachmentListAddEvent        -> [ key 'a' ]+        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') ]+        FormSubmitEvent               -> [ kb Vty.KEnter ]++-- | Given a configuration, we want to check it for internal consistency+-- (i.e. that a given keybinding isn't associated with multiple events+-- which both need to get generated in the same UI mode) and also for+-- 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 -> KeyHandlerMap)] -> Either String ()+ensureKeybindingConsistency kc modeMaps = mapM_ checkGroup allBindings+  where+    -- This is a list of lists, grouped by keybinding, of all the+    -- keybinding/event associations that are going to be used with the+    -- provided key configuration.+    allBindings = groupWith fst $ concat+      [ case M.lookup ev kc of+          Nothing -> zip (defaultBindings ev) (repeat (False, ev))+          Just (BindingList bs) -> zip bs (repeat (True, ev))+          Just Unbound -> []+      | ev <- allEvents+      ]++    -- The invariant here is that each call to checkGroup is made with a+    -- list where the first element of every list is the same binding.+    -- The Bool value in these is True if the event was associated with+    -- the binding by the user, and False if it's a Matterhorn default.+    checkGroup :: [(Binding, (Bool, KeyEvent))] -> Either String ()+    checkGroup [] = error "[ensureKeybindingConsistency: unreachable]"+    checkGroup evs@((b, _):_) = do++      -- We find out which modes an event can be used in and then invert+      -- the map, so this is a map from mode to the events contains+      -- which are bound by the binding included above.+      let modesFor :: M.Map String [(Bool, KeyEvent)]+          modesFor = M.unionsWith (++)+            [ M.fromList [ (m, [(i, ev)]) | m <- modeMap ev ]+            | (_, (i, ev)) <- evs+            ]++      -- If there is ever a situation where the same key is bound to two+      -- events which can appear in the same mode, then we want to throw+      -- an error, and also be informative about why. It is still okay+      -- to bind the same key to two events, so long as those events+      -- never appear in the same UI mode.+      forM_ (M.assocs modesFor) $ \ (_, vs) ->+         when (length vs > 1) $+           Left $ concat $+             "Multiple overlapping events bound to `" :+             T.unpack (ppBinding b) :+             "`:\n" :+             concat [ [ " - `"+                      , T.unpack (keyEventName ev)+                      , "` "+                      , if isFromUser+                          then "(via user override)"+                          else "(matterhorn default)"+                      , "\n"+                      ]+                    | (isFromUser, ev) <- vs+                    ]++      -- Check for overlap a set of built-in keybindings when we're in a+      -- mode where the user is typing. (These are perfectly fine when+      -- we're in other modes.)+      when ("main" `M.member` modesFor && isBareBinding b) $ do+        Left $ concat $+          [ "The keybinding `"+          , T.unpack (ppBinding b)+          , "` is bound to the "+          , case map (ppEvent . snd . snd) evs of+              [] -> error "unreachable"+              [e] -> "event " ++ e+              es  -> "events " ++ intercalate " and " es+          , "\n"+          , "This is probably not what you want, as it will interfere "+          , "with the ability to write messages!\n"+          ]++    -- Events get some nice formatting!+    ppEvent ev = "`" ++ T.unpack (keyEventName ev) ++ "`"++    -- This check should get more nuanced, but as a first approximation,+    -- we shouldn't bind to any bare character key in the main mode.+    isBareBinding (Binding [] (Vty.KChar {})) = True+    isBareBinding _ = False++    -- 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 matches kh = ByEvent ev == (kehEventTrigger $ khHandler kh)+      in [ mode+         | (mode, mkBindings) <- modeMaps+         , let KeyHandlerMap m = mkBindings kc+           in not $ null $ M.filter matches m+         ]
+ src/Matterhorn/Events/LeaveChannelConfirm.hs view
@@ -0,0 +1,19 @@+module Matterhorn.Events.LeaveChannelConfirm where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.State.Channels+import           Matterhorn.Types+++onEventLeaveChannelConfirm :: Vty.Event -> MH ()+onEventLeaveChannelConfirm (Vty.EvKey k []) = do+    case k of+        Vty.KChar c | c `elem` ("yY"::String) ->+            leaveCurrentChannel+        _ -> return ()+    setMode Main+onEventLeaveChannelConfirm _ = return ()
+ src/Matterhorn/Events/Main.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.Events.Main where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Widgets.Edit+import qualified Graphics.Vty as Vty++import           Matterhorn.Command+import           Matterhorn.Events.Keybindings+import           Matterhorn.State.Attachments+import           Matterhorn.State.ChannelSelect+import           Matterhorn.State.Channels+import           Matterhorn.State.Editing+import           Matterhorn.State.MessageSelect+import           Matterhorn.State.PostListOverlay ( enterFlaggedPostListMode )+import           Matterhorn.State.UrlSelect+import           Matterhorn.Types+++onEventMain :: Vty.Event -> MH ()+onEventMain =+  void . handleKeyboardEvent mainKeybindings (\ ev -> do+      resetReturnChannel+      case ev of+          (Vty.EvPaste bytes) -> handlePaste bytes+          _ -> handleEditingInput ev+  )++mainKeybindings :: KeyConfig -> KeyHandlerMap+mainKeybindings = mkKeybindings mainKeyHandlers++mainKeyHandlers :: [KeyEventHandler]+mainKeyHandlers =+    [ mkKb EnterSelectModeEvent+        "Select a message to edit/reply/delete"+        beginMessageSelect++    , mkKb ReplyRecentEvent+        "Reply to the most recent message"+        replyToLatestMessage++    , mkKb ToggleMessagePreviewEvent "Toggle message preview"+        toggleMessagePreview++    , mkKb ToggleChannelListVisibleEvent "Toggle channel list visibility"+        toggleChannelListVisibility++    , mkKb ToggleExpandedChannelTopicsEvent "Toggle display of expanded channel topics"+        toggleExpandedChannelTopics++    , mkKb+        InvokeEditorEvent+        "Invoke `$EDITOR` to edit the current message"+        invokeExternalEditor++    , mkKb+        EnterFastSelectModeEvent+        "Enter fast channel selection mode"+         beginChannelSelect++    , mkKb+        QuitEvent+        "Quit"+        requestQuit++    , staticKb "Tab-complete forward"+         (Vty.EvKey (Vty.KChar '\t') []) $+         tabComplete Forwards++    , staticKb "Tab-complete backward"+         (Vty.EvKey (Vty.KBackTab) []) $+         tabComplete Backwards++    , mkKb+        ScrollUpEvent+        "Scroll up in the channel input history" $ do+             -- Up in multiline mode does the usual thing; otherwise we+             -- navigate the history.+             isMultiline <- use (csEditState.cedEphemeral.eesMultiline)+             case isMultiline of+                 True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent+                                           (Vty.EvKey Vty.KUp [])+                 False -> channelHistoryBackward++    , mkKb+        ScrollDownEvent+        "Scroll down in the channel input history" $ do+             -- Down in multiline mode does the usual thing; otherwise+             -- we navigate the history.+             isMultiline <- use (csEditState.cedEphemeral.eesMultiline)+             case isMultiline of+                 True -> mhHandleEventLensed (csEditState.cedEditor) handleEditorEvent+                                           (Vty.EvKey Vty.KDown [])+                 False -> channelHistoryForward++    , mkKb PageUpEvent "Page up in the channel message list (enters message select mode)" $ do+             beginMessageSelect++    , mkKb SelectOldestMessageEvent "Scroll to top of channel message list" $ do+             beginMessageSelect+             messageSelectFirst++    , mkKb NextChannelEvent "Change to the next channel in the channel list"+         nextChannel++    , mkKb PrevChannelEvent "Change to the previous channel in the channel list"+         prevChannel++    , mkKb NextUnreadChannelEvent "Change to the next channel with unread messages or return to the channel marked '~'"+         nextUnreadChannel++    , mkKb ShowAttachmentListEvent "Show the attachment list"+         showAttachmentList++    , mkKb NextUnreadUserOrChannelEvent+         "Change to the next channel with unread messages preferring direct messages"+         nextUnreadUserOrChannel++    , mkKb LastChannelEvent "Change to the most recently-focused channel"+         recentChannel++    , staticKb "Send the current message"+         (Vty.EvKey Vty.KEnter []) $ do+             isMultiline <- use (csEditState.cedEphemeral.eesMultiline)+             case isMultiline of+                 -- Normally, this event causes the current message to+                 -- be sent. But in multiline mode we want to insert a+                 -- newline instead.+                 True -> handleEditingInput (Vty.EvKey Vty.KEnter [])+                 False -> do+                     cId <- use csCurrentChannelId+                     content <- getEditorContent+                     handleInputSubmission cId content++    , mkKb EnterOpenURLModeEvent "Select and open a URL posted to the current channel"+           startUrlSelect++    , mkKb ClearUnreadEvent "Clear the current channel's unread / edited indicators" $+           clearChannelUnreadStatus =<< use csCurrentChannelId++    , mkKb ToggleMultiLineEvent "Toggle multi-line message compose mode"+           toggleMultilineEditing++    , mkKb CancelEvent "Cancel autocomplete, message reply, or edit, in that order"+         cancelAutocompleteOrReplyOrEdit++    , mkKb EnterFlaggedPostsEvent "View currently flagged posts"+         enterFlaggedPostListMode+    ]
+ src/Matterhorn/Events/ManageAttachments.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Matterhorn.Events.ManageAttachments+  ( onEventManageAttachments+  , attachmentListKeybindings+  , attachmentBrowseKeyHandlers+  , attachmentBrowseKeybindings+  , attachmentListKeyHandlers+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Control.Exception as E+import qualified Brick.Widgets.FileBrowser as FB+import qualified Brick.Widgets.List as L+import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Vector as Vector+import qualified Graphics.Vty as V+import           Lens.Micro.Platform ( (?=), (%=), to )++import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+import           Matterhorn.Events.Keybindings+import           Matterhorn.State.Attachments+import           Matterhorn.State.Common+++onEventManageAttachments :: V.Event -> MH ()+onEventManageAttachments e = do+    mode <- gets appMode+    case mode of+        ManageAttachments -> void $ onEventAttachmentList e+        ManageAttachmentsBrowseFiles -> onEventBrowseFile e+        _ -> error "BUG: onEventManageAttachments called in invalid mode"++onEventAttachmentList :: V.Event -> MH Bool+onEventAttachmentList =+    handleKeyboardEvent attachmentListKeybindings $+        mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent++attachmentListKeybindings :: KeyConfig -> KeyHandlerMap+attachmentListKeybindings = mkKeybindings attachmentListKeyHandlers++attachmentListKeyHandlers :: [KeyEventHandler]+attachmentListKeyHandlers =+    [ mkKb CancelEvent "Close attachment list"+          (setMode Main)+    , mkKb SelectUpEvent "Move cursor up" $+          mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KUp [])+    , mkKb SelectDownEvent "Move cursor down" $+          mhHandleEventLensed (csEditState.cedAttachmentList) L.handleListEvent (V.EvKey V.KDown [])+    , mkKb AttachmentListAddEvent "Add a new attachment to the attachment list"+          showAttachmentFileBrowser+    , mkKb AttachmentOpenEvent "Open the selected attachment using the URL open command"+          openSelectedAttachment+    , mkKb AttachmentListDeleteEvent "Delete the selected attachment from the attachment list"+          deleteSelectedAttachment+    ]++attachmentBrowseKeybindings :: KeyConfig -> KeyHandlerMap+attachmentBrowseKeybindings = mkKeybindings attachmentBrowseKeyHandlers++attachmentBrowseKeyHandlers :: [KeyEventHandler]+attachmentBrowseKeyHandlers =+    [ mkKb CancelEvent "Cancel attachment file browse"+      cancelAttachmentBrowse+    , mkKb AttachmentOpenEvent "Open the selected file using the URL open command"+          openSelectedBrowserEntry+    ]++withFileBrowser :: ((FB.FileBrowser Name) -> MH ()) -> MH ()+withFileBrowser f = do+    use (csEditState.cedFileBrowser) >>= \case+        Nothing -> do+            -- The widget has not been created yet.  This should+            -- normally not occur, because the ManageAttachments+            -- events should not fire when there is no FileBrowser+            -- Widget active to cause Brick to generate these events.+            -- This could therefore be implemented as an `error "BUG:+            -- ..."` handler, but the more benign approach is to+            -- simply create an available FileBrowser at this stage.+            new_b <- liftIO $ FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser Nothing+            csEditState.cedFileBrowser ?= new_b+            f new_b+        Just b -> f b++openSelectedAttachment :: MH ()+openSelectedAttachment = do+    cur <- use (csEditState.cedAttachmentList.to L.listSelectedElement)+    case cur of+        Nothing -> return ()+        Just (_, entry) -> void $ openFilePath (FB.fileInfoFilePath $+                                                attachmentDataFileInfo entry)++openSelectedBrowserEntry :: MH ()+openSelectedBrowserEntry = withFileBrowser $ \b ->+    case FB.fileBrowserCursor b of+        Nothing -> return ()+        Just entry -> void $ openFilePath (FB.fileInfoFilePath entry)++onEventBrowseFile :: V.Event -> MH ()+onEventBrowseFile e = do+    withFileBrowser $ \b -> do+        case FB.fileBrowserIsSearching b of+            False ->+                void $ handleKeyboardEvent attachmentBrowseKeybindings handleFileBrowserEvent e+            True ->+                handleFileBrowserEvent e++    -- n.b. the FileBrowser may have been updated above, so re-acquire it+    withFileBrowser $ \b -> do+        case FB.fileBrowserException b of+            Nothing -> return ()+            Just ex -> do+                mhLog LogError $ T.pack $ "FileBrowser exception: " <> show ex++cancelAttachmentBrowse :: MH ()+cancelAttachmentBrowse = do+    es <- use (csEditState.cedAttachmentList.L.listElementsL)+    case length es of+        0 -> setMode Main+        _ -> setMode ManageAttachments++handleFileBrowserEvent :: V.Event -> MH ()+handleFileBrowserEvent e = do+  let fbHandle ev = sequence . (fmap (FB.handleFileBrowserEvent ev))+  mhHandleEventLensed (csEditState.cedFileBrowser) fbHandle e++  withFileBrowser $ \b -> do+    -- TODO: Check file browser exception state+    let entries = FB.fileBrowserSelection b+    forM_ entries $ \entry -> do+        -- Is the entry already present? If so, ignore the selection.+        es <- use (csEditState.cedAttachmentList.L.listElementsL)+        let matches = (== (FB.fileInfoFilePath entry)) .+                      FB.fileInfoFilePath .+                      attachmentDataFileInfo+        case Vector.find matches es of+            Just _ -> return ()+            Nothing -> do+                let path = FB.fileInfoFilePath entry+                readResult <- liftIO $ E.try $ BS.readFile path+                case readResult of+                    Left (_::E.SomeException) ->+                        -- TODO: report the error+                        return ()+                    Right bytes -> do+                        let a = AttachmentData { attachmentDataFileInfo = entry+                                               , attachmentDataBytes = bytes+                                               }+                        oldIdx <- use (csEditState.cedAttachmentList.L.listSelectedL)+                        let newIdx = if Vector.null es+                                     then Just 0+                                     else oldIdx+                        csEditState.cedAttachmentList %= L.listReplace (Vector.snoc es a) newIdx++    when (not $ null entries) $ setMode Main++deleteSelectedAttachment :: MH ()+deleteSelectedAttachment = do+    es <- use (csEditState.cedAttachmentList.L.listElementsL)+    mSel <- use (csEditState.cedAttachmentList.to L.listSelectedElement)+    case mSel of+        Nothing ->+            return ()+        Just (pos, _) -> do+            oldIdx <- use (csEditState.cedAttachmentList.L.listSelectedL)+            let idx = if Vector.length es == 1+                      then Nothing+                      else case oldIdx of+                          Nothing -> Just 0+                          Just old -> if pos >= old+                                      then Just $ pos - 1+                                      else Just pos+            csEditState.cedAttachmentList %= L.listReplace (deleteAt pos es) idx++deleteAt :: Int -> Vector.Vector a -> Vector.Vector a+deleteAt p as | p < 0 || p >= length as = as+              | otherwise = Vector.take p as <> Vector.drop (p + 1) as
+ src/Matterhorn/Events/MessageSelect.hs view
@@ -0,0 +1,85 @@+module Matterhorn.Events.MessageSelect where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Text as T+import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.MessageSelect+import           Matterhorn.State.ReactionEmojiListOverlay+import           Matterhorn.Types+++messagesPerPageOperation :: Int+messagesPerPageOperation = 10++onEventMessageSelect :: Vty.Event -> MH ()+onEventMessageSelect =+  void . handleKeyboardEvent messageSelectKeybindings (const $ return ())++onEventMessageSelectDeleteConfirm :: Vty.Event -> MH ()+onEventMessageSelectDeleteConfirm (Vty.EvKey (Vty.KChar 'y') []) = do+    deleteSelectedMessage+    setMode Main+onEventMessageSelectDeleteConfirm _ =+    setMode Main++messageSelectKeybindings :: KeyConfig -> KeyHandlerMap+messageSelectKeybindings = mkKeybindings messageSelectKeyHandlers++messageSelectKeyHandlers :: [KeyEventHandler]+messageSelectKeyHandlers =+    [ mkKb CancelEvent "Cancel message selection" $+        setMode Main++    , mkKb SelectUpEvent "Select the previous message" messageSelectUp+    , mkKb SelectDownEvent "Select the next message" messageSelectDown+    , mkKb ScrollTopEvent "Scroll to top and select the oldest message"+        messageSelectFirst+    , mkKb ScrollBottomEvent "Scroll to bottom and select the latest message"+        messageSelectLast+    , mkKb+        PageUpEvent+        (T.pack $ "Move the cursor up by " <> show messagesPerPageOperation <> " messages")+        (messageSelectUpBy messagesPerPageOperation)+    , mkKb+        PageDownEvent+        (T.pack $ "Move the cursor down by " <> show messagesPerPageOperation <> " messages")+        (messageSelectDownBy messagesPerPageOperation)++    , mkKb OpenMessageURLEvent "Open all URLs in the selected message"+        openSelectedMessageURLs++    , mkKb ReplyMessageEvent "Begin composing a reply to the selected message"+         beginReplyCompose++    , mkKb EditMessageEvent "Begin editing the selected message"+         beginEditMessage++    , mkKb DeleteMessageEvent "Delete the selected message (with confirmation)"+         beginConfirmDeleteSelectedMessage++    , mkKb YankMessageEvent "Copy a verbatim section or message to the clipboard"+         yankSelectedMessageVerbatim++    , mkKb YankWholeMessageEvent "Copy an entire message to the clipboard"+         yankSelectedMessage++    , mkKb PinMessageEvent "Toggle whether the selected message is pinned"+         pinSelectedMessage++    , mkKb FlagMessageEvent "Flag the selected message"+         flagSelectedMessage++    , mkKb ViewMessageEvent "View the selected message"+         viewSelectedMessage++    , mkKb FillGapEvent "Fetch messages for the selected gap"+         fillSelectedGap++    , mkKb ReactToMessageEvent "Post a reaction to the selected message"+         enterReactionEmojiListOverlayMode++    ]
+ src/Matterhorn/Events/PostListOverlay.hs view
@@ -0,0 +1,28 @@+module Matterhorn.Events.PostListOverlay where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.Types+import           Matterhorn.Events.Keybindings+import           Matterhorn.State.PostListOverlay+++onEventPostListOverlay :: Vty.Event -> MH ()+onEventPostListOverlay =+  void . handleKeyboardEvent postListOverlayKeybindings (const $ return ())++-- | The keybindings we want to use while viewing a post list overlay+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+  , mkKb FlagMessageEvent "Toggle the selected message flag" postListUnflagSelected+  , mkKb ActivateListItemEvent "Jump to and select current message" postListJumpToCurrent+  ]
+ src/Matterhorn/Events/ReactionEmojiListOverlay.hs view
@@ -0,0 +1,35 @@+module Matterhorn.Events.ReactionEmojiListOverlay+  ( onEventReactionEmojiListOverlay+  , reactionEmojiListOverlayKeybindings+  , reactionEmojiListOverlayKeyHandlers+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.ReactionEmojiListOverlay+import           Matterhorn.State.ListOverlay+import           Matterhorn.Types+++onEventReactionEmojiListOverlay :: Vty.Event -> MH ()+onEventReactionEmojiListOverlay =+    void . onEventListOverlay csReactionEmojiListOverlay reactionEmojiListOverlayKeybindings++-- | The keybindings we want to use while viewing an emoji list overlay+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+    , mkKb PageDownEvent "Page down in the emoji list" reactionEmojiListPageDown+    , mkKb PageUpEvent "Page up in the emoji list" reactionEmojiListPageUp+    , mkKb ActivateListItemEvent "Post the selected emoji reaction" (listOverlayActivateCurrent csReactionEmojiListOverlay)+    ]
+ src/Matterhorn/Events/ShowHelp.hs view
@@ -0,0 +1,44 @@+module Matterhorn.Events.ShowHelp where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import qualified Graphics.Vty as Vty++import           Matterhorn.Constants+import           Matterhorn.Events.Keybindings+import           Matterhorn.Types+++onEventShowHelp :: Vty.Event -> MH Bool+onEventShowHelp =+  handleKeyboardEvent helpKeybindings $ \ e -> case e of+    Vty.EvKey _ _ -> popMode+    _ -> return ()++helpKeybindings :: KeyConfig -> KeyHandlerMap+helpKeybindings = mkKeybindings helpKeyHandlers++helpKeyHandlers :: [KeyEventHandler]+helpKeyHandlers =+    [ mkKb ScrollUpEvent "Scroll up" $+        mh $ vScrollBy (viewportScroll HelpViewport) (-1)+    , mkKb ScrollDownEvent "Scroll down" $+        mh $ vScrollBy (viewportScroll HelpViewport) 1+    , mkKb PageUpEvent "Page up" $+        mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount)+    , mkKb PageDownEvent "Page down" $+        mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount)+    , mkKb CancelEvent "Return to the previous interface" $+        popMode+    , mkKb ScrollBottomEvent "Scroll to the end of the help" $+        mh $ vScrollToEnd (viewportScroll HelpViewport)+    , mkKb ScrollTopEvent "Scroll to the beginning of the help" $+        mh $ vScrollToBeginning (viewportScroll HelpViewport)+    ]++popMode :: MH ()+popMode = do+    ShowHelp _ prevMode <- gets appMode+    setMode prevMode
+ src/Matterhorn/Events/TabbedWindow.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE RankNTypes #-}+module Matterhorn.Events.TabbedWindow+  ( handleTabbedWindowEvent+  , tabbedWindowKeybindings+  , tabbedWindowKeyHandlers+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( Lens', (.=) )++import           Matterhorn.Types+import           Matterhorn.Types.KeyEvents+import           Matterhorn.Events.Keybindings++handleTabbedWindowEvent :: (Show a, Eq a)+                        => Lens' ChatState (TabbedWindow a)+                        -> Vty.Event+                        -> MH Bool+handleTabbedWindowEvent target e = do+    w <- use target+    handleKeyboardEvent (tabbedWindowKeybindings target) (forwardEvent w) e++forwardEvent :: (Show a, Eq a)+             => TabbedWindow a+             -> Vty.Event+             -> MH ()+forwardEvent w e = do+    let cur = getCurrentTabbedWindowEntry w+    tweHandleEvent cur (twValue w) e++tabbedWindowKeybindings :: (Show a, Eq a)+                        => Lens' ChatState (TabbedWindow a)+                        -> KeyConfig+                        -> 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)++    , mkKb SelectNextTabEvent "Select next tab" $ do+        w' <- tabbedWindowNextTab =<< use target+        target .= w'++    , mkKb SelectPreviousTabEvent "Select previous tab" $ do+        w' <- tabbedWindowPreviousTab =<< use target+        target .= w'+    ]
+ src/Matterhorn/Events/ThemeListOverlay.hs view
@@ -0,0 +1,30 @@+module Matterhorn.Events.ThemeListOverlay where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.ThemeListOverlay+import           Matterhorn.State.ListOverlay+import           Matterhorn.Types+++onEventThemeListOverlay :: Vty.Event -> MH ()+onEventThemeListOverlay =+    void . onEventListOverlay csThemeListOverlay themeListOverlayKeybindings++-- | The keybindings we want to use while viewing a user list overlay+themeListOverlayKeybindings :: KeyConfig -> KeyHandlerMap+themeListOverlayKeybindings = mkKeybindings themeListOverlayKeyHandlers++themeListOverlayKeyHandlers :: [KeyEventHandler]+themeListOverlayKeyHandlers =+    [ mkKb CancelEvent "Close the theme list" (exitListOverlay csThemeListOverlay)+    , mkKb SearchSelectUpEvent "Select the previous theme" themeListSelectUp+    , mkKb SearchSelectDownEvent "Select the next theme" themeListSelectDown+    , mkKb PageDownEvent "Page down in the theme list" themeListPageDown+    , mkKb PageUpEvent "Page up in the theme list" themeListPageUp+    , mkKb ActivateListItemEvent "Switch to the selected color theme" (listOverlayActivateCurrent csThemeListOverlay)+    ]
+ src/Matterhorn/Events/UrlSelect.hs view
@@ -0,0 +1,39 @@+module Matterhorn.Events.UrlSelect where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Widgets.List+import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.UrlSelect+import           Matterhorn.Types+++onEventUrlSelect :: Vty.Event -> MH Bool+onEventUrlSelect =+  handleKeyboardEvent urlSelectKeybindings $ \ ev ->+    mhHandleEventLensed csUrlList handleListEvent ev++urlSelectKeybindings :: KeyConfig -> KeyHandlerMap+urlSelectKeybindings = mkKeybindings urlSelectKeyHandlers++urlSelectKeyHandlers :: [KeyEventHandler]+urlSelectKeyHandlers =+    [ staticKb "Open the selected URL, if any"+         (Vty.EvKey Vty.KEnter []) $+             openSelectedURL++    , mkKb CancelEvent "Cancel URL selection" stopUrlSelect++    , mkKb SelectUpEvent "Move cursor up" $+        mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KUp [])++    , mkKb SelectDownEvent "Move cursor down" $+        mhHandleEventLensed csUrlList handleListEvent (Vty.EvKey Vty.KDown [])++    , staticKb "Cancel URL selection"+         (Vty.EvKey (Vty.KChar 'q') []) $ stopUrlSelect++    ]
+ src/Matterhorn/Events/UserListOverlay.hs view
@@ -0,0 +1,30 @@+module Matterhorn.Events.UserListOverlay where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty++import           Matterhorn.Events.Keybindings+import           Matterhorn.State.UserListOverlay+import           Matterhorn.State.ListOverlay+import           Matterhorn.Types+++onEventUserListOverlay :: Vty.Event -> MH ()+onEventUserListOverlay =+    void . onEventListOverlay csUserListOverlay userListOverlayKeybindings++-- | The keybindings we want to use while viewing a user list overlay+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+    , mkKb PageDownEvent "Page down in the user list" userListPageDown+    , mkKb PageUpEvent "Page up in the user list" userListPageUp+    , mkKb ActivateListItemEvent "Interact with the selected user" (listOverlayActivateCurrent csUserListOverlay)+    ]
+ src/Matterhorn/FilePaths.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE TupleSections #-}+module Matterhorn.FilePaths+  ( historyFilePath+  , historyFileName++  , lastRunStateFilePath+  , lastRunStateFileName++  , configFileName++  , xdgName+  , locateConfig+  , xdgSyntaxDir+  , syntaxDirName+  , userEmojiJsonPath+  , bundledEmojiJsonPath+  , emojiJsonFilename++  , Script(..)+  , locateScriptPath+  , getAllScripts+  )+where++import Prelude ()+import Matterhorn.Prelude++import Data.Text ( unpack )+import System.Directory ( doesFileExist+                        , doesDirectoryExist+                        , getDirectoryContents+                        , getPermissions+                        , executable+                        )+import System.Environment ( getExecutablePath )+import System.Environment.XDG.BaseDir ( getUserConfigFile+                                      , getAllConfigFiles+                                      , getUserConfigDir+                                      )+import System.FilePath ( (</>), takeBaseName, takeDirectory, splitPath, joinPath )+++xdgName :: String+xdgName = "matterhorn"++historyFileName :: FilePath+historyFileName = "history.txt"++lastRunStateFileName :: Text -> FilePath+lastRunStateFileName teamId = "last_run_state_" ++ unpack teamId ++ ".json"++configFileName :: FilePath+configFileName = "config.ini"++historyFilePath :: IO FilePath+historyFilePath = getUserConfigFile xdgName historyFileName++lastRunStateFilePath :: Text -> IO FilePath+lastRunStateFilePath teamId =+  getUserConfigFile xdgName (lastRunStateFileName teamId)++-- | Get the XDG path to the user-specific syntax definition directory.+-- The path does not necessarily exist.+xdgSyntaxDir :: IO FilePath+xdgSyntaxDir = (</> syntaxDirName) <$> getUserConfigDir xdgName++-- | Get the XDG path to the user-specific emoji JSON file. The path+-- does not necessarily exist.+userEmojiJsonPath :: IO FilePath+userEmojiJsonPath = (</> emojiJsonFilename) <$> getUserConfigDir xdgName++-- | Get the emoji JSON path relative to the development binary location+-- or the release binary location.+bundledEmojiJsonPath :: IO FilePath+bundledEmojiJsonPath = do+    selfPath <- getExecutablePath+    let distDir = "dist-newstyle/"+        pathBits = splitPath selfPath++    return $ if distDir `elem` pathBits+             then+                 -- We're in development, so use the development+                 -- executable path to locate the emoji path in the+                 -- development tree.+                 (joinPath $ takeWhile (/= distDir) pathBits) </> emojiDirName </> emojiJsonFilename+             else+                 -- In this case we assume the binary is being run from+                 -- a release, in which case the syntax directory is a+                 -- sibling of the executable path.+                 takeDirectory selfPath </> emojiDirName </> emojiJsonFilename++emojiJsonFilename :: FilePath+emojiJsonFilename = "emoji.json"++emojiDirName :: FilePath+emojiDirName = "emoji"++syntaxDirName :: FilePath+syntaxDirName = "syntax"++-- | Find a specified configuration file by looking in all of the+-- supported locations.+locateConfig :: FilePath -> IO (Maybe FilePath)+locateConfig filename = do+  xdgLocations <- getAllConfigFiles xdgName filename+  let confLocations = ["./" <> filename] +++                      xdgLocations +++                      ["/etc/matterhorn/" <> filename]+  results <- forM confLocations $ \fp -> (fp,) <$> doesFileExist fp+  return $ listToMaybe $ fst <$> filter snd results++scriptDirName :: FilePath+scriptDirName = "scripts"++data Script+  = ScriptPath FilePath+  | NonexecScriptPath FilePath+  | ScriptNotFound+    deriving (Eq, Read, Show)++toScript :: FilePath -> IO (Script)+toScript fp = do+  perm <- getPermissions fp+  return $ if executable perm+    then ScriptPath fp+    else NonexecScriptPath fp++isExecutable :: FilePath -> IO Bool+isExecutable fp = do+  perm <- getPermissions fp+  return (executable perm)++locateScriptPath :: FilePath -> IO Script+locateScriptPath name+  | head name == '.' = return ScriptNotFound+  | otherwise = do+    xdgLocations <- getAllConfigFiles xdgName scriptDirName+    let cmdLocations = [ xdgLoc ++ "/" ++ name+                       | xdgLoc <- xdgLocations+                       ] ++ [ "/etc/matterhorn/scripts/" <> name ]+    existingFiles <- filterM doesFileExist cmdLocations+    executables <- mapM toScript existingFiles+    return $ case executables of+      (path:_) -> path+      _        -> ScriptNotFound++-- | This returns a list of valid scripts, and a list of non-executable+--   scripts.+getAllScripts :: IO ([FilePath], [FilePath])+getAllScripts = do+  xdgLocations <- getAllConfigFiles xdgName scriptDirName+  let cmdLocations = xdgLocations ++ ["/etc/matterhorn/scripts"]+  let getCommands dir = do+        exists <- doesDirectoryExist dir+        if exists+          then map ((dir ++ "/") ++) `fmap` getDirectoryContents dir+          else return []+  let isNotHidden f = case f of+        ('.':_) -> False+        []      -> False+        _       -> True+  allScripts <- concat `fmap` mapM getCommands cmdLocations+  execs <- filterM isExecutable allScripts+  nonexecs <- filterM (fmap not . isExecutable) allScripts+  return ( filter isNotHidden $ map takeBaseName execs+         , filter isNotHidden $ map takeBaseName nonexecs+         )
+ src/Matterhorn/HelpTopics.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.HelpTopics+  ( helpTopics+  , lookupHelpTopic+  , themeHelpTopic+  , mainHelpTopic+  )+where++import Prelude ()+import Matterhorn.Prelude++import Matterhorn.Types+++helpTopics :: [HelpTopic]+helpTopics =+    [ mainHelpTopic+    , scriptHelpTopic+    , themeHelpTopic+    , keybindingHelpTopic+    , syntaxHighlightingHelpTopic+    ]++mainHelpTopic :: HelpTopic+mainHelpTopic =+    HelpTopic "main" "This help page" MainHelp HelpText++scriptHelpTopic :: HelpTopic+scriptHelpTopic =+    HelpTopic "scripts" "Help on available scripts" ScriptHelp ScriptHelpText++themeHelpTopic :: HelpTopic+themeHelpTopic =+    HelpTopic "themes" "Help on color themes" ThemeHelp ThemeHelpText++keybindingHelpTopic :: HelpTopic+keybindingHelpTopic =+    HelpTopic "keybindings" "Help on overriding keybindings"+      KeybindingHelp KeybindingHelpText++syntaxHighlightingHelpTopic :: HelpTopic+syntaxHighlightingHelpTopic =+    HelpTopic "syntax" "Help on syntax highlighing"+      SyntaxHighlightHelp SyntaxHighlightHelpText++lookupHelpTopic :: Text -> Maybe HelpTopic+lookupHelpTopic topic =+    listToMaybe $ filter ((== topic) . helpTopicName) helpTopics
+ src/Matterhorn/IOUtil.hs view
@@ -0,0 +1,20 @@+module Matterhorn.IOUtil+  ( convertIOException+  )+where++import Prelude ()+import Matterhorn.Prelude++import Control.Exception+import Control.Monad.Trans.Except+import System.IO.Error ( ioeGetErrorString )+++convertIOException :: IO a -> ExceptT String IO a+convertIOException act = do+    result <- liftIO $ (Right <$> act) `catch`+                       (\(e::IOError) -> return $ Left $ ioeGetErrorString e)+    case result of+        Left e -> throwE e+        Right v -> return v
+ src/Matterhorn/InputHistory.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE TemplateHaskell #-}+module Matterhorn.InputHistory+  ( InputHistory+  , newHistory+  , readHistory+  , writeHistory+  , addHistoryEntry+  , getHistoryEntry+  , removeChannelHistory+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Monad.Trans.Except+import qualified Data.HashMap.Strict as HM+import qualified Data.Vector as V+import           Lens.Micro.Platform ( (.~), (^?), (%~), at, ix, makeLenses )+import           System.Directory ( createDirectoryIfMissing )+import           System.FilePath ( dropFileName )+import qualified System.IO.Strict as S+import qualified System.Posix.Files as P+import qualified System.Posix.Types as P++import           Network.Mattermost.Types ( ChannelId )++import           Matterhorn.FilePaths+import           Matterhorn.IOUtil+++data InputHistory =+    InputHistory { _historyEntries :: HashMap ChannelId (V.Vector Text)+                 }+                 deriving (Show)++makeLenses ''InputHistory++newHistory :: InputHistory+newHistory = InputHistory mempty++removeChannelHistory :: ChannelId -> InputHistory -> InputHistory+removeChannelHistory cId ih = ih & historyEntries.at cId .~ Nothing++historyFileMode :: P.FileMode+historyFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode++writeHistory :: InputHistory -> IO ()+writeHistory ih = do+    historyFile <- historyFilePath+    createDirectoryIfMissing True $ dropFileName historyFile+    let entries = (\(cId, z) -> (cId, V.toList z)) <$>+                  (HM.toList $ ih^.historyEntries)+    writeFile historyFile $ show entries+    P.setFileMode historyFile historyFileMode++readHistory :: IO (Either String InputHistory)+readHistory = runExceptT $ do+    contents <- convertIOException (S.readFile =<< historyFilePath)+    case reads contents of+        [(val, "")] -> do+            let entries = (\(cId, es) -> (cId, V.fromList es)) <$> val+            return $ InputHistory $ HM.fromList entries+        _ -> throwE "Failed to parse history file"++addHistoryEntry :: Text -> ChannelId -> InputHistory -> InputHistory+addHistoryEntry e cId ih = ih & historyEntries.at cId %~ insertEntry+    where+    insertEntry Nothing  = Just $ V.singleton e+    insertEntry (Just v) =+      Just $ V.cons e (V.filter (/= e) v)++getHistoryEntry :: ChannelId -> Int -> InputHistory -> Maybe Text+getHistoryEntry cId i ih = do+    es <- ih^.historyEntries.at cId+    es ^? ix i
+ src/Matterhorn/KeyMap.hs view
@@ -0,0 +1,28 @@+module Matterhorn.KeyMap+  ( keybindingModeMap+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Matterhorn.Events.Keybindings+import           Matterhorn.Events.ChannelSelect+import           Matterhorn.Events.Main+import           Matterhorn.Events.MessageSelect+import           Matterhorn.Events.PostListOverlay+import           Matterhorn.Events.ShowHelp+import           Matterhorn.Events.UrlSelect+import           Matterhorn.Events.ManageAttachments++keybindingModeMap :: [(String, KeyConfig -> KeyHandlerMap)]+keybindingModeMap =+    [ ("main", mainKeybindings)+    , ("help screen", helpKeybindings)+    , ("channel select", channelSelectKeybindings)+    , ("url select", urlSelectKeybindings)+    , ("message select", messageSelectKeybindings)+    , ("post list overlay", postListOverlayKeybindings)+    , ("attachment list", attachmentListKeybindings)+    , ("attachment file browse", attachmentBrowseKeybindings)+    ]
+ src/Matterhorn/LastRunState.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE TemplateHaskell #-}+module Matterhorn.LastRunState+  ( LastRunState+  , lrsHost+  , lrsPort+  , lrsUserId+  , lrsSelectedChannelId+  , writeLastRunState+  , readLastRunState+  , isValidLastRunState+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Monad.Trans.Except+import qualified Data.Aeson as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import           Lens.Micro.Platform ( makeLenses )+import           System.Directory ( createDirectoryIfMissing )+import           System.FilePath ( dropFileName )+import qualified System.Posix.Files as P+import qualified System.Posix.Types as P++import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.FilePaths+import           Matterhorn.IOUtil+import           Matterhorn.Types+++-- | Run state of the program. This is saved in a file on program exit and+-- | looked up from the file on program startup.+data LastRunState = LastRunState+  { _lrsHost              :: Hostname  -- ^ Host of the server+  , _lrsPort              :: Port      -- ^ Post of the server+  , _lrsUserId            :: UserId    -- ^ ID of the logged-in user+  , _lrsSelectedChannelId :: ChannelId -- ^ ID of the last selected channel+  }++instance A.ToJSON LastRunState where+  toJSON lrs = A.object [ "host"           A..= _lrsHost lrs+                        , "port"           A..= _lrsPort lrs+                        , "user_id"        A..= _lrsUserId lrs+                        , "sel_channel_id" A..= _lrsSelectedChannelId lrs+                        ]++instance A.FromJSON LastRunState where+  parseJSON = A.withObject "LastRunState" $ \v ->+    LastRunState+    <$> v A..: "host"+    <*> v A..: "port"+    <*> v A..: "user_id"+    <*> v A..: "sel_channel_id"++makeLenses ''LastRunState++toLastRunState :: ChatState -> LastRunState+toLastRunState cs = LastRunState+  { _lrsHost              = cs^.csResources.crConn.cdHostnameL+  , _lrsPort              = cs^.csResources.crConn.cdPortL+  , _lrsUserId            = myUserId cs+  , _lrsSelectedChannelId = cs^.csCurrentChannelId+  }++lastRunStateFileMode :: P.FileMode+lastRunStateFileMode = P.unionFileModes P.ownerReadMode P.ownerWriteMode++-- | Writes the run state to a file. The file is specific to the current team.+-- | Writes only if the current channel is an ordrinary or a private channel.+writeLastRunState :: ChatState -> IO ()+writeLastRunState cs =+  when (cs^.csCurrentChannel.ccInfo.cdType `elem` [Ordinary, Private]) $ do+    let runState = toLastRunState cs+        tId      = myTeamId cs++    lastRunStateFile <- lastRunStateFilePath $ unId $ toId tId+    createDirectoryIfMissing True $ dropFileName lastRunStateFile+    BS.writeFile lastRunStateFile $ LBS.toStrict $ A.encode runState+    P.setFileMode lastRunStateFile lastRunStateFileMode++-- | Reads the last run state from a file given the current team ID.+readLastRunState :: TeamId -> IO (Either String LastRunState)+readLastRunState tId = runExceptT $ do+  contents <- convertIOException $+    lastRunStateFilePath (unId $ toId tId) >>= BS.readFile+  case A.eitherDecodeStrict' contents of+    Right val -> return val+    Left err -> throwE $ "Failed to parse lastRunState file: " ++ err++-- | Checks if the given last run state is valid for the current server and user.+isValidLastRunState :: ChatResources -> User -> LastRunState -> Bool+isValidLastRunState cr me rs =+     rs^.lrsHost   == cr^.crConn.cdHostnameL+  && rs^.lrsPort   == cr^.crConn.cdPortL+  && rs^.lrsUserId == me^.userIdL
+ src/Matterhorn/Login.hs view
@@ -0,0 +1,594 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE RankNTypes #-}+-- | This module provides the login interface for Matterhorn.+--+-- * Overview+--+-- The interface provides a set of form fields for the user to use to+-- enter their server information and credentials. The user enters+-- this information and presses Enter, and then this module+-- attempts to connect to the server. The module's main function,+-- interactiveGetLoginSession, returns the result of that connection+-- attempt, if any.+--+-- * Details+--+-- The interactiveGetLoginSession function takes the Matterhorn+-- configuration's initial connection information as input. If the+-- configuration provided a complete set of values needed to make a+-- login attempt, this module goes ahead and immediately makes a login+-- attempt before even showing the user the login form. This case is+-- the case where the configuration provided all four values needed:+-- server host name, port, username, and password. When the interface+-- immediately makes a login attempt under these conditions, this is+-- referred to as an "initial" attempt in various docstrings below.+-- Otherwise, the user is prompted to fill out the form to enter any+-- missing values. On pressing Enter, a login attempt is made.+--+-- A status message about whether a connection is underway is shown in+-- both cases: in the case where the user has edited the credentials and+-- pressed Enter, and in the case where the original credentials+-- provided to interactiveGetLoginSession caused an initial connection+-- attempt.+--+-- The "initial" login case is special because in addition to not+-- showing the form, we want to ensure that the "connecting to..."+-- status message that is shown is shown long enough for the user to+-- see what is happening (rather than just flashing by in the case+-- of a fast server connection). For this usability reason, we have+-- a "startup timer" thread: the thread waits a specified number+-- of milliseconds (see 'startupTimerMilliseconds' below) and then+-- notifies the interface that it has timed out. If there is an initial+-- connection attempt underway that succeeds *before* the timer+-- fires, we wait until the timer fires before quitting the Login+-- application and returning control to Matterhorn. This ensures that+-- the "connecting to..." message stays on the screen long enough to not+-- be jarring, and to show the user what is happening. If the connection+-- fails before the timer fires, we just resume normal operation and+-- show the login form so the user can intervene.+module Matterhorn.Login+  ( LoginAttempt(..)+  , interactiveGetLoginSession+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.BChan+import           Brick.Focus+import           Brick.Forms+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import           Brick.Widgets.Edit+import           Control.Concurrent ( forkIO, threadDelay )+import           Control.Exception ( SomeException, catch, try )+import           Data.Char (isHexDigit)+import           Data.List (tails, inits)+import           System.IO.Error ( catchIOError )+import qualified Data.Text as T+import           Graphics.Vty hiding (mkVty)+import           Lens.Micro.Platform ( (.~), Lens', makeLenses )+import qualified System.IO.Error as Err+import           Network.URI ( URI(..), URIAuth(..), parseURI )++import           Network.Mattermost ( ConnectionData )+import           Network.Mattermost.Types.Internal ( Token(..) )+import           Network.Mattermost.Types ( Session(..), User, Login(..), ConnectionPoolConfig(..)+                                          , initConnectionData, ConnectionType(..), UserParam(..) )+import           Network.Mattermost.Exceptions ( LoginFailureException(..) )+import           Network.Mattermost.Endpoints ( mmGetUser, mmGetLimitedClientConfiguration, mmLogin )++import           Matterhorn.Draw.RichText+import           Matterhorn.Themes ( clientEmphAttr )+import           Matterhorn.Types ( ConnectionInfo(..)+                       , ciPassword, ciUsername, ciHostname, ciUrlPath+                       , ciPort, ciType, AuthenticationException(..)+                       , LogManager, LogCategory(..), ioLogWithManager+                       , ciAccessToken+                       )+++-- | Resource names for the login interface.+data Name =+      Server+    | Username+    | Password+    | AccessToken+    deriving (Ord, Eq, Show)++-- | The result of an authentication attempt.+data LoginAttempt =+    AttemptFailed AuthenticationException+    -- ^ The attempt failed with the corresponding error.+    | AttemptSucceeded ConnectionInfo ConnectionData Session User (Maybe Text) --team+    -- ^ The attempt succeeded.++-- | The state of the login interface: whether a login attempt is+-- currently in progress.+data LoginState =+    Idle+    -- ^ No login attempt is in progress.+    | Connecting Bool Text+    -- ^ A login attempt to the specified host is in progress. The+    -- boolean flag indicates whether this login was user initiated+    -- (False) or triggered immediately when starting the interface+    -- (True). This "initial" flag is used to determine whether the+    -- login form is shown while the connection attempt is underway.+    deriving (Eq)++-- | Requests that we can make to the login worker thead.+data LoginRequest =+    DoLogin Bool ConnectionInfo+    -- ^ Request a login using the specified connection information.+    -- The boolean flag is the "initial" flag value corresponding to the+    -- "Connecting" constructor flag of the "LoginState" type.++-- | The messages that the login worker thread can send to the user+-- interface event handler.+data LoginEvent =+    StartConnect Bool Text+    -- ^ A connection to the specified host has begun. The boolean+    -- value is whether this was an "initial" connection attempt (see+    -- LoginState).+    | LoginResult LoginAttempt+    -- ^ A login attempt finished with the specified result.+    | StartupTimeout+    -- ^ The startup timer thread fired.++-- | The login application state.+data State =+    State { _loginForm :: Form ConnectionInfo LoginEvent Name+          , _lastAttempt :: Maybe LoginAttempt+          , _currentState :: LoginState+          , _reqChan :: BChan LoginRequest+          , _timeoutFired :: Bool+          }++makeLenses ''State++-- | The HTTP connection pool settings for the login worker thread.+poolCfg :: ConnectionPoolConfig+poolCfg = ConnectionPoolConfig { cpIdleConnTimeout = 60+                               , cpStripesCount = 1+                               , cpMaxConnCount = 5+                               }++-- | Run an IO action and convert various kinds of thrown exceptions+-- into a returned AuthenticationException.+convertLoginExceptions :: IO a -> IO (Either AuthenticationException a)+convertLoginExceptions act =+    (Right <$> act)+        `catch` (\e -> return $ Left $ ResolveError e)+        `catch` (\e -> return $ Left $ ConnectError e)+        `catchIOError` (\e -> return $ Left $ AuthIOError e)+        `catch` (\e -> return $ Left $ OtherAuthError e)++-- | The login worker thread.+loginWorker :: (ConnectionData -> ConnectionData)+            -- ^ The function used to set the logger on the+            -- ConnectionData that results from a successful login+            -- attempt.+            -> LogManager+            -- ^ The log manager used to do logging.+            -> BChan LoginRequest+            -- ^ The channel on which we'll await requests.+            -> BChan LoginEvent+            -- ^ The channel to which we'll send login attempt results.+            -> IO ()+loginWorker setLogger logMgr requestChan respChan = forever $ do+    req <- readBChan requestChan+    case req of+        DoLogin initial connInfo -> do+            writeBChan respChan $ StartConnect initial $ connInfo^.ciHostname+            let doLog = ioLogWithManager logMgr Nothing LogGeneral++            doLog $ "Attempting authentication to " <> connInfo^.ciHostname++            cdResult <- findConnectionData connInfo+            case cdResult of+              Left e ->+                do writeBChan respChan $ LoginResult $ AttemptFailed $ OtherAuthError e+              Right (cd_, mbTeam) -> do+                  let cd = setLogger cd_+                      token = connInfo^.ciAccessToken+                  case T.null token of+                      False -> do+                          let sess = Session cd $ Token $ T.unpack token++                          userResult <- try $ mmGetUser UserMe sess+                          writeBChan respChan $ case userResult of+                              Left (e::SomeException) ->+                                  LoginResult $ AttemptFailed $ OtherAuthError e+                              Right user ->+                                  LoginResult $ AttemptSucceeded connInfo cd sess user mbTeam+                      True -> do+                          let login = Login { username = connInfo^.ciUsername+                                            , password = connInfo^.ciPassword+                                            }++                          result <- convertLoginExceptions $ mmLogin cd login+                          case result of+                              Left e -> do+                                  doLog $ "Error authenticating to " <> connInfo^.ciHostname <> ": " <> (T.pack $ show e)+                                  writeBChan respChan $ LoginResult $ AttemptFailed e+                              Right (Left e) -> do+                                  doLog $ "Error authenticating to " <> connInfo^.ciHostname <> ": " <> (T.pack $ show e)+                                  writeBChan respChan $ LoginResult $ AttemptFailed $ LoginError e+                              Right (Right (sess, user)) -> do+                                  doLog $ "Authenticated successfully to " <> connInfo^.ciHostname <> " as " <> connInfo^.ciUsername+                                  writeBChan respChan $ LoginResult $ AttemptSucceeded connInfo cd sess user mbTeam++++-- | Searches prefixes of the given URL to determine Mattermost API URL+-- path and team name+findConnectionData :: ConnectionInfo -> IO (Either SomeException (ConnectionData, Maybe Text))+findConnectionData connInfo = startSearch+  where+    components = filter (not . T.null) (T.split ('/'==) (connInfo^.ciUrlPath))++    -- the candidates list is never empty because inits never returns an+    -- empty list+    primary:alternatives =+        reverse+        [ (T.intercalate "/" l, listToMaybe r)+        | (l,r) <- zip (inits components) (tails components)+        ]++    tryCandidate :: (Text, Maybe Text)+                 -> IO (Either SomeException (ConnectionData, Maybe Text))+    tryCandidate (path, team) =+       do cd  <- initConnectionData (connInfo^.ciHostname)+                                    (fromIntegral (connInfo^.ciPort))+                                    path (connInfo^.ciType) poolCfg+          res <- try (mmGetLimitedClientConfiguration cd)+          pure $! case res of+                    Left e  -> Left e+                    Right{} -> Right (cd, team)++    -- This code prefers to report the error from the URL corresponding+    -- to what the user actually provided. Errors from derived URLs are+    -- lost in favor of this first error.+    startSearch =+      do res1 <- tryCandidate primary+         case res1 of+           Left e -> search e alternatives+           Right cd -> pure (Right cd)++    search e [] = pure (Left e)+    search e (x:xs) =+      do res <- tryCandidate x+         case res of+           Left {}  -> search e xs+           Right cd -> pure (Right cd)+++-- | The amount of time that the startup timer thread will wait before+-- firing.+startupTimerMilliseconds :: Int+startupTimerMilliseconds = 750++-- | The startup timer thread.+startupTimer :: BChan LoginEvent -> IO ()+startupTimer respChan = do+    threadDelay $ startupTimerMilliseconds * 1000+    writeBChan respChan StartupTimeout++-- | The main function of this module: interactively present a login+-- interface, get the user's input, and attempt to log into the user's+-- specified mattermost server.+--+-- This always returns the final terminal state handle. If the user+-- makes no login attempt, this returns Nothing. Otherwise it returns+-- Just the result of the latest attempt.+interactiveGetLoginSession :: Vty+                           -- ^ The initial terminal state handle to use.+                           -> IO Vty+                           -- ^ An action to build a new state handle+                           -- if one is needed. (In practice this+                           -- never fires since the login app doesn't+                           -- use suspendAndResume, but we need it to+                           -- satisfy the Brick API.)+                           -> (ConnectionData -> ConnectionData)+                           -- ^ The function to set the logger on+                           -- connection handles.+                           -> LogManager+                           -- ^ The log manager used to do logging.+                           -> ConnectionInfo+                           -- ^ Initial connection info to use to+                           -- populate the login form. If the connection+                           -- info provided here is fully populated, an+                           -- initial connection attempt is made without+                           -- first getting the user to hit Enter.+                           -> IO (Maybe LoginAttempt, Vty)+interactiveGetLoginSession vty mkVty setLogger logMgr initialConfig = do+    requestChan <- newBChan 10+    respChan <- newBChan 10++    void $ forkIO $ loginWorker setLogger logMgr requestChan respChan+    void $ forkIO $ startupTimer respChan++    let initialState = mkState initialConfig requestChan++    startState <- case (populatedConnectionInfo initialConfig) of+        True -> do+            writeBChan requestChan $ DoLogin True initialConfig+            return $ initialState & currentState .~ Connecting True (initialConfig^.ciHostname)+        False -> do+            return initialState++    (finalSt, finalVty) <- customMainWithVty vty mkVty (Just respChan) app startState++    return (finalSt^.lastAttempt, finalVty)++-- | Is the specified ConnectionInfo sufficiently populated for us to+-- bother attempting to use it to connect?+populatedConnectionInfo :: ConnectionInfo -> Bool+populatedConnectionInfo ci =+    and [ not $ T.null $ ci^.ciHostname+        , or [ and [ not $ T.null $ ci^.ciUsername+                   , not $ T.null $ ci^.ciPassword+                   ]+             , not $ T.null $ ci^.ciAccessToken+             ]+        , ci^.ciPort > 0+        ]++-- | Make an initial login application state.+mkState :: ConnectionInfo -> BChan LoginRequest -> State+mkState cInfo chan = state+    where+        state = State { _loginForm = form { formFocus = focusSetCurrent initialFocus (formFocus form)+                                          }+                      , _currentState = Idle+                      , _lastAttempt = Nothing+                      , _reqChan = chan+                      , _timeoutFired = False+                      }+        form = mkForm cInfo+        initialFocus = if | T.null (cInfo^.ciHostname) -> Server+                          | T.null (cInfo^.ciUsername) -> Username+                          | T.null (cInfo^.ciPassword) -> Password+                          | otherwise                  -> Server++app :: App State LoginEvent Name+app = App+  { appDraw         = credsDraw+  , appChooseCursor = showFirstCursor+  , appHandleEvent  = onEvent+  , appStartEvent   = return+  , appAttrMap      = const colorTheme+  }++onEvent :: State -> BrickEvent Name LoginEvent -> EventM Name (Next State)+onEvent st (VtyEvent (EvKey KEsc [])) = do+    halt $ st & lastAttempt .~ Nothing+onEvent st (AppEvent (StartConnect initial host)) = do+    continue $ st & currentState .~ Connecting initial host+                  & lastAttempt .~ Nothing+onEvent st (AppEvent StartupTimeout) = do+    -- If the startup timer fired and we have already succeeded, halt.+    case st^.lastAttempt of+        Just (AttemptSucceeded {}) -> halt st+        _ -> continue $ st & timeoutFired .~ True+onEvent st (AppEvent (LoginResult attempt)) = do+    let st' = st & lastAttempt .~ Just attempt+                 & currentState .~ Idle++    case attempt of+        AttemptSucceeded {} -> do+            -- If the startup timer already fired, halt. Otherwise wait+            -- until that timer fires.+            case st^.timeoutFired of+                True -> halt st'+                False -> continue st'+        AttemptFailed {} -> continue st'++onEvent st (VtyEvent (EvKey KEnter [])) = do+    -- Ignore the keypress if we are already attempting a connection, or+    -- if have already successfully connected but are waiting on the+    -- startup timer.+    case st^.currentState of+        Connecting {} -> return ()+        Idle ->+            case st^.lastAttempt of+                Just (AttemptSucceeded {}) -> return ()+                _ -> do+                    let ci = formState $ st^.loginForm+                    when (populatedConnectionInfo ci) $ do+                        liftIO $ writeBChan (st^.reqChan) $ DoLogin False ci++    continue st+onEvent st e = do+    f' <- handleFormEvent e (st^.loginForm)+    continue $ st & loginForm .~ f'++mkForm :: ConnectionInfo -> Form ConnectionInfo e Name+mkForm =+    let label s w = padBottom (Pad 1) $+                    (vLimit 1 $ hLimit 22 $ str s <+> fill ' ') <+> w+        above s w = hCenter (str s) <=> w+    in newForm [ label "Server URL:"     @@= editServer+               , (above "Provide a username and password:" .+                  label "Username:")     @@= editTextField ciUsername Username (Just 1)+               , label "Password:"       @@= editPasswordField ciPassword Password+               , (above "Or provide a Session or Personal Access Token:" .+                  label "Access Token:") @@= editPasswordField ciAccessToken AccessToken+               ]++serverLens :: Lens' ConnectionInfo (Text, Int, Text, ConnectionType)+serverLens f ci = fmap (\(x,y,z,w) -> ci { _ciHostname = x, _ciPort = y, _ciUrlPath = z, _ciType = w})+                       (f (ci^.ciHostname, ci^.ciPort, ci^.ciUrlPath, ci^.ciType))++-- | Validate a server URI @hostname[:port][/path]@. Result is either an error message+-- indicating why validation failed or a tuple of (hostname, port, path)+validServer :: [Text] -> Either String (Text, Int, Text, ConnectionType)+validServer ts =++  do t <- case ts of+            []  -> Left "No input"+            [t] -> Right t+            _   -> Left "Too many lines"++     let inputWithScheme+           | "://" `T.isInfixOf` t = t+           | otherwise = "https://" <> t++     uri <- case parseURI (T.unpack inputWithScheme) of+              Nothing  -> Left "Unable to parse URI"+              Just uri -> Right uri++     auth <- case uriAuthority uri of+               Nothing   -> Left "Missing authority part"+               Just auth -> Right auth++     ty <- case uriScheme uri of+             "http:"           -> Right ConnectHTTP+             "https:"          -> Right (ConnectHTTPS True)+             "https-insecure:" -> Right (ConnectHTTPS False)+             _                 -> Left "Unknown scheme"++     port <- case (ty, uriPort auth) of+               (ConnectHTTP   , "") -> Right 80+               (ConnectHTTPS{}, "") -> Right 443+               (_, ':':portStr)+                 | Just port <- readMaybe portStr -> Right port+               _ -> Left "Invalid port"++     let host+           | not (null (uriRegName auth))+           , '[' == head (uriRegName auth)+           , ']' == last (uriRegName auth)+           = init (tail (uriRegName auth))+           | otherwise = uriRegName auth++     if null (uriRegName auth) then Left "Missing server name" else Right ()+     if null (uriQuery uri) then Right () else Left "Unexpected URI query"+     if null (uriFragment uri) then Right () else Left "Unexpected URI fragment"+     if null (uriUserInfo auth) then Right () else Left "Unexpected credentials"++     Right (T.pack host, port, T.pack (uriPath uri), ty)+++renderServer :: (Text, Int, Text, ConnectionType) -> Text+renderServer (h,p,u,t) = scheme <> hStr <> portStr <> uStr+  where+    hStr+      | T.all (\x -> isHexDigit x || ':'==x) h+      , T.any (':'==) h = "[" <> h <> "]"+      | otherwise = h++    scheme =+      case t of+        ConnectHTTP        -> "http://"+        ConnectHTTPS True  -> ""+        ConnectHTTPS False -> "https-insecure://"++    uStr+      | T.null u = u+      | otherwise = T.cons '/' (T.dropWhile ('/'==) u)++    portStr =+      case t of+        ConnectHTTP    | p ==  80 -> T.empty+        ConnectHTTPS{} | p == 443 -> T.empty+        _                         -> T.pack (':':show p)++editServer :: ConnectionInfo -> FormFieldState ConnectionInfo e Name+editServer =+    let val ts = case validServer ts of+                   Left{} -> Nothing+                   Right x-> Just x+        limit = Just 1+        renderTxt [""] = str "(Paste your Mattermost URL here)"+        renderTxt ts = txt (T.unlines ts)+    in editField serverLens Server limit renderServer val renderTxt id++errorAttr :: AttrName+errorAttr = "errorMessage"++colorTheme :: AttrMap+colorTheme = attrMap defAttr+  [ (editAttr, black `on` white)+  , (editFocusedAttr, black `on` yellow)+  , (errorAttr, fg red)+  , (focusedFormInputAttr, black `on` yellow)+  , (invalidFormInputAttr, white `on` red)+  , (clientEmphAttr, fg white `withStyle` bold)+  ]++credsDraw :: State -> [Widget Name]+credsDraw st =+    [ center $ vBox [ if shouldShowForm st then credentialsForm st else emptyWidget+                    , currentStateDisplay st+                    , lastAttemptDisplay (st^.lastAttempt)+                    ]+    ]++-- | Whether the login form should be displayed.+shouldShowForm :: State -> Bool+shouldShowForm st =+    case st^.currentState of+        -- If we're connecting, only show the form if the connection+        -- attempt is not an initial one.+        Connecting initial _ -> not initial++        -- If we're idle, we want to show the form - unless we have+        -- already connected and are waiting for the startup timer to+        -- fire.+        Idle -> case st^.lastAttempt of+            Just (AttemptSucceeded {}) -> st^.timeoutFired+            _ -> True++-- | The "current state" of the login process. Show a connecting status+-- message if a connection is underway, or if one is already established+-- and the startup timer has not fired.+currentStateDisplay :: State -> Widget Name+currentStateDisplay st =+    let msg host = padTop (Pad 1) $ hCenter $+                   txt "Connecting to " <+> withDefAttr clientEmphAttr (txt host) <+> txt "..."+    in case st^.currentState of+          Idle -> case st^.lastAttempt of+              Just (AttemptSucceeded ci _ _ _ _) -> msg (ci^.ciHostname)+              _ -> emptyWidget+          (Connecting _ host) -> msg host++lastAttemptDisplay :: Maybe LoginAttempt -> Widget Name+lastAttemptDisplay Nothing = emptyWidget+lastAttemptDisplay (Just (AttemptSucceeded {})) = emptyWidget+lastAttemptDisplay (Just (AttemptFailed e)) =+    hCenter $ hLimit uiWidth $+    padTop (Pad 1) $ renderError $ renderText $+    "Error: " <> renderAuthError e++renderAuthError :: AuthenticationException -> Text+renderAuthError (ConnectError _) =+    "Could not connect to server"+renderAuthError (ResolveError _) =+    "Could not resolve server hostname"+renderAuthError (AuthIOError err)+  | Err.isDoesNotExistErrorType (Err.ioeGetErrorType err) =+    "Unable to connect to the network"+  | otherwise = "GetAddrInfo: " <> T.pack (Err.ioeGetErrorString err)+renderAuthError (OtherAuthError e) =+    T.pack $ show e+renderAuthError (LoginError (LoginFailureException msg)) =+    T.pack msg++renderError :: Widget a -> Widget a+renderError = withDefAttr errorAttr++uiWidth :: Int+uiWidth = 60++credentialsForm :: State -> Widget Name+credentialsForm st =+    hCenter $ hLimit uiWidth $ vLimit 15 $+    border $+    vBox [ renderText "Please enter your Mattermost credentials to log in."+         , padTop (Pad 1) $ renderForm (st^.loginForm)+         , hCenter $ renderText "Press Enter to log in or Esc to exit."+         ]
+ src/Matterhorn/Options.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE TemplateHaskell #-}++module Matterhorn.Options where++import Prelude ()+import Matterhorn.Prelude++import Data.Char ( toLower )+import Data.Foldable (traverse_)+import Data.Tuple ( swap )+import Data.Version ( showVersion )+import Development.GitRev+import Network.Mattermost.Version ( mmApiVersion )+import Paths_matterhorn ( version )+import System.Console.GetOpt+import System.Environment ( getArgs )+import System.Exit ( exitFailure, exitSuccess )+import System.IO ( hPutStrLn, stderr )++import Matterhorn.Config+++data Behaviour+  = Normal+  | ShowVersion+  | ShowHelp+  | CheckConfig+    deriving (Eq, Show)++data PrintFormat =+    Markdown | Plain deriving (Eq, Show)++data Options = Options+  { optConfLocation     :: Maybe FilePath+  , optLogLocation      :: Maybe FilePath+  , optBehaviour        :: Behaviour+  , optIgnoreConfig     :: Bool+  , optPrintKeybindings :: Bool+  , optPrintCommands    :: Bool+  , optPrintFormat      :: PrintFormat+  } deriving (Eq, Show)++defaultOptions :: Options+defaultOptions = Options+  { optConfLocation     = Nothing+  , optLogLocation      = Nothing+  , optBehaviour        = Normal+  , optIgnoreConfig     = False+  , optPrintKeybindings = False+  , optPrintCommands    = False+  , optPrintFormat      = Plain+  }++optDescrs :: [OptDescr (Options -> Options)]+optDescrs =+  [ Option ['c'] ["config"]+    (ReqArg (\ path c -> c { optConfLocation = Just path }) "PATH")+    "Path to the configuration file"+  , Option ['l'] ["logs"]+    (ReqArg (\ path c -> c { optLogLocation = Just path }) "PATH")+    "Debug log output path"+  , Option ['v'] ["version"]+    (NoArg (\ c -> c { optBehaviour = ShowVersion }))+    "Print version information and exit"+  , Option ['h'] ["help"]+    (NoArg (\ c -> c { optBehaviour = ShowHelp }))+    "Print help for command-line flags and exit"+  , Option ['i'] ["ignore-config"]+    (NoArg (\ c -> c { optIgnoreConfig = True }))+    "Start with no configuration"+  , Option ['k'] ["keybindings"]+    (NoArg (\ c -> c { optPrintKeybindings = True }))+    "Print keybindings effective for the current configuration"+  , Option ['m'] ["commands"]+    (NoArg (\ c -> c { optPrintCommands = True }))+    "Print available commands"+  , Option ['f'] ["format"]+    (ReqArg handleFormat "FORMAT")+    ("Print keybinding or command output in the specified format " <>+     "(options: " <> formatChoicesStr <> ", default: " <>+     formatStringFor (optPrintFormat defaultOptions) <> ")")+  , Option [] ["check-config"]+    (NoArg (\ c -> c { optBehaviour = CheckConfig }))+    "Validate configuration file"+  ]++formatChoices :: [(String, PrintFormat)]+formatChoices =+    [ ("plain", Plain)+    , ("markdown", Markdown)+    ]++formatStringFor :: PrintFormat -> String+formatStringFor fmt =+    case lookup fmt (swap <$> formatChoices) of+        Nothing -> error $ "BUG: no format string for " <> show fmt+        Just s -> s++formatChoicesStr :: String+formatChoicesStr = intercalate ", " $ fst <$> formatChoices++handleFormat :: String -> Options -> Options+handleFormat fmtStr c =+    let fmt = case lookup (toLower <$> fmtStr) formatChoices of+            Just f -> f+            Nothing ->+                error $ "Invalid format: " <> show fmtStr <> ", choices: " <>+                        formatChoicesStr+    in c { optPrintFormat = fmt }++mhVersion :: String+mhVersion+  | $(gitHash) == ("UNKNOWN" :: String) = "matterhorn " ++ showVersion version+  | otherwise = "matterhorn " ++ showVersion version ++ " (" +++                $(gitBranch) ++ "@" ++ take 7 $(gitHash) ++ ")"++fullVersionString :: String+fullVersionString = mhVersion ++ "\n using " ++ mmApiVersion++usage :: IO ()+usage = putStr (usageInfo "matterhorn" optDescrs)++grabOptions :: IO Options+grabOptions = do+  args <- getArgs+  case getOpt Permute optDescrs args of+    (aps, [], []) -> do+      let rs = foldr (.) id aps defaultOptions+      case optBehaviour rs of+        Normal -> return rs+        ShowHelp -> usage >> exitSuccess+        ShowVersion -> putStrLn fullVersionString >> exitSuccess+        CheckConfig -> checkConfiguration (optConfLocation rs)+    (_, _, errs) -> do+      mapM_ putStr errs+      usage+      exitFailure++checkConfiguration :: Maybe FilePath -> IO a+checkConfiguration mb =+  do res <- findConfig mb+     let writeLn = hPutStrLn stderr+         printLocation Nothing = "No configuration file"+         printLocation (Just fp) = "Location: " ++ fp+     case res of+       Left e ->+         do writeLn e+            exitFailure+       Right ([], config) ->+         do writeLn "Configuration file valid"+            writeLn (printLocation (configAbsPath config))+            exitSuccess+       Right (ws, config) ->+         do writeLn "Configuration file generated warnings"+            writeLn (printLocation (configAbsPath config))+            traverse_ writeLn ws+            exitFailure
+ src/Matterhorn/Prelude.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE CPP #-}++{-| This module is for internal re-exports of commonly-used+  functions. This also lets us avoid churn between versions of GHC by+  putting changed functions behind CPP in a single place.+-}++{-+  GHC version <--> base version (https://wiki.haskell.org/Base_package) includes:+     8.0.1      4.9.0.0+     8.2.1      4.10.0.0+     8.4.1      4.11.0.0++  GHC distributions include a set of core packages; overriding these+  with new versions is unwise.  Core packages include (see+  https://downloads.haskell.org/~ghc/X.Y.Z/docs/html/users_guide/X.Y.Z-notes.html#included-libraries+  ):++    base, Cabal, array, bytestring, containers, deepseq, directory,+    filepath, mtl, parsec, process, text, time, unix+-}++module Matterhorn.Prelude+  ( module P+#if !MIN_VERSION_base(4,9,0)+  , (<>)+#endif+  , (<|>)+  -- commonly-used functions from Maybe+  , Maybe.isJust+  , Maybe.isNothing+  , Maybe.listToMaybe+  , Maybe.maybeToList+  , Maybe.fromMaybe+  , Maybe.catMaybes++  -- a non-partial Read function+  , Read.readMaybe++  -- commonly-used functions from Monad+  , Monad.forM+  , Monad.forM_+  , Monad.filterM+  , Monad.when+  , Monad.unless+  , Monad.void+  , Monad.join+  , Monad.forever+  , Monad.foldM+  , Monad.MonadIO(..)++  -- commonly-used functions from List+  , Foldable.toList+  , List.find+  , List.sort+  , List.intercalate+  , Exts.sortWith+  , Exts.groupWith++  -- common read-only lens operators+  , (Lens.&)+  , (Lens.^.)+  , Lens.use++  -- not available in all versions of GHC currently in use+#if MIN_VERSION_base(4,10,0)+  , Clock.nominalDay+#else+  , nominalDay+#endif++  -- various type aliases+  , Text+  , HashMap+  , Seq+  , Set+  , Time.UTCTime+  , Time.TimeZoneSeries+  , Time.NominalDiffTime+  )+where+++#if !MIN_VERSION_base(4,11,0)+import           Data.Semigroup ( (<>) )+#endif++import           Control.Applicative ( (<|>) )+import qualified Control.Monad as Monad+import qualified Control.Monad.IO.Class as Monad+import qualified Data.Foldable as Foldable+import qualified Data.List as List+import qualified Data.Maybe as Maybe+import qualified Data.Time as Time+#if MIN_VERSION_base(4,10,0)+import qualified Data.Time.Clock as Clock+#endif+import qualified Data.Time.LocalTime.TimeZone.Series as Time+import qualified GHC.Exts as Exts+import qualified Lens.Micro.Platform as Lens+import           Prelude.Compat+import qualified Prelude.Compat as P+import qualified Text.Read as Read++-- these below we import only for type aliases+import           Data.HashMap.Strict ( HashMap )+import           Data.Sequence ( Seq )+import           Data.Set ( Set )+import           Data.Text ( Text )++#if !MIN_VERSION_base(4,10,0)+nominalDay :: Time.NominalDiffTime+nominalDay = 86400+#endif
+ src/Matterhorn/Scripts.hs view
@@ -0,0 +1,81 @@+module Matterhorn.Scripts+  ( findAndRunScript+  , listScripts+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Concurrent ( takeMVar, newEmptyMVar )+import qualified Control.Concurrent.STM as STM+import qualified Data.Text as T+import           System.Exit ( ExitCode(..) )++import           Network.Mattermost.Types ( ChannelId )++import           Matterhorn.FilePaths ( Script(..), getAllScripts, locateScriptPath )+import           Matterhorn.State.Common+import           Matterhorn.State.Messages ( sendMessage )+import           Matterhorn.Types+++findAndRunScript :: ChannelId -> Text -> Text -> MH ()+findAndRunScript cId scriptName input = do+    fpMb <- liftIO $ locateScriptPath (T.unpack scriptName)+    outputChan <- use (csResources.crSubprocessLog)+    case fpMb of+      ScriptPath scriptPath -> do+        doAsyncWith Preempt $ runScript cId outputChan scriptPath input+      NonexecScriptPath scriptPath -> do+        let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <>+             "executed. Try running\n" <>+             "```\n" <>+             "$ chmod u+x " <> T.pack scriptPath <> "\n" <>+             "```\n" <>+             "to correct this error. " <> scriptHelpAddendum)+        mhError $ GenericError msg+      ScriptNotFound -> do+        mhError $ NoSuchScript scriptName++runScript :: ChannelId -> STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))+runScript cId outputChan fp text = do+  outputVar <- newEmptyMVar+  runLoggedCommand outputChan fp [] (Just $ T.unpack text) (Just outputVar)+  po <- takeMVar outputVar+  return $ case programExitCode po of+    ExitSuccess -> do+        case null $ programStderr po of+            True -> Just $ do+                mode <- use (csEditState.cedEditMode)+                sendMessage cId mode (T.pack $ programStdout po) []+            False -> Nothing+    ExitFailure _ -> Nothing++listScripts :: MH ()+listScripts = do+  (execs, nonexecs) <- liftIO getAllScripts+  let scripts = ("Available scripts are:\n" <>+                 mconcat [ "  - " <> T.pack cmd <> "\n"+                         | cmd <- execs+                         ])+  postInfoMessage scripts+  case nonexecs of+    [] -> return ()+    _  -> do+      let errMsg = ("Some non-executable script files are also " <>+                    "present. If you want to run these as scripts " <>+                    "in Matterhorn, mark them executable with \n" <>+                    "```\n" <>+                    "$ chmod u+x [script path]\n" <>+                    "```\n" <>+                    "\n" <>+                    mconcat [ "  - " <> T.pack cmd <> "\n"+                            | cmd <- nonexecs+                            ] <> "\n" <> scriptHelpAddendum)+      mhError $ GenericError errMsg++scriptHelpAddendum :: Text+scriptHelpAddendum =+  "For more help with scripts, run the command\n" <>+  "```\n/help scripts\n```\n"
+ src/Matterhorn/State/Async.hs view
@@ -0,0 +1,161 @@+module Matterhorn.State.Async+  ( AsyncPriority(..)+  , doAsync+  , doAsyncIO+  , doAsyncWith+  , doAsyncChannelMM+  , doAsyncWithIO+  , doAsyncMM+  , tryMM+  , endAsyncNOP+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Control.Concurrent.STM as STM+import           Control.Exception ( try )++import           Network.Mattermost.Types++import           Matterhorn.Types+++-- | Try to run a computation, posting an informative error+--   message if it fails with a 'MattermostServerError'.+tryMM :: IO a+      -- ^ The action to try (usually a MM API call)+      -> (a -> IO (Maybe (MH ())))+      -- ^ What to do on success+      -> IO (Maybe (MH ()))+tryMM act onSuccess = do+    result <- liftIO $ try act+    case result of+        Left e -> return $ Just $ mhError $ ServerError e+        Right value -> liftIO $ onSuccess value++-- * Background Computation++-- $background_computation+--+-- The main context for Matterhorn is the EventM context provided by+-- the 'Brick' library.  This context is normally waiting for user+-- input (or terminal resizing, etc.) which gets turned into an+-- MHEvent and the 'onEvent' event handler is called to process that+-- event, after which the display is redrawn as necessary and brick+-- awaits the next input.+--+-- However, it is often convenient to communicate with the Mattermost+-- server in the background, so that large numbers of+-- synchronously-blocking events (e.g. on startup) or refreshes can+-- occur whenever needed and without negatively impacting the UI+-- updates or responsiveness.  This is handled by a 'forkIO' context+-- that waits on an STM channel for work to do, performs the work, and+-- then sends brick an MHEvent containing the completion or failure+-- information for that work.+--+-- The /doAsyncWith/ family of functions here facilitates that+-- asynchronous functionality.  This is typically used in the+-- following fashion:+--+-- > doSomething :: MH ()+-- > doSomething = do+-- >    got <- something+-- >    doAsyncWith Normal $ do+-- >       r <- mmFetchR ....+-- >       return $ do+-- >          csSomething.here %= processed r+--+-- The second argument is an IO monad operation (because 'forkIO' runs+-- in the IO Monad context), but it returns an MH monad operation.+-- The IO monad has access to the closure of 'doSomething' (e.g. the+-- 'got' value), but it should be aware that the state of the MH monad+-- may have been changed by the time the IO monad runs in the+-- background, so the closure is a snapshot of information at the time+-- the 'doAsyncWith' was called.+--+-- Similarly, the returned MH monad operation is *not* run in the+-- context of the 'forkIO' background, but it is instead passed via an+-- MHEvent back to the main brick thread, where it is executed in an+-- EventM handler's MH monad context.  This operation therefore has+-- access to the combined closure of the pre- 'doAsyncWith' code and+-- the closure of the IO operation.  It is important that the final MH+-- monad operation should *re-obtain* state information from the MH+-- monad instead of using or setting the state obtained prior to the+-- 'doAsyncWith' call.++-- | Priority setting for asynchronous work items. Preempt means that+-- the queued item will be the next work item begun (i.e. it goes to the+-- front of the queue); normal means it will go last in the queue.+data AsyncPriority = Preempt | Normal++-- | Run a computation in the background, ignoring any results from it.+doAsync :: AsyncPriority -> IO () -> MH ()+doAsync prio act = doAsyncWith prio (act >> return Nothing)++-- | Run a computation in the background, returning a computation to be+-- called on the 'ChatState' value.+doAsyncWith :: AsyncPriority -> IO (Maybe (MH ())) -> MH ()+doAsyncWith prio act = do+    let putChan = case prio of+          Preempt -> STM.unGetTChan+          Normal  -> STM.writeTChan+    queue <- use (csResources.crRequestQueue)+    liftIO $ STM.atomically $ putChan queue act++doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()+doAsyncIO prio st act =+  doAsyncWithIO prio st (act >> return Nothing)++-- | Run a computation in the background, returning a computation to be+-- called on the 'ChatState' value.+doAsyncWithIO :: AsyncPriority -> ChatState -> IO (Maybe (MH ())) -> IO ()+doAsyncWithIO prio st act = do+    let putChan = case prio of+          Preempt -> STM.unGetTChan+          Normal  -> STM.writeTChan+    let queue = st^.csResources.crRequestQueue+    STM.atomically $ putChan queue act++-- | Performs an asynchronous IO operation. On completion, the final+-- argument a completion function is executed in an MH () context in the+-- main (brick) thread.+doAsyncMM :: AsyncPriority+          -- ^ the priority for this async operation+          -> (Session -> IO a)+          -- ^ the async MM channel-based IO operation+          -> (a -> Maybe (MH ()))+          -- ^ function to process the results in brick event handling+          -- context+          -> MH ()+doAsyncMM prio mmOp eventHandler = do+  session <- getSession+  doAsyncWith prio $ do+    r <- mmOp session+    return $ eventHandler r++-- | Helper type for a function to perform an asynchronous MM operation+-- on a channel and then invoke an MH completion event.+type DoAsyncChannelMM a =+    AsyncPriority+    -- ^ the priority for this async operation+    -> ChannelId+    -- ^ The channel+    -> (Session -> ChannelId -> IO a)+    -- ^ the asynchronous Mattermost channel-based IO operation+    -> (ChannelId -> a -> Maybe (MH ()))+    -- ^ function to process the results in brick event handling context+    -> MH ()++-- | Performs an asynchronous IO operation on a specific channel. On+-- completion, the final argument a completion function is executed in+-- an MH () context in the main (brick) thread.+doAsyncChannelMM :: DoAsyncChannelMM a+doAsyncChannelMM prio cId mmOp eventHandler =+  doAsyncMM prio (\s -> mmOp s cId) (eventHandler cId)++-- | Use this convenience function if no operation needs to be+-- performed in the MH state after an async operation completes.+endAsyncNOP :: ChannelId -> a -> Maybe (MH ())+endAsyncNOP _ _ = Nothing
+ src/Matterhorn/State/Attachments.hs view
@@ -0,0 +1,53 @@+module Matterhorn.State.Attachments+  ( showAttachmentList+  , resetAttachmentList+  , showAttachmentFileBrowser+  )+where++import           Prelude ()+import           Matterhorn.Prelude+import qualified Control.Exception as E+import           Data.Either ( isRight )+import           System.Directory ( doesDirectoryExist, getDirectoryContents )+import           Data.Bool ( bool )++import           Brick ( vScrollToBeginning, viewportScroll )+import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.FileBrowser as FB+import           Lens.Micro.Platform ( (.=) )++import           Matterhorn.Types++validateAttachmentPath :: FilePath -> IO (Maybe FilePath)+validateAttachmentPath path = bool Nothing (Just path) <$> do+    ex <- doesDirectoryExist path+    case ex of+        False -> return False+        True -> do+            result :: Either E.SomeException [FilePath]+                   <- E.try $ getDirectoryContents path+            return $ isRight result++defaultAttachmentsPath :: Config -> IO (Maybe FilePath)+defaultAttachmentsPath = maybe (return Nothing) validateAttachmentPath . configDefaultAttachmentPath++showAttachmentList :: MH ()+showAttachmentList = do+    lst <- use (csEditState.cedAttachmentList)+    case length (L.listElements lst) of+        0 -> showAttachmentFileBrowser+        _ -> setMode ManageAttachments++resetAttachmentList :: MH ()+resetAttachmentList = do+    csEditState.cedAttachmentList .= L.list AttachmentList mempty 1+    mh $ vScrollToBeginning $ viewportScroll AttachmentList++showAttachmentFileBrowser :: MH ()+showAttachmentFileBrowser = do+    config <- use (csResources.crConfiguration)+    filePath <- liftIO $ defaultAttachmentsPath config+    browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser filePath+    csEditState.cedFileBrowser .= browser+    setMode ManageAttachmentsBrowseFiles
+ src/Matterhorn/State/Autocomplete.hs view
@@ -0,0 +1,373 @@+module Matterhorn.State.Autocomplete+  ( AutocompleteContext(..)+  , checkForAutocompletion+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( viewportScroll, vScrollToBeginning )+import           Brick.Widgets.Edit ( editContentsL )+import qualified Brick.Widgets.List as L+import           Data.Char ( isSpace )+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM+import           Data.List ( sortBy, partition )+import qualified Data.Map as M+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Text.Zipper as Z+import qualified Data.Vector as V+import           Lens.Micro.Platform ( (%=), (.=), (.~), _Just, preuse )+import qualified Skylighting.Types as Sky++import           Network.Mattermost.Types (userId, channelId, Command(..))+import qualified Network.Mattermost.Endpoints as MM++import           Matterhorn.Constants ( userSigil, normalChannelSigil )+import {-# SOURCE #-} Matterhorn.Command ( commandList, printArgSpec )+import           Matterhorn.State.Common+import {-# SOURCE #-} Matterhorn.State.Editing ( Direction(..), tabComplete )+import           Matterhorn.Types hiding ( newState )+import           Matterhorn.Emoji+++data AutocompleteContext =+    AutocompleteContext { autocompleteManual :: Bool+                        -- ^ Whether the autocompletion was manual+                        -- (True) or automatic (False). The automatic+                        -- case is the case where the autocomplete+                        -- lookups and UI are triggered merely by+                        -- entering some initial text (such as "@").+                        -- The manual case is the case where the+                        -- autocomplete lookups and UI are triggered+                        -- explicitly by a user's TAB keypress.+                        , autocompleteFirstMatch :: Bool+                        -- ^ Once the results of the autocomplete lookup+                        -- are available, this flag determines whether+                        -- the user's input is replaced immediately+                        -- with the first available match (True) or not+                        -- (False).+                        }++-- | Check for whether the currently-edited word in the message editor+-- should cause an autocompletion UI to appear. If so, initiate a server+-- query or local cache lookup to present the completion alternatives+-- for the word at the cursor.+checkForAutocompletion :: AutocompleteContext -> MH ()+checkForAutocompletion ctx = do+    result <- getCompleterForInput ctx+    case result of+        Nothing -> resetAutocomplete+        Just (ty, runUpdater, searchString) -> do+            prevResult <- use (csEditState.cedAutocomplete)+            -- 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 ty ctx searchString++getCompleterForInput :: AutocompleteContext+                     -> MH (Maybe (AutocompletionType, AutocompletionType -> AutocompleteContext -> Text -> MH (), Text))+getCompleterForInput ctx = do+    z <- use (csEditState.cedEditor.editContentsL)++    let col = snd $ Z.cursorPosition z+        curLine = Z.currentLine z++    return $ case wordAtColumn col curLine of+        Just (startCol, w)+            | userSigil `T.isPrefixOf` w ->+                Just (ACUsers, doUserAutoCompletion, T.tail w)+            | normalChannelSigil `T.isPrefixOf` w ->+                Just (ACChannels, doChannelAutoCompletion, T.tail w)+            | ":" `T.isPrefixOf` w && autocompleteManual ctx ->+                Just (ACEmoji, doEmojiAutoCompletion, T.tail w)+            | "```" `T.isPrefixOf` w ->+                Just (ACCodeBlockLanguage, doSyntaxAutoCompletion, T.drop 3 w)+            | "/" `T.isPrefixOf` w && startCol == 0 ->+                Just (ACCommands, doCommandAutoCompletion, T.tail w)+        _ -> Nothing++-- Completion implementations++doEmojiAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doEmojiAutoCompletion ty ctx searchString = do+    session <- getSession+    em <- use (csResources.crEmoji)+    withCachedAutocompleteResults ctx ty searchString $+        doAsyncWith Preempt $ do+            results <- getMatchingEmoji session em searchString+            let alts = EmojiCompletion <$> results+            return $ Just $ setCompletionAlternatives ctx searchString alts ty++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 ty++-- | This list of server commands should be hidden because they make+-- assumptions about a web-based client or otherwise just don't make+-- sense for Matterhorn.+--+-- It's worth mentioning that other official mattermost client+-- implementations use this technique, too. The web client maintains+-- a list of commands to exclude when they aren't supported in the+-- mobile client. (Really this is a design flaw; they should never be+-- advertised by the server to begin with.)+hiddenServerCommands :: [Text]+hiddenServerCommands =+    -- These commands all only work in the web client.+    [ "settings"+    , "help"+    , "collapse"+    , "expand"++    -- We don't think this command makes sense for Matterhorn.+    , "logout"++    -- We provide a version of /leave with confirmation.+    , "leave"++    -- We provide our own join UI.+    , "join"++    -- We provide our own version of this command that opens our own+    -- help UI.+    , "shortcuts"++    -- Hidden because we provide other mechanisms to switch between+    -- channels.+    , "open"+    ]++hiddenCommand :: Command -> Bool+hiddenCommand c = (T.toLower $ commandTrigger c) `elem` hiddenServerCommands++isDeletedCommand :: Command -> Bool+isDeletedCommand cmd = commandDeleteAt cmd > commandCreateAt cmd++doCommandAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doCommandAutoCompletion ty ctx searchString = do+    session <- getSession+    myTid <- gets myTeamId++    mCache <- preuse (csEditState.cedAutocomplete._Just.acCachedResponses)+    mActiveTy <- preuse (csEditState.cedAutocomplete._Just.acType)++    -- Command completion works a little differently than the other+    -- modes. To do command autocompletion, we want to query the server+    -- for the list of available commands and merge that list with+    -- our own list of client-provided commands. But the server's API+    -- doesn't support *searching* commands; we can only ask for the+    -- full list. That means that, unlike the other completion modes+    -- where we want to ask the server repeatedly as the search string+    -- is refined, in this case we want to ask the server only once+    -- and avoid repeating the request for the same data as the user+    -- types more of the search string. To accomplish that, we use a+    -- special cache key -- the empty string, which normal user input+    -- processing will never use -- as the cache key for the "full" list+    -- of commands obtained by merging the server's list with our own.+    -- We populate that cache entry when completion starts and then+    -- subsequent completions consult *that* list instead of asking the+    -- server again. Subsequent completions then filter and match the+    -- cached list against the user's search string.+    let entry = HM.lookup serverResponseKey =<< mCache+        -- The special cache key to use to store the merged server and+        -- client command list, sorted but otherwise unfiltered except+        -- for eliminating deleted or hidden commands.+        serverResponseKey = ""+        lowerSearch = T.toLower searchString+        matches (CommandCompletion _ name _ desc) =+            lowerSearch `T.isInfixOf` (T.toLower name) ||+            lowerSearch `T.isInfixOf` (T.toLower desc)+        matches _ = False++    if (isNothing entry || (mActiveTy /= (Just ACCommands)))+       then doAsyncWith Preempt $ do+                let clientAlts = mkAlt <$> commandList+                    mkAlt (Cmd name desc args _) =+                        (Client, name, printArgSpec args, desc)++                serverCommands <- MM.mmListCommandsForTeam myTid False session+                let filteredServerCommands =+                        filter (\c -> not (hiddenCommand c || isDeletedCommand c)) $+                        F.toList serverCommands+                    serverAlts = mkTuple <$> filteredServerCommands+                    mkTuple cmd =+                        ( Server+                        , commandTrigger cmd+                        , commandAutoCompleteHint cmd+                        , commandAutoCompleteDesc cmd+                        )+                    mkCompletion (src, name, args, desc) =+                        CommandCompletion src name args desc+                    alts = fmap mkCompletion $+                           clientAlts <> serverAlts++                return $ Just $ do+                    -- Store the complete list of alterantives in the cache+                    setCompletionAlternatives ctx serverResponseKey alts ty++                    -- Also store the list of alternatives specific to+                    -- this search string+                    let newAlts = sortBy (compareCommandAlts searchString) $+                                  filter matches alts+                    setCompletionAlternatives ctx searchString newAlts ty++       else case entry of+           Just alts | mActiveTy == Just ACCommands ->+               let newAlts = sortBy (compareCommandAlts searchString) $+                             filter matches alts+               in setCompletionAlternatives ctx searchString newAlts ty+           _ -> return ()++compareCommandAlts :: Text -> AutocompleteAlternative -> AutocompleteAlternative -> Ordering+compareCommandAlts s (CommandCompletion _ nameA _ _)+                     (CommandCompletion _ nameB _ _) =+    let isAPrefix = s `T.isPrefixOf` nameA+        isBPrefix = s `T.isPrefixOf` nameB+    in if isAPrefix == isBPrefix+       then compare nameA nameB+       else if isAPrefix+            then LT+            else GT+compareCommandAlts _ _ _ = LT++doUserAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doUserAutoCompletion ty ctx searchString = do+    session <- getSession+    myTid <- gets myTeamId+    myUid <- gets myUserId+    cId <- use csCurrentChannelId++    withCachedAutocompleteResults ctx ty searchString $+        doAsyncWith Preempt $ do+            ac <- MM.mmAutocompleteUsers (Just myTid) (Just cId) searchString session++            let active = Seq.filter (\u -> userId u /= myUid && (not $ userDeleted u))+                alts = F.toList $+                       ((\u -> UserCompletion u True) <$> (active $ MM.userAutocompleteUsers ac)) <>+                       (maybe mempty (fmap (\u -> UserCompletion u False) . active) $+                              MM.userAutocompleteOutOfChannel ac)++                specials = [ MentionAll+                           , MentionChannel+                           ]+                extras = [ SpecialMention m | m <- specials+                         , (T.toLower searchString) `T.isPrefixOf` specialMentionName m+                         ]++            return $ Just $ setCompletionAlternatives ctx searchString (alts <> extras) ty++doChannelAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()+doChannelAutoCompletion ty ctx searchString = do+    session <- getSession+    tId <- gets myTeamId+    cs <- use csChannels++    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 ty++-- 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+                                  , _acCachedResponses = HM.fromList [(searchString, alts)]+                                  , _acType = ty+                                  }++    pending <- use (csEditState.cedAutocompletePending)+    case pending of+        Just val | val == searchString -> do++            -- If there is already state, update it, but also cache the+            -- search results.+            csEditState.cedAutocomplete %= \prev ->+                let newState = case prev of+                        Nothing ->+                            state+                        Just oldState ->+                            state & acCachedResponses .~+                                HM.insert searchString alts (oldState^.acCachedResponses)+                in Just newState++            mh $ vScrollToBeginning $ viewportScroll CompletionList++            when (autocompleteFirstMatch ctx) $+                tabComplete Forwards+        _ ->+            -- Do not update the state if this result does not+            -- correspond to the search string we used most recently.+            -- This happens when the editor changes faster than the+            -- async completion responses arrive from the server. If we+            -- don't check this, we show completion results that are+            -- wrong for the editor state.+            return ()++wordAtColumn :: Int -> Text -> Maybe (Int, Text)+wordAtColumn i t =+    let tokens = T.groupBy (\a b -> isSpace a == isSpace b) t+        go _ j _ | j < 0 = Nothing+        go col j ts = case ts of+            [] -> Nothing+            (w:rest) | j <= T.length w && not (isSpace $ T.head w) -> Just (col, w)+                     | otherwise -> go (col + T.length w) (j - T.length w) rest+    in go 0 i tokens
+ src/Matterhorn/State/ChannelListOverlay.hs view
@@ -0,0 +1,82 @@+module Matterhorn.State.ChannelListOverlay+  ( enterChannelListOverlayMode++  , channelListSelectDown+  , channelListSelectUp+  , channelListPageDown+  , channelListPageUp+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Brick.Widgets.List as L+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++import           Matterhorn.State.ListOverlay+import           Matterhorn.State.Channels+import           Matterhorn.Types+++enterChannelListOverlayMode :: MH ()+enterChannelListOverlayMode = do+    myTId <- gets myTeamId+    myChannels <- use (csChannels.to (filteredChannelIds (const True)))+    enterListOverlayMode csChannelListOverlay ChannelListOverlay+        AllChannels enterHandler (fetchResults myTId myChannels)++enterHandler :: Channel -> MH Bool+enterHandler chan = do+    joinChannel (getId chan)+    return True++fetchResults :: TeamId+             -> [ChannelId]+             -- ^ The channels to exclude from the results+             -> ChannelSearchScope+             -- ^ The scope to search+             -> Session+             -- ^ The connection session+             -> Text+             -- ^ The search string+             -> IO (Vec.Vector Channel)+fetchResults myTId exclude AllChannels session searchString = do+    resultChans <- MM.mmSearchChannels myTId searchString session+    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.+channelListSelectUp :: MH ()+channelListSelectUp = channelListMove L.listMoveUp++-- | Move the selection down in the channel list overlay by one channel.+channelListSelectDown :: MH ()+channelListSelectDown = channelListMove L.listMoveDown++-- | Move the selection up in the channel list overlay by a page of channels+-- (channelListPageSize).+channelListPageUp :: MH ()+channelListPageUp = channelListMove (L.listMoveBy (-1 * channelListPageSize))++-- | Move the selection down in the channel list overlay by a page of channels+-- (channelListPageSize).+channelListPageDown :: MH ()+channelListPageDown = channelListMove (L.listMoveBy channelListPageSize)++-- | Transform the channel list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+channelListMove :: (L.List Name Channel -> L.List Name Channel) -> MH ()+channelListMove = listOverlayMove csChannelListOverlay++-- | The number of channels in a "page" for cursor movement purposes.+channelListPageSize :: Int+channelListPageSize = 10
+ src/Matterhorn/State/ChannelSelect.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.State.ChannelSelect+  ( beginChannelSelect+  , updateChannelSelectMatches+  , channelSelectNext+  , channelSelectPrevious+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Widgets.Edit ( getEditContents )+import           Data.Char ( isUpper )+import qualified Data.Text as T+import           Lens.Micro.Platform++import qualified Network.Mattermost.Types as MM++import           Matterhorn.Constants ( userSigil, normalChannelSigil )+import           Matterhorn.Types+import qualified Matterhorn.Zipper as Z++beginChannelSelect :: MH ()+beginChannelSelect = do+    setMode ChannelSelect+    csChannelSelectState .= emptyChannelSelectState+    updateChannelSelectMatches++    -- Preserve the current channel selection when initializing channel+    -- selection mode+    zipper <- use csFocus+    let isCurrentFocus m = Just (matchEntry m) == Z.focus zipper+    csChannelSelectState.channelSelectMatches %= Z.findRight isCurrentFocus++-- Select the next match in channel selection mode.+channelSelectNext :: MH ()+channelSelectNext = updateSelectedMatch Z.right++-- Select the previous match in channel selection mode.+channelSelectPrevious :: MH ()+channelSelectPrevious = updateSelectedMatch Z.left++updateChannelSelectMatches :: MH ()+updateChannelSelectMatches = do+    st <- use id++    input <- use (csChannelSelectState.channelSelectInput)+    cconfig <- use csClientConfig+    prefs <- use (csResources.crUserPreferences)++    let pat = parseChannelSelectPattern $ T.concat $ getEditContents input+        chanNameMatches e = case pat of+            Nothing -> const Nothing+            Just p -> applySelectPattern p e+        patTy = case pat of+            Nothing -> Nothing+            Just CSPAny -> Nothing+            Just (CSP ty _) -> Just ty++    let chanMatches e chan =+            if patTy == Just PrefixDMOnly+            then Nothing+            else if chan^.ccInfo.cdType /= MM.Group+                 then chanNameMatches e $ chan^.ccInfo.cdDisplayName+                 else Nothing+        groupChanMatches e chan =+            if patTy == Just PrefixNonDMOnly+            then Nothing+            else if chan^.ccInfo.cdType == MM.Group+                 then chanNameMatches e $ chan^.ccInfo.cdDisplayName+                 else Nothing+        displayName uInfo = displayNameForUser uInfo cconfig prefs+        userMatches e uInfo =+            if patTy == Just PrefixNonDMOnly+            then Nothing+            else (chanNameMatches e . displayName) uInfo+        matches e@(CLChannel cId) = findChannelById cId (st^.csChannels) >>= chanMatches e+        matches e@(CLUserDM _ uId) = userById uId st >>= userMatches e+        matches e@(CLGroupDM cId) = findChannelById cId (st^.csChannels) >>= groupChanMatches e++        preserveFocus Nothing _ = False+        preserveFocus (Just m) m2 = matchEntry m == matchEntry m2++    csChannelSelectState.channelSelectMatches %= (Z.updateListBy preserveFocus $ Z.toList $ Z.maybeMapZipper matches (st^.csFocus))++applySelectPattern :: ChannelSelectPattern -> ChannelListEntry -> Text -> Maybe ChannelSelectMatch+applySelectPattern CSPAny entry chanName = do+    return $ ChannelSelectMatch "" "" chanName chanName entry+applySelectPattern (CSP ty pat) entry chanName = do+    let applyType Infix | pat `T.isInfixOf` normalizedChanName =+            case T.breakOn pat normalizedChanName of+                (pre, _) ->+                    return ( T.take (T.length pre) chanName+                           , T.take (T.length pat) $ T.drop (T.length pre) chanName+                           , T.drop (T.length pat + T.length pre) chanName+                           )++        applyType Prefix | pat `T.isPrefixOf` normalizedChanName = do+            let (b, a) = T.splitAt (T.length pat) chanName+            return ("", b, a)++        applyType PrefixDMOnly | pat `T.isPrefixOf` normalizedChanName = do+            let (b, a) = T.splitAt (T.length pat) chanName+            return ("", b, a)++        applyType PrefixNonDMOnly | pat `T.isPrefixOf` normalizedChanName = do+            let (b, a) = T.splitAt (T.length pat) chanName+            return ("", b, a)++        applyType Suffix | pat `T.isSuffixOf` normalizedChanName = do+            let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName+            return (b, a, "")++        applyType Equal  | pat == normalizedChanName =+            return ("", chanName, "")++        applyType _ = Nothing++        caseSensitive = T.any isUpper pat+        normalizedChanName = if caseSensitive+                             then chanName+                             else T.toLower chanName++    (pre, m, post) <- applyType ty+    return $ ChannelSelectMatch pre m post chanName entry++parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern+parseChannelSelectPattern "" = return CSPAny+parseChannelSelectPattern pat = do+    let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP PrefixDMOnly $ T.tail pat+                  | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP PrefixNonDMOnly $ T.tail pat+                  | otherwise -> Nothing++    (pat1, pfx) <- case "^" `T.isPrefixOf` pat of+        True  -> return (T.tail pat, Just Prefix)+        False -> return (pat, Nothing)++    (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of+        True  -> return (T.init pat1, Just Suffix)+        False -> return (pat1, Nothing)++    only <|> case (pfx, sfx) of+        (Nothing, Nothing)         -> return $ CSP Infix  pat2+        (Just Prefix, Nothing)     -> return $ CSP Prefix pat2+        (Nothing, Just Suffix)     -> return $ CSP Suffix pat2+        (Just Prefix, Just Suffix) -> return $ CSP Equal  pat2+        tys                        -> error $ "BUG: invalid channel select case: " <> show tys++-- Update the channel selection mode match cursor. The argument function+-- determines how to navigate to the next item.+updateSelectedMatch :: (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch)+                    -> MH ()+updateSelectedMatch nextItem =+    csChannelSelectState.channelSelectMatches %= nextItem
+ src/Matterhorn/State/ChannelTopicWindow.hs view
@@ -0,0 +1,16 @@+module Matterhorn.State.ChannelTopicWindow+  ( openChannelTopicWindow+  )+where++import           Lens.Micro.Platform ( (.=) )++import           Matterhorn.Types+import           Matterhorn.State.Channels ( getCurrentChannelTopic )+++openChannelTopicWindow :: MH ()+openChannelTopicWindow = do+    t <- getCurrentChannelTopic+    csChannelTopicDialog .= newChannelTopicDialog t+    setMode ChannelTopicWindow
+ src/Matterhorn/State/Channels.hs view
@@ -0,0 +1,1134 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.State.Channels+  ( updateSidebar+  , updateViewed+  , updateViewedChan+  , refreshChannel+  , refreshChannelsAndUsers+  , setFocus+  , refreshChannelById+  , applyPreferenceChange+  , leaveChannel+  , leaveCurrentChannel+  , getNextUnreadChannel+  , getNextUnreadUserOrChannel+  , nextUnreadChannel+  , nextUnreadUserOrChannel+  , createOrFocusDMChannel+  , clearChannelUnreadStatus+  , prevChannel+  , nextChannel+  , recentChannel+  , setReturnChannel+  , resetReturnChannel+  , hideDMChannel+  , createGroupChannel+  , showGroupChannelPref+  , channelHistoryForward+  , channelHistoryBackward+  , handleNewChannel+  , createOrdinaryChannel+  , handleChannelInvite+  , addUserByNameToCurrentChannel+  , addUserToCurrentChannel+  , removeUserFromCurrentChannel+  , removeChannelFromState+  , isRecentChannel+  , isReturnChannel+  , isCurrentChannel+  , deleteCurrentChannel+  , startLeaveCurrentChannel+  , joinChannel+  , joinChannel'+  , joinChannelByName+  , changeChannelByName+  , setChannelTopic+  , getCurrentChannelTopic+  , beginCurrentChannelDeleteConfirm+  , toggleChannelListVisibility+  , toggleExpandedChannelTopics+  , showChannelInSidebar+  , updateChannelNotifyProps+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning+                            , invalidateCache, invalidateCacheEntry )+import           Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL )+import           Control.Concurrent.Async ( runConcurrently, Concurrently(..) )+import           Control.Exception ( SomeException, try )+import           Data.Char ( isAlphaNum )+import qualified Data.HashMap.Strict as HM+import qualified Data.Foldable as F+import           Data.List ( nub )+import           Data.Maybe ( fromJust )+import qualified Data.Set as S+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )+import           Data.Time.Clock ( getCurrentTime )+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform++import qualified Network.Mattermost.Endpoints as MM+import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.Constants ( normalChannelSigil )+import           Matterhorn.InputHistory+import           Matterhorn.State.Common+import {-# SOURCE #-} Matterhorn.State.Messages ( fetchVisibleIfNeeded )+import           Matterhorn.State.Users+import           Matterhorn.State.Flagging+import           Matterhorn.Types+import           Matterhorn.Types.Common+import           Matterhorn.Zipper ( Zipper )+import qualified Matterhorn.Zipper as Z+++updateSidebar :: MH ()+updateSidebar = do+    -- Invalidate the cached sidebar rendering since we are about to+    -- change the underlying state+    mh $ invalidateCacheEntry ChannelSidebar++    -- Get the currently-focused channel ID so we can compare after the+    -- zipper is rebuilt+    cconfig <- use csClientConfig+    oldCid <- use csCurrentChannelId++    -- Update the zipper+    cs <- use csChannels+    us <- getUsers+    prefs <- use (csResources.crUserPreferences)+    now <- liftIO getCurrentTime+    config <- use (csResources.crConfiguration)++    let zl = mkChannelZipperList now config cconfig prefs cs us+    csFocus %= Z.updateList zl++    -- Schedule the current sidebar for user status updates at the end+    -- of this MH action.+    newZ <- use csFocus+    myId <- gets myUserId+    scheduleUserStatusFetches $ myId : userIdsFromZipper newZ++    -- Update the window title based on the unread status of the+    -- channels.+    let unread = sum $ (channelListGroupUnread . fst) <$> zl+        title = "matterhorn" <> if unread > 0 then "(" <> show unread <> ")" else ""++    vty <- mh getVtyHandle+    liftIO $ Vty.setWindowTitle vty title++    -- If the zipper rebuild caused the current channel to change, such+    -- as when the previously-focused channel was removed, we need to+    -- call fetchVisibleIfNeeded on the newly-focused channel to ensure+    -- that it gets loaded.+    newCid <- use csCurrentChannelId+    when (newCid /= oldCid) $+        fetchVisibleIfNeeded++updateViewed :: Bool -> MH ()+updateViewed updatePrev = do+    csCurrentChannel.ccInfo.cdMentionCount .= 0+    updateViewedChan updatePrev =<< use csCurrentChannelId++-- | When a new channel has been selected for viewing, this will+-- notify the server of the change, and also update the local channel+-- state to set the last-viewed time for the previous channel and+-- update the viewed time to now for the newly selected channel.+--+-- The boolean argument indicates whether the view time of the previous+-- channel (if any) should be updated, too. We typically want to do that+-- only on channel switching; when we just want to update the view time+-- of the specified channel, False should be provided.+updateViewedChan :: Bool -> ChannelId -> MH ()+updateViewedChan updatePrev cId = use csConnectionStatus >>= \case+    Connected -> do+        -- Only do this if we're connected to avoid triggering noisy+        -- exceptions.+        pId <- if updatePrev+               then use csRecentChannel+               else return Nothing+        doAsyncChannelMM Preempt cId+          (\s c -> MM.mmViewChannel UserMe c pId s)+          (\c () -> Just $ setLastViewedFor pId c)+    Disconnected ->+        -- Cannot update server; make no local updates to avoid getting+        -- out of sync with the server. Assumes that this is a temporary+        -- break in connectivity and that after the connection is+        -- restored, the user's normal activities will update state as+        -- appropriate. If connectivity is permanently lost, managing+        -- this state is irrelevant.+        return ()++toggleChannelListVisibility :: MH ()+toggleChannelListVisibility = do+    mh invalidateCache+    csShowChannelList %= not++toggleExpandedChannelTopics :: MH ()+toggleExpandedChannelTopics = do+    mh invalidateCache+    csShowExpandedChannelTopics %= not++-- | If the current channel is a DM channel with a single user or a+-- group of users, hide it from the sidebar and adjust the server-side+-- preference to hide it persistently.+--+-- If the current channel is any other kind of channel, complain with a+-- usage error.+hideDMChannel :: ChannelId -> MH ()+hideDMChannel cId = do+    me <- gets myUser+    session <- getSession+    withChannel cId $ \chan -> do+        case chan^.ccInfo.cdType of+            Direct -> do+                let pref = showDirectChannelPref (me^.userIdL) uId False+                    Just uId = chan^.ccInfo.cdDMUserId+                csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing+                doAsyncWith Preempt $ do+                    MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+                    return Nothing+            Group -> do+                let pref = hideGroupChannelPref cId (me^.userIdL)+                csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing+                doAsyncWith Preempt $ do+                    MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+                    return Nothing+            _ -> do+                mhError $ GenericError "Cannot hide this channel. Consider using /leave instead."++-- | Called on async completion when the currently viewed channel has+-- been updated (i.e., just switched to this channel) to update local+-- state.+setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH ()+setLastViewedFor prevId cId = do+    chan <- use (csChannels.to (findChannelById cId))+    -- Update new channel's viewed time, creating the channel if needed+    case chan of+        Nothing ->+            -- It's possible for us to get spurious WMChannelViewed+            -- events from the server, e.g. for channels that have been+            -- deleted. So here we ignore the request since it's hard to+            -- detect it before this point.+            return ()+        Just _  ->+          -- The server has been sent a viewed POST update, but there is+          -- no local information on what timestamp the server actually+          -- recorded. There are a couple of options for setting the+          -- local value of the viewed time:+          --+          --   1. Attempting to locally construct a value, which would+          --      involve scanning all (User) messages in the channel+          --      to find the maximum of the created date, the modified+          --      date, or the deleted date, and assuming that maximum+          --      mostly matched the server's viewed time.+          --+          --   2. Issuing a channel metadata request to get the server's+          --      new concept of the viewed time.+          --+          --   3. Having the "chan/viewed" POST that was just issued+          --      return a value from the server. See+          --      https://github.com/mattermost/platform/issues/6803.+          --+          -- Method 3 would be the best and most lightweight. Until that+          -- is available, Method 2 will be used. The downside to Method+          -- 2 is additional client-server messaging, and a delay in+          -- updating the client data, but it's also immune to any new+          -- or removed Message date fields, or anything else that would+          -- contribute to the viewed/updated times on the server.+          doAsyncChannelMM Preempt cId (\ s _ ->+                                           (,) <$> MM.mmGetChannel cId s+                                               <*> MM.mmGetChannelMember cId UserMe s)+          (\pcid (cwd, member) -> Just $ csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member)++    -- Update the old channel's previous viewed time (allows tracking of+    -- new messages)+    case prevId of+      Nothing -> return ()+      Just p -> clearChannelUnreadStatus p++-- | Refresh information about all channels and users. This is usually+-- triggered when a reconnect event for the WebSocket to the server+-- occurs.+refreshChannelsAndUsers :: MH ()+refreshChannelsAndUsers = do+    session <- getSession+    myTId <- gets myTeamId+    me <- gets myUser+    knownUsers <- gets allUserIds+    doAsyncWith Preempt $ do+      (chans, datas) <- runConcurrently $ (,)+                       <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)+                       <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)++      -- Collect all user IDs associated with DM channels so we can+      -- bulk-fetch their user records.+      let dmUsers = catMaybes $ flip map (F.toList chans) $ \chan ->+              case chan^.channelTypeL of+                  Direct -> case userIdForDMChannel (userId me) (sanitizeUserText $ channelName chan) of+                        Nothing -> Nothing+                        Just otherUserId -> Just otherUserId+                  _ -> Nothing+          uIdsToFetch = nub $ userId me : knownUsers <> dmUsers++          dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas+          mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap)+          chansWithData = mkPair <$> chans++      return $ Just $+          -- Fetch user data associated with DM channels+          handleNewUsers (Seq.fromList uIdsToFetch) $ do+              -- Then refresh all loaded channels+              forM_ chansWithData $ uncurry (refreshChannel SidebarUpdateDeferred)+              updateSidebar++-- | Refresh information about a specific channel.  The channel+-- metadata is refreshed, and if this is a loaded channel, the+-- scrollback is updated as well.+--+-- The sidebar update argument indicates whether this refresh should+-- also update the sidebar. Ordinarily you want this, so pass+-- SidebarUpdateImmediate unless you are very sure you know what you are+-- doing, i.e., you are very sure that a call to refreshChannel will+-- be followed immediately by a call to updateSidebar. We provide this+-- control so that channel refreshes can be batched and then a single+-- updateSidebar call can be used instead of the default behavior of+-- calling it once per refreshChannel call, which is the behavior if the+-- immediate setting is passed here.+refreshChannel :: SidebarUpdate -> Channel -> ChannelMember -> MH ()+refreshChannel upd chan member = do+    let cId = getId chan+    myTId <- gets myTeamId+    let ourTeam = channelTeamId chan == Nothing ||+                  Just myTId == channelTeamId chan++    case not ourTeam of+        True -> return ()+        False -> do+            -- If this channel is unknown, register it first.+            mChan <- preuse (csChannel(cId))+            when (isNothing mChan) $+                handleNewChannel False upd chan member++            updateChannelInfo cId chan member++handleNewChannel :: Bool -> SidebarUpdate -> Channel -> ChannelMember -> MH ()+handleNewChannel = handleNewChannel_ True++handleNewChannel_ :: Bool+                  -- ^ Whether to permit this call to recursively+                  -- schedule itself for later if it can't locate+                  -- a DM channel user record. This is to prevent+                  -- uncontrolled recursion.+                  -> Bool+                  -- ^ Whether to switch to the new channel once it has+                  -- been installed.+                  -> SidebarUpdate+                  -- ^ Whether to update the sidebar, in case the caller+                  -- wants to batch these before updating it. Pass+                  -- SidebarUpdateImmediate unless you know what+                  -- you are doing, i.e., unless you intend to call+                  -- updateSidebar yourself after calling this.+                  -> Channel+                  -- ^ The channel to install.+                  -> ChannelMember+                  -> MH ()+handleNewChannel_ permitPostpone switch sbUpdate nc member = do+    -- Only add the channel to the state if it isn't already known.+    me <- gets myUser+    mChan <- preuse (csChannel(getId nc))+    case mChan of+        Just _ -> when switch $ setFocus (getId nc)+        Nothing -> do+            -- Create a new ClientChannel structure+            cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>+                       makeClientChannel (me^.userIdL) nc++            st <- use id++            -- Add it to the message map, and to the name map so we+            -- can look it up by name. The name we use for the channel+            -- depends on its type:+            let chType = nc^.channelTypeL++            -- Get the channel name. If we couldn't, that means we have+            -- async work to do before we can register this channel (in+            -- which case abort because we got rescheduled).+            register <- case chType of+                Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of+                    Nothing -> return True+                    Just otherUserId ->+                        case userById otherUserId st of+                            -- If we found a user ID in the channel+                            -- name string but don't have that user's+                            -- metadata, postpone adding this channel+                            -- until we have fetched the metadata. This+                            -- can happen when we have a channel record+                            -- for a user that is no longer in the+                            -- current team. To avoid recursion due to a+                            -- problem, ensure that the rescheduled new+                            -- channel handler is not permitted to try+                            -- this again.+                            --+                            -- If we're already in a recursive attempt+                            -- to register this channel and still+                            -- couldn't find a username, just bail and+                            -- use the synthetic name (this has the same+                            -- problems as above).+                            Nothing -> do+                                case permitPostpone of+                                    False -> return True+                                    True -> do+                                        mhLog LogAPI $ T.pack $ "handleNewChannel_: about to call handleNewUsers for " <> show otherUserId+                                        handleNewUsers (Seq.singleton otherUserId) (return ())+                                        doAsyncWith Normal $+                                            return $ Just $ handleNewChannel_ False switch sbUpdate nc member+                                        return False+                            Just _ -> return True+                _ -> return True++            when register $ do+                csChannels %= addChannel (getId nc) cChannel+                when (sbUpdate == SidebarUpdateImmediate) $ do+                    -- Note that we only check for whether we should+                    -- switch to this channel when doing a sidebar+                    -- update, since that's the only case where it's+                    -- possible to do so.+                    updateSidebar++                    -- Finally, set our focus to the newly created+                    -- channel if the caller requested a change of+                    -- channel. Also consider the last join request+                    -- state field in case this is an asynchronous+                    -- channel addition triggered by a /join.+                    pending1 <- checkPendingChannelChange (getId nc)+                    pending2 <- case cChannel^.ccInfo.cdDMUserId of+                        Nothing -> return False+                        Just uId -> checkPendingChannelChangeByUserId uId++                    when (switch || isJust pending1 || pending2) $ do+                        setFocus (getId nc)+                        case pending1 of+                            Just (Just act) -> act+                            _ -> return ()++-- | Check to see whether the specified channel has been queued up to+-- be switched to.  Note that this condition is only cleared by the+-- actual setFocus switch to the channel because there may be multiple+-- operations that must complete before the channel is fully ready for+-- display/use.+--+-- Returns Just if the specified channel has a pending switch. The+-- result is an optional action to invoke after changing to the+-- specified channel.+checkPendingChannelChange :: ChannelId -> MH (Maybe (Maybe (MH ())))+checkPendingChannelChange cId = do+    ch <- use csPendingChannelChange+    return $ case ch of+        Just (ChangeByChannelId i act) ->+            if i == cId then Just act else Nothing+        _ -> Nothing++-- | Check to see whether the specified channel has been queued up to+-- be switched to.  Note that this condition is only cleared by the+-- actual setFocus switch to the channel because there may be multiple+-- operations that must complete before the channel is fully ready for+-- display/use.+--+-- Returns Just if the specified channel has a pending switch. The+-- result is an optional action to invoke after changing to the+-- specified channel.+checkPendingChannelChangeByUserId :: UserId -> MH Bool+checkPendingChannelChangeByUserId uId = do+    ch <- use csPendingChannelChange+    return $ case ch of+        Just (ChangeByUserId i) ->+            i == uId+        _ ->+            False++-- | Update the indicated Channel entry with the new data retrieved from+-- the Mattermost server. Also update the channel name if it changed.+updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH ()+updateChannelInfo cid new member = do+    mh $ invalidateCacheEntry $ ChannelMessages cid+    csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member+    updateSidebar++setFocus :: ChannelId -> MH ()+setFocus cId = do+    showChannelInSidebar cId True+    setFocusWith True (Z.findRight ((== cId) . channelListEntryChannelId)) (return ())++showChannelInSidebar :: ChannelId -> Bool -> MH ()+showChannelInSidebar cId setPending = do+    mChan <- preuse $ csChannel cId+    me <- gets myUser+    prefs <- use (csResources.crUserPreferences)+    session <- getSession++    case mChan of+        Nothing ->+          -- The requested channel doesn't actually exist yet, so no+          -- action can be taken.  It's likely that this is a+          -- pendingChannel situation and not all of the operations to+          -- locally define the channel have completed, in which case+          -- this code will be re-entered later and the mChan will be+          -- known.+          return ()+        Just ch -> do++            -- Able to successfully switch to a known channel.  This+            -- should clear any pending channel intention.  If the+            -- intention was for this channel, then: done.  If the+            -- intention was for a different channel, reaching this+            -- point means that the pending is still outstanding but+            -- that the user identified a new channel which *was*+            -- displayable, and the UI should always prefer to SATISFY+            -- the user's latest request over any pending/background+            -- task.+            csPendingChannelChange .= Nothing++            now <- liftIO getCurrentTime+            csChannel(cId).ccInfo.cdSidebarShowOverride .= Just now+            updateSidebar++            case ch^.ccInfo.cdType of+                Direct -> do+                    let Just uId = ch^.ccInfo.cdDMUserId+                    case dmChannelShowPreference prefs uId of+                        Just False -> do+                            let pref = showDirectChannelPref (me^.userIdL) uId True+                            when setPending $+                                csPendingChannelChange .= Just (ChangeByChannelId (ch^.ccInfo.cdChannelId) Nothing)+                            doAsyncWith Preempt $ do+                                MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+                                return Nothing+                        _ -> return ()++                Group ->+                    case groupChannelShowPreference prefs cId of+                        Just False -> do+                            let pref = showGroupChannelPref cId (me^.userIdL)+                            when setPending $+                                csPendingChannelChange .= Just (ChangeByChannelId (ch^.ccInfo.cdChannelId) Nothing)+                            doAsyncWith Preempt $ do+                                MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+                                return Nothing+                        _ -> return ()++                _ -> return ()++setFocusWith :: Bool+             -> (Zipper ChannelListGroup ChannelListEntry+             -> Zipper ChannelListGroup ChannelListEntry)+             -> MH ()+             -> MH ()+setFocusWith updatePrev f onNoChange = do+    oldZipper <- use csFocus+    let newZipper = f oldZipper+        newFocus = Z.focus newZipper+        oldFocus = Z.focus oldZipper++    -- If we aren't changing anything, skip all the book-keeping because+    -- we'll end up clobbering things like csRecentChannel.+    if newFocus /= oldFocus+       then do+          mh $ invalidateCacheEntry ChannelSidebar+          resetAutocomplete+          preChangeChannelCommon+          csFocus .= newZipper++          now <- liftIO getCurrentTime+          newCid <- use csCurrentChannelId+          csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now++          updateViewed updatePrev+          postChangeChannelCommon+       else onNoChange++postChangeChannelCommon :: MH ()+postChangeChannelCommon = do+    resetEditorState+    updateChannelListScroll+    loadLastEdit+    fetchVisibleIfNeeded++loadLastEdit :: MH ()+loadLastEdit = do+    cId <- use csCurrentChannelId++    oldEphemeral <- preuse (csChannel(cId).ccEditState)+    case oldEphemeral of+        Nothing -> return ()+        Just e -> csEditState.cedEphemeral .= e++    loadLastChannelInput++loadLastChannelInput :: MH ()+loadLastChannelInput = do+    cId <- use csCurrentChannelId+    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)+    case inputHistoryPos of+        Just i -> loadHistoryEntryToEditor cId i+        Nothing -> do+            (lastEdit, lastEditMode) <- use (csEditState.cedEphemeral.eesLastInput)+            csEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper)+            csEditState.cedEditMode .= lastEditMode++updateChannelListScroll :: MH ()+updateChannelListScroll = do+    mh $ vScrollToBeginning (viewportScroll ChannelList)++preChangeChannelCommon :: MH ()+preChangeChannelCommon = do+    cId <- use csCurrentChannelId+    csRecentChannel .= Just cId+    saveCurrentEdit++resetEditorState :: MH ()+resetEditorState = do+    csEditState.cedEditMode .= NewPost+    clearEditor++clearEditor :: MH ()+clearEditor = csEditState.cedEditor %= applyEdit clearZipper++saveCurrentEdit :: MH ()+saveCurrentEdit = do+    saveCurrentChannelInput++    oldEphemeral <- use (csEditState.cedEphemeral)+    cId <- use csCurrentChannelId+    csChannel(cId).ccEditState .= oldEphemeral++saveCurrentChannelInput :: MH ()+saveCurrentChannelInput = do+    cmdLine <- use (csEditState.cedEditor)+    mode <- use (csEditState.cedEditMode)++    -- Only save the editor contents if the user is not navigating the+    -- history.+    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)++    when (isNothing inputHistoryPos) $+        csEditState.cedEphemeral.eesLastInput .=+           (T.intercalate "\n" $ getEditContents $ cmdLine, mode)++hideGroupChannelPref :: ChannelId -> UserId -> Preference+hideGroupChannelPref cId uId =+    Preference { preferenceCategory = PreferenceCategoryGroupChannelShow+               , preferenceValue = PreferenceValue "false"+               , preferenceName = PreferenceName $ idString cId+               , preferenceUserId = uId+               }++showGroupChannelPref :: ChannelId -> UserId -> Preference+showGroupChannelPref cId uId =+    Preference { preferenceCategory = PreferenceCategoryGroupChannelShow+               , preferenceValue = PreferenceValue "true"+               , preferenceName = PreferenceName $ idString cId+               , preferenceUserId = uId+               }++showDirectChannelPref :: UserId -> UserId -> Bool -> Preference+showDirectChannelPref myId otherId s =+    Preference { preferenceCategory = PreferenceCategoryDirectChannelShow+               , preferenceValue = if s then PreferenceValue "true"+                                        else PreferenceValue "false"+               , preferenceName = PreferenceName $ idString otherId+               , preferenceUserId = myId+               }++applyPreferenceChange :: Preference -> MH ()+applyPreferenceChange pref = do+    -- always update our user preferences accordingly+    csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)++    -- Invalidate the entire rendering cache since many things depend on+    -- user preferences+    mh invalidateCache++    if+      | Just f <- preferenceToFlaggedPost pref -> do+          updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)++      | Just d <- preferenceToDirectChannelShowStatus pref -> do+          updateSidebar++          cs <- use csChannels++          -- We need to check on whether this preference was to show a+          -- channel and, if so, whether it was the one we attempted to+          -- switch to (thus triggering the preference change). If so,+          -- we need to switch to it now.+          let Just cId = getDmChannelFor (directChannelShowUserId d) cs+          case directChannelShowValue d of+              True -> do+                  pending <- checkPendingChannelChange cId+                  case pending of+                      Just mAct -> do+                          setFocus cId+                          fromMaybe (return ()) mAct+                      Nothing -> return ()+              False -> do+                  csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing++      | Just g <- preferenceToGroupChannelPreference pref -> do+          updateSidebar++          -- We need to check on whether this preference was to show a+          -- channel and, if so, whether it was the one we attempted to+          -- switch to (thus triggering the preference change). If so,+          -- we need to switch to it now.+          let cId = groupChannelId g+          case groupChannelShow g of+              True -> do+                  pending <- checkPendingChannelChange cId+                  case pending of+                      Just mAct -> do+                          setFocus cId+                          fromMaybe (return ()) mAct+                      Nothing -> return ()+              False -> do+                  csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing++      | otherwise -> return ()++refreshChannelById :: ChannelId -> MH ()+refreshChannelById cId = do+    session <- getSession+    doAsyncWith Preempt $ do+        cwd <- MM.mmGetChannel cId session+        member <- MM.mmGetChannelMember cId UserMe session+        return $ Just $ do+            refreshChannel SidebarUpdateImmediate cwd member++removeChannelFromState :: ChannelId -> MH ()+removeChannelFromState cId = do+    withChannel cId $ \ chan -> do+        when (chan^.ccInfo.cdType /= Direct) $ do+            origFocus <- use csCurrentChannelId+            when (origFocus == cId) nextChannelSkipPrevView+            -- Update input history+            csEditState.cedInputHistory         %= removeChannelHistory cId+            -- Update msgMap+            csChannels                          %= removeChannel cId+            -- Remove from focus zipper+            csFocus %= Z.filterZipper ((/= cId) . channelListEntryChannelId)+            updateSidebar++nextChannel :: MH ()+nextChannel = do+    resetReturnChannel+    setFocusWith True Z.right (return ())++-- | This is almost never what you want; we use this when we delete a+-- channel and we don't want to update the deleted channel's view time.+nextChannelSkipPrevView :: MH ()+nextChannelSkipPrevView = setFocusWith False Z.right (return ())++prevChannel :: MH ()+prevChannel = do+    resetReturnChannel+    setFocusWith True Z.left (return ())++recentChannel :: MH ()+recentChannel = do+  recent <- use csRecentChannel+  case recent of+    Nothing  -> return ()+    Just cId -> do+        ret <- use csReturnChannel+        when (ret == Just cId) resetReturnChannel+        setFocus cId++resetReturnChannel :: MH ()+resetReturnChannel = do+  val <- use csReturnChannel+  case val of+      Nothing -> return ()+      Just _ -> do+          mh $ invalidateCacheEntry ChannelSidebar+          csReturnChannel .= Nothing++gotoReturnChannel :: MH ()+gotoReturnChannel = do+  ret <- use csReturnChannel+  case ret of+    Nothing  -> return ()+    Just cId -> do+        resetReturnChannel+        setFocus cId++setReturnChannel :: MH ()+setReturnChannel = do+  ret <- use csReturnChannel+  case ret of+    Nothing  -> do+        cId <- use csCurrentChannelId+        csReturnChannel .= Just cId+        mh $ invalidateCacheEntry ChannelSidebar+    Just _ -> return ()++nextUnreadChannel :: MH ()+nextUnreadChannel = do+    st <- use id+    setReturnChannel+    setFocusWith True (getNextUnreadChannel st) gotoReturnChannel++nextUnreadUserOrChannel :: MH ()+nextUnreadUserOrChannel = do+    st <- use id+    setReturnChannel+    setFocusWith True (getNextUnreadUserOrChannel st) gotoReturnChannel++leaveChannel :: ChannelId -> MH ()+leaveChannel cId = leaveChannelIfPossible cId False++leaveChannelIfPossible :: ChannelId -> Bool -> MH ()+leaveChannelIfPossible cId delete = do+    st <- use id+    me <- gets myUser+    let isMe u = u^.userIdL == me^.userIdL++    case st ^? csChannel(cId).ccInfo of+        Nothing -> return ()+        Just cInfo -> case canLeaveChannel cInfo of+            False -> return ()+            True ->+                -- The server will reject an attempt to leave a private+                -- channel if we're the only member. To check this, we+                -- just ask for the first two members of the channel.+                -- If there is only one, it must be us: hence the "all+                -- isMe" check below. If there are two members, it+                -- doesn't matter who they are, because we just know+                -- that we aren't the only remaining member, so we can't+                -- delete the channel.+                doAsyncChannelMM Preempt cId+                    (\s _ ->+                      let query = MM.defaultUserQuery+                           { MM.userQueryPage = Just 0+                           , MM.userQueryPerPage = Just 2+                           , MM.userQueryInChannel = Just cId+                           }+                      in toList <$> MM.mmGetUsers query s)+                    (\_ members -> Just $ do+                        -- If the channel is private:+                        --  * leave it if we aren't the last member.+                        --  * delete it if we are.+                        --+                        -- Otherwise:+                        --  * leave (or delete) the channel as specified+                        --    by the delete argument.+                        let func = case cInfo^.cdType of+                                Private -> case all isMe members of+                                    True -> (\ s c -> MM.mmDeleteChannel c s)+                                    False -> (\ s c -> MM.mmRemoveUserFromChannel c UserMe s)+                                Group ->+                                    \s _ ->+                                        let pref = hideGroupChannelPref cId (me^.userIdL)+                                        in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s+                                _ -> if delete+                                     then (\ s c -> MM.mmDeleteChannel c s)+                                     else (\ s c -> MM.mmRemoveUserFromChannel c UserMe s)++                        doAsyncChannelMM Preempt cId func endAsyncNOP+                    )++getNextUnreadChannel :: ChatState+                     -> (Zipper a ChannelListEntry -> Zipper a ChannelListEntry)+getNextUnreadChannel st =+    -- The next channel with unread messages must also be a channel+    -- other than the current one, since the zipper may be on a channel+    -- that has unread messages and will stay that way until we leave+    -- it- so we need to skip that channel when doing the zipper search+    -- for the next candidate channel.+    Z.findRight (\e ->+                let cId = channelListEntryChannelId e+                in hasUnread st cId && (cId /= st^.csCurrentChannelId))++getNextUnreadUserOrChannel :: ChatState+                           -> Zipper a ChannelListEntry+                           -> Zipper a ChannelListEntry+getNextUnreadUserOrChannel st z =+    -- Find the next unread channel, prefering direct messages+    let cur = st^.csCurrentChannelId+        matches e = entryIsDMEntry e && isFresh (channelListEntryChannelId e)+        isFresh c = hasUnread st c && (c /= cur)+    in fromMaybe (Z.findRight (isFresh . channelListEntryChannelId) z)+                 (Z.maybeFindRight matches z)++leaveCurrentChannel :: MH ()+leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel++createGroupChannel :: Text -> MH ()+createGroupChannel usernameList = do+    me <- gets myUser+    session <- getSession+    cs <- use csChannels++    doAsyncWith Preempt $ do+        let usernames = Seq.fromList $ fmap trimUserSigil $ T.words usernameList+        results <- MM.mmGetUsersByUsernames usernames session++        -- If we found all of the users mentioned, then create the group+        -- channel.+        case length results == length usernames of+            True -> do+                chan <- MM.mmCreateGroupMessageChannel (userId <$> results) session+                return $ Just $ do+                    case findChannelById (channelId chan) cs of+                      Just _ ->+                          -- If we already know about the channel ID,+                          -- that means the channel already exists so+                          -- we can just switch to it.+                          setFocus (channelId chan)+                      Nothing -> do+                          csPendingChannelChange .= (Just $ ChangeByChannelId (channelId chan) Nothing)+                          let pref = showGroupChannelPref (channelId chan) (me^.userIdL)+                          doAsyncWith Normal $ do+                            MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session+                            return $ Just $ applyPreferenceChange pref+            False -> do+                let foundUsernames = userUsername <$> results+                    missingUsernames = S.toList $+                                       S.difference (S.fromList $ F.toList usernames)+                                                    (S.fromList $ F.toList foundUsernames)+                return $ Just $ do+                    forM_ missingUsernames (mhError . NoSuchUser)++channelHistoryForward :: MH ()+channelHistoryForward = do+    resetAutocomplete++    cId <- use csCurrentChannelId+    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)+    case inputHistoryPos of+        Just i+          | i == 0 -> do+            -- Transition out of history navigation+            csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing+            loadLastChannelInput+          | otherwise -> do+            let newI = i - 1+            loadHistoryEntryToEditor cId newI+            csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)+        _ -> return ()++loadHistoryEntryToEditor :: ChannelId -> Int -> MH ()+loadHistoryEntryToEditor cId idx = do+    inputHistory <- use (csEditState.cedInputHistory)+    case getHistoryEntry cId idx inputHistory of+        Nothing -> return ()+        Just entry -> do+            let eLines = T.lines entry+                mv = if length eLines == 1 then gotoEOL else id+            csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)++channelHistoryBackward :: MH ()+channelHistoryBackward = do+    resetAutocomplete++    cId <- use csCurrentChannelId+    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)+    saveCurrentChannelInput++    let newI = maybe 0 (+ 1) inputHistoryPos+    loadHistoryEntryToEditor cId newI+    csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)++createOrdinaryChannel :: Bool -> Text -> MH ()+createOrdinaryChannel public name = do+    session <- getSession+    myTId <- gets myTeamId+    doAsyncWith Preempt $ do+        -- create a new chat channel+        let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)+            minChannel = MinChannel+              { minChannelName        = slug+              , minChannelDisplayName = name+              , minChannelPurpose     = Nothing+              , minChannelHeader      = Nothing+              , minChannelType        = if public then Ordinary else Private+              , minChannelTeamId      = myTId+              }+        tryMM (do c <- MM.mmCreateChannel minChannel session+                  chan <- MM.mmGetChannel (getId c) session+                  member <- MM.mmGetChannelMember (getId c) UserMe session+                  return (chan, member)+              )+              (return . Just . uncurry (handleNewChannel True SidebarUpdateImmediate))++-- | When we are added to a channel not locally known about, we need+-- to fetch the channel info for that channel.+handleChannelInvite :: ChannelId -> MH ()+handleChannelInvite cId = do+    session <- getSession+    doAsyncWith Normal $ do+        member <- MM.mmGetChannelMember cId UserMe session+        tryMM (MM.mmGetChannel cId session)+              (\cwd -> return $ Just $ do+                  pending <- checkPendingChannelChange cId+                  handleNewChannel (isJust pending) SidebarUpdateImmediate cwd member)++addUserByNameToCurrentChannel :: Text -> MH ()+addUserByNameToCurrentChannel uname =+    withFetchedUser (UserFetchByUsername uname) addUserToCurrentChannel++addUserToCurrentChannel :: UserInfo -> MH ()+addUserToCurrentChannel u = do+    cId <- use csCurrentChannelId+    session <- getSession+    let channelMember = MinChannelMember (u^.uiId) cId+    doAsyncWith Normal $ do+        tryMM (void $ MM.mmAddUser cId channelMember session)+              (const $ return Nothing)++removeUserFromCurrentChannel :: Text -> MH ()+removeUserFromCurrentChannel uname =+    withFetchedUser (UserFetchByUsername uname) $ \u -> do+        cId <- use csCurrentChannelId+        session <- getSession+        doAsyncWith Normal $ do+            tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)+                  (const $ return Nothing)++startLeaveCurrentChannel :: MH ()+startLeaveCurrentChannel = do+    cInfo <- use (csCurrentChannel.ccInfo)+    case cInfo^.cdType of+        Direct -> hideDMChannel (cInfo^.cdChannelId)+        Group -> hideDMChannel (cInfo^.cdChannelId)+        _ -> setMode LeaveChannelConfirm++deleteCurrentChannel :: MH ()+deleteCurrentChannel = do+    setMode Main+    cId <- use csCurrentChannelId+    leaveChannelIfPossible cId True++isCurrentChannel :: ChatState -> ChannelId -> Bool+isCurrentChannel st cId = st^.csCurrentChannelId == cId++isRecentChannel :: ChatState -> ChannelId -> Bool+isRecentChannel st cId = st^.csRecentChannel == Just cId++isReturnChannel :: ChatState -> ChannelId -> Bool+isReturnChannel st cId = st^.csReturnChannel == Just cId++joinChannelByName :: Text -> MH ()+joinChannelByName rawName = do+    session <- getSession+    tId <- gets myTeamId+    doAsyncWith Preempt $ do+        result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session+        return $ Just $ case result of+            Left (_::SomeException) -> mhError $ NoSuchChannel rawName+            Right chan -> joinChannel $ getId chan++-- | If the user is not a member of the specified channel, submit a+-- request to join it. Otherwise switch to the channel.+joinChannel :: ChannelId -> MH ()+joinChannel chanId = joinChannel' chanId Nothing++joinChannel' :: ChannelId -> Maybe (MH ()) -> MH ()+joinChannel' chanId act = do+    setMode Main+    mChan <- preuse (csChannel(chanId))+    case mChan of+        Just _ -> do+            setFocus chanId+            fromMaybe (return ()) act+        Nothing -> do+            myId <- gets myUserId+            let member = MinChannelMember myId chanId+            csPendingChannelChange .= (Just $ ChangeByChannelId chanId act)+            doAsyncChannelMM Preempt chanId (\ s c -> MM.mmAddUser c member s) (const $ return act)++createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH ()+createOrFocusDMChannel user successAct = do+    cs <- use csChannels+    case getDmChannelFor (user^.uiId) cs of+        Just cId -> do+            setFocus cId+            case successAct of+                Nothing -> return ()+                Just act -> act cId+        Nothing -> do+            -- We have a user of that name but no channel. Time to make one!+            myId <- gets myUserId+            session <- getSession+            csPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId)+            doAsyncWith Normal $ do+                -- create a new channel+                chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session+                return $ successAct <*> pure (channelId chan)++-- | This switches to the named channel or creates it if it is a missing+-- but valid user channel.+changeChannelByName :: Text -> MH ()+changeChannelByName name = do+    mCId <- gets (channelIdByChannelName name)+    mDMCId <- gets (channelIdByUsername name)++    withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do+        let err = mhError $ AmbiguousName name+        case (mCId, mDMCId) of+          (Nothing, Nothing) ->+              case foundUser of+                  -- We know about the user but there isn't already a DM+                  -- channel, so create one.+                  Just user -> createOrFocusDMChannel user Nothing+                  -- There were no matches of any kind.+                  Nothing -> mhError $ NoSuchChannel name+          (Just cId, Nothing)+              -- We matched a channel and there was an explicit sigil, so we+              -- don't care about the username match.+              | normalChannelSigil `T.isPrefixOf` name -> setFocus cId+              -- We matched both a channel and a user, even though there is+              -- no DM channel.+              | Just _ <- foundUser -> err+              -- We matched a channel only.+              | otherwise -> setFocus cId+          (Nothing, Just cId) ->+              -- We matched a DM channel only.+              setFocus cId+          (Just _, Just _) ->+              -- We matched both a channel and a DM channel.+              err++setChannelTopic :: Text -> MH ()+setChannelTopic msg = do+    cId <- use csCurrentChannelId+    let patch = defaultChannelPatch { channelPatchHeader = Just msg }+    doAsyncChannelMM Preempt cId+        (\s _ -> MM.mmPatchChannel cId patch s)+        (\_ _ -> Nothing)++getCurrentChannelTopic :: MH Text+getCurrentChannelTopic = do+    ch <- use csCurrentChannel+    return $ ch^.ccInfo.cdHeader++beginCurrentChannelDeleteConfirm :: MH ()+beginCurrentChannelDeleteConfirm = do+    cId <- use csCurrentChannelId+    withChannel cId $ \chan -> do+        let chType = chan^.ccInfo.cdType+        if chType /= Direct+            then setMode DeleteChannelConfirm+            else mhError $ GenericError "Direct message channels cannot be deleted."++updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH ()+updateChannelNotifyProps cId notifyProps = do+    mh $ invalidateCacheEntry ChannelSidebar+    csChannel(cId).ccInfo.cdNotifyProps .= notifyProps
+ src/Matterhorn/State/Common.hs view
@@ -0,0 +1,374 @@+module Matterhorn.State.Common+  (+  -- * System interface+    openFilePath+  , openWithOpener+  , runLoggedCommand+  , prepareAttachment++  -- * Posts+  , installMessagesFromPosts+  , updatePostMap++  -- * Utilities+  , postInfoMessage+  , postErrorMessageIO+  , postErrorMessage'+  , addEmoteFormatting+  , removeEmoteFormatting++  , fetchMentionedUsers+  , doPendingUserFetches+  , doPendingUserStatusFetches++  , module Matterhorn.State.Async+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( invalidateCacheEntry )+import           Control.Concurrent ( MVar, putMVar, forkIO )+import           Control.Concurrent.Async ( concurrently )+import qualified Control.Concurrent.STM as STM+import           Control.Exception ( SomeException, try )+import qualified Data.ByteString as BS+import qualified Data.HashMap.Strict as HM+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import qualified Data.Text as T+import           Lens.Micro.Platform ( (.=), (%=), (%~), (.~) )+import           System.Directory ( createDirectoryIfMissing )+import           System.Environment.XDG.BaseDir ( getUserCacheDir )+import           System.Exit ( ExitCode(..) )+import           System.FilePath+import           System.IO ( hGetContents, hFlush, hPutStrLn )+import           System.Process ( proc, std_in, std_out, std_err, StdStream(..)+                                , createProcess, waitForProcess )++import           Network.Mattermost.Endpoints+import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.FilePaths ( xdgName )+import           Matterhorn.State.Async+import           Matterhorn.Types+import           Matterhorn.Types.Common+++-- * Client Messages++-- | Given a collection of posts from the server, save the posts in the+-- global post map. Also convert the posts to Matterhorn's Message type+-- and return them along with the set of all usernames mentioned in the+-- text of the resulting messages.+--+-- This also sets the mFlagged field of each message based on whether+-- its post ID is a flagged post according to crFlaggedPosts at the time+-- of this call.+installMessagesFromPosts :: Posts -> MH Messages+installMessagesFromPosts postCollection = do+  flags <- use (csResources.crFlaggedPosts)++  -- Add all posts in this collection to the global post cache+  updatePostMap postCollection++  baseUrl <- getServerBaseUrl++  -- Build the ordered list of posts. Note that postsOrder lists the+  -- posts most recent first, but we want most recent last.+  let postsInOrder = findPost <$> (Seq.reverse $ postsOrder postCollection)+      mkClientPost p = toClientPost baseUrl p (postId <$> parent p)+      clientPosts = mkClientPost <$> postsInOrder++      addNext cp (msgs, us) =+          let (msg, mUsernames) = clientPostToMessage cp+          in (addMessage (maybeFlag flags msg) msgs, Set.union us mUsernames)+      (ms, mentions) = foldr addNext (noMessages, mempty) clientPosts++  fetchMentionedUsers mentions+  return ms+    where+        maybeFlag flagSet msg+          | Just (MessagePostId pId) <- msg^.mMessageId, pId `Set.member` flagSet+            = msg & mFlagged .~ True+          | otherwise = msg+        parent x = do+            parentId <- x^.postRootIdL+            HM.lookup parentId (postCollection^.postsPostsL)+        findPost pId = case HM.lookup pId (postsPosts postCollection) of+            Nothing -> error $ "BUG: could not find post for post ID " <> show pId+            Just post -> post++-- Add all posts in this collection to the global post cache+updatePostMap :: Posts -> MH ()+updatePostMap postCollection = do+  -- Build a map from post ID to Matterhorn message, then add the new+  -- messages to the global post map. We use the "postsPosts" field for+  -- this because that might contain more messages than the "postsOrder"+  -- list, since the former can contain other messages in threads that+  -- the server sent us, even if those messages are not part of the+  -- ordered post listing of "postsOrder."+  baseUrl <- getServerBaseUrl+  let postMap = HM.fromList+          [ ( pId+            , fst $ clientPostToMessage (toClientPost baseUrl x Nothing)+            )+          | (pId, x) <- HM.toList (postCollection^.postsPostsL)+          ]+  csPostMap %= HM.union postMap++-- | Add a 'ClientMessage' to the current channel's message list+addClientMessage :: ClientMessage -> MH ()+addClientMessage msg = do+  cid <- use csCurrentChannelId+  uuid <- generateUUID+  let addCMsg = ccContents.cdMessages %~+          (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid))+  csChannels %= modifyChannelById cid addCMsg+  mh $ invalidateCacheEntry $ ChannelMessages cid+  mh $ invalidateCacheEntry ChannelSidebar++  let msgTy = case msg^.cmType of+        Error -> LogError+        _     -> LogGeneral++  mhLog msgTy $ T.pack $ show msg++-- | Add a new 'ClientMessage' representing an error message to+--   the current channel's message list+postInfoMessage :: Text -> MH ()+postInfoMessage info =+    addClientMessage =<< newClientMessage Informative (sanitizeUserText' info)++-- | Add a new 'ClientMessage' representing an error message to+--   the current channel's message list+postErrorMessage' :: Text -> MH ()+postErrorMessage' err =+    addClientMessage =<< newClientMessage Error (sanitizeUserText' err)++postErrorMessageIO :: Text -> ChatState -> IO ChatState+postErrorMessageIO err st = do+  msg <- newClientMessage Error err+  uuid <- generateUUID_IO+  let cId = st ^. csCurrentChannelId+      addEMsg = ccContents.cdMessages %~+          (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid))+  return $ st & csChannels %~ modifyChannelById cId addEMsg++openFilePath :: FilePath -> MH Bool+openFilePath path = openWithOpener (return path)++openWithOpener :: MH String -> MH Bool+openWithOpener getTarget = do+    cfg <- use (csResources.crConfiguration)+    case configURLOpenCommand cfg of+        Nothing ->+            return False+        Just urlOpenCommand -> do+            target <- getTarget++            -- Is the URL-opening command interactive? If so, pause+            -- Matterhorn and run the opener interactively. Otherwise+            -- run the opener asynchronously and continue running+            -- Matterhorn interactively.+            case configURLOpenCommandInteractive cfg of+                False -> do+                    outputChan <- use (csResources.crSubprocessLog)+                    doAsyncWith Preempt $ do+                        runLoggedCommand outputChan (T.unpack urlOpenCommand)+                                         [target] Nothing Nothing+                        return Nothing+                True -> do+                    -- If there isn't a new message cutoff showing in+                    -- the current channel, set one. This way, while the+                    -- user is gone using their interactive URL opener,+                    -- when they return, any messages that arrive in the+                    -- current channel will be displayed as new.+                    curChan <- use csCurrentChannel+                    let msgs = curChan^.ccContents.cdMessages+                    case findLatestUserMessage isEditable msgs of+                        Nothing -> return ()+                        Just m ->+                            case m^.mOriginalPost of+                                Nothing -> return ()+                                Just p ->+                                    case curChan^.ccInfo.cdNewMessageIndicator of+                                        Hide ->+                                            csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))+                                        _ -> return ()+                    -- No need to add a gap here: the websocket+                    -- disconnect/reconnect events will automatically+                    -- handle management of messages delivered while+                    -- suspended.++                    mhSuspendAndResume $ \st -> do+                        result <- runInteractiveCommand (T.unpack urlOpenCommand) [target]++                        let waitForKeypress = do+                                putStrLn "Press any key to return to Matterhorn."+                                void getChar++                        case result of+                            Right ExitSuccess -> return ()+                            Left err -> do+                                putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <>+                                           " could not be run: " <> err+                                waitForKeypress+                            Right (ExitFailure code) -> do+                                putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <>+                                           " exited with non-zero status " <> show code+                                waitForKeypress++                        return $ setMode' Main st++            return True++runInteractiveCommand :: String+                      -> [String]+                      -> IO (Either String ExitCode)+runInteractiveCommand cmd args = do+    let opener = (proc cmd args) { std_in = Inherit+                                 , std_out = Inherit+                                 , std_err = Inherit+                                 }+    result <- try $ createProcess opener+    case result of+        Left (e::SomeException) -> return $ Left $ show e+        Right (_, _, _, ph) -> do+            ec <- waitForProcess ph+            return $ Right ec++runLoggedCommand :: STM.TChan ProgramOutput+                 -- ^ The output channel to send the output to+                 -> String+                 -- ^ The program name+                 -> [String]+                 -- ^ Arguments+                 -> Maybe String+                 -- ^ The stdin to send, if any+                 -> Maybe (MVar ProgramOutput)+                 -- ^ Where to put the program output when it is ready+                 -> IO ()+runLoggedCommand outputChan cmd args mInput mOutputVar = void $ forkIO $ do+    let stdIn = maybe NoStream (const CreatePipe) mInput+        opener = (proc cmd args) { std_in = stdIn+                                 , std_out = CreatePipe+                                 , std_err = CreatePipe+                                 }+    result <- try $ createProcess opener+    case result of+        Left (e::SomeException) -> do+            let po = ProgramOutput cmd args "" (show e) (ExitFailure 1)+            STM.atomically $ STM.writeTChan outputChan po+            maybe (return ()) (flip putMVar po) mOutputVar+        Right (stdinResult, Just outh, Just errh, ph) -> do+            case stdinResult of+                Just inh -> do+                    let Just input = mInput+                    hPutStrLn inh input+                    hFlush inh+                Nothing -> return ()++            ec <- waitForProcess ph+            outResult <- hGetContents outh+            errResult <- hGetContents errh+            let po = ProgramOutput cmd args outResult errResult ec+            STM.atomically $ STM.writeTChan outputChan po+            maybe (return ()) (flip putMVar po) mOutputVar+        Right _ ->+            error $ "BUG: createProcess returned unexpected result, report this at " <>+                    "https://github.com/matterhorn-chat/matterhorn"++prepareAttachment :: FileId -> Session -> IO String+prepareAttachment fId sess = do+    -- The link is for an attachment, so fetch it and then+    -- open the local copy.++    (info, contents) <- concurrently (mmGetMetadataForFile fId sess) (mmGetFile fId sess)+    cacheDir <- getUserCacheDir xdgName++    let dir   = cacheDir </> "files" </> T.unpack (idString fId)+        fname = dir </> T.unpack (fileInfoName info)++    createDirectoryIfMissing True dir+    BS.writeFile fname contents+    return fname++removeEmoteFormatting :: T.Text -> T.Text+removeEmoteFormatting t+    | "*" `T.isPrefixOf` t &&+      "*" `T.isSuffixOf` t = T.init $ T.drop 1 t+    | otherwise = t++addEmoteFormatting :: T.Text -> T.Text+addEmoteFormatting t = "*" <> t <> "*"++fetchMentionedUsers :: Set.Set MentionedUser -> MH ()+fetchMentionedUsers ms+    | Set.null ms = return ()+    | otherwise = do+        let convertMention (UsernameMention u) = UserFetchByUsername u+            convertMention (UserIdMention i) = UserFetchById i+        scheduleUserFetches $ convertMention <$> Set.toList ms++doPendingUserStatusFetches :: MH ()+doPendingUserStatusFetches = do+    mz <- getScheduledUserStatusFetches+    case mz of+        Nothing -> return ()+        Just z -> do+            statusChan <- use (csResources.crStatusUpdateChan)+            liftIO $ STM.atomically $ STM.writeTChan statusChan z++doPendingUserFetches :: MH ()+doPendingUserFetches = do+    fs <- getScheduledUserFetches++    let getUsername (UserFetchByUsername u) = Just u+        getUsername _ = Nothing++        getUserId (UserFetchById i) = Just i+        getUserId _ = Nothing++    fetchUsers (catMaybes $ getUsername <$> fs) (catMaybes $ getUserId <$> fs)++-- | Given a list of usernames, ensure that we have a user record for+-- each one in the state, either by confirming that a local record+-- exists or by issuing a request for user records.+fetchUsers :: [Text] -> [UserId] -> MH ()+fetchUsers rawUsernames uids = do+    st <- use id+    session <- getSession+    let usernames = trimUserSigil <$> rawUsernames+        missingUsernames = filter isMissing usernames+        isMissing n = and [ not $ T.null n+                          , not $ isSpecialMention n+                          , isNothing $ userByUsername n st+                          ]+        missingIds = filter (\i -> isNothing $ userById i st) uids++    when (not $ null missingUsernames) $ do+        mhLog LogGeneral $ T.pack $ "fetchUsers: getting " <> show missingUsernames++    when (not $ null missingIds) $ do+        mhLog LogGeneral $ T.pack $ "fetchUsers: getting " <> show missingIds++    when ((not $ null missingUsernames) || (not $ null missingIds)) $ do+        doAsyncWith Normal $ do+            act1 <- case null missingUsernames of+                True -> return $ return ()+                False -> do+                    results <- mmGetUsersByUsernames (Seq.fromList missingUsernames) session+                    return $ do+                        forM_ results (\u -> addNewUser $ userInfoFromUser u True)++            act2 <- case null missingIds of+                True -> return $ return ()+                False -> do+                    results <- mmGetUsersByIds (Seq.fromList missingIds) session+                    return $ do+                        forM_ results (\u -> addNewUser $ userInfoFromUser u True)++            return $ Just $ act1 >> act2
+ src/Matterhorn/State/Editing.hs view
@@ -0,0 +1,525 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+module Matterhorn.State.Editing+  ( requestSpellCheck+  , editingKeybindings+  , editingKeyHandlers+  , messageEditingKeybindings+  , toggleMultilineEditing+  , invokeExternalEditor+  , handlePaste+  , handleInputSubmission+  , getEditorContent+  , handleEditingInput+  , cancelAutocompleteOrReplyOrEdit+  , replyToLatestMessage+  , Direction(..)+  , tabComplete+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( invalidateCache, invalidateCacheEntry )+import           Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent+                                    , getEditContents, editContentsL )+import qualified Brick.Widgets.List as L+import qualified Codec.Binary.UTF8.Generic as UTF8+import           Control.Arrow+import qualified Control.Concurrent.STM as STM+import qualified Data.ByteString as BS+import           Data.Char ( isSpace )+import qualified Data.Foldable as F+import qualified Data.Map as M+import           Data.Maybe ( fromJust )+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(..) )+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+import qualified System.IO.Temp as Sys+import qualified System.Process as Sys+import           Text.Aspell ( AspellResponse(..), mistakeWord, askAspell )++import           Network.Mattermost.Types ( Post(..), ChannelId )++import           Matterhorn.Config+import {-# SOURCE #-} Matterhorn.Command ( dispatchCommand )+import           Matterhorn.InputHistory+import           Matterhorn.Events.Keybindings+import           Matterhorn.State.Common+import           Matterhorn.State.Autocomplete+import           Matterhorn.State.Attachments+import           Matterhorn.State.Messages+import           Matterhorn.Types hiding ( newState )+import           Matterhorn.Types.Common ( sanitizeUserText' )+++startMultilineEditing :: MH ()+startMultilineEditing = do+    mh invalidateCache+    csEditState.cedEphemeral.eesMultiline .= True++toggleMultilineEditing :: MH ()+toggleMultilineEditing = do+    mh invalidateCache+    csEditState.cedEphemeral.eesMultiline %= not++    -- If multiline is now disabled and there is more than one line in+    -- the editor, that means we're showing the multiline message status+    -- (see Draw.Main.renderUserCommandBox.commandBox) so we want to be+    -- sure no autocomplete UI is present in case the cursor was left on+    -- a word that would otherwise show completion alternatives.+    multiline <- use (csEditState.cedEphemeral.eesMultiline)+    numLines <- use (csEditState.cedEditor.to getEditContents.to length)+    when (not multiline && numLines > 1) resetAutocomplete++invokeExternalEditor :: MH ()+invokeExternalEditor = do+    -- If EDITOR is in the environment, write the current message to a+    -- temp file, invoke EDITOR on it, read the result, remove the temp+    -- file, and update the program state.+    --+    -- If EDITOR is not present, fall back to 'vi'.+    mEnv <- liftIO $ Sys.lookupEnv "EDITOR"+    let editorProgram = maybe "vi" id mEnv++    mhSuspendAndResume $ \ st -> 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+        Sys.hClose tmpFileHandle++        -- Run the editor+        status <- Sys.system (editorProgram <> " " <> tmpFileName)++        -- On editor exit, if exited with zero status, read temp file.+        -- If non-zero status, skip temp file read.+        case status of+            Sys.ExitSuccess -> do+                tmpBytes <- BS.readFile tmpFileName+                case T.decodeUtf8' tmpBytes of+                    Left _ -> do+                        postErrorMessageIO "Failed to decode file contents as UTF-8" st+                    Right t -> do+                        let tmpLines = T.lines $ sanitizeUserText' t+                        return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing)+            Sys.ExitFailure _ -> return st++handlePaste :: BS.ByteString -> MH ()+handlePaste bytes = do+  let pasteStr = T.pack (UTF8.toString bytes)+  csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr))+  contents <- use (csEditState.cedEditor.to getEditContents)+  case length contents > 1 of+      True -> startMultilineEditing+      False -> return ()++editingPermitted :: ChatState -> Bool+editingPermitted st =+    (length (getEditContents $ st^.csEditState.cedEditor) == 1) ||+    st^.csEditState.cedEphemeral.eesMultiline++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+      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)+      editor %= applyEdit (Z.insertMany buf)+  ]++getEditorContent :: MH Text+getEditorContent = do+    cmdLine <- use (csEditState.cedEditor)+    let (line:rest) = getEditContents cmdLine+    return $ T.intercalate "\n" $ line : rest++-- | Handle an input submission in the message editor.+--+-- This handles the specified input text as if it were user input for+-- the specified channel. This means that if the specified input text+-- contains a command ("/...") then it is executed as normal. Otherwise+-- the text is sent as a message to the specified channel.+--+-- However, this function assumes that the message editor is the+-- *source* of the text, so it also takes care of clearing the editor,+-- resetting the edit mode, updating the input history for the specified+-- channel, etc.+handleInputSubmission :: ChannelId -> Text -> MH ()+handleInputSubmission cId content = do+    -- We clean up before dispatching the command or sending the message+    -- since otherwise the command could change the state and then doing+    -- cleanup afterwards could clean up the wrong things.+    csEditState.cedEditor %= applyEdit Z.clearZipper+    csEditState.cedInputHistory %= addHistoryEntry content cId+    csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing++    case T.uncons content of+      Just ('/', cmd) ->+          dispatchCommand cmd+      _ -> do+          attachments <- use (csEditState.cedAttachmentList.L.listElementsL)+          mode <- use (csEditState.cedEditMode)+          sendMessage cId mode content $ F.toList attachments++    -- Reset the autocomplete UI+    resetAutocomplete++    -- Empty the attachment list+    resetAttachmentList++    -- Reset the edit mode *after* handling the input so that the input+    -- handler can tell whether we're editing, replying, etc.+    csEditState.cedEditMode .= NewPost++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:+    -- if multiline mode is off, or if there is only one line of text+    -- in the editor. This means we skip input this catch-all handler+    -- if we're *not* in multiline mode *and* there are multiple lines,+    -- 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++    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+          -- composition+          EvKey KBS [] | (not $ editingPermitted st) ->+            csEditState.cedEditor %= applyEdit Z.clearZipper++          -- Backspace in editing mode with smart pair insertion means+          -- smart pair removal when possible+          EvKey KBS [] | editingPermitted st && smartBacktick ->+              let backspace = csEditState.cedEditor %= applyEdit Z.deletePrevChar+              in case cursorAtOneOf smartChars (st^.csEditState.cedEditor) of+                  Nothing -> backspace+                  Just ch ->+                      -- Smart char removal:+                      if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csEditState.cedEditor) &&+                           (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->+                             csEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar)+                         | otherwise -> backspace++          EvKey (KChar ch) []+            | editingPermitted st && smartBacktick && ch `elem` smartChars ->+              -- Smart char insertion:+              let doInsertChar = do+                    csEditState.cedEditor %= applyEdit (Z.insertChar ch)+                    sendUserTypingAction+                  curLine = Z.currentLine $ st^.csEditState.cedEditor.editContentsL+              -- First case: if the cursor is at the end of the current+              -- line and it contains "``" and the user entered a third+              -- "`", enable multi-line mode since they're likely typing+              -- a code block.+              in if | (cursorIsAtEnd $ st^.csEditState.cedEditor) &&+                         curLine == "``" &&+                         ch == '`' -> do+                        csEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch))+                        csEditState.cedEphemeral.eesMultiline .= True+                    -- Second case: user entered some smart character+                    -- (don't care which) on an empty line or at the end+                    -- of the line after whitespace, so enter a pair of+                    -- the smart chars and put the cursor between them.+                    | (editorEmpty $ st^.csEditState.cedEditor) ||+                         ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) &&+                          (cursorIsAtEnd $ st^.csEditState.cedEditor)) ->+                        csEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft)+                    -- Third case: the cursor is already on a smart+                    -- character and that character is the last one+                    -- on the line, so instead of inserting a new+                    -- character, just move past it.+                    | (cursorAtChar ch $ st^.csEditState.cedEditor) &&+                      (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->+                        csEditState.cedEditor %= applyEdit Z.moveRight+                    -- Fall-through case: just insert one of the chars+                    -- without doing anything smart.+                    | otherwise -> doInsertChar+            | editingPermitted st -> do++              -- 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+              sendUserTypingAction+            | otherwise -> return ()++    let ctx = AutocompleteContext { autocompleteManual = False+                                  , autocompleteFirstMatch = False+                                  }+    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.+sendUserTypingAction :: MH ()+sendUserTypingAction = do+  st <- use id+  when (configShowTypingIndicator (st^.csResources.crConfiguration)) $+    case st^.csConnectionStatus of+      Connected -> do+        let pId = case st^.csEditState.cedEditMode of+                    Replying _ post -> Just $ postId post+                    _               -> Nothing+        liftIO $ do+          now <- getCurrentTime+          let action = UserTyping now (st^.csCurrentChannelId) pId+          STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action+      Disconnected -> return ()++-- Kick off an async request to the spell checker for the current editor+-- contents.+requestSpellCheck :: MH ()+requestSpellCheck = do+    st <- use id+    case st^.csEditState.cedSpellChecker of+        Nothing -> return ()+        Just (checker, _) -> do+            -- Get the editor contents.+            contents <- getEditContents <$> use (csEditState.cedEditor)+            doAsyncWith Preempt $ do+                -- For each line in the editor, submit an aspell request.+                let query = concat <$> mapM (askAspell checker) contents+                    postMistakes :: [AspellResponse] -> MH ()+                    postMistakes responses = do+                        let getMistakes AllCorrect = []+                            getMistakes (Mistakes ms) = mistakeWord <$> ms+                            allMistakes = S.fromList $ concat $ getMistakes <$> responses+                        csEditState.cedMisspellings .= allMistakes++                tryMM query (return . Just . postMistakes)++editorEmpty :: Editor Text a -> Bool+editorEmpty e = cursorIsAtEnd e &&+                cursorIsAtBeginning e++cursorIsAtEnd :: Editor Text a -> Bool+cursorIsAtEnd e =+    let col = snd $ Z.cursorPosition z+        curLine = Z.currentLine z+        z = e^.editContentsL+    in col == T.length curLine++cursorIsAtBeginning :: Editor Text a -> Bool+cursorIsAtBeginning e =+    let col = snd $ Z.cursorPosition z+        z = e^.editContentsL+    in col == 0++cursorAtOneOf :: [Char] -> Editor Text a -> Maybe Char+cursorAtOneOf [] _ = Nothing+cursorAtOneOf (c:cs) e =+    if cursorAtChar c e+    then Just c+    else cursorAtOneOf cs e++cursorAtChar :: Char -> Editor Text a -> Bool+cursorAtChar ch e =+    let col = snd $ Z.cursorPosition z+        curLine = Z.currentLine z+        z = e^.editContentsL+    in (T.singleton ch) `T.isPrefixOf` T.drop col curLine++gotoHome :: Z.TextZipper Text -> Z.TextZipper Text+gotoHome = Z.moveCursor (0, 0)++gotoEnd :: Z.TextZipper Text -> Z.TextZipper Text+gotoEnd z =+    let zLines = Z.getText z+        numLines = length zLines+        lastLineLength = T.length $ last zLines+    in if numLines > 0+       then Z.moveCursor (numLines - 1, lastLineLength) z+       else z++cancelAutocompleteOrReplyOrEdit :: MH ()+cancelAutocompleteOrReplyOrEdit = do+    cId <- use csCurrentChannelId+    mh $ invalidateCacheEntry $ ChannelMessages cId+    ac <- use (csEditState.cedAutocomplete)+    case ac of+        Just _ -> do+            resetAutocomplete+        Nothing -> do+            mode <- use (csEditState.cedEditMode)+            case mode of+                NewPost -> return ()+                _ -> do+                    csEditState.cedEditMode .= NewPost+                    csEditState.cedEditor %= applyEdit Z.clearZipper+                    resetAttachmentList++replyToLatestMessage :: MH ()+replyToLatestMessage = do+  msgs <- use (csCurrentChannel . ccContents . cdMessages)+  case findLatestUserMessage isReplyable msgs of+    Just msg | isReplyable msg ->+        do rootMsg <- getReplyRootMessage msg+           setMode Main+           cId <- use csCurrentChannelId+           mh $ invalidateCacheEntry $ ChannelMessages cId+           csEditState.cedEditMode .= Replying rootMsg (fromJust $ rootMsg^.mOriginalPost)+    _ -> return ()++data Direction = Forwards | Backwards++tabComplete :: Direction -> MH ()+tabComplete dir = do+    let transform list =+            let len = list^.L.listElementsL.to length+            in case dir of+                Forwards ->+                    if (L.listSelected list == Just (len - 1)) ||+                       (L.listSelected list == Nothing && len > 0)+                    then L.listMoveTo 0 list+                    else L.listMoveBy 1 list+                Backwards ->+                    if (L.listSelected list == Just 0) ||+                       (L.listSelected list == Nothing && len > 0)+                    then L.listMoveTo (len - 1) list+                    else L.listMoveBy (-1) list+    csEditState.cedAutocomplete._Just.acCompletionList %= transform++    mac <- use (csEditState.cedAutocomplete)+    case mac of+        Nothing -> do+            let ctx = AutocompleteContext { autocompleteManual = True+                                          , autocompleteFirstMatch = True+                                          }+            checkForAutocompletion ctx+        Just ac -> do+            case ac^.acCompletionList.to L.listSelectedElement of+                Nothing -> return ()+                Just (_, alternative) -> do+                    let replacement = autocompleteAlternativeReplacement alternative+                        maybeEndOfWord z =+                            if maybe True isSpace (Z.currentChar z)+                            then z+                            else Z.moveWordRight z+                    csEditState.cedEditor %=+                        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/Matterhorn/State/Editing.hs-boot view
@@ -0,0 +1,10 @@+module Matterhorn.State.Editing+  ( Direction(..)+  , tabComplete+  )+where++import Matterhorn.Types ( MH )++data Direction = Forwards | Backwards+tabComplete :: Direction -> MH ()
+ src/Matterhorn/State/Flagging.hs view
@@ -0,0 +1,66 @@+module Matterhorn.State.Flagging+  ( loadFlaggedMessages+  , updateMessageFlag+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Data.Function ( on )+import qualified Data.Set as Set+import           Lens.Micro.Platform++import           Network.Mattermost.Types++import           Matterhorn.State.Common+import           Matterhorn.Types+++loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO ()+loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do+  return $ Just $ do+      sequence_ [ updateMessageFlag (flaggedPostId fp) True+                | fp <- toList prefs+                , flaggedPostStatus fp+                ]+++-- | Update the UI to reflect the flagged/unflagged state of a+-- message. This __does not__ talk to the Mattermost server, but+-- rather is the function we call when the Mattermost server notifies+-- us of flagged or unflagged messages.+updateMessageFlag :: PostId -> Bool -> MH ()+updateMessageFlag pId f = do+  if f+    then csResources.crFlaggedPosts %= Set.insert pId+    else csResources.crFlaggedPosts %= Set.delete pId+  msgMb <- use (csPostMap.at(pId))+  case msgMb of+    Just msg+      | Just cId <- msg^.mChannelId -> do+      let isTargetMessage m = m^.mMessageId == Just (MessagePostId pId)+      csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f+      csPostMap.ix(pId).mFlagged .= f+      -- We also want to update the post overlay if this happens while+      -- we're we're observing it+      mode <- gets appMode+      case mode of+        PostListOverlay PostListFlagged+          | f ->+              csPostListOverlay.postListPosts %=+                addMessage (msg & mFlagged .~ True)+          -- deleting here is tricky, because it means that we need to+          -- move the focus somewhere: we'll try moving it _up_ unless+          -- we can't, in which case we'll try moving it down.+          | otherwise -> do+              selId <- use (csPostListOverlay.postListSelected)+              posts <- use (csPostListOverlay.postListPosts)+              let nextId = case getNextPostId selId posts of+                    Nothing -> getPrevPostId selId posts+                    Just x  -> Just x+              csPostListOverlay.postListSelected .= nextId+              csPostListOverlay.postListPosts %=+                filterMessages (((/=) `on` _mMessageId) msg)+        _ -> return ()+    _ -> return ()
+ src/Matterhorn/State/Help.hs view
@@ -0,0 +1,21 @@+module Matterhorn.State.Help+  ( showHelpScreen+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( viewportScroll, vScrollToBeginning )++import           Matterhorn.Types+++showHelpScreen :: HelpTopic -> MH ()+showHelpScreen topic = do+    curMode <- gets appMode+    case curMode of+        ShowHelp {} -> return ()+        _ -> do+            mh $ vScrollToBeginning (viewportScroll HelpViewport)+            setMode $ ShowHelp topic curMode
+ src/Matterhorn/State/Links.hs view
@@ -0,0 +1,23 @@+module Matterhorn.State.Links+  ( openLinkTarget+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Text as T++import           Matterhorn.State.Common+import           Matterhorn.State.Messages ( jumpToPost )+import           Matterhorn.Types+import           Matterhorn.Types.RichText ( unURL )+++openLinkTarget :: LinkTarget -> MH Bool+openLinkTarget target = do+    session <- getSession+    case target of+        LinkURL url -> openWithOpener (return $ T.unpack $ unURL url)+        LinkFileId fId -> openWithOpener (liftIO $ prepareAttachment fId session)+        LinkPermalink _ pId -> jumpToPost pId >> return True
+ src/Matterhorn/State/ListOverlay.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE RankNTypes #-}+module Matterhorn.State.ListOverlay+  ( listOverlayActivateCurrent+  , listOverlaySearchString+  , listOverlayMove+  , exitListOverlay+  , enterListOverlayMode+  , resetListOverlaySearch+  , onEventListOverlay+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Brick.Widgets.Edit as E+import qualified Data.Text.Zipper as Z+import qualified Data.Vector as Vec+import           Lens.Micro.Platform ( Lens', (%=), (.=) )+import           Network.Mattermost.Types ( Session )+import qualified Graphics.Vty as Vty++import           Matterhorn.Types+import           Matterhorn.State.Common+import           Matterhorn.State.Editing ( editingKeybindings )+import           Matterhorn.Events.Keybindings ( KeyConfig, KeyHandlerMap, handleKeyboardEvent )+++-- | Activate the specified list overlay's selected item by invoking the+-- overlay's configured enter keypress handler function.+listOverlayActivateCurrent :: Lens' ChatState (ListOverlayState a b) -> MH ()+listOverlayActivateCurrent which = do+  mItem <- L.listSelectedElement <$> use (which.listOverlaySearchResults)+  case mItem of+      Nothing -> return ()+      Just (_, val) -> do+          handler <- use (which.listOverlayEnterHandler)+          activated <- handler val+          if activated+             then setMode Main+             else return ()++-- | Get the current search string for the specified overlay.+listOverlaySearchString :: Lens' ChatState (ListOverlayState a b) -> MH Text+listOverlaySearchString which =+    (head . E.getEditContents) <$> use (which.listOverlaySearchInput)++-- | Move the list cursor in the specified overlay.+listOverlayMove :: Lens' ChatState (ListOverlayState a b)+                -- ^ Which overlay+                -> (L.List Name a -> L.List Name a)+                -- ^ How to transform the list in the overlay+                -> MH ()+listOverlayMove which how = which.listOverlaySearchResults %= how++-- | Clear the state of the specified list overlay and return to the+-- Main mode.+exitListOverlay :: Lens' ChatState (ListOverlayState a b)+                -- ^ Which overlay to reset+                -> MH ()+exitListOverlay which = do+    st <- use which+    newList <- use (which.listOverlayNewList)+    which.listOverlaySearchResults .= newList mempty+    which.listOverlayEnterHandler .= (const $ return False)+    setMode (st^.listOverlayReturnMode)++-- | Initialize a list overlay with the specified arguments and switch+-- to the specified mode.+enterListOverlayMode :: (Lens' ChatState (ListOverlayState a b))+                     -- ^ Which overlay to initialize+                     -> Mode+                     -- ^ The mode to change to+                     -> b+                     -- ^ The overlay's initial search scope+                     -> (a -> MH Bool)+                     -- ^ The overlay's enter keypress handler+                     -> (b -> Session -> Text -> IO (Vec.Vector a))+                     -- ^ The overlay's results fetcher function+                     -> MH ()+enterListOverlayMode which mode scope enterHandler fetcher = do+    which.listOverlaySearchScope .= scope+    which.listOverlaySearchInput.E.editContentsL %= Z.clearZipper+    which.listOverlayEnterHandler .= enterHandler+    which.listOverlayFetchResults .= fetcher+    which.listOverlaySearching .= False+    newList <- use (which.listOverlayNewList)+    which.listOverlaySearchResults .= newList mempty+    setMode mode+    resetListOverlaySearch which++-- | Reset the overlay's search by initiating a new search request for+-- the string that is currently in the overlay's editor. This does+-- nothing if a search for this overlay is already in progress.+resetListOverlaySearch :: Lens' ChatState (ListOverlayState a b) -> MH ()+resetListOverlaySearch which = do+    searchPending <- use (which.listOverlaySearching)++    when (not searchPending) $ do+        searchString <- listOverlaySearchString which+        which.listOverlaySearching .= True+        newList <- use (which.listOverlayNewList)+        session <- getSession+        scope <- use (which.listOverlaySearchScope)+        fetcher <- use (which.listOverlayFetchResults)+        doAsyncWith Preempt $ do+            results <- fetcher scope session searchString+            return $ Just $ do+                which.listOverlaySearchResults .= newList results+                which.listOverlaySearching .= False++                -- Now that the results are available, check to see if the+                -- search string changed since this request was submitted.+                -- If so, issue another search.+                afterSearchString <- listOverlaySearchString which+                when (searchString /= afterSearchString) $ resetListOverlaySearch which++-- | Generically handle an event for the list overlay state targeted+-- by the specified lens. Automatically dispatches new searches in the+-- overlay's editor if the editor contents change.+onEventListOverlay :: Lens' ChatState (ListOverlayState a b)+                   -- ^ Which overlay to dispatch to?+                   -> (KeyConfig -> KeyHandlerMap)+                   -- ^ The keybinding builder+                   -> Vty.Event+                   -- ^ The event+                   -> MH Bool+onEventListOverlay which keybindings =+    handleKeyboardEvent keybindings $ \e -> do+        -- Get the editor content before the event.+        before <- listOverlaySearchString which++        -- 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.+        after <- listOverlaySearchString which+        when (before /= after) $ resetListOverlaySearch which
+ src/Matterhorn/State/Logging.hs view
@@ -0,0 +1,33 @@+module Matterhorn.State.Logging+  ( startLogging+  , stopLogging+  , logSnapshot+  , getLogDestination+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Matterhorn.Types+++startLogging :: FilePath -> MH ()+startLogging path = do+    mgr <- use (csResources.crLogManager)+    liftIO $ startLoggingToFile mgr path++stopLogging :: MH ()+stopLogging = do+    mgr <- use (csResources.crLogManager)+    liftIO $ stopLoggingToFile mgr++logSnapshot :: FilePath -> MH ()+logSnapshot path = do+    mgr <- use (csResources.crLogManager)+    liftIO $ requestLogSnapshot mgr path++getLogDestination :: MH ()+getLogDestination = do+    mgr <- use (csResources.crLogManager)+    liftIO $ requestLogDestination mgr
+ src/Matterhorn/State/MessageSelect.hs view
@@ -0,0 +1,294 @@+module Matterhorn.State.MessageSelect+  (+  -- * Message selection mode+    beginMessageSelect+  , flagSelectedMessage+  , pinSelectedMessage+  , viewSelectedMessage+  , fillSelectedGap+  , yankSelectedMessageVerbatim+  , yankSelectedMessage+  , openSelectedMessageURLs+  , beginConfirmDeleteSelectedMessage+  , messageSelectUp+  , messageSelectUpBy+  , messageSelectDown+  , messageSelectDownBy+  , messageSelectFirst+  , messageSelectLast+  , deleteSelectedMessage+  , beginReplyCompose+  , beginEditMessage+  , flagMessage+  , getSelectedMessage+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Widgets.Edit ( applyEdit )+import           Data.Text.Zipper ( clearZipper, insertMany )+import           Lens.Micro.Platform++import qualified Network.Mattermost.Endpoints as MM+import           Network.Mattermost.Types++import           Matterhorn.Clipboard ( copyToClipboard )+import           Matterhorn.State.Common+import           Matterhorn.State.Links+import           Matterhorn.State.Messages+import           Matterhorn.Types+import           Matterhorn.Types.RichText ( findVerbatimChunk )+import           Matterhorn.Types.Common+import           Matterhorn.Windows.ViewMessage+++-- | In these modes, we allow access to the selected message state.+messageSelectCompatibleModes :: [Mode]+messageSelectCompatibleModes =+    [ MessageSelect+    , MessageSelectDeleteConfirm+    , ReactionEmojiListOverlay+    ]++getSelectedMessage :: ChatState -> Maybe Message+getSelectedMessage st+    | not (appMode st `elem` messageSelectCompatibleModes) = Nothing+    | otherwise = do+        selMsgId <- selectMessageId $ st^.csMessageSelect+        let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages+        findMessage selMsgId chanMsgs++beginMessageSelect :: MH ()+beginMessageSelect = do+    -- Get the number of messages in the current channel and set the+    -- currently selected message index to be the most recently received+    -- message that corresponds to a Post (i.e. exclude informative+    -- messages).+    --+    -- If we can't find one at all, we ignore the mode switch request+    -- and just return.+    chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)+    let recentMsg = getLatestSelectableMessage chanMsgs++    when (isJust recentMsg) $ do+        setMode MessageSelect+        csMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId)++-- | Tell the server that the message we currently have selected+-- should have its flagged state toggled.+flagSelectedMessage :: MH ()+flagSelectedMessage = do+  selected <- use (to getSelectedMessage)+  case selected of+    Just msg+      | isFlaggable msg, Just pId <- messagePostId msg ->+        flagMessage pId (not (msg^.mFlagged))+    _        -> return ()++-- | Tell the server that the message we currently have selected+-- should have its pinned state toggled.+pinSelectedMessage :: MH ()+pinSelectedMessage = do+  selected <- use (to getSelectedMessage)+  case selected of+    Just msg+      | isPinnable msg, Just pId <- messagePostId msg ->+        pinMessage pId (not (msg^.mPinned))+    _ -> return ()++viewSelectedMessage :: MH ()+viewSelectedMessage = do+  selected <- use (to getSelectedMessage)+  case selected of+    Just msg+      | not (isGap msg) -> viewMessage msg+    _        -> return ()++fillSelectedGap :: MH ()+fillSelectedGap = do+  selected <- use (to getSelectedMessage)+  case selected of+    Just msg+      | isGap msg -> do cId <- use csCurrentChannelId+                        asyncFetchMessagesForGap cId msg+    _        -> return ()++viewMessage :: Message -> MH ()+viewMessage m = do+    let w = tabbedWindow VMTabMessage viewMessageWindowTemplate MessageSelect (78, 25)+    csViewedMessage .= Just (m, w)+    runTabShowHandlerFor (twValue w) w+    setMode ViewMessage++yankSelectedMessageVerbatim :: MH ()+yankSelectedMessageVerbatim = do+    selectedMessage <- use (to getSelectedMessage)+    case selectedMessage of+        Nothing -> return ()+        Just m -> do+            setMode Main+            case findVerbatimChunk (m^.mText) of+                Just txt -> copyToClipboard txt+                Nothing  -> return ()++yankSelectedMessage :: MH ()+yankSelectedMessage = do+    selectedMessage <- use (to getSelectedMessage)+    case selectedMessage of+        Nothing -> return ()+        Just m -> do+            setMode Main+            copyToClipboard $ m^.mMarkdownSource++openSelectedMessageURLs :: MH ()+openSelectedMessageURLs = whenMode MessageSelect $ do+    mCurMsg <- use (to getSelectedMessage)+    curMsg <- case mCurMsg of+        Nothing -> error "BUG: openSelectedMessageURLs: no selected message available"+        Just m -> return m++    let urls = msgURLs curMsg+    when (not (null urls)) $ do+        openedAll <- and <$> mapM (openLinkTarget . _linkTarget) urls+        case openedAll of+            True -> return ()+            False ->+                mhError $ ConfigOptionMissing "urlOpenCommand"++beginConfirmDeleteSelectedMessage :: MH ()+beginConfirmDeleteSelectedMessage = do+    st <- use id+    selected <- use (to getSelectedMessage)+    case selected of+        Just msg | isDeletable msg && isMine st msg ->+            setMode MessageSelectDeleteConfirm+        _ -> return ()++messageSelectUp :: MH ()+messageSelectUp = do+    mode <- gets appMode+    selected <- use (csMessageSelect.to selectMessageId)+    case selected of+        Just _ | mode == MessageSelect -> do+            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+            let nextMsgId = getPrevMessageId selected chanMsgs+            csMessageSelect .= MessageSelectState (nextMsgId <|> selected)+        _ -> return ()++messageSelectDown :: MH ()+messageSelectDown = do+    selected <- use (csMessageSelect.to selectMessageId)+    case selected of+        Just _ -> whenMode MessageSelect $ do+            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+            let nextMsgId = getNextMessageId selected chanMsgs+            csMessageSelect .= MessageSelectState (nextMsgId <|> selected)+        _ -> return ()++messageSelectDownBy :: Int -> MH ()+messageSelectDownBy amt+    | amt <= 0 = return ()+    | otherwise =+        messageSelectDown >> messageSelectDownBy (amt - 1)++messageSelectUpBy :: Int -> MH ()+messageSelectUpBy amt+    | amt <= 0 = return ()+    | otherwise =+      messageSelectUp >> messageSelectUpBy (amt - 1)++messageSelectFirst :: MH ()+messageSelectFirst = do+    selected <- use (csMessageSelect.to selectMessageId)+    case selected of+        Just _ -> whenMode MessageSelect $ do+            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+            case getEarliestSelectableMessage chanMsgs of+              Just firstMsg ->+                csMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)+              Nothing -> mhLog LogError "No first message found from current message?!"+        _ -> return ()++messageSelectLast :: MH ()+messageSelectLast = do+    selected <- use (csMessageSelect.to selectMessageId)+    case selected of+        Just _ -> whenMode MessageSelect $ do+            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)+            case getLatestSelectableMessage chanMsgs of+              Just lastSelMsg ->+                csMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)+              Nothing -> mhLog LogError "No last message found from current message?!"+        _ -> return ()++deleteSelectedMessage :: MH ()+deleteSelectedMessage = do+    selectedMessage <- use (to getSelectedMessage)+    st <- use id+    cId <- use csCurrentChannelId+    case selectedMessage of+        Just msg | isMine st msg && isDeletable msg ->+            case msg^.mOriginalPost of+              Just p ->+                  doAsyncChannelMM Preempt cId+                      (\s _ -> MM.mmDeletePost (postId p) s)+                      (\_ _ -> Just $ do+                          csEditState.cedEditMode .= NewPost+                          setMode Main)+              Nothing -> return ()+        _ -> return ()++beginReplyCompose :: MH ()+beginReplyCompose = do+    selected <- use (to getSelectedMessage)+    case selected of+        Just msg | isReplyable msg -> do+            rootMsg <- getReplyRootMessage msg+            let Just p = rootMsg^.mOriginalPost+            setMode Main+            csEditState.cedEditMode .= Replying rootMsg p+        _ -> return ()++beginEditMessage :: MH ()+beginEditMessage = do+    selected <- use (to getSelectedMessage)+    st <- use id+    case selected of+        Just msg | isMine st msg && isEditable msg -> do+            let Just p = msg^.mOriginalPost+            setMode Main+            csEditState.cedEditMode .= Editing p (msg^.mType)+            -- If the post that we're editing is an emote, we need+            -- to strip the formatting because that's only there to+            -- indicate that the post is an emote. This is annoying and+            -- can go away one day when there is an actual post type+            -- value of "emote" that we can look at. Note that the+            -- removed formatting needs to be reinstated just prior to+            -- issuing the API call to update the post.+            let sanitized = sanitizeUserText $ postMessage p+            let toEdit = if isEmote msg+                         then removeEmoteFormatting sanitized+                         else sanitized+            csEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper)+        _ -> return ()++-- | Tell the server that we have flagged or unflagged a message.+flagMessage :: PostId -> Bool -> MH ()+flagMessage pId f = do+  session <- getSession+  myId <- gets myUserId+  doAsyncWith Normal $ do+    let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost+    doFlag myId pId session+    return Nothing++-- | Tell the server that we have pinned or unpinned a message.+pinMessage :: PostId -> Bool -> MH ()+pinMessage pId f = do+  session <- getSession+  doAsyncWith Normal $ do+    let doPin = if f then MM.mmPinPostToChannel else MM.mmUnpinPostToChannel+    void $ doPin pId session+    return Nothing
+ src/Matterhorn/State/Messages.hs view
@@ -0,0 +1,929 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.State.Messages+  ( PostToAdd(..)+  , addDisconnectGaps+  , lastMsg+  , sendMessage+  , editMessage+  , deleteMessage+  , addNewPostedMessage+  , addObtainedMessages+  , asyncFetchMoreMessages+  , asyncFetchMessagesForGap+  , asyncFetchMessagesSurrounding+  , fetchVisibleIfNeeded+  , disconnectChannels+  , toggleMessageTimestamps+  , jumpToPost+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( getVtyHandle, invalidateCacheEntry, invalidateCache )+import qualified Brick.Widgets.FileBrowser as FB+import           Control.Exception ( SomeException, try )+import qualified Data.Foldable as F+import qualified Data.HashMap.Strict as HM+import qualified Data.Set as Set+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Graphics.Vty ( outputIface )+import           Graphics.Vty.Output.Interface ( ringTerminalBell )+import           Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~), (^?)+                                     , to, at, traversed, filtered, ix, _1 )++import           Network.Mattermost+import qualified Network.Mattermost.Endpoints as MM+import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.Constants+import           Matterhorn.State.Channels+import           Matterhorn.State.Common+import           Matterhorn.State.Reactions+import           Matterhorn.State.Users+import           Matterhorn.TimeUtils+import           Matterhorn.Types+import           Matterhorn.Types.Common ( sanitizeUserText )+import           Matterhorn.Types.DirectionalSeq ( DirectionalSeq, SeqDirection )+++-- ----------------------------------------------------------------------+-- Message gaps+++-- | Called to add an UnknownGap to the end of the Messages collection+-- for all channels when the client has become disconnected from the+-- server.  This gaps will later be removed by successful fetching+-- overlaps if the connection is re-established.  Note that the+-- disconnect is re-iterated periodically via a re-connect timer+-- attempt, so do not duplicate gaps.  Also clear any flags+-- representing a pending exchange with the server (which will now+-- never complete).+addDisconnectGaps :: MH ()+addDisconnectGaps = mapM_ onEach . filteredChannelIds (const True) =<< use csChannels+    where onEach c = do addEndGap c+                        clearPendingFlags c+                        mh $ invalidateCacheEntry (ChannelMessages c)++-- | Websocket was disconnected, so all channels may now miss some+-- messages+disconnectChannels :: MH ()+disconnectChannels = addDisconnectGaps++toggleMessageTimestamps :: MH ()+toggleMessageTimestamps = do+    mh invalidateCache+    let toggle c = c { configShowMessageTimestamps = not (configShowMessageTimestamps c)+                     }+    csResources.crConfiguration %= toggle++clearPendingFlags :: ChannelId -> MH ()+clearPendingFlags c = csChannel(c).ccContents.cdFetchPending .= False++addEndGap :: ChannelId -> MH ()+addEndGap cId = withChannel cId $ \chan ->+    let lastmsg_ = chan^.ccContents.cdMessages.to reverseMessages.to lastMsg+        lastIsGap = maybe False isGap lastmsg_+        gapMsg = newGapMessage timeJustAfterLast+        timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_+        t0 = ServerTime $ originTime  -- use any time for a channel with no messages yet+        newGapMessage = newMessageOfType+                        (T.pack "Disconnected. Will refresh when connected.")+                        (C UnknownGapAfter)+    in unless lastIsGap+           (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg))++lastMsg :: RetrogradeMessages -> Maybe Message+lastMsg = withFirstMessage id++-- | Send a message and attachments to the specified channel.+sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()+sendMessage chanId mode msg attachments =+    when (not $ shouldSkipMessage msg) $ do+        status <- use csConnectionStatus+        case status of+            Disconnected -> do+                let m = T.concat [ "Cannot send messages while disconnected. Enable logging to "+                                 , "get disconnection information. If Matterhorn's reconnection "+                                 , "attempts are failing, use `/reconnect` to attempt to "+                                 , "reconnect manually."+                                 ]+                mhError $ GenericError m+            Connected -> do+                session <- getSession+                doAsync Preempt $ do+                    -- Upload attachments+                    fileInfos <- forM attachments $ \a -> do+                        MM.mmUploadFile chanId (FB.fileInfoFilename $ attachmentDataFileInfo a)+                            (attachmentDataBytes a) session++                    let fileIds = Seq.fromList $+                                  fmap fileInfoId $+                                  concat $+                                  (F.toList . MM.uploadResponseFileInfos) <$> fileInfos++                    case mode of+                        NewPost -> do+                            let pendingPost = (rawPost msg chanId) { rawPostFileIds = fileIds }+                            void $ MM.mmCreatePost pendingPost session+                        Replying _ p -> do+                            let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p)+                                                                   , rawPostFileIds = fileIds+                                                                   }+                            void $ MM.mmCreatePost pendingPost session+                        Editing p ty -> do+                            let body = case ty of+                                         CP Emote -> addEmoteFormatting msg+                                         _ -> msg+                                update = (postUpdateBody body) { postUpdateFileIds = if null fileIds+                                                                                     then Nothing+                                                                                     else Just fileIds+                                                               }+                            void $ MM.mmPatchPost (postId p) update session++shouldSkipMessage :: Text -> Bool+shouldSkipMessage "" = True+shouldSkipMessage s = T.all (`elem` (" \t"::String)) s++editMessage :: Post -> MH ()+editMessage new = do+    myId <- gets myUserId+    baseUrl <- getServerBaseUrl+    let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)+        (msg, mentionedUsers) = clientPostToMessage (toClientPost baseUrl new (new^.postRootIdL))+        chan = csChannel (new^.postChannelIdL)+    chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg+    mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)++    fetchMentionedUsers mentionedUsers++    when (postUserId new /= Just myId) $+        chan %= adjustEditedThreshold new++    csPostMap.ix(postId new) .= msg+    asyncFetchReactionsForPost (postChannelId new) new+    asyncFetchAttachments new++deleteMessage :: Post -> MH ()+deleteMessage new = do+    let isDeletedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL) ||+                             isReplyTo (new^.postIdL) m+        chan :: Traversal' ChatState ClientChannel+        chan = csChannel (new^.postChannelIdL)+    chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)+    chan %= adjustUpdated new+    mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)++addNewPostedMessage :: PostToAdd -> MH ()+addNewPostedMessage p =+    addMessageToState True True p >>= postProcessMessageAdd++-- | Adds the set of Posts to the indicated channel.  The Posts must+-- all be for the specified Channel.  The reqCnt argument indicates+-- how many posts were requested, which will determine whether a gap+-- message is added to either end of the posts list or not.+--+-- The addTrailingGap is only True when fetching the very latest messages+-- for the channel, and will suppress the generation of a Gap message+-- following the added block of messages.+addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd+addObtainedMessages cId reqCnt addTrailingGap posts =+  if null $ posts^.postsOrderL+  then do when addTrailingGap $+            -- Fetched at the end of the channel, but nothing was+            -- available.  This is common if this is a new channel+            -- with no messages in it.  Need to remove any gaps that+            -- exist at the end of the channel.+            csChannels %= modifyChannelById cId+              (ccContents.cdMessages %~+               \msgs -> let startPoint = join $ _mMessageId <$> getLatestPostMsg msgs+                        in fst $ removeMatchesFromSubset isGap startPoint Nothing msgs)+          return NoAction+  else+    -- Adding a block of server-provided messages, which are known to+    -- be contiguous.  Locally this may overlap with some UnknownGap+    -- messages, which can therefore be removed.  Alternatively the+    -- new block may be discontiguous with the local blocks, in which+    -- case the new block should be surrounded by UnknownGaps.+    withChannelOrDefault cId NoAction $ \chan -> do+        let pIdList = toList (posts^.postsOrderL)+            -- the first and list PostId in the batch to be added+            earliestPId = last pIdList+            latestPId = head pIdList+            earliestDate = postCreateAt $ (posts^.postsPostsL) HM.! earliestPId+            latestDate = postCreateAt $ (posts^.postsPostsL) HM.! latestPId++            localMessages = chan^.ccContents . cdMessages++            -- Get a list of the duplicated message PostIds between+            -- the messages already in the channel and the new posts+            -- to be added.++            match = snd $ removeMatchesFromSubset+                          (\m -> maybe False (\p -> p `elem` pIdList) (messagePostId m))+                          (Just (MessagePostId earliestPId))+                          (Just (MessagePostId latestPId))+                          localMessages++            accum m l =+                case messagePostId m of+                    Just pId -> pId : l+                    Nothing -> l+            dupPIds = foldr accum [] match++            -- If there were any matches, then there was overlap of+            -- the new messages with existing messages.++            -- Don't re-add matching messages (avoid overhead like+            -- re-checking/re-fetching related post information, and+            -- do not signal action needed for notifications), and+            -- remove any gaps in the overlapping region.++            newGapMessage d isOlder =+              -- newGapMessage is a helper for generating a gap+              -- message+              do uuid <- generateUUID+                 let txt = "Load " <>+                           (if isOlder then "older" else "newer") <>+                           " messages" <>+                           (if isOlder then "  ↥↥↥" else "  ↧↧↧")+                     ty = if isOlder+                          then C UnknownGapBefore+                          else C UnknownGapAfter+                 return (newMessageOfType txt ty d+                         & mMessageId .~ Just (MessageUUID uuid))++            -- If this batch contains the latest known messages, do+            -- not add a following gap.  A gap at this point is added+            -- by a websocket disconnect, and any fetches thereafter+            -- are assumed to be the most current information (until+            -- another disconnect), so no gap is needed.+            -- Additionally, the presence of a gap at the end for a+            -- connected client causes a fetch of messages at this+            -- location, so adding the gap here would cause an+            -- infinite update loop.++            addingAtEnd = maybe True (latestDate >=) $+                          (^.mDate) <$> getLatestPostMsg localMessages++            addingAtStart = maybe True (earliestDate <=) $+                            (^.mDate) <$> getEarliestPostMsg localMessages+            removeStart = if addingAtStart && noMoreBefore+                          then Nothing+                          else Just (MessagePostId earliestPId)+            removeEnd = if addTrailingGap || (addingAtEnd && noMoreAfter)+                        then Nothing+                        else Just (MessagePostId latestPId)++            noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)+            noMoreAfter = addTrailingGap || reqCnt > 0 && length pIdList < reqCnt++            reAddGapBefore = earliestPId `elem` dupPIds || noMoreBefore+            -- addingAtEnd used to be in reAddGapAfter but does not+            -- seem to be needed.  I may have missed a specific use+            -- case/scenario, so I've left it commented out here for+            -- debug assistance.+            reAddGapAfter = latestPId `elem` dupPIds || {- addingAtEnd || -} noMoreAfter++        -- The post map returned by the server will *already* have+        -- all thread messages for each post that is part of a+        -- thread. By calling installMessagesFromPosts here, we go ahead+        -- and populate the csPostMap with those posts so that below, in+        -- addMessageToState, we notice that we already know about reply+        -- parent messages and can avoid fetching them. This converts+        -- the posts to Messages and stores those and also returns+        -- them, but we don't need them here. We just want the post+        -- map update. This also gathers up the set of all mentioned+        -- usernames in the text of the messages which we need to use to+        -- submit a single batch request for user metadata so we don't+        -- submit one request per mention.+        void $ installMessagesFromPosts posts++        -- Add all the new *unique* posts into the existing channel+        -- corpus, generating needed fetches of data associated with+        -- the post, and determining an notification action to be+        -- taken (if any).+        action <- foldr andProcessWith NoAction <$>+          mapM (addMessageToState False False . OldPost)+                   [ (posts^.postsPostsL) HM.! p+                   | p <- toList (posts^.postsOrderL)+                   , not (p `elem` dupPIds)+                   ]++        -- The channel messages now include all the fetched messages.+        -- Things to do at this point are:+        --+        --   1. Remove any duplicates just added, as well as any gaps+        --   2. Add new gaps (if needed) at either end of the added+        --      messages.+        --   3. Update the "current selection" if it was on a removed message.+        --+        -- Do this with the updated copy of the channel's messages.++        withChannelOrDefault cId () $ \updchan -> do+          let updMsgs = updchan ^. ccContents . cdMessages++          -- Remove any gaps in the added region.  If there was an+          -- active message selection and it is one of the removed+          -- gaps, reset the selection to the beginning or end of the+          -- added region (if there are any added selectable messages,+          -- otherwise just the end if the message list in it's+          -- entirety, or no selection at all).++          let (resultMessages, removedMessages) =+                removeMatchesFromSubset isGap removeStart removeEnd updMsgs+          csChannels %= modifyChannelById cId+            (ccContents.cdMessages .~ resultMessages)++          -- Determine if the current selected message was one of the+          -- removed messages.++          selMsgId <- use (csMessageSelect.to selectMessageId)+          let rmvdSel = do+                i <- selMsgId -- :: Maybe MessageId+                findMessage i removedMessages+              rmvdSelType = _mType <$> rmvdSel++          case rmvdSel of+            Nothing -> return ()+            Just rm ->+              if isGap rm+              then return ()  -- handled during gap insertion below+              else do+                -- Replaced a selected message that wasn't a gap.+                -- This is unlikely, but may occur if the previously+                -- selected message was just deleted by another user+                -- and is in the fetched region.  The choices here are+                -- to move the selection, or cancel the selection.+                -- Both will be unpleasant surprises for the user, but+                -- cancelling the selection is probably the better+                -- choice than allowing the user to perform select+                -- actions on a message that isn't the one they just+                -- selected.+                setMode Main+                csMessageSelect .= MessageSelectState Nothing++          -- Add a gap at each end of the newly fetched data, unless:+          --   1. there is an overlap+          --   2. there is no more in the indicated direction+          --      a. indicated by adding messages later than any currently+          --         held messages (see note above re 'addingAtEnd').+          --      b. the amount returned was less than the amount requested++          if reAddGapBefore+            then+              -- No more gaps.  If the selected gap was removed, move+              -- select to first (earliest) message)+              case rmvdSelType of+                Just (C UnknownGapBefore) ->+                  csMessageSelect .= MessageSelectState (pure $ MessagePostId earliestPId)+                _ -> return ()+            else do+              -- add a gap at the start of the newly fetched block and+              -- make that the active selection if this fetch removed+              -- the previously selected gap in this direction.+              gapMsg <- newGapMessage (justBefore earliestDate) True+              csChannels %= modifyChannelById cId+                (ccContents.cdMessages %~ addMessage gapMsg)+              -- Move selection from old gap to new gap+              case rmvdSelType of+                Just (C UnknownGapBefore) -> do+                  csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)+                _ -> return ()++          if reAddGapAfter+            then+              -- No more gaps.  If the selected gap was removed, move+              -- select to last (latest) message.+              case rmvdSelType of+                Just (C UnknownGapAfter) ->+                  csMessageSelect .= MessageSelectState (pure $ MessagePostId latestPId)+                _ -> return ()+            else do+              -- add a gap at the end of the newly fetched block and+              -- make that the active selection if this fetch removed+              -- the previously selected gap in this direction.+              gapMsg <- newGapMessage (justAfter latestDate) False+              csChannels %= modifyChannelById cId+                (ccContents.cdMessages %~ addMessage gapMsg)+              -- Move selection from old gap to new gap+              case rmvdSelType of+                Just (C UnknownGapAfter) ->+                  csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)+                _ -> return ()++        -- Now initiate fetches for use information for any+        -- as-yet-unknown users related to this new set of messages++        let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post))+                          Set.empty (posts^.postsPostsL)+            addUnknownUsers inputUserIds = do+                knownUserIds <- Set.fromList <$> gets allUserIds+                let unknownUsers = Set.difference inputUserIds knownUserIds+                if Set.null unknownUsers+                   then return ()+                   else handleNewUsers (Seq.fromList $ toList unknownUsers) (return ())++        addUnknownUsers users++        -- Return the aggregated user notification action needed+        -- relative to the set of added messages.++        return action++-- | Adds a possibly new message to the associated channel contents.+-- Returns an indicator of whether the user should be potentially+-- notified of a change (a new message not posted by this user, a+-- mention of the user, etc.).  This operation has no effect on any+-- existing UnknownGap entries and should be called when those are+-- irrelevant.+--+-- The first boolean argument ('doFetchMentionedUsers') indicates+-- whether this function should schedule a fetch for any mentioned+-- users in the message. This is provided so that callers can batch+-- this operation if a large collection of messages is being added+-- together, in which case we don't want this function to schedule a+-- single request per message (worst case). If you're calling this as+-- part of scrollback processing, you should pass False. Otherwise if+-- you're adding only a single message, you should pass True.+--+-- The second boolean argument ('fetchAuthor') is similar to the first+-- boolean argument but it refers to the author of the message instead+-- of any user mentions within the message body.+--+-- The third argument ('newPostData') indicates whether this message+-- is being added as part of a fetch of old messages (e.g. scrollback)+-- or if ti is a new message and affects things like whether+-- notifications are generated and if the "New Messages" marker gets+-- updated.+addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd+addMessageToState doFetchMentionedUsers fetchAuthor newPostData = do+    let (new, wasMentioned) = case newPostData of+          -- A post from scrollback history has no mention data, and+          -- that's okay: we only need to track mentions to tell the+          -- user that recent posts contained mentions.+          OldPost p      -> (p, False)+          RecentPost p m -> (p, m)++    st <- use id+    case st ^? csChannel(postChannelId new) of+        Nothing -> do+            session <- getSession+            doAsyncWith Preempt $ do+                nc <- MM.mmGetChannel (postChannelId new) session+                member <- MM.mmGetChannelMember (postChannelId new) UserMe session++                let chType = nc^.channelTypeL+                    pref = showGroupChannelPref (postChannelId new) (myUserId st)++                -- If the channel has been archived, we don't want to+                -- post this message or add the channel to the state.+                case channelDeleted nc of+                    True -> return Nothing+                    False -> return $ Just $ do+                        -- If the incoming message is for a group+                        -- channel we don't know about, that's because+                        -- it was previously hidden by the user. We need+                        -- to show it, and to do that we need to update+                        -- the server-side preference. (That, in turn,+                        -- triggers a channel refresh.)+                        if chType == Group+                            then applyPreferenceChange pref+                            else refreshChannel SidebarUpdateImmediate nc member++                        addMessageToState doFetchMentionedUsers fetchAuthor newPostData >>=+                            postProcessMessageAdd++            return NoAction+        Just _ -> do+            baseUrl <- getServerBaseUrl+            let cp = toClientPost baseUrl new (new^.postRootIdL)+                fromMe = (cp^.cpUser == (Just $ myUserId st)) &&+                         (isNothing $ cp^.cpUserOverride)+                userPrefs = st^.csResources.crUserPreferences+                isJoinOrLeave = case cp^.cpType of+                  Join  -> True+                  Leave -> True+                  _     -> False+                ignoredJoinLeaveMessage =+                  not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave+                cId = postChannelId new++                doAddMessage = do+                    -- Do we have the user data for the post author?+                    case cp^.cpUser of+                        Nothing -> return ()+                        Just authorId -> when fetchAuthor $ do+                            authorResult <- gets (userById authorId)+                            when (isNothing authorResult) $+                                handleNewUsers (Seq.singleton authorId) (return ())++                    currCId <- use csCurrentChannelId+                    flags <- use (csResources.crFlaggedPosts)+                    let (msg', mentionedUsers) = clientPostToMessage cp+                                 & _1.mFlagged .~ ((cp^.cpPostId) `Set.member` flags)++                    when doFetchMentionedUsers $+                        fetchMentionedUsers mentionedUsers++                    csPostMap.at(postId new) .= Just msg'+                    mh $ invalidateCacheEntry (ChannelMessages cId)+                    csChannels %= modifyChannelById cId+                      ((ccContents.cdMessages %~ addMessage msg') .+                       (if not ignoredJoinLeaveMessage then adjustUpdated new else id) .+                       (\c -> if currCId == cId+                              then c+                              else case newPostData of+                                     OldPost _ -> c+                                     RecentPost _ _ ->+                                       updateNewMessageIndicator new c) .+                       (\c -> if wasMentioned+                              then c & ccInfo.cdMentionCount %~ succ+                              else c)+                      )+                    asyncFetchReactionsForPost cId new+                    asyncFetchAttachments new+                    postedChanMessage++                doHandleAddedMessage = do+                    -- If the message is in reply to another message,+                    -- try to find it in the scrollback for the post's+                    -- channel. If the message isn't there, fetch it. If+                    -- we have to fetch it, don't post this message to the+                    -- channel until we have fetched the parent.+                    case cp^.cpInReplyToPost of+                        Just parentId ->+                            case getMessageForPostId st parentId of+                                Nothing -> do+                                    doAsyncChannelMM Preempt cId+                                        (\s _ -> MM.mmGetThread parentId s)+                                        (\_ p -> Just $ updatePostMap p)+                                _ -> return ()+                        _ -> return ()++                    doAddMessage++                postedChanMessage =+                  withChannelOrDefault (postChannelId new) NoAction $ \chan -> do+                      currCId <- use csCurrentChannelId++                      let notifyPref = notifyPreference (myUser st) chan+                          curChannelAction = if postChannelId new == currCId+                                             then UpdateServerViewed+                                             else NoAction+                          originUserAction =+                            if | fromMe                            -> NoAction+                               | ignoredJoinLeaveMessage           -> NoAction+                               | notifyPref == NotifyOptionAll     -> NotifyUser [newPostData]+                               | notifyPref == NotifyOptionMention+                                   && wasMentioned                 -> NotifyUser [newPostData]+                               | otherwise                         -> NoAction++                      return $ curChannelAction `andProcessWith` originUserAction++            doHandleAddedMessage++-- | PostProcessMessageAdd is an internal value that informs the main+-- code whether the user should be notified (e.g., ring the bell) or+-- the server should be updated (e.g., that the channel has been+-- viewed).  This is a monoid so that it can be folded over when there+-- are multiple inbound posts to be processed.+data PostProcessMessageAdd = NoAction+                           | NotifyUser [PostToAdd]+                           | UpdateServerViewed+                           | NotifyUserAndServer [PostToAdd]++andProcessWith+  :: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd+andProcessWith NoAction x                                        = x+andProcessWith x NoAction                                        = x+andProcessWith (NotifyUserAndServer p) UpdateServerViewed        = NotifyUserAndServer p+andProcessWith (NotifyUserAndServer p1) (NotifyUser p2)          = NotifyUserAndServer (p1 <> p2)+andProcessWith (NotifyUserAndServer p1) (NotifyUserAndServer p2) = NotifyUserAndServer (p1 <> p2)+andProcessWith (NotifyUser p1) (NotifyUserAndServer p2)          = NotifyUser (p1 <> p2)+andProcessWith (NotifyUser p1) (NotifyUser p2)                   = NotifyUser (p1 <> p2)+andProcessWith (NotifyUser p) UpdateServerViewed                 = NotifyUserAndServer p+andProcessWith UpdateServerViewed UpdateServerViewed             = UpdateServerViewed+andProcessWith UpdateServerViewed (NotifyUserAndServer p)        = NotifyUserAndServer p+andProcessWith UpdateServerViewed (NotifyUser p)                 = NotifyUserAndServer p++-- | postProcessMessageAdd performs the actual actions indicated by+-- the corresponding input value.+postProcessMessageAdd :: PostProcessMessageAdd -> MH ()+postProcessMessageAdd ppma = postOp ppma+    where+        postOp NoAction                = return ()+        postOp UpdateServerViewed      = updateViewed False+        postOp (NotifyUser p)          = maybeRingBell >> mapM_ maybeNotify p+        postOp (NotifyUserAndServer p) = updateViewed False >> maybeRingBell >> mapM_ maybeNotify p++maybeNotify :: PostToAdd -> MH ()+maybeNotify (OldPost _) = do+    return ()+maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned++maybeRingBell :: MH ()+maybeRingBell = do+    doBell <- use (csResources.crConfiguration.to configActivityBell)+    when doBell $ do+        vty <- mh getVtyHandle+        liftIO $ ringTerminalBell $ outputIface vty++-- | When we add posts to the application state, we either get them+-- from the server during scrollback fetches (here called 'OldPost') or+-- we get them from websocket events when they are posted in real time+-- (here called 'RecentPost').+data PostToAdd =+    OldPost Post+    -- ^ A post from the server's history+    | RecentPost Post Bool+    -- ^ A message posted to the channel since the user connected, along+    -- with a flag indicating whether the post triggered any of the+    -- user's mentions. We need an extra flag because the server+    -- determines whether the post has any mentions, and that data is+    -- only available in websocket events (and then provided to this+    -- constructor).++runNotifyCommand :: Post -> Bool -> MH ()+runNotifyCommand post mentioned = do+    outputChan <- use (csResources.crSubprocessLog)+    st <- use id+    notifyCommand <- use (csResources.crConfiguration.to configActivityNotifyCommand)+    case notifyCommand of+        Nothing -> return ()+        Just cmd ->+            doAsyncWith Preempt $ do+                let messageString = T.unpack $ sanitizeUserText $ postMessage post+                    notified = if mentioned then "1" else "2"+                    sender = T.unpack $ maybePostUsername st post+                runLoggedCommand outputChan (T.unpack cmd)+                                 [notified, sender, messageString] Nothing Nothing+                return Nothing++maybePostUsername :: ChatState -> Post -> T.Text+maybePostUsername st p =+    fromMaybe T.empty $ do+        uId <- postUserId p+        usernameForUserId uId st++-- | Fetches additional message history for the current channel.  This+-- is generally called when in ChannelScroll mode, in which state the+-- output is cached and seen via a scrolling viewport; new messages+-- received in this mode are not normally shown, but this explicit+-- user-driven fetch should be displayed, so this also invalidates the+-- cache.+--+-- This function assumes it is being called to add "older" messages to+-- the message history (i.e. near the beginning of the known+-- messages).  It will normally try to overlap the fetch with the+-- known existing messages so that when the fetch results are+-- processed (which should be a contiguous set of messages as provided+-- by the server) there will be an overlap with existing messages; if+-- there is no overlap, then a special "gap" must be inserted in the+-- area between the existing messages and the newly fetched messages+-- to indicate that this client does not know if there are missing+-- messages there or not.+--+-- In order to achieve an overlap, this code attempts to get the+-- second oldest messages as the message ID to pass to the server as+-- the "older than" marker ('postQueryBefore'), so that the oldest+-- message here overlaps with the fetched results to ensure no gap+-- needs to be inserted.  However, there may already be a gap between+-- the oldest and second-oldest messages, so this code must actually+-- search for the first set of two *contiguous* messages it is aware+-- of to avoid adding additional gaps. (It's OK if gaps are added, but+-- the user must explicitly request a check for messages in order to+-- eliminate them, so it's better to avoid adding them in the first+-- place).  This code is nearly always used to extend the older+-- history of a channel that information has already been retrieved+-- from, so it's almost certain that there are at least two contiguous+-- messages to use as a starting point, but exceptions are new+-- channels and empty channels.+asyncFetchMoreMessages :: MH ()+asyncFetchMoreMessages = do+    cId  <- use csCurrentChannelId+    withChannel cId $ \chan ->+        let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2+            page = offset `div` pageAmount+            usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages)+            sndOldestId = (messagePostId . snd) =<< usefulMsgs+            query = MM.defaultPostQuery+                      { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId+                      , MM.postQueryPerPage = Just pageAmount+                      , MM.postQueryBefore = sndOldestId+                      }+            addTrailingGap = MM.postQueryBefore query == Nothing &&+                             MM.postQueryPage query == Just 0+        in doAsyncChannelMM Preempt cId+               (\s c -> MM.mmGetPostsForChannel c query s)+               (\c p -> Just $ do+                   pp <- addObtainedMessages c (-pageAmount) addTrailingGap p+                   postProcessMessageAdd pp+                   mh $ invalidateCacheEntry (ChannelMessages cId))+++-- | Given a starting point and a direction to move from that point,+-- returns the closest two adjacent messages on that direction (as a+-- tuple of closest and next-closest), or Nothing if there are no+-- adjacent messages in the indicated direction.+getTwoContiguousPosts :: SeqDirection dir =>+                         Maybe Message+                      -> DirectionalSeq dir Message+                      -> Maybe (Message, Message)+getTwoContiguousPosts startMsg msgs =+  let go start =+        do anchor <- getRelMessageId (_mMessageId =<< start) msgs+           hinge <- getRelMessageId (anchor^.mMessageId) msgs+           if isGap anchor || isGap hinge+             then go $ Just anchor+             else Just (anchor, hinge)+  in go startMsg+++asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()+asyncFetchMessagesForGap cId gapMessage =+  when (isGap gapMessage) $+  withChannel cId $ \chan ->+    let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2+        page = offset `div` pageAmount+        chanMsgs = chan^.ccContents.cdMessages+        fromMsg = Just gapMessage+        fetchNewer = case gapMessage^.mType of+                       C UnknownGapAfter -> True+                       C UnknownGapBefore -> False+                       _ -> error "fetch gap messages: unknown gap message type"+        baseId = messagePostId . snd =<<+                 case gapMessage^.mType of+                    C UnknownGapAfter -> getTwoContiguousPosts fromMsg $+                                         reverseMessages chanMsgs+                    C UnknownGapBefore -> getTwoContiguousPosts fromMsg chanMsgs+                    _ -> error "fetch gap messages: unknown gap message type"+        query = MM.defaultPostQuery+                { MM.postQueryPage = maybe (Just page) (const Nothing) baseId+                , MM.postQueryPerPage = Just pageAmount+                , MM.postQueryBefore = if fetchNewer then Nothing else baseId+                , MM.postQueryAfter = if fetchNewer then baseId else Nothing+                }+        addTrailingGap = MM.postQueryBefore query == Nothing &&+                         MM.postQueryPage query == Just 0+    in doAsyncChannelMM Preempt cId+       (\s c -> MM.mmGetPostsForChannel c query s)+       (\c p -> Just $ do+           void $ addObtainedMessages c (-pageAmount) addTrailingGap p+           mh $ invalidateCacheEntry (ChannelMessages cId))++-- | Given a particular message ID, this fetches n messages before and+-- after immediately before and after the specified message in order+-- to establish some context for that message.  This is frequently+-- used as a background operation when looking at search or flag+-- results so that jumping to message select mode for one of those+-- messages will show a bit of context (and it also prevents showing+-- gap messages for adjacent targets).+--+-- The result will be adding at most 2n messages to the channel, with+-- the input post ID being somewhere in the middle of the added+-- messages.+--+-- Note that this fetch will add messages to the channel, but it+-- performs no notifications or updates of new-unread indicators+-- because it is assumed to be used for non-current (previously-seen)+-- messages in background mode.+asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH ()+asyncFetchMessagesSurrounding cId pId = do+    let query = MM.defaultPostQuery+          { MM.postQueryBefore = Just pId+          , MM.postQueryPerPage = Just reqAmt+          }+        reqAmt = 5  -- both before and after+    doAsyncChannelMM Preempt cId+      -- first get some messages before the target, no overlap+      (\s c -> MM.mmGetPostsForChannel c query s)+      (\c p -> Just $ do+          let last2ndId = secondToLastPostId p+          void $ addObtainedMessages c (-reqAmt) False p+          mh $ invalidateCacheEntry (ChannelMessages cId)+          -- now start 2nd from end of this fetch to fetch some+          -- messages forward, also overlapping with this fetch and+          -- the original message ID to eliminate all gaps in this+          -- surrounding set of messages.+          let query' = MM.defaultPostQuery+                       { MM.postQueryAfter = last2ndId+                       , MM.postQueryPerPage = Just $ reqAmt + 2+                       }+          doAsyncChannelMM Preempt cId+            (\s' c' -> MM.mmGetPostsForChannel c' query' s')+            (\c' p' -> Just $ do+                void $ addObtainedMessages c' (reqAmt + 2) False p'+                mh $ invalidateCacheEntry (ChannelMessages cId)+            )+      )+      where secondToLastPostId posts =+              let pl = toList $ postsOrder posts+              in if length pl > 1 then Just $ last $ init pl else Nothing+++fetchVisibleIfNeeded :: MH ()+fetchVisibleIfNeeded = do+    sts <- use csConnectionStatus+    when (sts == Connected) $ do+        cId <- use csCurrentChannelId+        withChannel cId $ \chan ->+            let msgs = chan^.ccContents.cdMessages.to reverseMessages+                (numRemaining, gapInDisplayable, _, rel'pId, overlap) =+                    foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs+                gapTrail a@(_,  True, _, _, _) _ = a+                gapTrail a@(0,     _, _, _, _) _ = a+                gapTrail   (a, False, b, c, d) m | isGap m = (a, True, b, c, d)+                gapTrail (remCnt, _, prev'pId, prev''pId, ovl) msg =+                    (remCnt - 1, False, msg^.mMessageId <|> prev'pId, prev'pId <|> prev''pId,+                     ovl + if not (isPostMessage msg) then 1 else 0)+                numToReq = numRemaining + overlap+                query = MM.defaultPostQuery+                        { MM.postQueryPage    = Just 0+                        , MM.postQueryPerPage = Just numToReq+                        }+                finalQuery = case rel'pId of+                               Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid }+                               _ -> query+                op = \s c -> MM.mmGetPostsForChannel c finalQuery s+                addTrailingGap = MM.postQueryBefore finalQuery == Nothing &&+                                 MM.postQueryPage finalQuery == Just 0+            in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do+                      csChannel(cId).ccContents.cdFetchPending .= True+                      doAsyncChannelMM Preempt cId op+                          (\c p -> Just $ do+                              addObtainedMessages c (-numToReq) addTrailingGap p >>= postProcessMessageAdd+                              csChannel(c).ccContents.cdFetchPending .= False)++asyncFetchAttachments :: Post -> MH ()+asyncFetchAttachments p = do+    let cId = p^.postChannelIdL+        pId = p^.postIdL+    session <- getSession+    host <- use (csResources.crConn.cdHostnameL)+    F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do+        info <- MM.mmGetMetadataForFile fId session+        let scheme = "https://"+            attUrl = scheme <> host <> urlForFile fId+            attachment = mkAttachment (fileInfoName info) attUrl fId+            addIfMissing a as =+                if isNothing $ Seq.elemIndexL a as+                then a Seq.<| as+                else as+            addAttachment m+                | m^.mMessageId == Just (MessagePostId pId) =+                    m & mAttachments %~ (addIfMissing attachment)+                | otherwise =+                    m+        return $ Just $ do+            csChannel(cId).ccContents.cdMessages.traversed %= addAttachment+            mh $ invalidateCacheEntry $ ChannelMessages cId++-- | Given a post ID, switch to that post's channel and select the post+-- in message selection mode.+--+-- This function will do what it can to honor the request even when we+-- don't know about the post because it hasn't been fetched, or when+-- the post is in a channel that we aren't a member of. In each case a+-- reasonable effort will be made (fetch the post, join the channel)+-- before giving up.+jumpToPost :: PostId -> MH ()+jumpToPost pId = do+    st <- use id+    case getMessageForPostId st pId of+      Just msg ->+        case msg ^. mChannelId of+          Just cId -> do+              -- Are we a member of the channel?+              case findChannelById cId (st^.csChannels) of+                  Nothing ->+                      joinChannel' cId (Just $ jumpToPost pId)+                  Just _ -> do+                      setFocus cId+                      setMode MessageSelect+                      csMessageSelect .= MessageSelectState (msg^.mMessageId)+          Nothing ->+            error "INTERNAL: selected Post ID not associated with a channel"+      Nothing -> do+          session <- getSession+          doAsyncWith Preempt $ do+              result <- try $ MM.mmGetPost pId session+              return $ Just $ do+                  case result of+                      Right p -> do+                          -- Are we a member of the channel?+                          case findChannelById (postChannelId p) (st^.csChannels) of+                              -- If not, join it and then try jumping to+                              -- the post if the channel join is successful.+                              Nothing -> do+                                  joinChannel' (postChannelId p) (Just $ jumpToPost pId)+                              -- Otherwise add the post to the state and+                              -- then jump.+                              Just _ -> do+                                  void $ addMessageToState True True (OldPost p)+                                  jumpToPost pId+                      Left (_::SomeException) ->+                          postErrorMessage' "Could not fetch linked post"
+ src/Matterhorn/State/Messages.hs-boot view
@@ -0,0 +1,11 @@+module Matterhorn.State.Messages+  ( fetchVisibleIfNeeded+  )+where++import Matterhorn.Types ( MH )++-- State.Channels needs this in setFocusWith, but that creates an+-- import cycle because several things in State.Messages need things in+-- State.Channels.+fetchVisibleIfNeeded :: MH ()
+ src/Matterhorn/State/NotifyPrefs.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+module Matterhorn.State.NotifyPrefs+    ( enterEditNotifyPrefsMode+    , exitEditNotifyPrefsMode+    )+where++import Prelude ()+import Matterhorn.Prelude++import Network.Mattermost.Types ( ChannelNotifyProps+                                , User(..)+                                , UserNotifyProps(..)+                                , Type(..)+                                , channelNotifyPropsMarkUnread+                                , channelNotifyPropsIgnoreChannelMentions+                                , WithDefault(..)+                                , NotifyOption(..)+                                )++import Brick+import Brick.Forms+import Lens.Micro.Platform ( Lens', (.=), lens )++import Matterhorn.Types+++muteLens :: Lens' ChannelNotifyProps Bool+muteLens = lens (\props -> props^.channelNotifyPropsMarkUnreadL == IsValue NotifyOptionMention)+           (\props muted -> props { channelNotifyPropsMarkUnread =+                                          if muted+                                          then IsValue NotifyOptionMention+                                          else IsValue NotifyOptionAll+                                  })++channelMentionLens :: Lens' ChannelNotifyProps Bool+channelMentionLens = lens (\props -> props^.channelNotifyPropsIgnoreChannelMentionsL == IsValue True)+                     (\props ignoreChannelMentions ->+                          props { channelNotifyPropsIgnoreChannelMentions = if ignoreChannelMentions+                                                                            then IsValue True+                                                                            else Default+                                })++notifyOptionName :: NotifyOption -> Text+notifyOptionName NotifyOptionAll = "All activity"+notifyOptionName NotifyOptionMention = "Mentions"+notifyOptionName NotifyOptionNone = "Never"++mkNotifyButtons :: ((WithDefault NotifyOption) -> Name)+                -> Lens' ChannelNotifyProps (WithDefault NotifyOption)+                -> NotifyOption+                -> ChannelNotifyProps+                -> FormFieldState ChannelNotifyProps e Name+mkNotifyButtons mkName l globalDefault =+    let optTuple opt = (IsValue opt, mkName $ IsValue opt, notifyOptionName opt)+        defaultField = (Default, mkName Default, "Global default (" <> notifyOptionName globalDefault <> ")")+        nonDefault = optTuple <$> [ NotifyOptionAll+                                  , NotifyOptionMention+                                  , NotifyOptionNone+                                  ]+    in radioField l (defaultField : nonDefault)++notifyPrefsForm :: UserNotifyProps -> ChannelNotifyProps -> Form ChannelNotifyProps e Name+notifyPrefsForm globalDefaults =+    newForm [ checkboxField muteLens MuteToggleField "Mute channel"+            , (padTop $ Pad 1) @@= checkboxField channelMentionLens ChannelMentionsField "Ignore channel mentions"+            , radioStyle "Desktop notifications" @@=+                mkNotifyButtons DesktopNotificationsField channelNotifyPropsDesktopL (userNotifyPropsDesktop globalDefaults)+            , radioStyle "Push notifications" @@=+                mkNotifyButtons PushNotificationsField channelNotifyPropsPushL (userNotifyPropsPush globalDefaults)+            ]+    where radioStyle label = (padTop $ Pad 1 ) . (str label <=>) . (padLeft $ Pad 1)++enterEditNotifyPrefsMode :: MH ()+enterEditNotifyPrefsMode = do+    chanInfo <- use (csCurrentChannel.ccInfo)+    case chanInfo^.cdType of+      Direct -> mhError $ GenericError "Cannot open notification preferences for DM channel."+      _ -> do+        let props = chanInfo^.cdNotifyProps+        user <- use csMe+        csNotifyPrefs .= (Just (notifyPrefsForm (userNotifyProps user) props))+        setMode EditNotifyPrefs++exitEditNotifyPrefsMode :: MH ()+exitEditNotifyPrefsMode = do+    setMode Main
+ src/Matterhorn/State/PostListOverlay.hs view
@@ -0,0 +1,148 @@+module Matterhorn.State.PostListOverlay+  ( enterFlaggedPostListMode+  , enterPinnedPostListMode+  , enterSearchResultPostListMode+  , postListJumpToCurrent+  , postListSelectUp+  , postListSelectDown+  , postListUnflagSelected+  , exitPostListMode+  )+where++import           GHC.Exts ( IsList(..) )+import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Foldable as F+import qualified Data.Text as T+import           Lens.Micro.Platform ( (.=) )+import           Network.Mattermost.Endpoints+import           Network.Mattermost.Types++import           Matterhorn.State.Messages ( jumpToPost )+import           Matterhorn.State.Common+import           Matterhorn.State.MessageSelect+import           Matterhorn.State.Messages ( addObtainedMessages+                                           , asyncFetchMessagesSurrounding )+import           Matterhorn.Types+import           Matterhorn.Types.DirectionalSeq (emptyDirSeq)+++-- | Create a PostListOverlay with the given content description and+-- with a specified list of messages.+enterPostListMode ::  PostListContents -> Messages -> MH ()+enterPostListMode contents msgs = do+  csPostListOverlay.postListPosts .= msgs+  let mlatest = getLatestPostMsg msgs+      pId = mlatest >>= messagePostId+      cId = mlatest >>= \m -> m^.mChannelId+  csPostListOverlay.postListSelected .= pId+  setMode $ PostListOverlay contents+  case (pId, cId) of+    (Just p, Just c) -> asyncFetchMessagesSurrounding c p+    _ -> return ()++-- | Clear out the state of a PostListOverlay+exitPostListMode :: MH ()+exitPostListMode = do+  csPostListOverlay.postListPosts .= emptyDirSeq+  csPostListOverlay.postListSelected .= Nothing+  setMode Main+++createPostList :: PostListContents -> (Session -> IO Posts) -> MH ()+createPostList contentsType fetchOp = do+  session <- getSession+  doAsyncWith Preempt $ do+    posts <- fetchOp session+    return $ Just $ do+      messages <- installMessagesFromPosts posts+      -- n.b. do not use addNewPostedMessage because these messages+      -- are not new, and so no notifications or channel highlighting+      -- or other post-processing should be performed.+      let plist = F.toList $ postsPosts posts+          postsSpec p = Posts { postsPosts = fromList [(postId p, p)]+                              , postsOrder = fromList [postId p]+                              }+      mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist+      enterPostListMode contentsType messages+++-- | Create a PostListOverlay with flagged messages from the server.+enterFlaggedPostListMode :: MH ()+enterFlaggedPostListMode = createPostList PostListFlagged $+                           mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery++-- | Create a PostListOverlay with pinned messages from the server for+-- the current channel.+enterPinnedPostListMode :: MH ()+enterPinnedPostListMode = do+    cId <- use csCurrentChannelId+    createPostList (PostListPinned cId) $ mmGetChannelPinnedPosts cId++-- | Create a PostListOverlay with post search result messages from the+-- server.+enterSearchResultPostListMode :: Text -> MH ()+enterSearchResultPostListMode terms+  | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term."+  | otherwise = do+      enterPostListMode (PostListSearch terms True) noMessages+      tId <- gets myTeamId+      createPostList (PostListSearch terms False) $+        mmSearchForTeamPosts tId (SearchPosts terms False)+++-- | Move the selection up in the PostListOverlay, which corresponds+-- to finding a chronologically /newer/ message.+postListSelectUp :: MH ()+postListSelectUp = do+  selId <- use (csPostListOverlay.postListSelected)+  posts <- use (csPostListOverlay.postListPosts)+  let nextMsg = getNextMessage (MessagePostId <$> selId) posts+  case nextMsg of+    Nothing -> return ()+    Just m -> do+      let pId = m^.mMessageId >>= messageIdPostId+      csPostListOverlay.postListSelected .= pId+      case (m^.mChannelId, pId) of+        (Just c, Just p) -> asyncFetchMessagesSurrounding c p+        o -> mhLog LogError+             (T.pack $ "postListSelectUp" <>+              " unable to get channel or post ID: " <> show o)++-- | Move the selection down in the PostListOverlay, which corresponds+-- to finding a chronologically /old/ message.+postListSelectDown :: MH ()+postListSelectDown = do+  selId <- use (csPostListOverlay.postListSelected)+  posts <- use (csPostListOverlay.postListPosts)+  let prevMsg = getPrevMessage (MessagePostId <$> selId) posts+  case prevMsg of+    Nothing -> return ()+    Just m -> do+      let pId = m^.mMessageId >>= messageIdPostId+      csPostListOverlay.postListSelected .= pId+      case (m^.mChannelId, pId) of+        (Just c, Just p) -> asyncFetchMessagesSurrounding c p+        o -> mhLog LogError+             (T.pack $ "postListSelectDown" <>+              " unable to get channel or post ID: " <> show o)++-- | Unflag the post currently selected in the PostListOverlay, if any+postListUnflagSelected :: MH ()+postListUnflagSelected = do+  msgId <- use (csPostListOverlay.postListSelected)+  case msgId of+    Nothing  -> return ()+    Just pId -> flagMessage pId False+++-- | Jumps to the specified message in the message's main channel+-- display and changes to MessageSelectState.+postListJumpToCurrent :: MH ()+postListJumpToCurrent = do+  msgId <- use (csPostListOverlay.postListSelected)+  case msgId of+    Nothing  -> return ()+    Just pId -> jumpToPost pId
+ src/Matterhorn/State/ReactionEmojiListOverlay.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE TupleSections #-}+module Matterhorn.State.ReactionEmojiListOverlay+  ( enterReactionEmojiListOverlayMode++  , reactionEmojiListSelectDown+  , reactionEmojiListSelectUp+  , reactionEmojiListPageDown+  , reactionEmojiListPageUp+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Data.Vector as Vec+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.Set as Set+import           Data.Function ( on )+import           Data.List ( nubBy )+import           Lens.Micro.Platform ( to )++import           Network.Mattermost.Types+import           Network.Mattermost.Endpoints ( mmPostReaction, mmDeleteReaction )++import           Matterhorn.Emoji+import           Matterhorn.State.ListOverlay+import           Matterhorn.State.MessageSelect+import           Matterhorn.State.Async+import           Matterhorn.Types+++enterReactionEmojiListOverlayMode :: MH ()+enterReactionEmojiListOverlayMode = do+    selectedMessage <- use (to getSelectedMessage)+    case selectedMessage of+        Nothing -> return ()+        Just msg -> do+            em <- use (csResources.crEmoji)+            myId <- gets myUserId+            enterListOverlayMode csReactionEmojiListOverlay ReactionEmojiListOverlay+                () enterHandler (fetchResults myId msg em)++enterHandler :: (Bool, T.Text) -> MH Bool+enterHandler (mine, e) = do+    session <- getSession+    myId <- gets myUserId++    selectedMessage <- use (to getSelectedMessage)+    case selectedMessage of+        Nothing -> return False+        Just m -> do+            case m^.mOriginalPost of+                Nothing -> return False+                Just p -> do+                    case mine of+                        False ->+                            doAsyncWith Preempt $ do+                                mmPostReaction (postId p) myId e session+                                return Nothing+                        True ->+                            doAsyncWith Preempt $ do+                                mmDeleteReaction (postId p) myId e session+                                return Nothing+                    return True++fetchResults :: UserId+             -- ^ My user ID, so we can see which reactions I haven't+             -- posted+             -> Message+             -- ^ The selected message, so we can include its current+             -- reactions in the list+             -> EmojiCollection+             -- ^ The emoji collection+             -> ()+             -- ^ The scope to search+             -> Session+             -- ^ The connection session+             -> Text+             -- ^ The search string+             -> IO (Vec.Vector (Bool, T.Text))+fetchResults myId msg em () session searchString = do+    let currentReactions = [ (myId `Set.member` uIds, k)+                           | (k, uIds) <- M.toList (msg^.mReactions)+                           ]+        matchingCurrentOtherReactions = [ (mine, r) | (mine, r) <- currentReactions+                                        , matchesEmoji searchString r+                                        , not mine+                                        ]+        matchingCurrentMyReactions = [ (mine, r) | (mine, r) <- currentReactions+                                     , matchesEmoji searchString r+                                     , mine+                                     ]+    serverMatches <- getMatchingEmoji session em searchString+    return $ Vec.fromList $ nubBy ((==) `on` snd) $+        matchingCurrentOtherReactions <> matchingCurrentMyReactions <> ((False,) <$> serverMatches)++-- | Move the selection up in the emoji list overlay by one emoji.+reactionEmojiListSelectUp :: MH ()+reactionEmojiListSelectUp = reactionEmojiListMove L.listMoveUp++-- | Move the selection down in the emoji list overlay by one emoji.+reactionEmojiListSelectDown :: MH ()+reactionEmojiListSelectDown = reactionEmojiListMove L.listMoveDown++-- | Move the selection up in the emoji list overlay by a page of emoji+-- (ReactionEmojiListPageSize).+reactionEmojiListPageUp :: MH ()+reactionEmojiListPageUp = reactionEmojiListMove (L.listMoveBy (-1 * reactionEmojiListPageSize))++-- | Move the selection down in the emoji list overlay by a page of emoji+-- (ReactionEmojiListPageSize).+reactionEmojiListPageDown :: MH ()+reactionEmojiListPageDown = reactionEmojiListMove (L.listMoveBy reactionEmojiListPageSize)++-- | Transform the emoji list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+reactionEmojiListMove :: (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH ()+reactionEmojiListMove = listOverlayMove csReactionEmojiListOverlay++-- | The number of emoji in a "page" for cursor movement purposes.+reactionEmojiListPageSize :: Int+reactionEmojiListPageSize = 10
+ src/Matterhorn/State/Reactions.hs view
@@ -0,0 +1,52 @@+module Matterhorn.State.Reactions+  ( asyncFetchReactionsForPost+  , addReactions+  , removeReaction+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Main ( invalidateCacheEntry )+import qualified Data.Map.Strict as Map+import           Lens.Micro.Platform+import qualified Data.Set as S++import           Network.Mattermost.Endpoints+import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.State.Async+import           Matterhorn.State.Common ( fetchMentionedUsers )+import           Matterhorn.Types+++asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()+asyncFetchReactionsForPost cId p+  | not (p^.postHasReactionsL) = return ()+  | otherwise = doAsyncChannelMM Normal cId+        (\s _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s))+        (\_ rs -> Just $ addReactions cId rs)++addReactions :: ChannelId -> [Reaction] -> MH ()+addReactions cId rs = do+    mh $ invalidateCacheEntry $ ChannelMessages cId+    csChannel(cId).ccContents.cdMessages %= fmap upd+    let mentions = S.fromList $ UserIdMention <$> reactionUserId <$> rs+    fetchMentionedUsers mentions+  where upd msg = msg & mReactions %~ insertAll (msg^.mMessageId)+        insert mId r+          | mId == Just (MessagePostId (r^.reactionPostIdL)) =+              Map.insertWith S.union (r^.reactionEmojiNameL) (S.singleton $ r^.reactionUserIdL)+          | otherwise = id+        insertAll mId msg = foldr (insert mId) msg rs++removeReaction :: Reaction -> ChannelId -> MH ()+removeReaction r cId = do+    mh $ invalidateCacheEntry $ ChannelMessages cId+    csChannel(cId).ccContents.cdMessages %= fmap upd+  where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) =+                  m & mReactions %~ (Map.alter delReaction (r^.reactionEmojiNameL))+              | otherwise = m+        delReaction mUs = S.delete (r^.reactionUserIdL) <$> mUs
+ src/Matterhorn/State/Setup.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE TypeFamilies #-}+module Matterhorn.State.Setup+  ( setupState+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.BChan ( newBChan )+import           Brick.Themes ( themeToAttrMap, loadCustomizations )+import qualified Control.Concurrent.STM as STM+import           Data.Maybe ( fromJust )+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time.Clock ( getCurrentTime )+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( (.~) )+import           System.Exit ( exitFailure, exitSuccess )+import           System.FilePath ( (</>), isRelative, dropFileName )++import           Network.Mattermost.Endpoints+import           Network.Mattermost.Types++import           Matterhorn.Config+import           Matterhorn.InputHistory+import           Matterhorn.LastRunState+import           Matterhorn.Login+import           Matterhorn.State.Flagging+import           Matterhorn.State.Messages ( fetchVisibleIfNeeded )+import           Matterhorn.State.Setup.Threads+import           Matterhorn.TeamSelect+import           Matterhorn.Themes+import           Matterhorn.TimeUtils ( lookupLocalTimeZone )+import           Matterhorn.Types+import           Matterhorn.Types.Common+import           Matterhorn.Emoji+import           Matterhorn.FilePaths ( userEmojiJsonPath, bundledEmojiJsonPath )+import qualified Matterhorn.Zipper as Z+++incompleteCredentials :: Config -> ConnectionInfo+incompleteCredentials config = ConnectionInfo+  { _ciHostname = fromMaybe "" (configHost config)+  , _ciPort     = configPort config+  , _ciUrlPath  = fromMaybe "" (configUrlPath config)+  , _ciUsername = fromMaybe "" (configUser config)+  , _ciPassword = case configPass config of+                    Just (PasswordString s) -> s+                    _                       -> ""+  , _ciAccessToken = case configToken config of+                       Just (TokenString s) -> s+                       _                    -> ""+  , _ciType     = configConnectionType config+  }++apiLogEventToLogMessage :: LogEvent -> IO LogMessage+apiLogEventToLogMessage ev = do+    now <- getCurrentTime+    let msg = T.pack $ "Function: " <> logFunction ev <>+                       ", event: " <> show (logEventType ev)+    return $ LogMessage { logMessageCategory = LogAPI+                        , logMessageText = msg+                        , logMessageContext = Nothing+                        , logMessageTimestamp = now+                        }++setupState :: IO Vty.Vty -> Maybe FilePath -> Config -> IO (ChatState, Vty.Vty)+setupState mkVty mLogLocation config = do+  initialVty <- mkVty++  eventChan <- newBChan 2500+  logMgr <- newLogManager eventChan (configLogMaxBufferSize config)++  -- If we got an initial log location, start logging there.+  case mLogLocation of+      Nothing -> return ()+      Just loc -> startLoggingToFile logMgr loc++  let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr+      setLogger cd = cd `withLogger` logApiEvent++  (mLastAttempt, loginVty) <- interactiveGetLoginSession initialVty mkVty+                                                         setLogger+                                                         logMgr+                                                         (incompleteCredentials config)++  let shutdown vty = do+          Vty.shutdown vty+          exitSuccess++  (session, me, cd, mbTeam) <- case mLastAttempt of+      Nothing ->+          -- The user never attempted a connection and just chose to+          -- quit.+          shutdown loginVty+      Just (AttemptFailed {}) ->+          -- The user attempted a connection and failed, and then chose+          -- to quit.+          shutdown loginVty+      Just (AttemptSucceeded _ cd sess user mbTeam) ->+          -- The user attempted a connection and succeeded so continue+          -- with setup.+          return (sess, user, cd, mbTeam)++  teams <- mmGetUsersTeams UserMe session+  when (Seq.null teams) $ do+      putStrLn "Error: your account is not a member of any teams"+      exitFailure++  (myTeam, teamSelVty) <- do+      let foundTeam = do+             tName <- mbTeam <|> configTeam config+             let matchingTeam = listToMaybe $ filter matches $ toList teams+                 matches t = (sanitizeUserText $ teamName t) == tName+             matchingTeam++      case foundTeam of+          Just t -> return (t, loginVty)+          Nothing -> do+              (mTeam, vty) <- interactiveTeamSelection loginVty mkVty $ toList teams+              case mTeam of+                  Nothing -> shutdown vty+                  Just team -> return (team, vty)++  userStatusChan <- STM.newTChanIO+  slc <- STM.newTChanIO+  wac <- STM.newTChanIO++  prefs <- mmGetUsersPreferences UserMe session+  let userPrefs = setUserPreferences prefs defaultUserPreferences+      themeName = case configTheme config of+          Nothing -> internalThemeName defaultTheme+          Just t -> t+      baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName)++  -- Did the configuration specify a theme customization file? If so,+  -- load it and customize the theme.+  custTheme <- case configThemeCustomizationFile config of+      Nothing -> return baseTheme+      Just path ->+          -- If we have no configuration path (i.e. we used the default+          -- config) then ignore theme customization.+          let pathStr = T.unpack path+          in if isRelative pathStr && isNothing (configAbsPath config)+             then return baseTheme+             else do+                 let absPath = if isRelative pathStr+                               then (dropFileName $ fromJust $ configAbsPath config) </> pathStr+                               else pathStr+                 result <- loadCustomizations absPath baseTheme+                 case result of+                     Left e -> do+                         Vty.shutdown teamSelVty+                         putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e+                         exitFailure+                     Right t -> return t++  requestChan <- STM.atomically STM.newTChan++  emoji <- either (const emptyEmojiCollection) id <$> do+      result1 <- loadEmoji =<< userEmojiJsonPath+      case result1 of+          Right e -> return $ Right e+          Left _ -> loadEmoji =<< bundledEmojiJsonPath++  let cr = ChatResources { _crSession             = session+                         , _crWebsocketThreadId   = Nothing+                         , _crConn                = cd+                         , _crRequestQueue        = requestChan+                         , _crEventQueue          = eventChan+                         , _crSubprocessLog       = slc+                         , _crWebsocketActionChan = wac+                         , _crTheme               = themeToAttrMap custTheme+                         , _crStatusUpdateChan    = userStatusChan+                         , _crConfiguration       = config+                         , _crFlaggedPosts        = mempty+                         , _crUserPreferences     = userPrefs+                         , _crSyntaxMap           = mempty+                         , _crLogManager          = logMgr+                         , _crEmoji               = emoji+                         }++  st <- initializeState cr myTeam me++  return (st, teamSelVty)++initializeState :: ChatResources -> Team -> User -> IO ChatState+initializeState cr myTeam me = do+  let session = getResourceSession cr+      requestChan = cr^.crRequestQueue+      myTId = getId myTeam++  -- Create a predicate to find the last selected channel by reading the+  -- run state file. If unable to read or decode or validate the file, this+  -- predicate is just `isTownSquare`.+  isLastSelectedChannel <- do+    result <- readLastRunState $ teamId myTeam+    case result of+      Right lrs | isValidLastRunState cr me lrs -> return $ \c ->+           channelId c == lrs^.lrsSelectedChannelId+      _ -> return isTownSquare++  -- Get all channels, but filter down to just the one we want to start+  -- in. We get all, rather than requesting by name or ID, because+  -- we don't know whether the server will give us a last-viewed preference.+  -- We first try to find a channel matching with the last selected channel ID,+  -- failing which we look for the Town Square channel by name.+  userChans <- mmGetChannelsForUser UserMe myTId session+  let lastSelectedChans = Seq.filter isLastSelectedChannel userChans+      chans = if Seq.null lastSelectedChans+                then Seq.filter isTownSquare userChans+                else lastSelectedChans++  -- Since the only channel we are dealing with is by construction the+  -- last channel, we don't have to consider other cases here:+  chanPairs <- forM (toList chans) $ \c -> do+      cChannel <- makeClientChannel (userId me) c+      return (getId c, cChannel)++  tz <- lookupLocalTimeZone+  hist <- do+      result <- readHistory+      case result of+          Left _ -> return newHistory+          Right h -> return h++  --------------------------------------------------------------------+  -- Start background worker threads:+  --+  --  * Syntax definition loader+  startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue)++  --  * Main async queue worker thread+  startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue)++  --  * User status thread+  startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan++  --  * Refresher for users who are typing currently+  when (configShowTypingIndicator (cr^.crConfiguration)) $+    startTypingUsersRefreshThread requestChan++  --  * Timezone change monitor+  startTimezoneMonitorThread tz requestChan++  --  * Subprocess logger+  startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan++  --  * Spell checker and spell check timer, if configured+  spResult <- maybeStartSpellChecker (cr^.crConfiguration) (cr^.crEventQueue)++  -- End thread startup ----------------------------------------------++  now <- getCurrentTime+  let chanIds = mkChannelZipperList now (cr^.crConfiguration) Nothing (cr^.crUserPreferences) clientChans noUsers+      chanZip = Z.fromList chanIds+      clientChans = foldr (uncurry addChannel) noChannels chanPairs+      startupState =+          StartupStateInfo { startupStateResources      = cr+                           , startupStateChannelZipper  = chanZip+                           , startupStateConnectedUser  = me+                           , startupStateTeam           = myTeam+                           , startupStateTimeZone       = tz+                           , startupStateInitialHistory = hist+                           , startupStateSpellChecker   = spResult+                           }++  initialState <- newState startupState+  let st = initialState & csChannels .~ clientChans++  loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st++  -- Trigger an initial websocket refresh+  writeBChan (cr^.crEventQueue) RefreshWebsocketEvent++  -- Refresh initial channel(s)+  writeBChan (cr^.crEventQueue) $ RespEvent $ do+      fetchVisibleIfNeeded++  return st
+ src/Matterhorn/State/Setup/Threads.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.State.Setup.Threads+  ( startUserStatusUpdateThread+  , startTypingUsersRefreshThread+  , startSubprocessLoggerThread+  , startTimezoneMonitorThread+  , maybeStartSpellChecker+  , startAsyncWorkerThread+  , startSyntaxMapLoaderThread+  , module Matterhorn.State.Setup.Threads.Logging+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.BChan ( BChan )+import           Brick.Main ( invalidateCache )+import           Control.Concurrent ( threadDelay, forkIO )+import qualified Control.Concurrent.STM as STM+import           Control.Concurrent.STM.Delay+import           Control.Exception ( SomeException, try, fromException, catch )+import           Data.List ( isInfixOf )+import qualified Data.Map as M+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time ( getCurrentTime, addUTCTime )+import           Lens.Micro.Platform ( (.=), (%=), (%~), mapped )+import           Skylighting.Loader ( loadSyntaxesFromDir )+import           System.Directory ( getTemporaryDirectory )+import           System.Exit ( ExitCode(ExitSuccess) )+import           System.IO ( hPutStrLn, hFlush )+import           System.IO.Temp ( openTempFile )+import           System.Timeout ( timeout )+import           Text.Aspell ( Aspell, AspellOption(..), startAspell )++import           Network.Mattermost.Exceptions ( RateLimitException+                                               , rateLimitExceptionReset )+import           Network.Mattermost.Endpoints+import           Network.Mattermost.Types++import           Matterhorn.Constants+import           Matterhorn.State.Editing ( requestSpellCheck )+import           Matterhorn.State.Setup.Threads.Logging+import           Matterhorn.TimeUtils ( lookupLocalTimeZone )+import           Matterhorn.Types+++updateUserStatuses :: [UserId] -> Session -> IO (Maybe (MH ()))+updateUserStatuses uIds session =+    case null uIds of+        False -> do+            statuses <- mmGetUserStatusByIds (Seq.fromList uIds) session+            return $ Just $ do+                forM_ statuses $ \s ->+                    setUserStatus (statusUserId s) (statusStatus s)+        True -> return Nothing++startUserStatusUpdateThread :: STM.TChan [UserId] -> Session -> RequestChan -> IO ()+startUserStatusUpdateThread zipperChan session requestChan = void $ forkIO body+  where+      seconds = (* (1000 * 1000))+      userRefreshInterval = 30+      body = refresh []+      refresh prev = do+          result <- timeout (seconds userRefreshInterval)+                            (STM.atomically $ STM.readTChan zipperChan)+          let (uIds, update) = case result of+                  Nothing -> (prev, True)+                  Just ids -> (ids, ids /= prev)++          when update $ do+              STM.atomically $ STM.writeTChan requestChan $ do+                  rs <- try $ updateUserStatuses uIds session+                  case rs of+                      Left (_ :: SomeException) -> return Nothing+                      Right upd -> return upd++          refresh uIds++-- This thread refreshes the map of typing users every second, forever,+-- to expire users who have stopped typing. Expiry time is 3 seconds.+startTypingUsersRefreshThread :: RequestChan -> IO ()+startTypingUsersRefreshThread requestChan = void $ forkIO $ forever refresh+  where+    seconds = (* (1000 * 1000))+    refreshIntervalMicros = ceiling $ seconds $ userTypingExpiryInterval / 2+    refresh = do+      STM.atomically $ STM.writeTChan requestChan $ return $ Just $ do+        now <- liftIO getCurrentTime+        let expiry = addUTCTime (- userTypingExpiryInterval) now+        let expireUsers c = c & ccInfo.cdTypingUsers %~ expireTypingUsers expiry+        csChannels . mapped %= expireUsers++      threadDelay refreshIntervalMicros++startSubprocessLoggerThread :: STM.TChan ProgramOutput -> RequestChan -> IO ()+startSubprocessLoggerThread logChan requestChan = do+    let logMonitor mPair = do+          ProgramOutput progName args out err ec <-+              STM.atomically $ STM.readTChan logChan++          case ec == ExitSuccess of+              -- the "good" case, no output and exit sucess+              True -> logMonitor mPair+              False -> do+                  (logPath, logHandle) <- case mPair of+                      Just p ->+                          return p+                      Nothing -> do+                          tmp <- getTemporaryDirectory+                          openTempFile tmp "matterhorn-subprocess.log"++                  hPutStrLn logHandle $+                      unlines [ "Program: " <> progName+                              , "Arguments: " <> show args+                              , "Exit code: " <> show ec+                              , "Stdout:"+                              , out+                              , "Stderr:"+                              , err+                              ]+                  hFlush logHandle++                  STM.atomically $ STM.writeTChan requestChan $ do+                      return $ Just $ mhError $ ProgramExecutionFailed (T.pack progName)+                                                                       (T.pack logPath)++                  logMonitor (Just (logPath, logHandle))++    void $ forkIO $ logMonitor Nothing++startTimezoneMonitorThread :: TimeZoneSeries -> RequestChan -> IO ()+startTimezoneMonitorThread tz requestChan = do+  -- Start the timezone monitor thread+  let timezoneMonitorSleepInterval = minutes 5+      minutes = (* (seconds 60))+      seconds = (* (1000 * 1000))+      timezoneMonitor prevTz = do+        threadDelay timezoneMonitorSleepInterval++        newTz <- lookupLocalTimeZone+        when (newTz /= prevTz) $+            STM.atomically $ STM.writeTChan requestChan $ do+                return $ Just $ do+                    timeZone .= newTz+                    mh invalidateCache++        timezoneMonitor newTz++  void $ forkIO (timezoneMonitor tz)++maybeStartSpellChecker :: Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ()))+maybeStartSpellChecker config eventQueue = do+  case configEnableAspell config of+      False -> return Nothing+      True -> do+          let aspellOpts = catMaybes [ UseDictionary <$> (configAspellDictionary config)+                                     ]+              spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms+          asResult <- either (const Nothing) Just <$> startAspell aspellOpts+          case asResult of+              Nothing -> return Nothing+              Just as -> do+                  resetSCChan <- startSpellCheckerThread eventQueue spellCheckerTimeout+                  let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan ()+                  return $ Just (as, resetSCTimer)++-- Start the background spell checker delay thread.+--+-- The purpose of this thread is to postpone the spell checker query+-- while the user is actively typing and only wait until they have+-- stopped typing before bothering with a query. This is to avoid spell+-- checker queries when the editor contents are changing rapidly.+-- Avoiding such queries reduces system load and redraw frequency.+--+-- We do this by starting a thread whose job is to wait for the event+-- loop to tell it to schedule a spell check. Spell checks are scheduled+-- by writing to the channel returned by this function. The scheduler+-- thread reads from that channel and then works with another worker+-- thread as follows:+--+-- A wakeup of the main spell checker thread causes it to determine+-- whether the worker thread is already waiting on a timer. When that+-- timer goes off, a spell check will be requested. If there is already+-- an active timer that has not yet expired, the timer's expiration is+-- extended. This is the case where typing is occurring and we want to+-- continue postponing the spell check. If there is not an active timer+-- or the active timer has expired, we create a new timer and send it to+-- the worker thread for waiting.+--+-- The worker thread works by reading a timer from its queue, waiting+-- until the timer expires, and then injecting an event into the main+-- event loop to request a spell check.+startSpellCheckerThread :: BChan MHEvent+                        -- ^ The main event loop's event channel.+                        -> Int+                        -- ^ The number of microseconds to wait before+                        -- requesting a spell check.+                        -> IO (STM.TChan ())+startSpellCheckerThread eventChan spellCheckTimeout = do+  delayWakeupChan <- STM.atomically STM.newTChan+  delayWorkerChan <- STM.atomically STM.newTChan+  delVar <- STM.atomically $ STM.newTVar Nothing++  -- The delay worker actually waits on the delay to expire and then+  -- requests a spell check.+  void $ forkIO $ forever $ do+    STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan+    writeBChan eventChan (RespEvent requestSpellCheck)++  -- The delay manager waits for requests to start a delay timer and+  -- signals the worker to begin waiting.+  void $ forkIO $ forever $ do+    () <- STM.atomically $ STM.readTChan delayWakeupChan++    oldDel <- STM.atomically $ STM.readTVar delVar+    mNewDel <- case oldDel of+        Nothing -> Just <$> newDelay spellCheckTimeout+        Just del -> do+            -- It's possible that between this check for expiration and+            -- the updateDelay below, the timer will expire -- at which+            -- point this will mean that we won't extend the timer as+            -- originally desired. But that's alright, because future+            -- keystrokes will trigger another timer anyway.+            expired <- tryWaitDelayIO del+            case expired of+                True -> Just <$> newDelay spellCheckTimeout+                False -> do+                    updateDelay del spellCheckTimeout+                    return Nothing++    case mNewDel of+        Nothing -> return ()+        Just newDel -> STM.atomically $ do+            STM.writeTVar delVar $ Just newDel+            STM.writeTChan delayWorkerChan newDel++  return delayWakeupChan++startSyntaxMapLoaderThread :: Config -> BChan MHEvent -> IO ()+startSyntaxMapLoaderThread config eventChan = void $ forkIO $ do+    -- Iterate over the configured syntax directories, loading syntax+    -- maps. Ensure that entries loaded in earlier directories in the+    -- sequence take precedence over entries loaded later.+    mMaps <- forM (configSyntaxDirs config) $ \dir -> do+        result <- try $ loadSyntaxesFromDir dir+        case result of+            Left (_::SomeException) -> return Nothing+            Right (Left _)          -> return Nothing+            Right (Right m)         -> return $ Just m++    let maps = catMaybes mMaps+        finalMap = foldl M.union mempty maps++    writeBChan eventChan $ RespEvent $ do+        csResources.crSyntaxMap .= finalMap+        mh invalidateCache++-------------------------------------------------------------------+-- Async worker thread++startAsyncWorkerThread :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()+startAsyncWorkerThread c r e = void $ forkIO $ asyncWorker c r e++asyncWorker :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()+asyncWorker c r e = forever $ doAsyncWork c r e++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+                     case chk of+                       Nothing -> do writeBChan eventChan BGIdle+                                     return $ writeBChan eventChan $ BGBusy Nothing+                       _ -> return $ return ()+        ActiveCount -> do+          chk <- STM.atomically $ do+            chanCopy <- STM.cloneTChan requestChan+            let cntMsgs = do m <- STM.tryReadTChan chanCopy+                             case m of+                               Nothing -> return 0+                               Just _ -> (1 +) <$> cntMsgs+            cntMsgs+          case chk of+            0 -> do writeBChan eventChan BGIdle+                    return (writeBChan eventChan $ BGBusy (Just 1))+            _ -> do writeBChan eventChan $ BGBusy (Just chk)+                    return $ return ()++    req <- STM.atomically $ STM.readTChan requestChan+    startWork+    -- 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+              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+              -- 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+-- information.+--+-- E.g.+-- https://github.com/matterhorn-chat/matterhorn/issues/391+shouldIgnore :: SomeException -> Bool+shouldIgnore e =+    let eStr = show e+    in or [ "getAddrInfo" `isInfixOf` eStr+          , "Network.Socket.recvBuf" `isInfixOf` eStr+          , "Network.Socket.sendBuf" `isInfixOf` eStr+          , "resource vanished" `isInfixOf` eStr+          , "timeout" `isInfixOf` eStr+          , "partial packet" `isInfixOf` eStr+          ]
+ src/Matterhorn/State/Setup/Threads/Logging.hs view
@@ -0,0 +1,317 @@+{-# LANGUAGE RecordWildCards #-}+-- | This module implements the logging thread. This thread can+-- optionally write logged messages to an output file. When the thread+-- is created, it is initially not writing to any output file and+-- must be told to do so by issuing a LogCommand using the LogManager+-- interface.+--+-- The logging thread has an internal bounded log message buffer. Logged+-- messages always get written to the buffer (potentially evicting old+-- messages to maintain the size bound). If the thread is also writing+-- to a file, such messages also get written to the file. When the+-- thread begins logging to a file, the entire buffer is written to the+-- file so that a historical snapshot of log activity can be saved in+-- cases where logging is turned on at runtime only once a problematic+-- behavior is observed.+module Matterhorn.State.Setup.Threads.Logging+  ( newLogManager+  , shutdownLogManager+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.BChan ( BChan )+import           Control.Concurrent.Async ( Async, async, wait )+import qualified Control.Concurrent.STM as STM+import           Control.Exception ( SomeException, try )+import           Control.Monad.State.Strict+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time ( getCurrentTime )+import           System.IO ( Handle, IOMode(AppendMode), hPutStr, hPutStrLn+                           , hFlush, openFile, hClose )++import           Matterhorn.Types+++-- | Used to remember the last logging output point for various log output targets.+newtype LogMemory = LogMemory { logMem :: [(FilePath, LogMessage)] }++blankLogMemory :: LogMemory+blankLogMemory = LogMemory []++-- | Adds or updates the last log message output to this destination.+-- This is used for the case when logging is re-enabled to that+-- destination to avoid repeating logging output.+--+-- The number of log memories is limited by forgetting the oldest ones+-- if over a threshold.  This handles a pathological case where the+-- user has redirected output to a very large number of logfiles.+-- This is very unlikely to happen (a script or bad paste buffer+-- maybe?) but this provides defensive behavior to prevent+-- uncontrolled memory consumption in this case.  The limit here is+-- arbitrary, but it should suffice and once it's reached the+-- degradation case is simply the potential for duplicated messages+-- when returning to logfiles that haven't been recently logged to.+rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory+rememberOutputPoint logPath logMsg oldLogMem =+  LogMemory $+  take 50 $ -- upper limit on number of logpath+message memories retained+  (logPath, logMsg) : filter ((/=) logPath . fst) (logMem oldLogMem)++-- | Returns the last LogMessage logged to the specified output log+-- file path if it was previously logged to.+memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage+memoryOfOutputPath p = lookup p . logMem++-- | The state of the logging thread.+data LogThreadState =+    LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)+                   -- ^ The logging thread's active logging destination.+                   -- Nothing means log messages are not being written+                   -- anywhere except the internal buffer.+                   , logThreadEventChan :: BChan MHEvent+                   -- ^ The application event channel that we'll use to+                   -- notify of logging events.+                   , logThreadCommandChan :: STM.TChan LogCommand+                   -- ^ The channel on which the logging thread will+                   -- wait for logging commands.+                   , logThreadMessageBuffer :: Seq.Seq LogMessage+                   -- ^ The internal bounded log message buffer.+                   , logThreadMaxBufferSize :: Int+                   -- ^ The size bound of the logThreadMessageBuffer.+                   , logPreviousStopPoint :: LogMemory+                   -- ^ Previous logging stop points to avoid+                   -- duplication if logging is re-enabled to the same+                   -- output+                   }++-- | Create a new log manager and start a logging thread for it.+newLogManager :: BChan MHEvent -> Int -> IO LogManager+newLogManager eventChan maxBufferSize = do+    chan <- STM.newTChanIO+    self <- startLoggingThread eventChan chan maxBufferSize+    let mgr = LogManager { logManagerCommandChannel = chan+                         , logManagerHandle = self+                         }+    return mgr++-- | Shuts down the log manager and blocks until shutdown is complete.+shutdownLogManager :: LogManager -> IO ()+shutdownLogManager mgr = do+    STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) ShutdownLogging+    wait $ logManagerHandle mgr++-- | The logging thread.+startLoggingThread :: BChan MHEvent -> STM.TChan LogCommand -> Int -> IO (Async ())+startLoggingThread eventChan logChan maxBufferSize = do+    let initialState = LogThreadState { logThreadDestination = Nothing+                                      , logThreadEventChan = eventChan+                                      , logThreadCommandChan = logChan+                                      , logThreadMessageBuffer = mempty+                                      , logThreadMaxBufferSize = maxBufferSize+                                      , logPreviousStopPoint = blankLogMemory+                                      }+    async $ void $ runStateT logThreadBody initialState++logThreadBody :: StateT LogThreadState IO ()+logThreadBody = do+    cmd <- nextLogCommand+    continue <- handleLogCommand cmd+    when continue logThreadBody++-- | Get the next pending log thread command.+nextLogCommand :: StateT LogThreadState IO LogCommand+nextLogCommand = do+    chan <- gets logThreadCommandChan+    liftIO $ STM.atomically $ STM.readTChan chan++putMarkerMessage :: String -> Handle -> IO ()+putMarkerMessage msg h = do+    now <- getCurrentTime+    hPutStrLn h $ "[" <> show now <> "] " <> msg++-- | Emit a log stop marker to the file.+putLogEndMarker :: Handle -> IO ()+putLogEndMarker = putMarkerMessage "<<< Logging end >>>"++-- | Emit a log start marker to the file.+putLogStartMarker :: Handle -> IO ()+putLogStartMarker = putMarkerMessage "<<< Logging start >>>"++-- | Emit a log stop marker to the file and close it, then notify the+-- application that we have stopped logging.+finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()+finishLog eventChan oldPath oldHandle = do+    liftIO $ do+        putLogEndMarker oldHandle+        hClose oldHandle+        writeBChan eventChan $ IEvent $ LoggingStopped oldPath+    modify $ \s ->+      let buf = logThreadMessageBuffer s+          lastLm = Seq.index buf (Seq.length buf - 1) -- n.b. putLogEndMarker ensures buf not empty+          stops = rememberOutputPoint oldPath lastLm $ logPreviousStopPoint s+      in s { logThreadDestination = Nothing+           , logPreviousStopPoint = stops+           }++stopLogOutput :: StateT LogThreadState IO ()+stopLogOutput = do+    oldDest <- gets logThreadDestination+    case oldDest of+        Nothing -> return ()+        Just (oldPath, oldHandle) -> do+            eventChan <- gets logThreadEventChan+            finishLog eventChan oldPath oldHandle++-- | Handle a single logging command.+handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool+handleLogCommand (LogSnapshot path) = do+    -- LogSnapshot: write the current log message buffer to the+    -- specified path. Ignore the request if it is for the path that we+    -- are already logging to.+    eventChan <- gets logThreadEventChan+    dest <- gets logThreadDestination++    let shouldWrite = case dest of+          Nothing -> True+          Just (curPath, _) -> curPath /= path++    when shouldWrite $ do+        result <- liftIO $ try $ openFile path AppendMode+        case result of+            Left (e::SomeException) -> do+                liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotFailed path (show e)+            Right handle -> do+                flushLogMessageBuffer path handle+                liftIO $ hClose handle+                liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotSucceeded path++    return True+handleLogCommand GetLogDestination = do+    -- GetLogDestination: the application asked us to provide the+    -- current log destination.+    dest <- gets logThreadDestination+    eventChan <- gets logThreadEventChan+    liftIO $ writeBChan eventChan $ IEvent $ LogDestination $ fst <$> dest+    return True+handleLogCommand ShutdownLogging = do+    -- ShutdownLogging: if we were logging to a file, close it. Then+    -- unlock the shutdown lock.+    stopLogOutput+    return False+handleLogCommand StopLogging = do+    -- StopLogging: if we were logging to a file, close it and notify+    -- the application. Otherwise do nothing.+    stopLogOutput+    return True+handleLogCommand (LogToFile newPath) = do+    -- LogToFile: if we were logging to a file, close that file, notify+    -- the application, then attempt to open the new file. If that+    -- failed, notify the application of the error. If it succeeded,+    -- start logging and notify the application.+    eventChan <- gets logThreadEventChan+    oldDest <- gets logThreadDestination++    shouldChange <- case oldDest of+        Nothing ->+            return True+        Just (oldPath, _) ->+            return (oldPath /= newPath)++    when shouldChange $ do+        result <- liftIO $ try $ openFile newPath AppendMode+        case result of+            Left (e::SomeException) -> liftIO $ do+                let msg = "Error in log thread: could not open " <> show newPath <>+                          ": " <> show e+                writeBChan eventChan $ IEvent $ LogStartFailed newPath msg+            Right handle -> do+                stopLogOutput++                modify $ \s -> s { logThreadDestination = Just (newPath, handle) }+                flushLogMessageBuffer newPath handle+                liftIO $ putLogStartMarker handle+                liftIO $ writeBChan eventChan $ IEvent $ LoggingStarted newPath++    return True+handleLogCommand (LogAMessage lm) = do+    -- LogAMessage: log a single message. Write the message to the+    -- bounded internal buffer (which may cause an older message to be+    -- evicted). Then, if we are actively logging to a file, write the+    -- message to that file and flush the output stream.+    maxBufSize <- gets logThreadMaxBufferSize++    let addMessageToBuffer s =+            -- Ensure that newSeq is always at most maxBufSize elements+            -- long.+            let newSeq = s Seq.|> lm+                toDrop = Seq.length s - maxBufSize+            in Seq.drop toDrop newSeq++    -- Append the message to the internal buffer, maintaining the bound+    -- on the internal buffer size.+    modify $ \s -> s { logThreadMessageBuffer = addMessageToBuffer (logThreadMessageBuffer s) }++    -- If we have an active log destination, write the message to the+    -- output file.+    dest <- gets logThreadDestination+    case dest of+        Nothing -> return ()+        Just (_, handle) -> liftIO $ do+            hPutLogMessage handle lm+            hFlush handle++    return True++-- | Write a single log message to the output handle.+hPutLogMessage :: Handle -> LogMessage -> IO ()+hPutLogMessage handle (LogMessage {..}) = do+    hPutStr handle $ "[" <> show logMessageTimestamp <> "] "+    hPutStr handle $ "[" <> show logMessageCategory <> "] "+    case logMessageContext of+        Nothing -> hPutStr handle "[*] "+        Just c  -> hPutStr handle $ "[" <> show c <> "] "+    hPutStrLn handle $ T.unpack logMessageText++-- | Flush the contents of the internal log message buffer.+flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()+flushLogMessageBuffer pathOfHandle handle = do+    buf <- gets logThreadMessageBuffer+    when (not $ Seq.null buf) $ do+      lastPoint <- memoryOfOutputPath pathOfHandle <$> gets logPreviousStopPoint+      case lastPoint of+        Nothing ->+          -- never logged to this output point before, so dump the+          -- current internal buffer of log messages to the beginning of+          -- the output file.+          dumpBuf buf+        Just lm ->+          -- There was previous logging to this file.  If the log buffer+          -- contains the entirety of the log messages during the+          -- logging disable, then just dump that portion; otherwise+          -- dump the entire buffer and indicate there may be missing+          -- entries before the buffer.+          let unseen = Seq.takeWhileR (not . (==) lm) buf+              firstM = Seq.index buf 0 -- above ensures that buf is not empty here+          in do when (Seq.length buf == Seq.length unseen) $ liftIO $+                  hPutStrLn handle $ mkMsg (logMessageTimestamp firstM)+                                     "<<< Potentially missing log messages here... >>>"+                dumpBuf unseen+      where+        mkMsg t m = "[" <> show t <> "] " <> m+        dumpBuf buf = liftIO $ do+          let firstLm = Seq.index buf 0+              lastLm = Seq.index buf (Seq.length buf - 1)++          hPutStrLn handle $ mkMsg (logMessageTimestamp firstLm)+                             "<<< Log message buffer begin >>>"++          forM_ buf (hPutLogMessage handle)++          hPutStrLn handle $ mkMsg (logMessageTimestamp lastLm)+                                   "<<< Log message buffer end >>>"++          hFlush handle
+ src/Matterhorn/State/ThemeListOverlay.hs view
@@ -0,0 +1,86 @@+module Matterhorn.State.ThemeListOverlay+  ( enterThemeListMode++  , themeListSelectDown+  , themeListSelectUp+  , themeListPageDown+  , themeListPageUp++  , setTheme+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick ( invalidateCache )+import           Brick.Themes ( themeToAttrMap )+import qualified Brick.Widgets.List as L+import qualified Data.Text as T+import qualified Data.Vector as Vec+import           Lens.Micro.Platform ( (.=) )++import           Network.Mattermost.Types++import           Matterhorn.State.ListOverlay+import           Matterhorn.Themes+import           Matterhorn.Types+++-- | Show the user list overlay with the given search scope, and issue a+-- request to gather the first search results.+enterThemeListMode :: MH ()+enterThemeListMode =+    enterListOverlayMode csThemeListOverlay ThemeListOverlay () setInternalTheme getThemesMatching++-- | Move the selection up in the user list overlay by one user.+themeListSelectUp :: MH ()+themeListSelectUp = themeListMove L.listMoveUp++-- | Move the selection down in the user list overlay by one user.+themeListSelectDown :: MH ()+themeListSelectDown = themeListMove L.listMoveDown++-- | Move the selection up in the user list overlay by a page of users+-- (themeListPageSize).+themeListPageUp :: MH ()+themeListPageUp = themeListMove (L.listMoveBy (-1 * themeListPageSize))++-- | Move the selection down in the user list overlay by a page of users+-- (themeListPageSize).+themeListPageDown :: MH ()+themeListPageDown = themeListMove (L.listMoveBy themeListPageSize)++-- | Transform the user list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+themeListMove :: (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH ()+themeListMove = listOverlayMove csThemeListOverlay++-- | The number of users in a "page" for cursor movement purposes.+themeListPageSize :: Int+themeListPageSize = 10++getThemesMatching :: ()+                  -> Session+                  -> Text+                  -> IO (Vec.Vector InternalTheme)+getThemesMatching _ _ searchString = do+    let matching = filter matches internalThemes+        search = T.toLower searchString+        matches t = search `T.isInfixOf` T.toLower (internalThemeName t) ||+                    search `T.isInfixOf` T.toLower (internalThemeDesc t)+    return $ Vec.fromList matching++setInternalTheme :: InternalTheme -> MH Bool+setInternalTheme t = do+    setTheme $ internalThemeName t+    return False++setTheme :: Text -> MH ()+setTheme name =+    case lookupTheme name of+        Nothing -> enterThemeListMode+        Just it -> do+            mh invalidateCache+            csResources.crTheme .= (themeToAttrMap $ internalTheme it)
+ src/Matterhorn/State/UrlSelect.hs view
@@ -0,0 +1,48 @@+module Matterhorn.State.UrlSelect+  (+  -- * URL selection mode+    startUrlSelect+  , stopUrlSelect+  , openSelectedURL+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick.Widgets.List ( list, listMoveTo, listSelectedElement )+import qualified Data.Vector as V+import           Lens.Micro.Platform ( (.=), to )++import           Matterhorn.State.Links+import           Matterhorn.Types+import           Matterhorn.Util+++startUrlSelect :: MH ()+startUrlSelect = do+    urls <- use (csCurrentChannel.to findUrls.to V.fromList)+    setMode UrlSelect+    csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)++stopUrlSelect :: MH ()+stopUrlSelect = setMode Main++openSelectedURL :: MH ()+openSelectedURL = whenMode UrlSelect $ do+    selected <- use (csUrlList.to listSelectedElement)+    case selected of+        Nothing -> setMode Main+        Just (_, link) -> do+            opened <- openLinkTarget (link^.linkTarget)+            when (not opened) $ do+                mhError $ ConfigOptionMissing "urlOpenCommand"+                setMode Main++findUrls :: ClientChannel -> [LinkChoice]+findUrls chan =+    let msgs = chan^.ccContents.cdMessages+    in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs++removeDuplicates :: [LinkChoice] -> [LinkChoice]+removeDuplicates = nubOn (\ l -> (l^.linkTarget, l^.linkUser, l^.linkLabel))
+ src/Matterhorn/State/UserListOverlay.hs view
@@ -0,0 +1,174 @@+module Matterhorn.State.UserListOverlay+  ( enterChannelMembersUserList+  , enterChannelInviteUserList+  , enterDMSearchUserList++  , userListSelectDown+  , userListSelectUp+  , userListPageDown+  , userListPageUp+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Brick.Widgets.List as L+import qualified Data.HashMap.Strict as HM+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Vector as Vec+import           Lens.Micro.Platform ( (.~), (.=) )++import qualified Network.Mattermost.Endpoints as MM+import qualified Network.Mattermost.Types.Config as MM+import           Network.Mattermost.Types++import           Matterhorn.State.Async ( doAsyncWith, AsyncPriority(Preempt) )+import           Matterhorn.State.Channels ( createOrFocusDMChannel, addUserToCurrentChannel )+import           Matterhorn.State.ListOverlay+import           Matterhorn.Types+++-- | Show the user list overlay for searching/showing members of the+-- current channel.+enterChannelMembersUserList :: MH ()+enterChannelMembersUserList = do+    cId <- use csCurrentChannelId+    myId <- gets myUserId+    myTId <- gets myTeamId+    session <- getSession++    doAsyncWith Preempt $ do+        stats <- MM.mmGetChannelStatistics cId session+        return $ Just $ do+            enterUserListMode (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats)+              (\u -> case u^.uiId /= myId of+                True -> createOrFocusDMChannel u Nothing >> return True+                False -> return False+              )++-- | Show the user list overlay for showing users that are not members+-- of the current channel for the purpose of adding them to the+-- channel.+enterChannelInviteUserList :: MH ()+enterChannelInviteUserList = do+    cId <- use csCurrentChannelId+    myId <- gets myUserId+    myTId <- gets myTeamId+    enterUserListMode (ChannelNonMembers cId myTId) Nothing+      (\u -> case u^.uiId /= myId of+        True -> addUserToCurrentChannel u >> return True+        False -> return False+      )++-- | Show the user list overlay for showing all users for the purpose of+-- starting a direct message channel with another user.+enterDMSearchUserList :: MH ()+enterDMSearchUserList = do+    myId <- gets myUserId+    myTId <- gets myTeamId+    config <- use csClientConfig+    let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of+            Just MM.RestrictTeam -> Just myTId+            _ -> Nothing+    enterUserListMode (AllUsers restrictTeam) Nothing+      (\u -> case u^.uiId /= myId of+        True -> createOrFocusDMChannel u Nothing >> return True+        False -> return False+      )++-- | Show the user list overlay with the given search scope, and issue a+-- request to gather the first search results.+enterUserListMode :: UserSearchScope -> Maybe Int -> (UserInfo -> MH Bool) -> MH ()+enterUserListMode scope resultCount enterHandler = do+    csUserListOverlay.listOverlayRecordCount .= resultCount+    enterListOverlayMode csUserListOverlay UserListOverlay scope enterHandler getUserSearchResults++userInfoFromPair :: User -> Text -> UserInfo+userInfoFromPair u status =+    userInfoFromUser u True & uiStatus .~ statusFromText status++-- | Move the selection up in the user list overlay by one user.+userListSelectUp :: MH ()+userListSelectUp = userListMove L.listMoveUp++-- | Move the selection down in the user list overlay by one user.+userListSelectDown :: MH ()+userListSelectDown = userListMove L.listMoveDown++-- | Move the selection up in the user list overlay by a page of users+-- (userListPageSize).+userListPageUp :: MH ()+userListPageUp = userListMove (L.listMoveBy (-1 * userListPageSize))++-- | Move the selection down in the user list overlay by a page of users+-- (userListPageSize).+userListPageDown :: MH ()+userListPageDown = userListMove (L.listMoveBy userListPageSize)++-- | Transform the user list results in some way, e.g. by moving the+-- cursor, and then check to see whether the modification warrants a+-- prefetch of more search results.+userListMove :: (L.List Name UserInfo -> L.List Name UserInfo) -> MH ()+userListMove = listOverlayMove csUserListOverlay++-- | The number of users in a "page" for cursor movement purposes.+userListPageSize :: Int+userListPageSize = 10++getUserSearchResults :: UserSearchScope+                     -- ^ The scope to search+                     -> Session+                     -- ^ The connection session+                     -> Text+                     -- ^ The search string+                     -> IO (Vec.Vector UserInfo)+getUserSearchResults scope s searchString = do+    -- Unfortunately, we don't get pagination control when there is a+    -- search string in effect. We'll get at most 100 results from a+    -- search.+    let query = UserSearch { userSearchTerm = if T.null searchString then " " else searchString+                           -- Hack alert: Searching with the string " "+                           -- above is a hack to use the search+                           -- endpoint to get "all users" instead of+                           -- those matching a particular non-empty+                           -- non-whitespace string. This is because+                           -- only the search endpoint provides a+                           -- control to eliminate deleted users from+                           -- the results. If we don't do this, and+                           -- use the /users endpoint instead, we'll+                           -- get deleted users in those results and+                           -- then those deleted users will disappear+                           -- from the results once the user enters a+                           -- non-empty string string.+                           , userSearchAllowInactive = False+                           , userSearchWithoutTeam = False+                           , userSearchInChannelId = case scope of+                               ChannelMembers cId _ -> Just cId+                               _                    -> Nothing+                           , userSearchNotInTeamId = Nothing+                           , userSearchNotInChannelId = case scope of+                               ChannelNonMembers cId _ -> Just cId+                               _                       -> Nothing+                           , userSearchTeamId = case scope of+                               AllUsers tId            -> tId+                               ChannelMembers _ tId    -> Just tId+                               ChannelNonMembers _ tId -> Just tId+                           }+    users <- MM.mmSearchUsers query s++    let uList = toList users+        uIds = userId <$> uList++    -- Now fetch status info for the users we got.+    case null uList of+        False -> do+            statuses <- MM.mmGetUserStatusByIds (Seq.fromList uIds) s+            let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- toList statuses ]+                usersWithStatus = [ userInfoFromPair u (fromMaybe "" $ HM.lookup (userId u) statusMap)+                                  | u <- uList+                                  ]++            return $ Vec.fromList usersWithStatus+        True -> return mempty
+ src/Matterhorn/State/Users.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.State.Users+  ( handleNewUsers+  , handleTypingUser+  , withFetchedUser+  , withFetchedUserMaybe+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Text as T+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import           Data.Time ( getCurrentTime )+import           Lens.Micro.Platform++import qualified Network.Mattermost.Endpoints as MM+import           Network.Mattermost.Types++import           Matterhorn.Config+import           Matterhorn.Types+import           Matterhorn.State.Common+++handleNewUsers :: Seq UserId -> MH () -> MH ()+handleNewUsers newUserIds after = do+    doAsyncMM Preempt getUserInfo addNewUsers+    where getUserInfo session =+              do nUsers <- MM.mmGetUsersByIds newUserIds session+                 let usrInfo u = userInfoFromUser u True+                     usrList = toList nUsers+                 return $ usrInfo <$> usrList++          addNewUsers :: [UserInfo] -> Maybe (MH ())+          addNewUsers is = Just $ mapM_ addNewUser is >> after++-- | Handle the typing events from the websocket to show the currently+-- typing users on UI+handleTypingUser :: UserId -> ChannelId -> MH ()+handleTypingUser uId cId = do+    config <- use (csResources.crConfiguration)+    when (configShowTypingIndicator config) $ do+        withFetchedUser (UserFetchById uId) $ const $ do+            ts <- liftIO getCurrentTime+            csChannels %= modifyChannelById cId (addChannelTypingUser uId ts)++-- | Given a user fetching strategy, locate the user in the state or+-- fetch it from the server, and pass the result to the specified+-- action. Assumes a single match is the only expected/valid result.+withFetchedUser :: UserFetch -> (UserInfo -> MH ()) -> MH ()+withFetchedUser fetch handle =+    withFetchedUserMaybe fetch $ \u -> do+        case u of+            Nothing -> postErrorMessage' "No such user"+            Just user -> handle user++withFetchedUserMaybe :: UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()+withFetchedUserMaybe fetch handle = do+    st <- use id+    session <- getSession++    let localMatch = case fetch of+            UserFetchById uId -> userById uId st+            UserFetchByUsername uname -> userByUsername uname st+            UserFetchByNickname nick -> userByNickname nick st++    case localMatch of+        Just user -> handle $ Just user+        Nothing -> do+            mhLog LogGeneral $ T.pack $ "withFetchedUserMaybe: getting " <> show fetch+            doAsyncWith Normal $ do+                results <- case fetch of+                    UserFetchById uId ->+                        MM.mmGetUsersByIds (Seq.singleton uId) session+                    UserFetchByUsername uname ->+                        MM.mmGetUsersByUsernames (Seq.singleton $ trimUserSigil uname) session+                    UserFetchByNickname nick -> do+                        let req = UserSearch { userSearchTerm = trimUserSigil nick+                                             , userSearchAllowInactive = True+                                             , userSearchWithoutTeam = True+                                             , userSearchInChannelId = Nothing+                                             , userSearchNotInTeamId = Nothing+                                             , userSearchNotInChannelId = Nothing+                                             , userSearchTeamId = Nothing+                                             }+                        MM.mmSearchUsers req session++                return $ Just $ do+                    infos <- forM (F.toList results) $ \u -> do+                        let info = userInfoFromUser u True+                        addNewUser info+                        return info++                    case infos of+                        [match] -> handle $ Just match+                        [] -> handle Nothing+                        _ -> postErrorMessage' "Error: ambiguous user information"
+ src/Matterhorn/TeamSelect.hs view
@@ -0,0 +1,90 @@+module Matterhorn.TeamSelect+  ( interactiveTeamSelection+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border+import           Brick.Widgets.Center+import           Brick.Widgets.List+import qualified Data.Function as F+import           Data.List ( sortBy )+import qualified Data.Vector as V+import           Graphics.Vty hiding (mkVty)+import qualified Data.Text as T++import           Network.Mattermost.Types++import           Matterhorn.Draw.RichText+import           Matterhorn.Types.Common+++data State =+    State { appList :: List () Team+          , appCancelled :: Bool+          }++interactiveTeamSelection :: Vty -> IO Vty -> [Team] -> IO (Maybe Team, Vty)+interactiveTeamSelection vty mkVty teams = do+    let state = State { appList = list () (V.fromList sortedTeams) 1+                      , appCancelled = False+                      }+        sortedTeams = sortBy (compare `F.on` teamName) teams++    (finalSt, finalVty) <- customMainWithVty vty mkVty Nothing app state++    let result = if appCancelled finalSt+                 then Nothing+                 else snd <$> listSelectedElement (appList finalSt)++    return (result, finalVty)++app :: App State e ()+app = App+  { appDraw         = teamSelectDraw+  , appChooseCursor = neverShowCursor+  , appHandleEvent  = onEvent+  , appStartEvent   = return+  , appAttrMap      = const colorTheme+  }++colorTheme :: AttrMap+colorTheme = attrMap defAttr+  [ (listSelectedFocusedAttr, black `on` yellow)+  ]++teamSelectDraw :: State -> [Widget ()]+teamSelectDraw st =+    [ teamSelect st+    ]++teamSelect :: State -> Widget ()+teamSelect st =+    center $ hLimit 50 $ vLimit 15 $+    vBox [ hCenter $ txt "Welcome to Mattermost. Please select a team:"+         , txt " "+         , border theList+         , txt " "+         , renderText "Press Enter to select a team and connect or Esc to exit."+         ]+    where+    theList = renderList renderTeamItem True (appList st)++renderTeamItem :: Bool -> Team -> Widget ()+renderTeamItem _ t =+    padRight Max $ txt $ (sanitizeUserText $ teamName t) <>+        if not $ T.null (sanitizeUserText $ teamDisplayName t)+        then " (" <> (sanitizeUserText $ teamDisplayName t) <> ")"+        else ""++onEvent :: State -> BrickEvent () e -> EventM () (Next State)+onEvent st (VtyEvent (EvKey KEsc [])) = do+    halt $ st { appCancelled = True }+onEvent st (VtyEvent (EvKey KEnter [])) = halt st+onEvent st (VtyEvent e) = do+    list' <- handleListEvent e (appList st)+    continue $ st { appList = list' }+onEvent st _ = continue st
+ src/Matterhorn/Themes.hs view
@@ -0,0 +1,808 @@+{-# LANGUAGE OverloadedStrings #-}+module Matterhorn.Themes+  ( InternalTheme(..)++  , defaultTheme+  , internalThemes+  , lookupTheme+  , themeDocs++  -- * Attribute names+  , currentUserAttr+  , timeAttr+  , channelHeaderAttr+  , channelListHeaderAttr+  , currentChannelNameAttr+  , unreadChannelAttr+  , unreadGroupMarkerAttr+  , mentionsChannelAttr+  , urlAttr+  , codeAttr+  , emailAttr+  , emojiAttr+  , channelNameAttr+  , clientMessageAttr+  , clientHeaderAttr+  , strikeThroughAttr+  , clientEmphAttr+  , clientStrongAttr+  , dateTransitionAttr+  , pinnedMessageIndicatorAttr+  , newMessageTransitionAttr+  , gapMessageAttr+  , errorMessageAttr+  , helpAttr+  , helpEmphAttr+  , channelSelectPromptAttr+  , channelSelectMatchAttr+  , completionAlternativeListAttr+  , completionAlternativeCurrentAttr+  , permalinkAttr+  , dialogAttr+  , dialogEmphAttr+  , recentMarkerAttr+  , replyParentAttr+  , loadMoreAttr+  , urlListSelectedAttr+  , messageSelectAttr+  , messageSelectStatusAttr+  , misspellingAttr+  , editedMarkingAttr+  , editedRecentlyMarkingAttr+  , tabSelectedAttr+  , tabUnselectedAttr+  , buttonAttr+  , buttonFocusedAttr++  -- * Username formatting+  , colorUsername+  , attrForUsername+  , usernameColorHashBuckets+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Themes+import           Brick.Widgets.List+import qualified Brick.Widgets.FileBrowser as FB+import           Brick.Widgets.Skylighting ( attrNameForTokenType+                                           , attrMappingsForStyle+                                           , highlightedCodeBlockAttr+                                           )+import           Brick.Forms ( focusedFormInputAttr )+import           Data.Hashable ( hash )+import qualified Data.Map as M+import qualified Data.Text as T+import           Graphics.Vty+import qualified Skylighting.Styles as Sky+import           Skylighting.Types ( TokenType(..) )++import           Matterhorn.Types ( InternalTheme(..), specialUserMentions )+++helpAttr :: AttrName+helpAttr = "help"++helpEmphAttr :: AttrName+helpEmphAttr = "helpEmphasis"++recentMarkerAttr :: AttrName+recentMarkerAttr = "recentChannelMarker"++replyParentAttr :: AttrName+replyParentAttr = "replyParentPreview"++pinnedMessageIndicatorAttr :: AttrName+pinnedMessageIndicatorAttr = "pinnedMessageIndicator"++loadMoreAttr :: AttrName+loadMoreAttr = "loadMoreMessages"++urlListSelectedAttr :: AttrName+urlListSelectedAttr = "urlListCursor"++messageSelectAttr :: AttrName+messageSelectAttr = "messageSelectCursor"++editedMarkingAttr :: AttrName+editedMarkingAttr = "editedMarking"++editedRecentlyMarkingAttr :: AttrName+editedRecentlyMarkingAttr = "editedRecentlyMarking"++permalinkAttr :: AttrName+permalinkAttr = "permalink"++dialogAttr :: AttrName+dialogAttr = "dialog"++dialogEmphAttr :: AttrName+dialogEmphAttr = "dialogEmphasis"++channelSelectMatchAttr :: AttrName+channelSelectMatchAttr = "channelSelectMatch"++channelSelectPromptAttr :: AttrName+channelSelectPromptAttr = "channelSelectPrompt"++completionAlternativeListAttr :: AttrName+completionAlternativeListAttr = "tabCompletionAlternative"++completionAlternativeCurrentAttr :: AttrName+completionAlternativeCurrentAttr = "tabCompletionCursor"++timeAttr :: AttrName+timeAttr = "time"++currentUserAttr :: AttrName+currentUserAttr = "currentUser"++channelHeaderAttr :: AttrName+channelHeaderAttr = "channelHeader"++channelListHeaderAttr :: AttrName+channelListHeaderAttr = "channelListSectionHeader"++currentChannelNameAttr :: AttrName+currentChannelNameAttr = "currentChannelName"++channelNameAttr :: AttrName+channelNameAttr = "channelName"++unreadChannelAttr :: AttrName+unreadChannelAttr = "unreadChannel"++unreadGroupMarkerAttr :: AttrName+unreadGroupMarkerAttr = "unreadChannelGroupMarker"++mentionsChannelAttr :: AttrName+mentionsChannelAttr = "channelWithMentions"++tabSelectedAttr :: AttrName+tabSelectedAttr = "tabSelected"++tabUnselectedAttr :: AttrName+tabUnselectedAttr = "tabUnselected"++dateTransitionAttr :: AttrName+dateTransitionAttr = "dateTransition"++newMessageTransitionAttr :: AttrName+newMessageTransitionAttr = "newMessageTransition"++urlAttr :: AttrName+urlAttr = "url"++codeAttr :: AttrName+codeAttr = "codeBlock"++emailAttr :: AttrName+emailAttr = "email"++emojiAttr :: AttrName+emojiAttr = "emoji"++clientMessageAttr :: AttrName+clientMessageAttr = "clientMessage"++clientHeaderAttr :: AttrName+clientHeaderAttr = "markdownHeader"++strikeThroughAttr :: AttrName+strikeThroughAttr = "markdownStrikethrough"++clientEmphAttr :: AttrName+clientEmphAttr = "markdownEmph"++clientStrongAttr :: AttrName+clientStrongAttr = "markdownStrong"++errorMessageAttr :: AttrName+errorMessageAttr = "errorMessage"++gapMessageAttr :: AttrName+gapMessageAttr = "gapMessage"++misspellingAttr :: AttrName+misspellingAttr = "misspelling"++messageSelectStatusAttr :: AttrName+messageSelectStatusAttr = "messageSelectStatus"++buttonAttr :: AttrName+buttonAttr = "button"++buttonFocusedAttr :: AttrName+buttonFocusedAttr = buttonAttr <> "focused"++lookupTheme :: Text -> Maybe InternalTheme+lookupTheme n = find ((== n) . internalThemeName) internalThemes++internalThemes :: [InternalTheme]+internalThemes = validateInternalTheme <$>+    [ darkColorTheme+    , darkColor256Theme+    , lightColorTheme+    , lightColor256Theme+    ]++validateInternalTheme :: InternalTheme -> InternalTheme+validateInternalTheme it =+    let un = undocumentedAttrNames (internalTheme it)+    in if not $ null un+       then error $ "Internal theme " <> show (T.unpack (internalThemeName it)) <>+                    " references undocumented attribute names: " <> show un+       else it++undocumentedAttrNames :: Theme -> [AttrName]+undocumentedAttrNames t =+    let noDocs k = isNothing $ attrNameDescription themeDocs k+    in filter noDocs (M.keys $ themeDefaultMapping t)++defaultTheme :: InternalTheme+defaultTheme = darkColorTheme++lightColorTheme :: InternalTheme+lightColorTheme = InternalTheme name theme desc+    where+        theme = newTheme def $ lightAttrs usernameColors16+        name = "builtin:light"+        def = black `on` white+        desc = "A color theme for terminal windows with light background colors"++lightColor256Theme :: InternalTheme+lightColor256Theme = InternalTheme name theme desc+    where+        theme = newTheme def $ lightAttrs usernameColors256+        name = "builtin:light256"+        def = black `on` white+        desc = "Like builtin:light, but with 256-color username colors"++lightAttrs :: [Attr] -> [(AttrName, Attr)]+lightAttrs usernameColors =+    let sty = Sky.kate+    in [ (timeAttr,                         fg black)+       , (buttonAttr,                       black `on` cyan)+       , (buttonFocusedAttr,                black `on` yellow)+       , (currentUserAttr,                  defAttr `withStyle` bold)+       , (channelHeaderAttr,                fg black)+       , (channelListHeaderAttr,            fg cyan)+       , (currentChannelNameAttr,           black `on` yellow `withStyle` bold)+       , (unreadChannelAttr,                black `on` cyan   `withStyle` bold)+       , (unreadGroupMarkerAttr,            fg black `withStyle` bold)+       , (mentionsChannelAttr,              black `on` red    `withStyle` bold)+       , (urlAttr,                          fg brightYellow)+       , (emailAttr,                        fg yellow)+       , (codeAttr,                         fg magenta)+       , (emojiAttr,                        fg yellow)+       , (channelNameAttr,                  fg blue)+       , (clientMessageAttr,                fg black)+       , (clientEmphAttr,                   fg black `withStyle` bold)+       , (clientStrongAttr,                 fg black `withStyle` bold `withStyle` underline)+       , (clientHeaderAttr,                 fg red `withStyle` bold)+       , (strikeThroughAttr,                defAttr `withStyle` strikethrough)+       , (dateTransitionAttr,               fg green)+       , (newMessageTransitionAttr,         black `on` yellow)+       , (errorMessageAttr,                 fg red)+       , (gapMessageAttr,                   fg red)+       , (helpAttr,                         fg black)+       , (pinnedMessageIndicatorAttr,       black `on` cyan)+       , (helpEmphAttr,                     fg blue `withStyle` bold)+       , (channelSelectMatchAttr,           black `on` magenta `withStyle` underline)+       , (channelSelectPromptAttr,          fg black)+       , (completionAlternativeListAttr,    white `on` blue)+       , (completionAlternativeCurrentAttr, black `on` yellow)+       , (dialogAttr,                       black `on` cyan)+       , (dialogEmphAttr,                   fg white)+       , (permalinkAttr,                    fg green)+       , (listSelectedFocusedAttr,          black `on` yellow)+       , (recentMarkerAttr,                 fg black `withStyle` bold)+       , (loadMoreAttr,                     black `on` cyan)+       , (urlListSelectedAttr,              black `on` yellow)+       , (messageSelectAttr,                black `on` yellow)+       , (messageSelectStatusAttr,          fg black)+       , (misspellingAttr,                  fg red `withStyle` underline)+       , (editedMarkingAttr,                fg yellow)+       , (editedRecentlyMarkingAttr,        black `on` yellow)+       , (tabSelectedAttr,                  black `on` yellow)+       , (focusedFormInputAttr,             black `on` yellow)+       , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue)+       , (FB.fileBrowserSelectionInfoAttr,  white `on` blue)+       , (FB.fileBrowserDirectoryAttr,      fg blue)+       , (FB.fileBrowserBlockDeviceAttr,    fg magenta)+       , (FB.fileBrowserCharacterDeviceAttr, fg green)+       , (FB.fileBrowserNamedPipeAttr,      fg yellow)+       , (FB.fileBrowserSymbolicLinkAttr,   fg cyan)+       , (FB.fileBrowserUnixSocketAttr,     fg red)+       ] <>+       ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..usernameColorHashBuckets-1] (cycle usernameColors)) <>+       (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty)++darkAttrs :: [Attr] -> [(AttrName, Attr)]+darkAttrs usernameColors =+  let sty = Sky.espresso+  in [ (timeAttr,                         fg white)+     , (buttonAttr,                       black `on` cyan)+     , (buttonFocusedAttr,                black `on` yellow)+     , (currentUserAttr,                  defAttr `withStyle` bold)+     , (channelHeaderAttr,                fg white)+     , (channelListHeaderAttr,            fg cyan)+     , (currentChannelNameAttr,           black `on` yellow `withStyle` bold)+     , (unreadChannelAttr,                black `on` cyan   `withStyle` bold)+     , (unreadGroupMarkerAttr,            fg white `withStyle` bold)+     , (mentionsChannelAttr,              black `on` brightMagenta `withStyle` bold)+     , (urlAttr,                          fg yellow)+     , (emailAttr,                        fg yellow)+     , (codeAttr,                         fg magenta)+     , (emojiAttr,                        fg yellow)+     , (channelNameAttr,                  fg cyan)+     , (pinnedMessageIndicatorAttr,       fg cyan `withStyle` bold)+     , (clientMessageAttr,                fg white)+     , (clientEmphAttr,                   fg white `withStyle` bold)+     , (clientStrongAttr,                 fg white `withStyle` bold `withStyle` underline)+     , (clientHeaderAttr,                 fg red `withStyle` bold)+     , (strikeThroughAttr,                defAttr `withStyle` strikethrough)+     , (dateTransitionAttr,               fg green)+     , (newMessageTransitionAttr,         fg yellow `withStyle` bold)+     , (errorMessageAttr,                 fg red)+     , (gapMessageAttr,                   black `on` yellow)+     , (helpAttr,                         fg white)+     , (helpEmphAttr,                     fg cyan `withStyle` bold)+     , (channelSelectMatchAttr,           black `on` magenta `withStyle` underline)+     , (channelSelectPromptAttr,          fg white)+     , (completionAlternativeListAttr,    white `on` blue)+     , (completionAlternativeCurrentAttr, black `on` yellow)+     , (dialogAttr,                       black `on` cyan)+     , (dialogEmphAttr,                   fg white)+     , (permalinkAttr,                    fg brightCyan)+     , (listSelectedFocusedAttr,          black `on` yellow)+     , (recentMarkerAttr,                 fg yellow `withStyle` bold)+     , (loadMoreAttr,                     black `on` cyan)+     , (urlListSelectedAttr,              black `on` yellow)+     , (messageSelectAttr,                black `on` yellow)+     , (messageSelectStatusAttr,          fg white)+     , (misspellingAttr,                  fg red `withStyle` underline)+     , (editedMarkingAttr,                fg yellow)+     , (editedRecentlyMarkingAttr,        black `on` yellow)+     , (tabSelectedAttr,                  black `on` yellow)+     , (focusedFormInputAttr,             black `on` yellow)+     , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue)+     , (FB.fileBrowserSelectionInfoAttr,  white `on` blue)+     , (FB.fileBrowserDirectoryAttr,      fg blue)+     , (FB.fileBrowserBlockDeviceAttr,    fg magenta)+     , (FB.fileBrowserCharacterDeviceAttr, fg green)+     , (FB.fileBrowserNamedPipeAttr,      fg yellow)+     , (FB.fileBrowserSymbolicLinkAttr,   fg cyan)+     , (FB.fileBrowserUnixSocketAttr,     fg red)+     ] <>+     ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..usernameColorHashBuckets-1] (cycle usernameColors)) <>+     (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty)++skipBaseCodeblockAttr :: (AttrName, Attr) -> Bool+skipBaseCodeblockAttr = ((/= highlightedCodeBlockAttr) . fst)++darkColorTheme :: InternalTheme+darkColorTheme = InternalTheme name theme desc+    where+        theme = newTheme def $ darkAttrs usernameColors16+        name = "builtin:dark"+        def = defAttr+        desc = "A color theme for terminal windows with dark background colors"++darkColor256Theme :: InternalTheme+darkColor256Theme = InternalTheme name theme desc+    where+        theme = newTheme def $ darkAttrs usernameColors256+        name = "builtin:dark256"+        def = defAttr+        desc = "Like builtin:dark, but with 256-color username colors"++usernameAttr :: Int -> AttrName+usernameAttr i = "username" <> (attrName $ show i)++-- | Render a string with a color chosen based on the text of a+-- username.+--+-- This function takes some display text and renders it using an+-- attribute based on the username associated with the text. If the+-- username associated with the text is equal to the username of+-- the user running Matterhorn, the display text is formatted with+-- 'currentAttr'. Otherwise it is formatted with an attribute chosen+-- by hashing the associated username and choosing from amongst the+-- username color hash buckets with 'usernameAttr'.+--+-- Usually the first argument to this function will be @myUsername st@,+-- where @st@ is a 'ChatState'.+--+-- The most common way to call this function is+--+-- @colorUsername (myUsername st) u u+--+-- The third argument is allowed to vary from the second since sometimes+-- we call this with the user's status sigil as the third argument.+colorUsername :: Text+              -- ^ The username for the user currently running+              -- Matterhorn+              -> Text+              -- ^ The username associated with the text to render+              -> Text+              -- ^ The text to render+              -> Widget a+colorUsername current username display =+    let aName = attrForUsername username+        maybeWithCurrentAttr = if current == username+                               then withAttr currentUserAttr+                               else id+    in withDefAttr aName $+       maybeWithCurrentAttr $+       txt (display)++-- | Return the attribute name to use for the specified username.+-- The input username is expected to be the username only (i.e. no+-- sigil).+--+-- If the input username is a special reserved username such as "all",+-- the @clientEmphAttr@ attribute name will be returned. Otherwise+-- a hash-bucket username attribute name will be returned based on+-- the hash value of the username and the number of hash buckets+-- (@usernameColorHashBuckets@).+attrForUsername :: Text+                -- ^ The username to get an attribute for+                -> AttrName+attrForUsername username =+    let normalizedUsername = T.toLower username+        aName = if normalizedUsername `elem` specialUserMentions+                then clientEmphAttr+                else usernameAttr h+        h = hash normalizedUsername `mod` usernameColorHashBuckets+    in aName++-- | The number of hash buckets to use when hashing usernames to choose+-- their colors.+usernameColorHashBuckets :: Int+usernameColorHashBuckets = 50++usernameColors16 :: [Attr]+usernameColors16 =+    [ fg red+    , fg green+    , fg yellow+    , fg blue+    , fg magenta+    , fg cyan+    , fg brightRed+    , fg brightGreen+    , fg brightYellow+    , fg brightBlue+    , fg brightMagenta+    , fg brightCyan+    ]++usernameColors256 :: [Attr]+usernameColors256 = mkColor <$> username256ColorChoices+    where+        mkColor (r, g, b) = defAttr `withForeColor` rgbColor r g b++username256ColorChoices :: [(Integer, Integer, Integer)]+username256ColorChoices =+    [ (255, 0, 86)+    , (158, 0, 142)+    , (14, 76, 161)+    , (255, 229, 2)+    , (149, 0, 58)+    , (255, 147, 126)+    , (164, 36, 0)+    , (98, 14, 0)+    , (0, 0, 255)+    , (106, 130, 108)+    , (0, 174, 126)+    , (194, 140, 159)+    , (0, 143, 156)+    , (95, 173, 78)+    , (255, 2, 157)+    , (255, 116, 163)+    , (152, 255, 82)+    , (167, 87, 64)+    , (254, 137, 0)+    , (1, 208, 255)+    , (187, 136, 0)+    , (117, 68, 177)+    , (165, 255, 210)+    , (122, 71, 130)+    , (0, 71, 84)+    , (181, 0, 255)+    , (144, 251, 146)+    , (189, 211, 147)+    , (229, 111, 254)+    , (222, 255, 116)+    , (0, 255, 120)+    , (0, 155, 255)+    , (0, 100, 1)+    , (0, 118, 255)+    , (133, 169, 0)+    , (0, 185, 23)+    , (120, 130, 49)+    , (0, 255, 198)+    , (255, 110, 65)+    ]++-- Functions for dealing with Skylighting styles++attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe Text+attrNameDescription td an = M.lookup an (themeDescriptions td)++themeDocs :: ThemeDocumentation+themeDocs = ThemeDocumentation $ M.fromList $+    [ ( timeAttr+      , "Timestamps on chat messages"+      )+    , ( channelHeaderAttr+      , "Channel headers displayed above chat message lists"+      )+    , ( channelListHeaderAttr+      , "The heading of the channel list sections"+      )+    , ( currentChannelNameAttr+      , "The currently selected channel in the channel list"+      )+    , ( unreadChannelAttr+      , "A channel in the channel list with unread messages"+      )+    , ( unreadGroupMarkerAttr+      , "The channel group marker indicating unread messages"+      )+    , ( mentionsChannelAttr+      , "A channel in the channel list with unread mentions"+      )+    , ( urlAttr+      , "A URL in a chat message"+      )+    , ( codeAttr+      , "A code block in a chat message with no language indication"+      )+    , ( emailAttr+      , "An e-mail address in a chat message"+      )+    , ( emojiAttr+      , "A text emoji indication in a chat message"+      )+    , ( channelNameAttr+      , "A channel name in a chat message"+      )+    , ( clientMessageAttr+      , "A Matterhorn diagnostic or informative message"+      )+    , ( clientHeaderAttr+      , "Markdown heading"+      )+    , ( strikeThroughAttr+      , "Markdown strikethrough text"+      )+    , ( clientEmphAttr+      , "Markdown 'emphasized' text"+      )+    , ( clientStrongAttr+      , "Markdown 'strong' text"+      )+    , ( dateTransitionAttr+      , "Date transition lines between chat messages on different days"+      )+    , ( pinnedMessageIndicatorAttr+      , "The indicator for messages that have been pinned"+      )+    , ( newMessageTransitionAttr+      , "The 'New Messages' line that appears above unread messages"+      )+    , ( tabSelectedAttr+      , "Selected tabs in tabbed windows"+      )+    , ( tabUnselectedAttr+      , "Unselected tabs in tabbed windows"+      )+    , ( errorMessageAttr+      , "Matterhorn error messages"+      )+    , ( gapMessageAttr+      , "Matterhorn message gap information"+      )+    , ( helpAttr+      , "The help screen text"+      )+    , ( helpEmphAttr+      , "The help screen's emphasized text"+      )+    , ( channelSelectPromptAttr+      , "Channel selection: prompt"+      )+    , ( channelSelectMatchAttr+      , "Channel selection: the portion of a channel name that matches"+      )+    , ( completionAlternativeListAttr+      , "Tab completion alternatives"+      )+    , ( completionAlternativeCurrentAttr+      , "The currently-selected tab completion alternative"+      )+    , ( permalinkAttr+      , "A post permalink"+      )+    , ( dialogAttr+      , "Dialog box text"+      )+    , ( dialogEmphAttr+      , "Dialog box emphasized text"+      )+    , ( recentMarkerAttr+      , "The marker indicating the channel last visited"+      )+    , ( replyParentAttr+      , "The first line of parent messages appearing above reply messages"+      )+    , ( loadMoreAttr+      , "The 'Load More' line that appears at the top of a chat message list"+      )+    , ( urlListSelectedAttr+      , "URL list: the selected URL"+      )+    , ( messageSelectAttr+      , "Message selection: the currently-selected message"+      )+    , ( messageSelectStatusAttr+      , "Message selection: the message selection actions"+      )+    , ( misspellingAttr+      , "A misspelled word in the chat message editor"+      )+    , ( editedMarkingAttr+      , "The 'edited' marking that appears on edited messages"+      )+    , ( editedRecentlyMarkingAttr+      , "The 'edited' marking that appears on newly-edited messages"+      )+    , ( highlightedCodeBlockAttr+      , "The base attribute for syntax-highlighted code blocks"+      )+    , ( attrNameForTokenType KeywordTok+      , "Syntax highlighting: Keyword"+      )+    , ( attrNameForTokenType DataTypeTok+      , "Syntax highlighting: DataType"+      )+    , ( attrNameForTokenType DecValTok+      , "Syntax highlighting: Declaration"+      )+    , ( attrNameForTokenType BaseNTok+      , "Syntax highlighting: BaseN"+      )+    , ( attrNameForTokenType FloatTok+      , "Syntax highlighting: Float"+      )+    , ( attrNameForTokenType ConstantTok+      , "Syntax highlighting: Constant"+      )+    , ( attrNameForTokenType CharTok+      , "Syntax highlighting: Char"+      )+    , ( attrNameForTokenType SpecialCharTok+      , "Syntax highlighting: Special Char"+      )+    , ( attrNameForTokenType StringTok+      , "Syntax highlighting: String"+      )+    , ( attrNameForTokenType VerbatimStringTok+      , "Syntax highlighting: Verbatim String"+      )+    , ( attrNameForTokenType SpecialStringTok+      , "Syntax highlighting: Special String"+      )+    , ( attrNameForTokenType ImportTok+      , "Syntax highlighting: Import"+      )+    , ( attrNameForTokenType CommentTok+      , "Syntax highlighting: Comment"+      )+    , ( attrNameForTokenType DocumentationTok+      , "Syntax highlighting: Documentation"+      )+    , ( attrNameForTokenType AnnotationTok+      , "Syntax highlighting: Annotation"+      )+    , ( attrNameForTokenType CommentVarTok+      , "Syntax highlighting: Comment"+      )+    , ( attrNameForTokenType OtherTok+      , "Syntax highlighting: Other"+      )+    , ( attrNameForTokenType FunctionTok+      , "Syntax highlighting: Function"+      )+    , ( attrNameForTokenType VariableTok+      , "Syntax highlighting: Variable"+      )+    , ( attrNameForTokenType ControlFlowTok+      , "Syntax highlighting: Control Flow"+      )+    , ( attrNameForTokenType OperatorTok+      , "Syntax highlighting: Operator"+      )+    , ( attrNameForTokenType BuiltInTok+      , "Syntax highlighting: Built-In"+      )+    , ( attrNameForTokenType ExtensionTok+      , "Syntax highlighting: Extension"+      )+    , ( attrNameForTokenType PreprocessorTok+      , "Syntax highlighting: Preprocessor"+      )+    , ( attrNameForTokenType AttributeTok+      , "Syntax highlighting: Attribute"+      )+    , ( attrNameForTokenType RegionMarkerTok+      , "Syntax highlighting: Region Marker"+      )+    , ( attrNameForTokenType InformationTok+      , "Syntax highlighting: Information"+      )+    , ( attrNameForTokenType WarningTok+      , "Syntax highlighting: Warning"+      )+    , ( attrNameForTokenType AlertTok+      , "Syntax highlighting: Alert"+      )+    , ( attrNameForTokenType ErrorTok+      , "Syntax highlighting: Error"+      )+    , ( attrNameForTokenType NormalTok+      , "Syntax highlighting: Normal text"+      )+    , ( listSelectedFocusedAttr+      , "The selected channel"+      )+    , ( focusedFormInputAttr+      , "A form input that has focus"+      )+    , ( FB.fileBrowserAttr+      , "The base file browser attribute"+      )+    , ( FB.fileBrowserCurrentDirectoryAttr+      , "The file browser current directory attribute"+      )+    , ( FB.fileBrowserSelectionInfoAttr+      , "The file browser selection information attribute"+      )+    , ( FB.fileBrowserDirectoryAttr+      , "Attribute for directories in the file browser"+      )+    , ( FB.fileBrowserBlockDeviceAttr+      , "Attribute for block devices in the file browser"+      )+    , ( FB.fileBrowserRegularFileAttr+      , "Attribute for regular files in the file browser"+      )+    , ( FB.fileBrowserCharacterDeviceAttr+      , "Attribute for character devices in the file browser"+      )+    , ( FB.fileBrowserNamedPipeAttr+      , "Attribute for named pipes in the file browser"+      )+    , ( FB.fileBrowserSymbolicLinkAttr+      , "Attribute for symbolic links in the file browser"+      )+    , ( FB.fileBrowserUnixSocketAttr+      , "Attribute for Unix sockets in the file browser"+      )+    , ( buttonAttr+      , "Attribute for input form buttons"+      )+    , ( buttonFocusedAttr+      , "Attribute for focused input form buttons"+      )+    , ( currentUserAttr+      , "Attribute for the username of the user running Matterhorn"+      )+    ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i)+         | i <- [0..usernameColorHashBuckets-1]+         ]
+ src/Matterhorn/TimeUtils.hs view
@@ -0,0 +1,70 @@+module Matterhorn.TimeUtils+    ( lookupLocalTimeZone+    , startOfDay+    , justAfter, justBefore+    , asLocalTime+    , localTimeText+    , originTime+    )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Text as T+import           Data.Time.Clock ( UTCTime(..) )+import           Data.Time.Format ( formatTime, defaultTimeLocale )+import           Data.Time.LocalTime ( LocalTime(..), TimeOfDay(..) )+import           Data.Time.LocalTime.TimeZone.Olson ( getTimeZoneSeriesFromOlsonFile )+import           Data.Time.LocalTime.TimeZone.Series ( localTimeToUTC'+                                                     , utcToLocalTime')++import           Network.Mattermost.Types ( ServerTime(..) )+++-- | Get the timezone series that should be used for converting UTC+-- times into local times with appropriate DST adjustments.+lookupLocalTimeZone :: IO TimeZoneSeries+lookupLocalTimeZone = getTimeZoneSeriesFromOlsonFile "/etc/localtime"+++-- | Sometimes it is convenient to render a divider between messages;+-- the 'justAfter' function can be used to get a time that is after+-- the input time but by such a small increment that there is unlikely+-- to be anything between (or at) the result.  Adding the divider+-- using this timestamp value allows the general sorting based on+-- timestamps to operate normally (whereas a type-match for a+-- non-timestamp-entry in the sort operation would be considerably+-- more complex).+justAfter :: ServerTime -> ServerTime+justAfter = ServerTime . justAfterUTC . withServerTime+    where justAfterUTC time = let UTCTime d t = time in UTCTime d (succ t)++-- | Obtain a time value that is just moments before the input time;+-- see the comment for the 'justAfter' function for more details.+justBefore :: ServerTime -> ServerTime+justBefore = ServerTime . justBeforeUTC . withServerTime+    where justBeforeUTC time = let UTCTime d t = time in UTCTime d (pred t)++-- | The timestamp for the start of the day associated with the input+-- timestamp.  If timezone information is supplied, then the returned+-- value will correspond to when the day started in that timezone;+-- otherwise it is the start of the day in a timezone aligned with+-- UTC.+startOfDay :: Maybe TimeZoneSeries -> UTCTime -> UTCTime+startOfDay Nothing time = let UTCTime d _ = time in UTCTime d 0+startOfDay (Just tz) time = let lt = utcToLocalTime' tz time+                                ls = LocalTime (localDay lt) (TimeOfDay 0 0 0)+                            in localTimeToUTC' tz ls++-- | Convert a UTC time value to a local time.+asLocalTime :: TimeZoneSeries -> UTCTime -> LocalTime+asLocalTime = utcToLocalTime'++-- | Local time in displayable format+localTimeText :: Text -> LocalTime -> Text+localTimeText fmt time = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) time++-- | Provides a time value that can be used when there are no other times available+originTime :: UTCTime+originTime = UTCTime (toEnum 0) 0
+ src/Matterhorn/Types.hs view
@@ -0,0 +1,2165 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+module Matterhorn.Types+  ( ConnectionStatus(..)+  , HelpTopic(..)+  , MessageSelectState(..)+  , ProgramOutput(..)+  , MHEvent(..)+  , InternalEvent(..)+  , Name(..)+  , ChannelSelectMatch(..)+  , StartupStateInfo(..)+  , MHError(..)+  , AttachmentData(..)+  , CPUUsagePolicy(..)+  , tabbedWindow+  , getCurrentTabbedWindowEntry+  , tabbedWindowNextTab+  , tabbedWindowPreviousTab+  , runTabShowHandlerFor+  , getServerBaseUrl+  , serverBaseUrl+  , TabbedWindow(..)+  , TabbedWindowEntry(..)+  , TabbedWindowTemplate(..)+  , ConnectionInfo(..)+  , SidebarUpdate(..)+  , PendingChannelChange(..)+  , ViewMessageWindowTab(..)+  , clearChannelUnreadStatus+  , ChannelListEntry(..)+  , ChannelListOrientation(..)+  , channelListEntryChannelId+  , channelListEntryUserId+  , userIdsFromZipper+  , entryIsDMEntry+  , ciHostname+  , ciPort+  , ciUrlPath+  , ciUsername+  , ciPassword+  , ciType+  , ciAccessToken+  , newChannelTopicDialog+  , ChannelTopicDialogState(..)+  , channelTopicDialogEditor+  , channelTopicDialogFocus+  , Config(..)+  , HelpScreen(..)+  , PasswordSource(..)+  , TokenSource(..)+  , MatchType(..)+  , Mode(..)+  , ChannelSelectPattern(..)+  , PostListContents(..)+  , AuthenticationException(..)+  , BackgroundInfo(..)+  , RequestChan+  , UserFetch(..)+  , writeBChan+  , InternalTheme(..)++  , attrNameToConfig++  , mkChannelZipperList+  , ChannelListGroup(..)+  , channelListGroupUnread++  , trimChannelSigil++  , ChannelSelectState(..)+  , channelSelectMatches+  , channelSelectInput+  , emptyChannelSelectState++  , ChatState+  , newState+  , csChannelTopicDialog+  , csChannelListOrientation+  , csResources+  , csFocus+  , csCurrentChannel+  , csCurrentChannelId+  , csUrlList+  , csShowMessagePreview+  , csShowChannelList+  , csShowExpandedChannelTopics+  , csPostMap+  , csRecentChannel+  , csReturnChannel+  , csThemeListOverlay+  , csPostListOverlay+  , csUserListOverlay+  , csChannelListOverlay+  , csReactionEmojiListOverlay+  , csMyTeam+  , csMessageSelect+  , csConnectionStatus+  , csWorkerIsBusy+  , csChannel+  , csChannels+  , csChannelSelectState+  , csEditState+  , csClientConfig+  , csPendingChannelChange+  , csViewedMessage+  , csNotifyPrefs+  , csMe+  , timeZone+  , whenMode+  , setMode+  , setMode'+  , appMode++  , ChatEditState+  , emptyEditState+  , cedAttachmentList+  , cedFileBrowser+  , cedYankBuffer+  , cedSpellChecker+  , cedMisspellings+  , cedEditMode+  , cedEphemeral+  , cedEditor+  , cedInputHistory+  , cedAutocomplete+  , cedAutocompletePending+  , cedJustCompleted++  , AutocompleteState(..)+  , acPreviousSearchString+  , acCompletionList+  , acCachedResponses+  , acType++  , AutocompletionType(..)++  , CompletionSource(..)+  , AutocompleteAlternative(..)+  , autocompleteAlternativeReplacement+  , SpecialMention(..)+  , specialMentionName+  , isSpecialMention++  , PostListOverlayState+  , postListSelected+  , postListPosts++  , UserSearchScope(..)+  , ChannelSearchScope(..)++  , ListOverlayState+  , listOverlaySearchResults+  , listOverlaySearchInput+  , listOverlaySearchScope+  , listOverlaySearching+  , listOverlayEnterHandler+  , listOverlayNewList+  , listOverlayFetchResults+  , listOverlayRecordCount+  , listOverlayReturnMode++  , getUsers++  , ChatResources(..)+  , crUserPreferences+  , crEventQueue+  , crTheme+  , crStatusUpdateChan+  , crSubprocessLog+  , crWebsocketActionChan+  , crWebsocketThreadId+  , crRequestQueue+  , crFlaggedPosts+  , crConn+  , crConfiguration+  , crSyntaxMap+  , crLogManager+  , crEmoji+  , getSession+  , getResourceSession++  , specialUserMentions++  , UserPreferences(UserPreferences)+  , userPrefShowJoinLeave+  , userPrefFlaggedPostList+  , userPrefGroupChannelPrefs+  , userPrefDirectChannelPrefs+  , userPrefTeammateNameDisplayMode+  , dmChannelShowPreference+  , groupChannelShowPreference++  , defaultUserPreferences+  , setUserPreferences++  , WebsocketAction(..)++  , Cmd(..)+  , commandName+  , CmdArgs(..)++  , MH+  , runMHEvent+  , scheduleUserFetches+  , scheduleUserStatusFetches+  , getScheduledUserFetches+  , getScheduledUserStatusFetches+  , mh+  , generateUUID+  , generateUUID_IO+  , mhSuspendAndResume+  , mhHandleEventLensed+  , St.gets+  , mhError++  , mhLog+  , mhGetIOLogger+  , ioLogWithManager+  , LogContext(..)+  , withLogContext+  , withLogContextChannelId+  , getLogContext+  , LogMessage(..)+  , LogCommand(..)+  , LogCategory(..)++  , LogManager(..)+  , startLoggingToFile+  , stopLoggingToFile+  , requestLogSnapshot+  , requestLogDestination+  , sendLogMessage++  , requestQuit+  , getMessageForPostId+  , getParentMessage+  , getReplyRootMessage+  , resetSpellCheckTimer+  , withChannel+  , withChannelOrDefault+  , userList+  , resetAutocomplete+  , hasUnread+  , hasUnread'+  , isMine+  , setUserStatus+  , myUser+  , myUsername+  , myUserId+  , myTeamId+  , usernameForUserId+  , userByUsername+  , userByNickname+  , channelIdByChannelName+  , channelIdByUsername+  , channelByName+  , userById+  , allUserIds+  , addNewUser+  , useNickname+  , useNickname'+  , displayNameForUserId+  , displayNameForUser+  , raiseInternalEvent+  , getNewMessageCutoff+  , getEditedMessageCutoff++  , HighlightSet(..)+  , UserSet+  , ChannelSet+  , getHighlightSet++  , module Matterhorn.Types.Channels+  , module Matterhorn.Types.Messages+  , module Matterhorn.Types.Posts+  , module Matterhorn.Types.Users+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Graphics.Vty as Vty+import qualified Brick+import           Brick ( EventM, Next, Widget )+import           Brick.Focus ( FocusRing, focusRing )+import           Brick.Themes ( Theme )+import           Brick.Main ( invalidateCache, invalidateCacheEntry )+import           Brick.AttrMap ( AttrMap )+import qualified Brick.BChan as BCH+import           Brick.Forms (Form)+import           Brick.Widgets.Edit ( Editor, editor )+import           Brick.Widgets.List ( List, list )+import qualified Brick.Widgets.FileBrowser as FB+import           Control.Concurrent ( ThreadId )+import           Control.Concurrent.Async ( Async )+import qualified Control.Concurrent.STM as STM+import           Control.Exception ( SomeException )+import qualified Control.Monad.Fail as MHF+import qualified Control.Monad.State as St+import qualified Control.Monad.Reader as R+import qualified Data.Set as Set+import qualified Data.ByteString as BS+import qualified Data.Foldable as F+import qualified Data.Kind as K+import           Data.Ord ( comparing )+import qualified Data.HashMap.Strict as HM+import           Data.List ( sortBy, nub, elemIndex )+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import           Data.Time.Clock ( getCurrentTime, addUTCTime )+import           Data.UUID ( UUID )+import qualified Data.Vector as Vec+import           Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=)+                                     , (%=), (^?), (.~)+                                     , _Just, Traversal', preuse, to+                                     , SimpleGetter+                                     )+import           Network.Connection ( HostNotResolved, HostCannotConnect )+import           Skylighting.Types ( SyntaxMap )+import           System.Exit ( ExitCode )+import           System.Random ( randomIO )+import           Text.Aspell ( Aspell )++import           Network.Mattermost ( ConnectionData )+import           Network.Mattermost.Exceptions+import           Network.Mattermost.Lenses+import           Network.Mattermost.Types+import           Network.Mattermost.Types.Config+import           Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse )++import           Matterhorn.Constants ( userSigil, normalChannelSigil )+import           Matterhorn.InputHistory+import           Matterhorn.Emoji+import           Matterhorn.Types.Common+import           Matterhorn.Types.Channels+import           Matterhorn.Types.DirectionalSeq ( emptyDirSeq )+import           Matterhorn.Types.KeyEvents+import           Matterhorn.Types.Messages+import           Matterhorn.Types.Posts+import           Matterhorn.Types.RichText ( TeamBaseURL(..), TeamURLName(..) )+import           Matterhorn.Types.Users+import qualified Matterhorn.Zipper as Z+++-- * Configuration++-- | A user password is either given to us directly, or a command+-- which we execute to find the password.+data PasswordSource =+    PasswordString Text+    | PasswordCommand Text+    deriving (Eq, Read, Show)++-- | An access token source.+data TokenSource =+    TokenString Text+    | TokenCommand Text+    deriving (Eq, Read, Show)++-- | The type of channel list group headings. Integer arguments indicate+-- total number of channels in the group that have unread activity.+data ChannelListGroup =+    ChannelGroupPublicChannels Int+    | ChannelGroupPrivateChannels Int+    | ChannelGroupDirectMessages Int+    deriving (Eq)++channelListGroupUnread :: ChannelListGroup -> Int+channelListGroupUnread (ChannelGroupPublicChannels n)  = n+channelListGroupUnread (ChannelGroupPrivateChannels n) = n+channelListGroupUnread (ChannelGroupDirectMessages n)  = n++-- | The type of channel list entries.+data ChannelListEntry =+    CLChannel ChannelId+    -- ^ A non-DM entry+    | CLUserDM ChannelId UserId+    -- ^ A single-user DM entry+    | CLGroupDM ChannelId+    -- ^ A multi-user DM entry+    deriving (Eq, Show)++-- | This is how we represent the user's configuration. Most fields+-- correspond to configuration file settings (see Config.hs) but some+-- are for internal book-keeping purposes only.+data Config =+    Config { configUser :: Maybe Text+           -- ^ The username to use when connecting.+           , configHost :: Maybe Text+           -- ^ The hostname to use when connecting.+           , configTeam :: Maybe Text+           -- ^ The team name to use when connecting.+           , configPort :: Int+           -- ^ The port to use when connecting.+           , configUrlPath :: Maybe Text+           -- ^ The server path to use when connecting.+           , configPass :: Maybe PasswordSource+           -- ^ The password source to use when connecting.+           , configToken :: Maybe TokenSource+           -- ^ The token source to use when connecting.+           , configTimeFormat :: Maybe Text+           -- ^ The format string for timestamps.+           , configDateFormat :: Maybe Text+           -- ^ The format string for dates.+           , configTheme :: Maybe Text+           -- ^ The name of the theme to use.+           , configThemeCustomizationFile :: Maybe Text+           -- ^ 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+           -- ^ Whether the URL-opening command is interactive (i.e.+           -- whether it should be given control of the terminal).+           , configActivityNotifyCommand :: Maybe T.Text+           -- ^ The command to run for activity notifications.+           , configActivityBell :: Bool+           -- ^ Whether to ring the terminal bell on activity.+           , configShowMessageTimestamps :: Bool+           -- ^ Whether to show timestamps on messages.+           , configShowBackground :: BackgroundInfo+           -- ^ Whether to show async background worker thread info.+           , configShowMessagePreview :: Bool+           -- ^ Whether to show the message preview area.+           , configShowChannelList :: Bool+           -- ^ Whether to show the channel list.+           , configShowExpandedChannelTopics :: Bool+           -- ^ Whether to show expanded channel topics.+           , configEnableAspell :: Bool+           -- ^ Whether to enable Aspell spell checking.+           , configAspellDictionary :: Maybe Text+           -- ^ A specific Aspell dictionary name to use.+           , configUnsafeUseHTTP :: Bool+           -- ^ Whether to permit an insecure HTTP connection.+           , configValidateServerCertificate :: Bool+           -- ^ Whether to validate TLS certificates.+           , configChannelListWidth :: Int+           -- ^ The width, in columns, of the channel list sidebar.+           , configLogMaxBufferSize :: Int+           -- ^ The maximum size, in log entries, of the internal log+           -- message buffer.+           , configShowOlderEdits :: Bool+           -- ^ Whether to highlight the edit indicator on edits made+           -- prior to the beginning of the current session.+           , configShowTypingIndicator :: Bool+           -- ^ Whether to show the typing indicator for other users,+           -- and whether to send typing notifications to other users.+           , configAbsPath :: Maybe FilePath+           -- ^ A book-keeping field for the absolute path to the+           -- configuration. (Not a user setting.)+           , configUserKeys :: KeyConfig+           -- ^ The user's keybinding configuration.+           , configHyperlinkingMode :: Bool+           -- ^ Whether to enable terminal hyperlinking mode.+           , configSyntaxDirs :: [FilePath]+           -- ^ The search path for syntax description XML files.+           , configDirectChannelExpirationDays :: Int+           -- ^ The number of days to show a user in the channel menu after a direct+           -- message with them.+           , configCpuUsagePolicy :: CPUUsagePolicy+           -- ^ The CPU usage policy for the application.+           , configDefaultAttachmentPath :: Maybe FilePath+           -- ^ The default path for browsing attachments+           , configChannelListOrientation :: ChannelListOrientation+           -- ^ The orientation of the channel list.+           } deriving (Eq, Show)++-- | The policy for CPU usage.+--+-- The idea is that Matterhorn can benefit from using multiple CPUs,+-- but the exact number is application-determined. We expose this policy+-- setting to the user in the configuration.+data CPUUsagePolicy =+    SingleCPU+    -- ^ Constrain the application to use one CPU.+    | MultipleCPUs+    -- ^ Permit the usage of multiple CPUs (the exact number is+    -- determined by the application).+    deriving (Eq, Show)++-- | The state of the UI diagnostic indicator for the async worker+-- thread.+data BackgroundInfo =+    Disabled+    -- ^ Disable (do not show) the indicator.+    | Active+    -- ^ Show the indicator when the thread is working.+    | ActiveCount+    -- ^ Show the indicator when the thread is working, but include the+    -- thread's work queue length.+    deriving (Eq, Show)++data UserPreferences =+    UserPreferences { _userPrefShowJoinLeave     :: Bool+                    , _userPrefFlaggedPostList   :: Seq FlaggedPost+                    , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool+                    , _userPrefDirectChannelPrefs :: HashMap UserId Bool+                    , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode+                    }++hasUnread :: ChatState -> ChannelId -> Bool+hasUnread st cId = fromMaybe False $+    hasUnread' <$> findChannelById cId (_csChannels st)++hasUnread' :: ClientChannel -> Bool+hasUnread' chan = fromMaybe False $ do+    let info = _ccInfo chan+    lastViewTime <- _cdViewed info+    return $ _cdMentionCount info > 0 ||+             (not (isMuted chan) &&+              (((_cdUpdated info) > lastViewTime) ||+               (isJust $ _cdEditedMessageThreshold info)))++mkChannelZipperList :: UTCTime+                    -> Config+                    -> Maybe ClientConfig+                    -> UserPreferences+                    -> ClientChannels+                    -> Users+                    -> [(ChannelListGroup, [ChannelListEntry])]+mkChannelZipperList now config cconfig prefs cs us =+    [ let (unread, entries) = getChannelEntriesInOrder cs Ordinary+      in (ChannelGroupPublicChannels unread, entries)+    , let (unread, entries) = getChannelEntriesInOrder cs Private+      in (ChannelGroupPrivateChannels unread, entries)+    , let (unread, entries) = getDMChannelEntriesInOrder now config cconfig prefs us cs+      in (ChannelGroupDirectMessages unread, entries)+    ]++getChannelEntriesInOrder :: ClientChannels -> Type -> (Int, [ChannelListEntry])+getChannelEntriesInOrder cs ty =+    let matches (_, info) = info^.ccInfo.cdType == ty+        pairs = filteredChannels matches cs+        unread = length $ filter (== True) $ (hasUnread' . snd) <$> pairs+        entries = fmap (CLChannel . fst) $+                  sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) pairs+    in (unread, entries)++getDMChannelEntriesInOrder :: UTCTime+                           -> Config+                           -> Maybe ClientConfig+                           -> UserPreferences+                           -> Users+                           -> ClientChannels+                           -> (Int, [ChannelListEntry])+getDMChannelEntriesInOrder now config cconfig prefs us cs =+    let oneOnOneDmChans = getDMChannelEntries now config cconfig prefs us cs+        groupChans = getGroupDMChannelEntries now config prefs cs+        allDmChans = groupChans <> oneOnOneDmChans+        sorter (u1, n1, _) (u2, n2, _) =+            if u1 == u2+            then compare n1 n2+            else if u1 && not u2+                 then LT+                 else GT+        sorted = sortBy sorter allDmChans+        third (_, _, c) = c+        fst3 (a, _, _) = a+        unread = length $ filter id $ fst3 <$> sorted+    in (unread, third <$> sorted)++useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool+useNickname' clientConfig prefs =+    let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of+            Just TMNicknameOrFullname -> Just True+            _                         -> Nothing+        accountSetting = (== TMNicknameOrFullname) <$> (_userPrefTeammateNameDisplayMode prefs)+        fallback = False+    in fromMaybe fallback $ accountSetting <|> serverSetting++displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text+displayNameForUser u clientConfig prefs+    | useNickname' clientConfig prefs =+        fromMaybe (u^.uiName) (u^.uiNickName)+    | otherwise =+        u^.uiName++getGroupDMChannelEntries :: UTCTime+                         -> Config+                         -> UserPreferences+                         -> ClientChannels+                         -> [(Bool, T.Text, ChannelListEntry)]+getGroupDMChannelEntries now config prefs cs =+    let matches (_, info) = info^.ccInfo.cdType == Group &&+                            groupChannelShouldAppear now config prefs info+    in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdDisplayName, CLGroupDM cId)) $+       filteredChannels matches cs++getDMChannelEntries :: UTCTime+                    -> Config+                    -> Maybe ClientConfig+                    -> UserPreferences+                    -> Users+                    -> ClientChannels+                    -> [(Bool, T.Text, ChannelListEntry)]+getDMChannelEntries now config cconfig prefs us cs =+    let mapping = allDmChannelMappings cs+        mappingWithUserInfo = catMaybes $ getInfo <$> mapping+        getInfo (uId, cId) = do+            c <- findChannelById cId cs+            u <- findUserById uId us+            case u^.uiDeleted of+                True -> Nothing+                False ->+                    if dmChannelShouldAppear now config prefs c+                    then return (hasUnread' c, displayNameForUser u cconfig prefs, CLUserDM cId uId)+                    else Nothing+    in mappingWithUserInfo++-- Always show a DM channel if it has unread activity.+--+-- If it has no unread activity and if the preferences explicitly say to+-- hide it, hide it.+--+-- Otherwise, only show it if at least one of the other conditions are+-- met (see 'or' below).+dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool+dmChannelShouldAppear now config prefs c =+    let ndays = configDirectChannelExpirationDays config+        localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now+        cutoff = ServerTime localCutoff+        updated = c^.ccInfo.cdUpdated+        Just uId = c^.ccInfo.cdDMUserId+    in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)+       then True+       else case dmChannelShowPreference prefs uId of+           Just False -> False+           _ -> or [+                   -- The channel was updated recently enough+                     updated >= cutoff+                   ]++groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool+groupChannelShouldAppear now config prefs c =+    let ndays = configDirectChannelExpirationDays config+        localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now+        cutoff = ServerTime localCutoff+        updated = c^.ccInfo.cdUpdated+    in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)+       then True+       else case groupChannelShowPreference prefs (c^.ccInfo.cdChannelId) of+           Just False -> False+           _ -> or [+                   -- The channel was updated recently enough+                     updated >= cutoff+                   ]++dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool+dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps)++groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool+groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps)++-- * Internal Names and References++-- | This 'Name' type is the type used in 'brick' to identify various+-- parts of the interface.+data Name =+    ChannelMessages ChannelId+    | MessageInput+    | ChannelList+    | HelpViewport+    | HelpText+    | ScriptHelpText+    | ThemeHelpText+    | SyntaxHighlightHelpText+    | KeybindingHelpText+    | ChannelSelectString+    | CompletionAlternatives+    | CompletionList+    | JoinChannelList+    | UrlList+    | MessagePreviewViewport+    | ThemeListSearchInput+    | UserListSearchInput+    | JoinChannelListSearchInput+    | UserListSearchResults+    | ThemeListSearchResults+    | ViewMessageArea+    | ViewMessageReactionsArea+    | ChannelSidebar+    | ChannelSelectInput+    | AttachmentList+    | AttachmentFileBrowser+    | MessageReactionsArea+    | ReactionEmojiList+    | ReactionEmojiListInput+    | TabbedWindowTabBar+    | MuteToggleField+    | ChannelMentionsField+    | DesktopNotificationsField (WithDefault NotifyOption)+    | PushNotificationsField (WithDefault NotifyOption)+    | ChannelTopicEditor+    | ChannelTopicSaveButton+    | ChannelTopicCancelButton+    | ChannelTopicEditorPreview+    deriving (Eq, Show, Ord)++-- | The sum type of exceptions we expect to encounter on authentication+-- failure. We encode them explicitly here so that we can print them in+-- a more user-friendly manner than just 'show'.+data AuthenticationException =+    ConnectError HostCannotConnect+    | ResolveError HostNotResolved+    | AuthIOError IOError+    | LoginError LoginFailureException+    | OtherAuthError SomeException+    deriving (Show)++-- | Our 'ConnectionInfo' contains exactly as much information as is+-- necessary to start a connection with a Mattermost server. This is+-- built up during interactive authentication and then is used to log+-- in.+--+-- If the access token field is non-empty, that value is used and the+-- username and password values are ignored.+data ConnectionInfo =+    ConnectionInfo { _ciHostname :: Text+                   , _ciPort     :: Int+                   , _ciUrlPath  :: Text+                   , _ciUsername :: Text+                   , _ciPassword :: Text+                   , _ciAccessToken :: Text+                   , _ciType     :: ConnectionType+                   }++-- | We want to continue referring to posts by their IDs, but we don't+-- want to have to synthesize new valid IDs for messages from the client+-- itself (like error messages or informative client responses). To that+-- end, a PostRef can be either a PostId or a newly-generated client ID.+data PostRef+    = MMId PostId+    | CLId Int+    deriving (Eq, Show)++-- ** Channel-matching types++-- | A match in channel selection mode.+data ChannelSelectMatch =+    ChannelSelectMatch { nameBefore :: Text+                       -- ^ The content of the match before the user's+                       -- matching input.+                       , nameMatched :: Text+                       -- ^ The potion of the name that matched the+                       -- user's input.+                       , nameAfter :: Text+                       -- ^ The portion of the name that came after the+                       -- user's matching input.+                       , matchFull :: Text+                       -- ^ The full string for this entry so it doesn't+                       -- have to be reassembled from the parts above.+                       , matchEntry :: ChannelListEntry+                       -- ^ The original entry data corresponding to the+                       -- text match.+                       }+                       deriving (Eq, Show)++data ChannelSelectPattern = CSP MatchType Text+                          | CSPAny+                          deriving (Eq, Show)++data MatchType =+    Prefix+    | Suffix+    | Infix+    | Equal+    | PrefixDMOnly+    | PrefixNonDMOnly+    deriving (Eq, Show)++-- * Application State Values++data ProgramOutput =+    ProgramOutput { program :: FilePath+                  , programArgs :: [String]+                  , programStdout :: String+                  , programStderr :: String+                  , programExitCode :: ExitCode+                  }++defaultUserPreferences :: UserPreferences+defaultUserPreferences =+    UserPreferences { _userPrefShowJoinLeave     = True+                    , _userPrefFlaggedPostList   = mempty+                    , _userPrefGroupChannelPrefs = mempty+                    , _userPrefDirectChannelPrefs = mempty+                    , _userPrefTeammateNameDisplayMode = Nothing+                    }++setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences+setUserPreferences = flip (F.foldr go)+    where go p u+            | Just fp <- preferenceToFlaggedPost p =+              u { _userPrefFlaggedPostList =+                  _userPrefFlaggedPostList u Seq.|> fp+                }+            | Just gp <- preferenceToDirectChannelShowStatus p =+              u { _userPrefDirectChannelPrefs =+                  HM.insert+                    (directChannelShowUserId gp)+                    (directChannelShowValue gp)+                    (_userPrefDirectChannelPrefs u)+                }+            | Just gp <- preferenceToGroupChannelPreference p =+              u { _userPrefGroupChannelPrefs =+                  HM.insert+                    (groupChannelId gp)+                    (groupChannelShow gp)+                    (_userPrefGroupChannelPrefs u)+                }+            | preferenceName p == PreferenceName "join_leave" =+              u { _userPrefShowJoinLeave =+                  preferenceValue p /= PreferenceValue "false" }+            | preferenceCategory p == PreferenceCategoryDisplaySettings &&+              preferenceName p == PreferenceName "name_format" =+                  let PreferenceValue txt = preferenceValue p+                  in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt }+            | otherwise = u++-- | Log message tags.+data LogCategory =+    LogGeneral+    | LogAPI+    | LogWebsocket+    | LogError+    | LogUserMark+    deriving (Eq, Show)++-- | A log message.+data LogMessage =+    LogMessage { logMessageText :: !Text+               -- ^ The text of the log message.+               , logMessageContext :: !(Maybe LogContext)+               -- ^ The optional context information relevant to the log+               -- message.+               , logMessageCategory :: !LogCategory+               -- ^ The category of the log message.+               , logMessageTimestamp :: !UTCTime+               -- ^ The timestamp of the log message.+               }+               deriving (Eq, Show)++-- | A logging thread command.+data LogCommand =+    LogToFile FilePath+    -- ^ Start logging to the specified path.+    | LogAMessage !LogMessage+    -- ^ Log the specified message.+    | StopLogging+    -- ^ Stop any active logging.+    | ShutdownLogging+    -- ^ Shut down.+    | GetLogDestination+    -- ^ Ask the logging thread about its active logging destination.+    | LogSnapshot FilePath+    -- ^ Ask the logging thread to dump the current buffer to the+    -- specified destination.+    deriving (Show)++-- | A handle to the log manager thread.+data LogManager =+    LogManager { logManagerCommandChannel :: STM.TChan LogCommand+               , logManagerHandle :: Async ()+               }++startLoggingToFile :: LogManager -> FilePath -> IO ()+startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc++stopLoggingToFile :: LogManager -> IO ()+stopLoggingToFile mgr = sendLogCommand mgr StopLogging++requestLogSnapshot :: LogManager -> FilePath -> IO ()+requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path++requestLogDestination :: LogManager -> IO ()+requestLogDestination mgr = sendLogCommand mgr GetLogDestination++sendLogMessage :: LogManager -> LogMessage -> IO ()+sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm++sendLogCommand :: LogManager -> LogCommand -> IO ()+sendLogCommand mgr c =+    STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c++-- | 'ChatResources' represents configuration and connection-related+-- information, as opposed to current model or view information.+-- Information that goes in the 'ChatResources' value should be limited+-- to information that we read or set up prior to setting up the bulk of+-- the application state.+data ChatResources =+    ChatResources { _crSession             :: Session+                  , _crWebsocketThreadId   :: Maybe ThreadId+                  , _crConn                :: ConnectionData+                  , _crRequestQueue        :: RequestChan+                  , _crEventQueue          :: BCH.BChan MHEvent+                  , _crSubprocessLog       :: STM.TChan ProgramOutput+                  , _crWebsocketActionChan :: STM.TChan WebsocketAction+                  , _crTheme               :: AttrMap+                  , _crStatusUpdateChan    :: STM.TChan [UserId]+                  , _crConfiguration       :: Config+                  , _crFlaggedPosts        :: Set PostId+                  , _crUserPreferences     :: UserPreferences+                  , _crSyntaxMap           :: SyntaxMap+                  , _crLogManager          :: LogManager+                  , _crEmoji               :: EmojiCollection+                  }++-- | A "special" mention that does not map to a specific user, but is an+-- alias that the server uses to notify users.+data SpecialMention =+    MentionAll+    -- ^ @all: notify everyone in the channel.+    | MentionChannel+    -- ^ @channel: notify everyone in the channel.++data AutocompleteAlternative =+    UserCompletion User Bool+    -- ^ User, plus whether the user is in the channel that triggered+    -- the autocomplete+    | SpecialMention SpecialMention+    -- ^ A special mention.+    | ChannelCompletion Bool Channel+    -- ^ Channel, plus whether the user is a member of the channel+    | SyntaxCompletion Text+    -- ^ Name of a skylighting syntax definition+    | CommandCompletion CompletionSource Text Text Text+    -- ^ Source, name of a slash command, argspec, and description+    | EmojiCompletion Text+    -- ^ The text of an emoji completion++-- | The source of an autocompletion alternative.+data CompletionSource = Server | Client+                      deriving (Eq, Show)++specialMentionName :: SpecialMention -> Text+specialMentionName MentionChannel = "channel"+specialMentionName MentionAll = "all"++isSpecialMention :: T.Text -> Bool+isSpecialMention n = isJust $ lookup (T.toLower $ trimUserSigil n) pairs+    where+        pairs = mkPair <$> mentions+        mentions = [ MentionChannel+                   , MentionAll+                   ]+        mkPair v = (specialMentionName v, v)++autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text+autocompleteAlternativeReplacement (EmojiCompletion e) =+    ":" <> e <> ":"+autocompleteAlternativeReplacement (SpecialMention m) =+    userSigil <> specialMentionName m+autocompleteAlternativeReplacement (UserCompletion u _) =+    userSigil <> userUsername u+autocompleteAlternativeReplacement (ChannelCompletion _ c) =+    normalChannelSigil <> (sanitizeUserText $ channelName c)+autocompleteAlternativeReplacement (SyntaxCompletion t) =+    "```" <> t+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+                      -- currently-displayed autocomplete results, for+                      -- use in deciding whether to issue another server+                      -- query+                      , _acCompletionList :: List Name AutocompleteAlternative+                      -- ^ The list of alternatives that the user+                      -- selects from+                      , _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.+                      -- The idea here is that users type quickly enough+                      -- (and edit their input) that would normally lead+                      -- to rapid consecutive requests, some for the+                      -- same strings during editing, that we can avoid+                      -- that by caching them here. Note that this cache+                      -- gets destroyed whenever autocompletion is not+                      -- on, so this cache does not live very long.+                      }++-- | The 'ChatEditState' value contains the editor widget itself as well+-- as history and metadata we need for editing-related operations.+data ChatEditState =+    ChatEditState { _cedEditor :: Editor Text Name+                  , _cedEditMode :: EditMode+                  , _cedEphemeral :: EphemeralEditState+                  , _cedInputHistory :: InputHistory+                  -- ^ The map of per-channel input history for the+                  -- application. We don't distribute the per-channel+                  -- history into the per-channel states (like we do+                  -- for other per-channel state) since keeping it+                  -- under the InputHistory banner lets us use a nicer+                  -- startup/shutdown disk file management API.+                  , _cedYankBuffer :: Text+                  , _cedSpellChecker :: Maybe (Aspell, IO ())+                  , _cedMisspellings :: Set Text+                  , _cedAutocomplete :: Maybe AutocompleteState+                  -- ^ The autocomplete state. The autocompletion UI is+                  -- showing only when this state is present.+                  , _cedAutocompletePending :: Maybe Text+                  -- ^ The search string associated with the latest+                  -- in-flight autocompletion request. This is used to+                  -- determine whether any (potentially late-arriving)+                  -- API responses are for stale queries since the user+                  -- can type more quickly than the server can get us+                  -- the results, and we wouldn't want to show results+                  -- associated with old editor states.+                  , _cedAttachmentList :: List Name AttachmentData+                  -- ^ The list of attachments to be uploaded with the+                  -- post being edited.+                  , _cedFileBrowser :: Maybe (FB.FileBrowser Name)+                  -- ^ The browser for selecting attachment files.+                  -- This is a Maybe because the instantiation of the+                  -- 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.+data AttachmentData =+    AttachmentData { attachmentDataFileInfo :: FB.FileInfo+                   , attachmentDataBytes :: BS.ByteString+                   }+                   deriving (Eq, Show)++-- | We can initialize a new 'ChatEditState' value with just an edit+-- history, which we save locally.+emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState+emptyEditState hist sp =+    return ChatEditState { _cedEditor               = editor MessageInput Nothing ""+                         , _cedEphemeral            = defaultEphemeralEditState+                         , _cedInputHistory         = hist+                         , _cedEditMode             = NewPost+                         , _cedYankBuffer           = ""+                         , _cedSpellChecker         = sp+                         , _cedMisspellings         = mempty+                         , _cedAutocomplete         = Nothing+                         , _cedAutocompletePending  = Nothing+                         , _cedAttachmentList       = list AttachmentList mempty 1+                         , _cedFileBrowser          = Nothing+                         , _cedJustCompleted        = False+                         }++-- | A 'RequestChan' is a queue of operations we have to perform in the+-- background to avoid blocking on the main loop+type RequestChan = STM.TChan (IO (Maybe (MH ())))++-- | The 'HelpScreen' type represents the set of possible 'Help'+-- dialogues we have to choose from.+data HelpScreen =+    MainHelp+    | ScriptHelp+    | ThemeHelp+    | SyntaxHighlightHelp+    | KeybindingHelp+    deriving (Eq)++-- | Help topics+data HelpTopic =+    HelpTopic { helpTopicName         :: Text+              , helpTopicDescription  :: Text+              , helpTopicScreen       :: HelpScreen+              , helpTopicViewportName :: Name+              }+              deriving (Eq)++-- | Mode type for the current contents of the post list overlay+data PostListContents =+    PostListFlagged+    | PostListPinned ChannelId+    | PostListSearch Text Bool -- for the query and search status+    deriving (Eq)++-- | The 'Mode' represents the current dominant UI activity+data Mode =+    Main+    | ShowHelp HelpTopic Mode+    | ChannelSelect+    | UrlSelect+    | LeaveChannelConfirm+    | DeleteChannelConfirm+    | MessageSelect+    | MessageSelectDeleteConfirm+    | PostListOverlay PostListContents+    | UserListOverlay+    | ReactionEmojiListOverlay+    | ChannelListOverlay+    | ThemeListOverlay+    | ViewMessage+    | ManageAttachments+    | ManageAttachmentsBrowseFiles+    | EditNotifyPrefs+    | ChannelTopicWindow+    deriving (Eq)++-- | We're either connected or we're not.+data ConnectionStatus = Connected | Disconnected deriving (Eq)++-- | An entry in a tabbed window corresponding to a tab and its content.+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindowEntry a =+    TabbedWindowEntry { tweValue :: a+                      -- ^ The handle for this tab.+                      , tweRender :: a -> ChatState -> Widget Name+                      -- ^ The rendering function to use when this tab+                      -- is selected.+                      , tweHandleEvent :: a -> Vty.Event -> MH ()+                      -- ^ The event-handling function to use when this+                      -- tab is selected.+                      , tweTitle :: a -> Bool -> T.Text+                      -- ^ Title function for this tab, with a boolean+                      -- indicating whether this is the current tab.+                      , tweShowHandler :: a -> MH ()+                      -- ^ A handler to be invoked when this tab is+                      -- shown.+                      }++-- | The definition of a tabbed window. Note that this does not track+-- the *state* of the window; it merely provides a collection of tab+-- window entries (see above). To track the state of a tabbed window,+-- use a TabbedWindow.+--+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindowTemplate a =+    TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a]+                         -- ^ The entries in tabbed windows with this+                         -- structure.+                         , twtTitle :: a -> Widget Name+                         -- ^ The title-rendering function for this kind+                         -- of tabbed window.+                         }++-- | An instantiated tab window. This is based on a template and tracks+-- the state of the tabbed window (current tab).+--+-- Parameterized over an abstract handle type ('a') for the tabs so we+-- can give each a unique handle.+data TabbedWindow a =+    TabbedWindow { twValue :: a+                 -- ^ The handle of the currently-selected tab.+                 , twReturnMode :: Mode+                 -- ^ The mode to return to when the tab is closed.+                 , twTemplate :: TabbedWindowTemplate a+                 -- ^ The template to use as a basis for rendering the+                 -- window and handling user input.+                 , twWindowWidth :: Int+                 , twWindowHeight :: Int+                 -- ^ Window dimensions+                 }++-- | Construct a new tabbed window from a template. This will raise an+-- exception if the initially-selected tab does not exist in the window+-- template, or if the window template has any duplicated tab handles.+--+-- Note that the caller is responsible for determining whether to call+-- the initially-selected tab's on-show handler.+tabbedWindow :: (Show a, Eq a)+             => a+             -- ^ The handle corresponding to the tab that should be+             -- selected initially.+             -> TabbedWindowTemplate a+             -- ^ The template for the window to construct.+             -> Mode+             -- ^ When the window is closed, return to this application+             -- mode.+             -> (Int, Int)+             -- ^ The window dimensions (width, height).+             -> TabbedWindow a+tabbedWindow initialVal t retMode (width, height) =+    let handles = tweValue <$> twtEntries t+    in if | null handles ->+              error "BUG: tabbed window template must provide at least one entry"+          | length handles /= length (nub handles) ->+              error "BUG: tabbed window should have one entry per handle"+          | not (initialVal `elem` handles) ->+              error $ "BUG: tabbed window handle " <>+                      show initialVal <> " not present in template"+          | otherwise ->+              TabbedWindow { twTemplate = t+                           , twValue = initialVal+                           , twReturnMode = retMode+                           , twWindowWidth = width+                           , twWindowHeight = height+                           }++-- | Get the currently-selected tab entry for a tabbed window. Raise+-- an exception if the window's selected tab handle is not found in its+-- template (which is a bug in the tabbed window infrastructure).+getCurrentTabbedWindowEntry :: (Show a, Eq a)+                            => TabbedWindow a+                            -> TabbedWindowEntry a+getCurrentTabbedWindowEntry w =+    lookupTabbedWindowEntry (twValue w) w++-- | Run the on-show handler for the window tab entry with the specified+-- handle.+runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH ()+runTabShowHandlerFor handle w = do+    let entry = lookupTabbedWindowEntry handle w+    tweShowHandler entry handle++-- | Look up a tabbed window entry by handle. Raises an exception if no+-- such entry exists.+lookupTabbedWindowEntry :: (Eq a, Show a)+                        => a+                        -> TabbedWindow a+                        -> TabbedWindowEntry a+lookupTabbedWindowEntry handle w =+    let matchesVal e = tweValue e == handle+    in case filter matchesVal (twtEntries $ twTemplate w) of+        [e] -> e+        _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <>+                     " should have matched a single entry"++-- | Switch a tabbed window's selected tab to its next tab, cycling back+-- to the first tab if the last tab is the selected tab. This also+-- invokes the on-show handler for the newly-selected tab.+--+-- Note that this does nothing if the window has only one tab.+tabbedWindowNextTab :: (Show a, Eq a)+                    => TabbedWindow a+                    -> MH (TabbedWindow a)+tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w+tabbedWindowNextTab w = do+    let curIdx = case elemIndex (tweValue curEntry) allHandles of+            Nothing ->+                error $ "BUG: tabbedWindowNextTab: could not find " <>+                        "current handle in handle list"+            Just i -> i+        nextIdx = if curIdx == length allHandles - 1+                  then 0+                  else curIdx + 1+        newHandle = allHandles !! nextIdx+        allHandles = tweValue <$> twtEntries (twTemplate w)+        curEntry = getCurrentTabbedWindowEntry w+        newWin = w { twValue = newHandle }++    runTabShowHandlerFor newHandle newWin+    return newWin++-- | Switch a tabbed window's selected tab to its previous tab, cycling+-- to the last tab if the first tab is the selected tab. This also+-- invokes the on-show handler for the newly-selected tab.+--+-- Note that this does nothing if the window has only one tab.+tabbedWindowPreviousTab :: (Show a, Eq a)+                        => TabbedWindow a+                        -> MH (TabbedWindow a)+tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w+tabbedWindowPreviousTab w = do+    let curIdx = case elemIndex (tweValue curEntry) allHandles of+            Nothing ->+                error $ "BUG: tabbedWindowPreviousTab: could not find " <>+                        "current handle in handle list"+            Just i -> i+        nextIdx = if curIdx == 0+                  then length allHandles - 1+                  else curIdx - 1+        newHandle = allHandles !! nextIdx+        allHandles = tweValue <$> twtEntries (twTemplate w)+        curEntry = getCurrentTabbedWindowEntry w+        newWin = w { twValue = newHandle }++    runTabShowHandlerFor newHandle newWin+    return newWin++data ChannelListOrientation =+    ChannelListLeft+    -- ^ Show the channel list to the left of the message area.+    | ChannelListRight+    -- ^ Show the channel list to the right of the message area.+    deriving (Eq, Show)++-- | This is the giant bundle of fields that represents the current+-- state of our application at any given time.+data ChatState =+    ChatState { _csResources :: ChatResources+              -- ^ Global application-wide resources that don't change+              -- much.+              , _csFocus :: Z.Zipper ChannelListGroup ChannelListEntry+              -- ^ The channel sidebar zipper that tracks which channel+              -- is selected.+              , _csChannelListOrientation :: ChannelListOrientation+              -- ^ The orientation of the channel list.+              , _csMe :: User+              -- ^ The authenticated user.+              , _csMyTeam :: Team+              -- ^ The active team of the authenticated user.+              , _csChannels :: ClientChannels+              -- ^ The channels that we are showing, including their+              -- message lists.+              , _csPostMap :: HashMap PostId Message+              -- ^ The map of post IDs to messages. This allows us to+              -- access messages by ID without having to linearly scan+              -- channel message lists.+              , _csUsers :: Users+              -- ^ All of the users we know about.+              , _timeZone :: TimeZoneSeries+              -- ^ The client time zone.+              , _csEditState :: ChatEditState+              -- ^ The state of the input box used for composing and+              -- editing messages and commands.+              , _csMode :: Mode+              -- ^ The current application mode. This is used to+              -- dispatch to different rendering and event handling+              -- routines.+              , _csShowMessagePreview :: Bool+              -- ^ Whether to show the message preview area.+              , _csShowChannelList :: Bool+              -- ^ Whether to show the channel list.+              , _csShowExpandedChannelTopics :: Bool+              -- ^ Whether to show expanded channel topics.+              , _csChannelSelectState :: ChannelSelectState+              -- ^ The state of the user's input and selection for+              -- channel selection mode.+              , _csRecentChannel :: Maybe ChannelId+              -- ^ The most recently-selected channel, if any.+              , _csReturnChannel :: Maybe ChannelId+              -- ^ The channel to return to after visiting one or more+              -- unread channels.+              , _csUrlList :: List Name LinkChoice+              -- ^ The URL list used to show URLs drawn from messages in+              -- a channel.+              , _csConnectionStatus :: ConnectionStatus+              -- ^ Our view of the connection status.+              , _csWorkerIsBusy :: Maybe (Maybe Int)+              -- ^ Whether the async worker thread is busy, and its+              -- queue length if so.+              , _csMessageSelect :: MessageSelectState+              -- ^ The state of message selection mode.+              , _csThemeListOverlay :: ListOverlayState InternalTheme ()+              -- ^ The state of the theme list overlay.+              , _csPostListOverlay :: PostListOverlayState+              -- ^ The state of the post list overlay.+              , _csUserListOverlay :: ListOverlayState UserInfo UserSearchScope+              -- ^ The state of the user list overlay.+              , _csChannelListOverlay :: ListOverlayState Channel ChannelSearchScope+              -- ^ The state of the user list overlay.+              , _csReactionEmojiListOverlay :: ListOverlayState (Bool, T.Text) ()+              -- ^ The state of the reaction emoji list overlay.+              , _csClientConfig :: Maybe ClientConfig+              -- ^ The Mattermost client configuration, as we understand it.+              , _csPendingChannelChange :: Maybe PendingChannelChange+              -- ^ A pending channel change that we need to apply once+              -- the channel in question is available. We set this up+              -- when we need to change to a channel in the sidebar, but+              -- it isn't even there yet because we haven't loaded its+              -- metadata.+              , _csViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab)+              -- ^ Set when the ViewMessage mode is active. The message+              -- being viewed. Note that this stores a message, not+              -- a message ID. That's because not all messages have+              -- message IDs (e.g. client messages) and we still+              -- want to support viewing of those messages. It's the+              -- responsibility of code that uses this message to always+              -- consult the chat state for the latest *version* of any+              -- message with an ID here, to be sure that the latest+              -- version is used (e.g. if it gets edited, etc.).+              , _csNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name)+              -- ^ A form for editing the notification preferences for+              -- the current channel. This is set when entering+              -- EditNotifyPrefs mode and updated when the user+              -- changes the form state.+              , _csChannelTopicDialog :: ChannelTopicDialogState+              -- ^ The state for the interactive channel topic editor+              -- window.+              }++-- | Handles for the View Message window's tabs.+data ViewMessageWindowTab =+    VMTabMessage+    -- ^ The message tab.+    | VMTabReactions+    -- ^ The reactions tab.+    deriving (Eq, Show)++data PendingChannelChange =+    ChangeByChannelId ChannelId (Maybe (MH ()))+    | ChangeByUserId UserId++-- | Startup state information that is constructed prior to building a+-- ChatState.+data StartupStateInfo =+    StartupStateInfo { startupStateResources      :: ChatResources+                     , startupStateChannelZipper  :: Z.Zipper ChannelListGroup ChannelListEntry+                     , startupStateConnectedUser  :: User+                     , startupStateTeam           :: Team+                     , startupStateTimeZone       :: TimeZoneSeries+                     , startupStateInitialHistory :: InputHistory+                     , startupStateSpellChecker   :: Maybe (Aspell, IO ())+                     }++-- | The state of the channel topic editor window.+data ChannelTopicDialogState =+    ChannelTopicDialogState { _channelTopicDialogEditor :: Editor T.Text Name+                            -- ^ The topic string editor state.+                            , _channelTopicDialogFocus :: FocusRing Name+                            -- ^ The window focus state (editor/buttons)+                            }++newState :: StartupStateInfo -> IO ChatState+newState (StartupStateInfo {..}) = do+    editState <- emptyEditState startupStateInitialHistory startupStateSpellChecker+    let config = _crConfiguration startupStateResources+    return ChatState { _csResources                   = startupStateResources+                     , _csFocus                       = startupStateChannelZipper+                     , _csChannelListOrientation      = configChannelListOrientation config+                     , _csMe                          = startupStateConnectedUser+                     , _csMyTeam                      = startupStateTeam+                     , _csChannels                    = noChannels+                     , _csPostMap                     = HM.empty+                     , _csUsers                       = noUsers+                     , _timeZone                      = startupStateTimeZone+                     , _csEditState                   = editState+                     , _csMode                        = Main+                     , _csShowMessagePreview          = configShowMessagePreview config+                     , _csShowChannelList             = configShowChannelList config+                     , _csShowExpandedChannelTopics   = configShowExpandedChannelTopics config+                     , _csChannelSelectState          = emptyChannelSelectState+                     , _csRecentChannel               = Nothing+                     , _csReturnChannel               = Nothing+                     , _csUrlList                     = list UrlList mempty 2+                     , _csConnectionStatus            = Connected+                     , _csWorkerIsBusy                = Nothing+                     , _csMessageSelect               = MessageSelectState Nothing+                     , _csThemeListOverlay            = nullThemeListOverlayState+                     , _csPostListOverlay             = PostListOverlayState emptyDirSeq Nothing+                     , _csUserListOverlay             = nullUserListOverlayState+                     , _csChannelListOverlay          = nullChannelListOverlayState+                     , _csReactionEmojiListOverlay    = nullEmojiListOverlayState+                     , _csClientConfig                = Nothing+                     , _csPendingChannelChange        = Nothing+                     , _csViewedMessage               = Nothing+                     , _csNotifyPrefs                 = Nothing+                     , _csChannelTopicDialog          = newChannelTopicDialog ""+                     }++-- | Make a new channel topic editor window state.+newChannelTopicDialog :: T.Text -> ChannelTopicDialogState+newChannelTopicDialog t =+    ChannelTopicDialogState { _channelTopicDialogEditor = editor ChannelTopicEditor Nothing t+                            , _channelTopicDialogFocus = focusRing [ ChannelTopicEditor+                                                                   , ChannelTopicSaveButton+                                                                   , ChannelTopicCancelButton+                                                                   ]+                            }++nullChannelListOverlayState :: ListOverlayState Channel ChannelSearchScope+nullChannelListOverlayState =+    let newList rs = list JoinChannelList rs 2+    in ListOverlayState { _listOverlaySearchResults  = newList mempty+                        , _listOverlaySearchInput    = editor JoinChannelListSearchInput (Just 1) ""+                        , _listOverlaySearchScope    = AllChannels+                        , _listOverlaySearching      = False+                        , _listOverlayEnterHandler   = const $ return False+                        , _listOverlayNewList        = newList+                        , _listOverlayFetchResults   = const $ const $ const $ return mempty+                        , _listOverlayRecordCount    = Nothing+                        , _listOverlayReturnMode     = Main+                        }++nullThemeListOverlayState :: ListOverlayState InternalTheme ()+nullThemeListOverlayState =+    let newList rs = list ThemeListSearchResults rs 3+    in ListOverlayState { _listOverlaySearchResults  = newList mempty+                        , _listOverlaySearchInput    = editor ThemeListSearchInput (Just 1) ""+                        , _listOverlaySearchScope    = ()+                        , _listOverlaySearching      = False+                        , _listOverlayEnterHandler   = const $ return False+                        , _listOverlayNewList        = newList+                        , _listOverlayFetchResults   = const $ const $ const $ return mempty+                        , _listOverlayRecordCount    = Nothing+                        , _listOverlayReturnMode     = Main+                        }++nullUserListOverlayState :: ListOverlayState UserInfo UserSearchScope+nullUserListOverlayState =+    let newList rs = list UserListSearchResults rs 1+    in ListOverlayState { _listOverlaySearchResults  = newList mempty+                        , _listOverlaySearchInput    = editor UserListSearchInput (Just 1) ""+                        , _listOverlaySearchScope    = AllUsers Nothing+                        , _listOverlaySearching      = False+                        , _listOverlayEnterHandler   = const $ return False+                        , _listOverlayNewList        = newList+                        , _listOverlayFetchResults   = const $ const $ const $ return mempty+                        , _listOverlayRecordCount    = Nothing+                        , _listOverlayReturnMode     = Main+                        }++nullEmojiListOverlayState :: ListOverlayState (Bool, T.Text) ()+nullEmojiListOverlayState =+    let newList rs = list ReactionEmojiList rs 1+    in ListOverlayState { _listOverlaySearchResults  = newList mempty+                        , _listOverlaySearchInput    = editor ReactionEmojiListInput (Just 1) ""+                        , _listOverlaySearchScope    = ()+                        , _listOverlaySearching      = False+                        , _listOverlayEnterHandler   = const $ return False+                        , _listOverlayNewList        = newList+                        , _listOverlayFetchResults   = const $ const $ const $ return mempty+                        , _listOverlayRecordCount    = Nothing+                        , _listOverlayReturnMode     = MessageSelect+                        }++getServerBaseUrl :: MH TeamBaseURL+getServerBaseUrl = do+    st <- use id+    return $ serverBaseUrl st++serverBaseUrl :: ChatState -> TeamBaseURL+serverBaseUrl st =+    let baseUrl = connectionDataURL $ _crConn $ _csResources st+        tName = teamName $ _csMyTeam st+    in TeamBaseURL (TeamURLName $ sanitizeUserText tName) baseUrl++-- | The state of channel selection mode.+data ChannelSelectState =+    ChannelSelectState { _channelSelectInput :: Editor Text Name+                       , _channelSelectMatches :: Z.Zipper ChannelListGroup ChannelSelectMatch+                       }++emptyChannelSelectState :: ChannelSelectState+emptyChannelSelectState =+    ChannelSelectState { _channelSelectInput = editor ChannelSelectInput (Just 1) ""+                       , _channelSelectMatches = Z.fromList []+                       }++-- | The state of message selection mode.+data MessageSelectState =+    MessageSelectState { selectMessageId :: Maybe MessageId+                       }++-- | The state of the post list overlay.+data PostListOverlayState =+    PostListOverlayState { _postListPosts    :: Messages+                         , _postListSelected :: Maybe PostId+                         }++data InternalTheme =+    InternalTheme { internalThemeName :: Text+                  , internalTheme :: Theme+                  , internalThemeDesc :: Text+                  }++-- | The state of the search result list overlay. Type 'a' is the type+-- of data in the list. Type 'b' is the search scope type.+data ListOverlayState a b =+    ListOverlayState { _listOverlaySearchResults :: List Name a+                     -- ^ The list of search results currently shown in+                     -- the overlay.+                     , _listOverlaySearchInput :: Editor Text Name+                     -- ^ The editor for the overlay's search input.+                     , _listOverlaySearchScope :: b+                     -- ^ The overlay's current search scope.+                     , _listOverlaySearching :: Bool+                     -- ^ Whether a search is in progress (i.e. whether+                     -- we are currently awaiting a response from a+                     -- search query to the server).+                     , _listOverlayEnterHandler :: a -> MH Bool+                     -- ^ The handler to invoke on the selected element+                     -- when the user presses Enter.+                     , _listOverlayNewList :: Vec.Vector a -> List Name a+                     -- ^ The function to build a new brick List from a+                     -- vector of search results.+                     , _listOverlayFetchResults :: b -> Session -> Text -> IO (Vec.Vector a)+                     -- ^ The function to call to issue a search query+                     -- to the server.+                     , _listOverlayRecordCount :: Maybe Int+                     -- ^ The total number of available records, if known.+                     , _listOverlayReturnMode :: Mode+                     -- ^ The mode to return to when the window closes.+                     }++-- | The scope for searching for users in a user list overlay.+data UserSearchScope =+    ChannelMembers ChannelId TeamId+    | ChannelNonMembers ChannelId TeamId+    | AllUsers (Maybe TeamId)++-- | The scope for searching for channels to join.+data ChannelSearchScope =+    AllChannels++-- | Actions that can be sent on the websocket to the server.+data WebsocketAction =+    UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box+    deriving (Read, Show, Eq, Ord)++-- * MH Monad++-- | Logging context information, in the event that metadata should+-- accompany a log message.+data LogContext =+    LogContext { logContextChannelId :: Maybe ChannelId+               }+               deriving (Eq, Show)++-- | A user fetching strategy.+data UserFetch =+    UserFetchById UserId+    -- ^ Fetch the user with the specified ID.+    | UserFetchByUsername Text+    -- ^ Fetch the user with the specified username.+    | UserFetchByNickname Text+    -- ^ Fetch the user with the specified nickname.+    deriving (Eq, Show)++data MHState =+    MHState { mhCurrentState :: ChatState+            , mhNextAction :: ChatState -> EventM Name (Next ChatState)+            , mhUsersToFetch :: [UserFetch]+            , mhPendingStatusList :: Maybe [UserId]+            }++-- | A value of type 'MH' @a@ represents a computation that can+-- manipulate the application state and also request that the+-- application quit+newtype MH a =+    MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name)) a }++-- | Use a modified logging context for the duration of the specified MH+-- action.+withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a+withLogContext modifyContext act =+    MH $ R.withReaderT modifyContext (fromMH act)++withLogContextChannelId :: ChannelId -> MH a -> MH a+withLogContextChannelId cId act =+    let f Nothing = Just $ LogContext (Just cId)+        f (Just c) = Just $ c { logContextChannelId = Just cId }+    in withLogContext f act++-- | Get the current logging context.+getLogContext :: MH (Maybe LogContext)+getLogContext = MH R.ask++-- | Log a message.+mhLog :: LogCategory -> Text -> MH ()+mhLog cat msg = do+    logger <- mhGetIOLogger+    liftIO $ logger cat msg++-- | Get a logger suitable for use in IO. The logger always logs using+-- the MH monad log context at the time of the call to mhGetIOLogger.+mhGetIOLogger :: MH (LogCategory -> Text -> IO ())+mhGetIOLogger = do+    ctx <- getLogContext+    mgr <- use (to (_crLogManager . _csResources))+    return $ ioLogWithManager mgr ctx++ioLogWithManager :: LogManager -> Maybe LogContext -> LogCategory -> Text -> IO ()+ioLogWithManager mgr ctx cat msg = do+    now <- getCurrentTime+    let lm = LogMessage { logMessageText = msg+                        , logMessageContext = ctx+                        , logMessageCategory = cat+                        , logMessageTimestamp = now+                        }+    sendLogMessage mgr lm++-- | Run an 'MM' computation, choosing whether to continue or halt based+-- on the resulting+runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState)+runMHEvent st (MH mote) = do+  let mhSt = MHState { mhCurrentState = st+                     , mhNextAction = Brick.continue+                     , mhUsersToFetch = []+                     , mhPendingStatusList = Nothing+                     }+  ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt+  (mhNextAction st') (mhCurrentState st')++scheduleUserFetches :: [UserFetch] -> MH ()+scheduleUserFetches fs = MH $ do+    St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s }++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 [UserId])+getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList++-- | lift a computation in 'EventM' into 'MH'+mh :: EventM Name a -> MH a+mh = MH . R.lift . St.lift++generateUUID :: MH UUID+generateUUID = liftIO generateUUID_IO++generateUUID_IO :: IO UUID+generateUUID_IO = randomIO++mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH ()+mhHandleEventLensed ln f event = MH $ do+    s <- St.get+    let st = mhCurrentState s+    n <- R.lift $ St.lift $ f event (st ^. ln)+    St.put (s { mhCurrentState = st & ln .~ n })++mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()+mhSuspendAndResume mote = MH $ do+    s <- St.get+    St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) }++-- | This will request that after this computation finishes the+-- application should exit+requestQuit :: MH ()+requestQuit = MH $ do+    s <- St.get+    St.put $ s { mhNextAction = Brick.halt }++instance Functor MH where+    fmap f (MH x) = MH (fmap f x)++instance Applicative MH where+    pure x = MH (pure x)+    MH f <*> MH x = MH (f <*> x)++instance MHF.MonadFail MH where+    fail = MH . MHF.fail++instance Monad MH where+    return x = MH (return x)+    MH x >>= f = MH (x >>= \ x' -> fromMH (f x'))++-- We want to pretend that the state is only the ChatState, rather+-- than the ChatState and the Brick continuation+instance St.MonadState ChatState MH where+    get = mhCurrentState `fmap` MH St.get+    put st = MH $ do+        s <- St.get+        St.put $ s { mhCurrentState = st }++instance St.MonadIO MH where+    liftIO = MH . St.liftIO++-- | This represents events that we handle in the main application loop.+data MHEvent =+    WSEvent WebsocketEvent+    -- ^ For events that arise from the websocket+    | WSActionResponse WebsocketActionResponse+    -- ^ For responses to websocket actions+    | RespEvent (MH ())+    -- ^ For the result values of async IO operations+    | RefreshWebsocketEvent+    -- ^ Tell our main loop to refresh the websocket connection+    | WebsocketParseError String+    -- ^ We failed to parse an incoming websocket event+    | WebsocketDisconnect+    -- ^ The websocket connection went down.+    | WebsocketConnect+    -- ^ The websocket connection came up.+    | BGIdle+    -- ^ 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++-- | Internal application events.+data InternalEvent =+    DisplayError MHError+    -- ^ Some kind of application error occurred+    | LoggingStarted FilePath+    | LoggingStopped FilePath+    | LogStartFailed FilePath String+    | LogDestination (Maybe FilePath)+    | LogSnapshotSucceeded FilePath+    | LogSnapshotFailed FilePath String+    -- ^ Logging events from the logging thread++-- | Application errors.+data MHError =+    GenericError T.Text+    -- ^ A generic error message constructor+    | NoSuchChannel T.Text+    -- ^ The specified channel does not exist+    | NoSuchUser T.Text+    -- ^ The specified user does not exist+    | AmbiguousName T.Text+    -- ^ The specified name matches both a user and a channel+    | ServerError MattermostError+    -- ^ A Mattermost server error occurred+    | ClipboardError T.Text+    -- ^ A problem occurred trying to deal with yanking or the system+    -- clipboard+    | ConfigOptionMissing T.Text+    -- ^ A missing config option is required to perform an operation+    | ProgramExecutionFailed T.Text T.Text+    -- ^ Args: program name, path to log file. A problem occurred when+    -- running the program.+    | NoSuchScript T.Text+    -- ^ The specified script was not found+    | NoSuchHelpTopic T.Text+    -- ^ The specified help topic was not found+    | AsyncErrEvent SomeException+    -- ^ For errors that arise in the course of async IO operations+    deriving (Show)++-- ** Application State Lenses++makeLenses ''ChatResources+makeLenses ''ChatState+makeLenses ''ChatEditState+makeLenses ''AutocompleteState+makeLenses ''PostListOverlayState+makeLenses ''ListOverlayState+makeLenses ''ChannelSelectState+makeLenses ''UserPreferences+makeLenses ''ConnectionInfo+makeLenses ''ChannelTopicDialogState++getSession :: MH Session+getSession = use (csResources.crSession)++getResourceSession :: ChatResources -> Session+getResourceSession = _crSession++whenMode :: Mode -> MH () -> MH ()+whenMode m act = do+    curMode <- use csMode+    when (curMode == m) act++setMode :: Mode -> MH ()+setMode m = do+    csMode .= m+    mh invalidateCache++setMode' :: Mode -> ChatState -> ChatState+setMode' m = csMode .~ m++appMode :: ChatState -> Mode+appMode = _csMode++resetSpellCheckTimer :: ChatEditState -> IO ()+resetSpellCheckTimer s =+    case s^.cedSpellChecker of+        Nothing -> return ()+        Just (_, reset) -> reset++-- ** Utility Lenses+csCurrentChannelId :: SimpleGetter ChatState ChannelId+csCurrentChannelId = csFocus.to Z.unsafeFocus.to channelListEntryChannelId++channelListEntryChannelId :: ChannelListEntry -> ChannelId+channelListEntryChannelId (CLChannel cId) = cId+channelListEntryChannelId (CLUserDM cId _) = cId+channelListEntryChannelId (CLGroupDM cId) = cId++channelListEntryUserId :: ChannelListEntry -> Maybe UserId+channelListEntryUserId (CLUserDM _ uId) = Just uId+channelListEntryUserId _ = Nothing++userIdsFromZipper :: Z.Zipper ChannelListGroup ChannelListEntry -> [UserId]+userIdsFromZipper z =+    concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Z.toList z++entryIsDMEntry :: ChannelListEntry -> Bool+entryIsDMEntry (CLUserDM {}) = True+entryIsDMEntry (CLGroupDM {}) = True+entryIsDMEntry (CLChannel {}) = False++csCurrentChannel :: Lens' ChatState ClientChannel+csCurrentChannel =+    lens (\ st -> findChannelById (st^.csCurrentChannelId) (st^.csChannels) ^?! _Just)+         (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId) n)++csChannel :: ChannelId -> Traversal' ChatState ClientChannel+csChannel cId =+    csChannels . channelByIdL cId++withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH ()+withChannel cId = withChannelOrDefault cId ()++withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a+withChannelOrDefault cId deflt mote = do+    chan <- preuse (csChannel(cId))+    case chan of+        Nothing -> return deflt+        Just c  -> mote c++-- ** 'ChatState' Helper Functions++raiseInternalEvent :: InternalEvent -> MH ()+raiseInternalEvent ev = do+    queue <- use (csResources.crEventQueue)+    writeBChan queue (IEvent ev)++writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m ()+writeBChan chan e = do+    written <- liftIO $ BCH.writeBChanNonBlocking chan e+    when (not written) $+        error $ "mhSendEvent: BChan full, please report this as a bug!"++-- | Log and raise an error.+mhError :: MHError -> MH ()+mhError err = do+    mhLog LogError $ T.pack $ show err+    raiseInternalEvent (DisplayError err)++isMine :: ChatState -> Message -> Bool+isMine st msg =+    case msg^.mUser of+        UserI _ uid -> uid == myUserId st+        _ -> False++getMessageForPostId :: ChatState -> PostId -> Maybe Message+getMessageForPostId st pId = st^.csPostMap.at(pId)++getParentMessage :: ChatState -> Message -> Maybe Message+getParentMessage st msg+    | InReplyTo pId <- msg^.mInReplyToMsg+      = st^.csPostMap.at(pId)+    | otherwise = Nothing++getReplyRootMessage :: Message -> MH Message+getReplyRootMessage msg = do+    case postRootId =<< (msg^.mOriginalPost) of+        Nothing -> return msg+        Just rootId -> do+            st <- use id+            case getMessageForPostId st rootId of+                -- NOTE: this case should never happen. This is the+                -- case where a message has a root post ID but we+                -- don't have a copy of the root post in storage. This+                -- shouldn't happen because whenever we add a message+                -- to a channel, we always fetch the parent post and+                -- store it if it is in a thread. That should mean that+                -- whenever we reply to a post, if that post is itself+                -- a reply, we should have its root post in storage+                -- and this case should never match. Even though it+                -- shouldn't happen, rather than raising a BUG exception+                -- here we'll just fall back to the input message.+                Nothing -> return msg+                Just m -> return m++setUserStatus :: UserId -> Text -> MH ()+setUserStatus uId t = do+    csUsers %= modifyUserById uId (uiStatus .~ statusFromText t)+    mh $ invalidateCacheEntry ChannelSidebar++usernameForUserId :: UserId -> ChatState -> Maybe Text+usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers)++displayNameForUserId :: UserId -> ChatState -> Maybe Text+displayNameForUserId uId st = do+    u <- findUserById uId (st^.csUsers)+    return $ displayNameForUser u (st^.csClientConfig) (st^.csResources.crUserPreferences)++-- | Note: this only searches users we have already loaded. Be+-- aware that if you think you need a user we haven't fetched, use+-- withFetchedUser!+userIdForUsername :: Text -> ChatState -> Maybe UserId+userIdForUsername name st =+    fst <$> (findUserByUsername name $ st^.csUsers)++channelIdByChannelName :: Text -> ChatState -> Maybe ChannelId+channelIdByChannelName name st =+    let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name)+    in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels)++channelIdByUsername :: Text -> ChatState -> Maybe ChannelId+channelIdByUsername name st = do+    uId <- userIdForUsername name st+    getDmChannelFor uId (st^.csChannels)++useNickname :: ChatState -> Bool+useNickname st =+    useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences)++channelByName :: Text -> ChatState -> Maybe ClientChannel+channelByName n st = do+    cId <- channelIdByChannelName n st+    findChannelById cId (st^.csChannels)++trimChannelSigil :: Text -> Text+trimChannelSigil n+    | normalChannelSigil `T.isPrefixOf` n = T.tail n+    | otherwise = n++addNewUser :: UserInfo -> MH ()+addNewUser u = do+    csUsers %= addUser u+    -- Invalidate the cache because channel message rendering may need+    -- to get updated if this user authored posts in any channels.+    mh invalidateCache++data SidebarUpdate =+    SidebarUpdateImmediate+    | SidebarUpdateDeferred+    deriving (Eq, Show)+++resetAutocomplete :: MH ()+resetAutocomplete = do+    csEditState.cedAutocomplete .= Nothing+    csEditState.cedAutocompletePending .= Nothing+++-- * Slash Commands++-- | The 'CmdArgs' type represents the arguments to a slash-command; the+-- type parameter represents the argument structure.+data CmdArgs :: K.Type -> K.Type where+    NoArg    :: CmdArgs ()+    LineArg  :: Text -> CmdArgs Text+    UserArg  :: CmdArgs rest -> CmdArgs (Text, rest)+    ChannelArg :: CmdArgs rest -> CmdArgs (Text, rest)+    TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest)++-- | A 'CmdExec' value represents the implementation of a command when+-- provided with its arguments+type CmdExec a = a -> MH ()++-- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec'+-- implementation with a name and a description.+data Cmd =+    forall a. Cmd { cmdName    :: Text+                  , cmdDescr   :: Text+                  , cmdArgSpec :: CmdArgs a+                  , cmdAction  :: CmdExec a+                  }++-- | Helper function to extract the name out of a 'Cmd' value+commandName :: Cmd -> Text+commandName (Cmd name _ _ _ ) = name++-- *  Channel Updates and Notifications++userList :: ChatState -> [UserInfo]+userList st = filter showUser $ allUsers (st^.csUsers)+    where showUser u = not (isSelf u) && (u^.uiInTeam)+          isSelf u = (myUserId st) == (u^.uiId)++allUserIds :: ChatState -> [UserId]+allUserIds st = getAllUserIds $ st^.csUsers++-- BEWARE: you probably don't want this, but instead+-- State.Users.withFetchedUser, since this only looks up users in the+-- collection we have already loaded rather than all valid users on the+-- server.+userById :: UserId -> ChatState -> Maybe UserInfo+userById uId st = findUserById uId (st^.csUsers)++myUserId :: ChatState -> UserId+myUserId st = myUser st ^. userIdL++myTeamId :: ChatState -> TeamId+myTeamId st = st ^. csMyTeam . teamIdL++myUser :: ChatState -> User+myUser st = st^.csMe++myUsername :: ChatState -> Text+myUsername st = userUsername $ st^.csMe++-- BEWARE: you probably don't want this, but instead+-- State.Users.withFetchedUser, since this only looks up users in the+-- collection we have already loaded rather than all valid users on the+-- server.+userByUsername :: Text -> ChatState -> Maybe UserInfo+userByUsername name st = do+    snd <$> (findUserByUsername name $ st^.csUsers)++-- BEWARE: you probably don't want this, but instead+-- State.Users.withFetchedUser, since this only looks up users in the+-- collection we have already loaded rather than all valid users on the+-- server.+userByNickname :: Text -> ChatState -> Maybe UserInfo+userByNickname name st =+    snd <$> (findUserByNickname name $ st^.csUsers)++getUsers :: MH Users+getUsers = use csUsers++-- * HighlightSet++type UserSet = Set Text+type ChannelSet = Set Text++-- | The set of usernames, channel names, and language names used for+-- highlighting when rendering messages.+data HighlightSet =+    HighlightSet { hUserSet    :: Set Text+                 , hChannelSet :: Set Text+                 , hSyntaxMap  :: SyntaxMap+                 }++getHighlightSet :: ChatState -> HighlightSet+getHighlightSet st =+    HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers+                 , hChannelSet = getChannelNameSet $ st^.csChannels+                 , hSyntaxMap = st^.csResources.crSyntaxMap+                 }++attrNameToConfig :: Brick.AttrName -> Text+attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents++-- From: https://docs.mattermost.com/help/messaging/mentioning-teammates.html+specialUserMentions :: [T.Text]+specialUserMentions = ["all", "channel", "here"]++addSpecialUserMentions :: Set Text -> Set Text+addSpecialUserMentions s = foldr Set.insert s specialUserMentions++getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator+getNewMessageCutoff cId st = do+    cc <- st^?csChannel(cId)+    return $ cc^.ccInfo.cdNewMessageIndicator++getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime+getEditedMessageCutoff cId st = do+    cc <- st^?csChannel(cId)+    cc^.ccInfo.cdEditedMessageThreshold++clearChannelUnreadStatus :: ChannelId -> MH ()+clearChannelUnreadStatus cId = do+    mh $ invalidateCacheEntry (ChannelMessages cId)+    csChannel(cId) %= (clearNewMessageIndicator .+                       clearEditedThreshold)
+ src/Matterhorn/Types/Channels.hs view
@@ -0,0 +1,420 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RankNTypes #-}++module Matterhorn.Types.Channels+  ( ClientChannel(..)+  , ChannelContents(..)+  , ChannelInfo(..)+  , ClientChannels -- constructor remains internal+  , NewMessageIndicator(..)+  , EphemeralEditState(..)+  , EditMode(..)+  , eesMultiline, eesInputHistoryPosition, eesLastInput+  , defaultEphemeralEditState+  -- * Lenses created for accessing ClientChannel fields+  , ccContents, ccInfo, ccEditState+  -- * Lenses created for accessing ChannelInfo fields+  , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated+  , cdName, cdDisplayName, cdHeader, cdPurpose, cdType+  , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId+  , cdSidebarShowOverride, cdNotifyProps+  -- * Lenses created for accessing ChannelContents fields+  , cdMessages, cdFetchPending+  -- * Creating ClientChannel objects+  , makeClientChannel+  -- * Managing ClientChannel collections+  , noChannels, addChannel, removeChannel, findChannelById, modifyChannelById+  , channelByIdL, maybeChannelByIdL+  , filteredChannelIds+  , filteredChannels+  -- * Creating ChannelInfo objects+  , channelInfoFromChannelWithData+  -- * Channel State management+  , clearNewMessageIndicator+  , clearEditedThreshold+  , adjustUpdated+  , adjustEditedThreshold+  , updateNewMessageIndicator+  , addChannelTypingUser+  -- * Notification settings+  , notifyPreference+  , isMuted+  , channelNotifyPropsMarkUnreadL+  , channelNotifyPropsIgnoreChannelMentionsL+  , channelNotifyPropsDesktopL+  , channelNotifyPropsPushL+  -- * Miscellaneous channel-related operations+  , canLeaveChannel+  , preferredChannelName+  , isTownSquare+  , channelDeleted+  , getDmChannelFor+  , allDmChannelMappings+  , getChannelNameSet+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.HashMap.Strict as HM+import qualified Data.Set as S+import qualified Data.Text as T+import           Lens.Micro.Platform ( (%~), (.~), Traversal', Lens'+                                     , makeLenses, ix, at+                                     , to, non )++import           Network.Mattermost.Lenses hiding ( Lens' )+import           Network.Mattermost.Types ( Channel(..), UserId, ChannelId+                                          , ChannelMember(..)+                                          , Type(..)+                                          , Post+                                          , User(userNotifyProps)+                                          , ChannelNotifyProps+                                          , NotifyOption(..)+                                          , WithDefault(..)+                                          , ServerTime+                                          , emptyChannelNotifyProps+                                          )++import           Matterhorn.Types.Messages ( Messages, noMessages, addMessage+                                           , clientMessageToMessage, Message, MessageType )+import           Matterhorn.Types.Posts ( ClientMessageType(UnknownGapBefore)+                                        , newClientMessage )+import           Matterhorn.Types.Users ( TypingUsers, noTypingUsers, addTypingUser )+import           Matterhorn.Types.Common+++-- * Channel representations++-- | A 'ClientChannel' contains both the message+--   listing and the metadata about a channel+data ClientChannel = ClientChannel+  { _ccContents :: ChannelContents+    -- ^ A list of 'Message's in the channel+  , _ccInfo :: ChannelInfo+    -- ^ The 'ChannelInfo' for the channel+  , _ccEditState :: EphemeralEditState+    -- ^ Editor state that we swap in and out as the current channel is+    -- changed.+  }++-- | The input state associated with the message editor.+data EditMode =+    NewPost+    -- ^ The input is for a new post.+    | Editing Post MessageType+    -- ^ The input is ultimately to replace the body of an existing post+    -- of the specified type.+    | Replying Message Post+    -- ^ The input is to be used as a new post in reply to the specified+    -- post.+    deriving (Show)++data EphemeralEditState =+    EphemeralEditState { _eesMultiline :: Bool+                       -- ^ Whether the editor is in multiline mode+                       , _eesInputHistoryPosition :: Maybe Int+                       -- ^ The input history position, if any+                       , _eesLastInput :: (T.Text, EditMode)+                       -- ^ The input entered into the text editor last+                       -- time the user was focused on the channel+                       -- associated with this state.+                       }++-- Get a channel's name, depending on its type+preferredChannelName :: Channel -> Text+preferredChannelName ch+    | channelType ch == Group = sanitizeUserText $ channelDisplayName ch+    | otherwise               = sanitizeUserText $ channelName ch++data NewMessageIndicator =+    Hide+    | NewPostsAfterServerTime ServerTime+    | NewPostsStartingAt ServerTime+    deriving (Eq, Show)++initialChannelInfo :: UserId -> Channel -> ChannelInfo+initialChannelInfo myId chan =+    let updated  = chan ^. channelLastPostAtL+    in ChannelInfo { _cdChannelId              = chan^.channelIdL+                   , _cdViewed                 = Nothing+                   , _cdNewMessageIndicator    = Hide+                   , _cdEditedMessageThreshold = Nothing+                   , _cdMentionCount           = 0+                   , _cdUpdated                = updated+                   , _cdName                   = preferredChannelName chan+                   , _cdDisplayName            = sanitizeUserText $ channelDisplayName chan+                   , _cdHeader                 = sanitizeUserText $ chan^.channelHeaderL+                   , _cdPurpose                = sanitizeUserText $ chan^.channelPurposeL+                   , _cdType                   = chan^.channelTypeL+                   , _cdNotifyProps            = emptyChannelNotifyProps+                   , _cdTypingUsers            = noTypingUsers+                   , _cdDMUserId               = if chan^.channelTypeL == Direct+                                                 then userIdForDMChannel myId $+                                                      sanitizeUserText $ channelName chan+                                                 else Nothing+                   , _cdSidebarShowOverride    = Nothing+                   }++channelInfoFromChannelWithData :: Channel -> ChannelMember -> ChannelInfo -> ChannelInfo+channelInfoFromChannelWithData chan chanMember ci =+    let viewed   = chanMember ^. to channelMemberLastViewedAt+        updated  = chan ^. channelLastPostAtL+    in ci { _cdViewed           = Just viewed+          , _cdNewMessageIndicator = case _cdNewMessageIndicator ci of+              Hide -> if updated > viewed then NewPostsAfterServerTime viewed else Hide+              v -> v+          , _cdUpdated          = updated+          , _cdName             = preferredChannelName chan+          , _cdDisplayName      = sanitizeUserText $ channelDisplayName chan+          , _cdHeader           = (sanitizeUserText $ chan^.channelHeaderL)+          , _cdPurpose          = (sanitizeUserText $ chan^.channelPurposeL)+          , _cdType             = (chan^.channelTypeL)+          , _cdMentionCount     = chanMember^.to channelMemberMentionCount+          , _cdNotifyProps      = chanMember^.to channelMemberNotifyProps+          }++-- | The 'ChannelContents' is a wrapper for a list of+--   'Message' values+data ChannelContents = ChannelContents+  { _cdMessages :: Messages+  , _cdFetchPending :: Bool+  }++-- | An initial empty 'ChannelContents' value.  This also contains an+-- UnknownGapBefore, which is a signal that causes actual content fetching.+-- The initial Gap's timestamp is the local client time, but+-- subsequent fetches will synchronize with the server (and eventually+-- eliminate this Gap as well).+emptyChannelContents :: MonadIO m => m ChannelContents+emptyChannelContents = do+  gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGapBefore "--Fetching messages--"+  return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages+                           , _cdFetchPending = False+                           }+++------------------------------------------------------------------------++-- | The 'ChannelInfo' record represents metadata+--   about a channel+data ChannelInfo = ChannelInfo+  { _cdChannelId        :: ChannelId+    -- ^ The channel's ID+  , _cdViewed           :: Maybe ServerTime+    -- ^ The last time we looked at a channel+  , _cdNewMessageIndicator :: NewMessageIndicator+    -- ^ The state of the channel's new message indicator.+  , _cdEditedMessageThreshold :: Maybe ServerTime+    -- ^ The channel's edited message threshold.+  , _cdMentionCount     :: Int+    -- ^ The current number of unread mentions+  , _cdUpdated          :: ServerTime+    -- ^ The last time a message showed up in the channel+  , _cdName             :: Text+    -- ^ The name of the channel+  , _cdDisplayName      :: Text+    -- ^ The display name of the channel+  , _cdHeader           :: Text+    -- ^ The header text of a channel+  , _cdPurpose          :: Text+    -- ^ The stated purpose of the channel+  , _cdType             :: Type+    -- ^ The type of a channel: public, private, or DM+  , _cdNotifyProps      :: ChannelNotifyProps+    -- ^ The user's notification settings for this channel+  , _cdTypingUsers      :: TypingUsers+    -- ^ The users who are currently typing in this channel+  , _cdDMUserId         :: Maybe UserId+    -- ^ The user associated with this channel, if it is a DM channel+  , _cdSidebarShowOverride :: Maybe UTCTime+    -- ^ If set, show this channel in the sidebar regardless of other+    -- considerations as long as the specified timestamp meets a cutoff.+    -- Otherwise fall back to other application policy to determine+    -- whether to show the channel.+  }++-- ** Channel-related Lenses++makeLenses ''ChannelContents+makeLenses ''ChannelInfo+makeLenses ''ClientChannel+makeLenses ''EphemeralEditState++isMuted :: ClientChannel -> Bool+isMuted cc = cc^.ccInfo.cdNotifyProps.channelNotifyPropsMarkUnreadL ==+             IsValue NotifyOptionMention++notifyPreference :: User -> ClientChannel -> NotifyOption+notifyPreference u cc =+    if isMuted cc then NotifyOptionNone+    else case cc^.ccInfo.cdNotifyProps.channelNotifyPropsDesktopL of+             IsValue v -> v+             Default   -> (userNotifyProps u)^.userNotifyPropsDesktopL++-- ** Miscellaneous channel operations++makeClientChannel :: (MonadIO m) => UserId -> Channel -> m ClientChannel+makeClientChannel myId nc = emptyChannelContents >>= \contents ->+  return ClientChannel+  { _ccContents = contents+  , _ccInfo = initialChannelInfo myId nc+  , _ccEditState = defaultEphemeralEditState+  }++defaultEphemeralEditState :: EphemeralEditState+defaultEphemeralEditState =+    EphemeralEditState { _eesMultiline = False+                       , _eesInputHistoryPosition = Nothing+                       , _eesLastInput = ("", NewPost)+                       }++canLeaveChannel :: ChannelInfo -> Bool+canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct]++-- ** Manage the collection of all Channels++-- | Define a binary kinded type to allow derivation of functor.+data AllMyChannels a =+    AllChannels { _chanMap :: HashMap ChannelId a+                , _userChannelMap :: HashMap UserId ChannelId+                , _channelNameSet :: S.Set Text+                }+                deriving (Functor, Foldable, Traversable)++-- | Define the exported typename which universally binds the+-- collection to the ChannelInfo type.+type ClientChannels = AllMyChannels ClientChannel++makeLenses ''AllMyChannels++getChannelNameSet :: ClientChannels -> S.Set Text+getChannelNameSet = _channelNameSet++-- | Initial collection of Channels with no members+noChannels :: ClientChannels+noChannels = AllChannels HM.empty HM.empty mempty++-- | Add a channel to the existing collection.+addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels+addChannel cId cinfo =+    (chanMap %~ HM.insert cId cinfo) .+    (if cinfo^.ccInfo.cdType `notElem` [Direct, Group]+     then channelNameSet %~ S.insert (cinfo^.ccInfo.cdName)+     else id) .+    (case cinfo^.ccInfo.cdDMUserId of+         Nothing -> id+         Just uId -> userChannelMap %~ HM.insert uId cId+    )++-- | Remove a channel from the collection.+removeChannel :: ChannelId -> ClientChannels -> ClientChannels+removeChannel cId cs =+    let mChan = findChannelById cId cs+        removeChannelName = case mChan of+            Nothing -> id+            Just ch -> channelNameSet %~ S.delete (ch^.ccInfo.cdName)+    in cs & chanMap %~ HM.delete cId+          & removeChannelName+          & userChannelMap %~ HM.filter (/= cId)++getDmChannelFor :: UserId -> ClientChannels -> Maybe ChannelId+getDmChannelFor uId cs = cs^.userChannelMap.at uId++allDmChannelMappings :: ClientChannels -> [(UserId, ChannelId)]+allDmChannelMappings = HM.toList . _userChannelMap++-- | Get the ChannelInfo information given the ChannelId+findChannelById :: ChannelId -> ClientChannels -> Maybe ClientChannel+findChannelById cId = HM.lookup cId . _chanMap++-- | Transform the specified channel in place with provided function.+modifyChannelById :: ChannelId -> (ClientChannel -> ClientChannel)+                  -> ClientChannels -> ClientChannels+modifyChannelById cId f = chanMap.ix(cId) %~ f++-- | A 'Traversal' that will give us the 'ClientChannel' in a+-- 'ClientChannels' structure if it exists+channelByIdL :: ChannelId -> Traversal' ClientChannels ClientChannel+channelByIdL cId = chanMap . ix cId++-- | A 'Lens' that will give us the 'ClientChannel' in a+-- 'ClientChannels' wrapped in a 'Maybe'+maybeChannelByIdL :: ChannelId -> Lens' ClientChannels (Maybe ClientChannel)+maybeChannelByIdL cId = chanMap . at cId++-- | Apply a filter to each ClientChannel and return a list of the+-- ChannelId values for which the filter matched.+filteredChannelIds :: (ClientChannel -> Bool) -> ClientChannels -> [ChannelId]+filteredChannelIds f cc = fst <$> filter (f . snd) (HM.toList (cc^.chanMap))++-- | Filter the ClientChannel collection, keeping only those for which+-- the provided filter test function returns True.+filteredChannels :: ((ChannelId, ClientChannel) -> Bool)+                 -> ClientChannels -> [(ChannelId, ClientChannel)]+filteredChannels f cc = filter f $ cc^.chanMap.to HM.toList++------------------------------------------------------------------------++-- * Channel State management+++-- | Add user to the list of users in this channel who are currently typing.+addChannelTypingUser :: UserId -> UTCTime -> ClientChannel -> ClientChannel+addChannelTypingUser uId ts = ccInfo.cdTypingUsers %~ (addTypingUser uId ts)++-- | Clear the new message indicator for the specified channel+clearNewMessageIndicator :: ClientChannel -> ClientChannel+clearNewMessageIndicator c = c & ccInfo.cdNewMessageIndicator .~ Hide++-- | Clear the edit threshold for the specified channel+clearEditedThreshold :: ClientChannel -> ClientChannel+clearEditedThreshold c = c & ccInfo.cdEditedMessageThreshold .~ Nothing++-- | Adjust updated time based on a message, ensuring that the updated+-- time does not move backward.+adjustUpdated :: Post -> ClientChannel -> ClientChannel+adjustUpdated m =+    ccInfo.cdUpdated %~ max (maxPostTimestamp m)++adjustEditedThreshold :: Post -> ClientChannel -> ClientChannel+adjustEditedThreshold m c =+    if m^.postUpdateAtL <= m^.postCreateAtL+    then c+    else c & ccInfo.cdEditedMessageThreshold %~ (\mt -> case mt of+        Just t -> Just $ min (m^.postUpdateAtL) t+        Nothing -> Just $ m^.postUpdateAtL+        )++maxPostTimestamp :: Post -> ServerTime+maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL)++updateNewMessageIndicator :: Post -> ClientChannel -> ClientChannel+updateNewMessageIndicator m =+    ccInfo.cdNewMessageIndicator %~+        (\old ->+          case old of+              Hide ->+                  NewPostsStartingAt $ m^.postCreateAtL+              NewPostsStartingAt ts ->+                  NewPostsStartingAt $ min (m^.postCreateAtL) ts+              NewPostsAfterServerTime ts ->+                  if m^.postCreateAtL <= ts+                  then NewPostsStartingAt $ m^.postCreateAtL+                  else NewPostsAfterServerTime ts+              )++-- | Town Square is special in that its non-display name cannot be+-- changed and is a hard-coded constant server-side according to the+-- developers (as of 8/2/17). So this is a reliable way to check for+-- whether a channel is in fact that channel, even if the user has+-- changed its display name.+isTownSquare :: Channel -> Bool+isTownSquare c = (sanitizeUserText $ c^.channelNameL) == "town-square"++channelDeleted :: Channel -> Bool+channelDeleted c = c^.channelDeleteAtL > c^.channelCreateAtL
+ src/Matterhorn/Types/Common.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE MultiWayIf #-}+module Matterhorn.Types.Common+  ( sanitizeUserText+  , sanitizeUserText'+  , userIdForDMChannel+  )+where++import Prelude ()+import Matterhorn.Prelude++import qualified Data.Text as T++import Network.Mattermost.Types ( UserText, unsafeUserText, UserId(..), Id(..) )++sanitizeUserText :: UserText -> T.Text+sanitizeUserText = sanitizeUserText' . unsafeUserText++sanitizeUserText' :: T.Text -> T.Text+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+-- is but neither user ID in the name matches the current user's ID.+userIdForDMChannel :: UserId+                   -- ^ My user ID+                   -> Text+                   -- ^ The channel name+                   -> Maybe UserId+userIdForDMChannel me chanName =+    -- Direct channel names are of the form "UID__UID" where one of the+    -- UIDs is mine and the other is the other channel participant.+    let vals = T.splitOn "__" chanName+    in case vals of+        [u1, u2] -> if | (UI $ Id u1) == me  -> Just $ UI $ Id u2+                       | (UI $ Id u2) == me  -> Just $ UI $ Id u1+                       | otherwise        -> Nothing+        _ -> Nothing
+ src/Matterhorn/Types/DirectionalSeq.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}++{- | These declarations allow the use of a DirectionalSeq, which is a+   Seq that uses a phantom type to identify the ordering of the+   elements in the sequence (Forward or Reverse).  The constructors+   are not exported from this module so that a DirectionalSeq can only+   be constructed by the functions in this module.+-}++module Matterhorn.Types.DirectionalSeq where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Sequence as Seq+++data Chronological+data Retrograde+class SeqDirection a where+  type ReverseDirection a+instance SeqDirection Chronological+  where type ReverseDirection Chronological = Retrograde+instance SeqDirection Retrograde+  where type ReverseDirection Retrograde = Chronological++data SeqDirection dir => DirectionalSeq dir a =+    DSeq { dseq :: Seq a }+         deriving (Show, Functor, Foldable, Traversable)++emptyDirSeq :: DirectionalSeq dir a+emptyDirSeq = DSeq mempty++appendDirSeq :: DirectionalSeq dir a -> DirectionalSeq dir a -> DirectionalSeq dir a+appendDirSeq a b = DSeq $ mappend (dseq a) (dseq b)++onDirectedSeq :: SeqDirection dir => (Seq a -> Seq b)+              -> DirectionalSeq dir a -> DirectionalSeq dir b+onDirectedSeq f = DSeq . f . dseq++-- | Uses a start-predicate and and end-predicate to+-- identify (the first matching) subset that is delineated by+-- start-predicate and end-predicate (inclusive).  It will then call+-- the passed operation function on the subset messages to get back a+-- (possibly modified) set of messages, along with an extracted value.+-- The 'onDirSeqSubset' function will replace the original subset of+-- messages with the set returned by the operation function and return+-- the resulting message list along with the extracted value.++onDirSeqSubset :: SeqDirection dir =>+                 (e -> Bool) -> (e -> Bool)+               -> (DirectionalSeq dir e -> (DirectionalSeq dir e, a))+               -> DirectionalSeq dir e+               -> (DirectionalSeq dir e, a)+onDirSeqSubset startPred endPred op entries =+    let ml = dseq entries+        (bl, ml1) = Seq.breakl startPred ml+        (ml2, el) = Seq.breakl endPred ml1+        -- move match from start of el to end of ml2+        (ml2', el') = if not (Seq.null el)+                      then (ml2 <> Seq.take 1 el, Seq.drop 1 el)+                      else (ml2, el)+        (ml3, rval) = op $ DSeq ml2'+    in (DSeq bl `appendDirSeq` ml3 `appendDirSeq` DSeq el', rval)++-- | dirSeqBreakl splits the DirectionalSeq into a tuple where the+-- first element is the (possibly empty) DirectionalSeq of all+-- elements from the start for which the predicate returns false; the+-- second tuple element is the remainder of the list, starting with+-- the first element for which the predicate matched.+dirSeqBreakl :: SeqDirection dir =>+               (e -> Bool) -> DirectionalSeq dir e+             -> (DirectionalSeq dir e, DirectionalSeq dir e)+dirSeqBreakl isMatch entries =+    let (removed, remaining) = Seq.breakl isMatch $ dseq entries+    in (DSeq removed, DSeq remaining)++-- | dirSeqPartition splits the DirectionalSeq into a tuple of two+-- DirectionalSeq elements: the first contains all elements for which+-- the predicate is true and the second contains all elements for+-- which the predicate is false.+dirSeqPartition :: SeqDirection dir =>+                  (e -> Bool) -> DirectionalSeq dir e+                -> (DirectionalSeq dir e, DirectionalSeq dir e)+dirSeqPartition isMatch entries =+    let (match, nomatch) = Seq.partition isMatch $ dseq entries+    in (DSeq match, DSeq nomatch)+++withDirSeqHead :: SeqDirection dir => (e -> r) -> DirectionalSeq dir e -> Maybe r+withDirSeqHead op entries =+    case Seq.viewl (dseq entries) of+      Seq.EmptyL -> Nothing+      e Seq.:< _ -> Just $ op e
+ src/Matterhorn/Types/KeyEvents.hs view
@@ -0,0 +1,437 @@+module Matterhorn.Types.KeyEvents+  (+  -- * Types+    KeyEvent(..)+  , KeyConfig+  , Binding(..)+  , BindingState(..)++  -- * Data+  , allEvents++  -- * Parsing and pretty-printing+  , parseBinding+  , parseBindingList+  , ppBinding+  , nonCharKeys+  , eventToBinding++  -- * Key event name resolution+  , keyEventFromName+  , keyEventName+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Graphics.Vty as Vty+++-- | This enum represents all the possible key events a user might+--   want to use.+data KeyEvent+  = VtyRefreshEvent+  | ShowHelpEvent+  | EnterSelectModeEvent+  | ReplyRecentEvent+  | ToggleMessagePreviewEvent+  | InvokeEditorEvent+  | EnterFastSelectModeEvent+  | QuitEvent+  | NextChannelEvent+  | PrevChannelEvent+  | NextChannelEventAlternate+  | PrevChannelEventAlternate+  | NextUnreadChannelEvent+  | NextUnreadUserOrChannelEvent+  | LastChannelEvent+  | EnterOpenURLModeEvent+  | ClearUnreadEvent+  | ToggleMultiLineEvent+  | EnterFlaggedPostsEvent+  | ToggleChannelListVisibleEvent+  | ToggleExpandedChannelTopicsEvent+  | ShowAttachmentListEvent++  | EditorKillToBolEvent+  | EditorKillToEolEvent+  | EditorBolEvent+  | EditorEolEvent+  | EditorTransposeCharsEvent+  | EditorDeleteCharacter+  | EditorPrevCharEvent+  | EditorNextCharEvent+  | EditorPrevWordEvent+  | EditorNextWordEvent+  | EditorDeleteNextWordEvent+  | EditorDeletePrevWordEvent+  | EditorHomeEvent+  | EditorEndEvent+  | EditorYankEvent++  | SelectNextTabEvent+  | SelectPreviousTabEvent++  -- generic cancel+  | CancelEvent++  -- channel-scroll-specific+  | LoadMoreEvent+  | OpenMessageURLEvent++  -- scrolling events---maybe rebindable?+  | ScrollUpEvent+  | ScrollDownEvent+  | ScrollLeftEvent+  | ScrollRightEvent+  | PageUpEvent+  | PageDownEvent+  | PageRightEvent+  | PageLeftEvent+  | ScrollTopEvent+  | ScrollBottomEvent+  | SelectOldestMessageEvent++  -- select events---not the same as scrolling sometimes!+  | SelectUpEvent+  | SelectDownEvent++  -- search select events---these need to not be valid editor inputs+  -- (such as 'j' and 'k')+  | SearchSelectUpEvent+  | SearchSelectDownEvent++  -- E.g. Pressing enter on an item in a list to do something with it+  | ActivateListItemEvent++  | ViewMessageEvent+  | FillGapEvent+  | FlagMessageEvent+  | PinMessageEvent+  | YankMessageEvent+  | YankWholeMessageEvent+  | DeleteMessageEvent+  | EditMessageEvent+  | ReplyMessageEvent+  | ReactToMessageEvent++  -- Attachments+  | AttachmentListAddEvent+  | AttachmentListDeleteEvent+  | AttachmentOpenEvent++  -- Form submission+  | FormSubmitEvent+    deriving (Eq, Show, Ord, Enum)++allEvents :: [KeyEvent]+allEvents =+  [ QuitEvent+  , VtyRefreshEvent+  , ClearUnreadEvent++  , ToggleMessagePreviewEvent+  , InvokeEditorEvent+  , ToggleMultiLineEvent+  , CancelEvent+  , ReplyRecentEvent+  , SelectNextTabEvent+  , SelectPreviousTabEvent++  , 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+  , ToggleExpandedChannelTopicsEvent+  , ShowHelpEvent+  , EnterSelectModeEvent+  , EnterOpenURLModeEvent++  , LoadMoreEvent+  , OpenMessageURLEvent++  , ScrollUpEvent+  , ScrollDownEvent+  , ScrollLeftEvent+  , ScrollRightEvent+  , PageUpEvent+  , PageDownEvent+  , PageLeftEvent+  , PageRightEvent+  , ScrollTopEvent+  , ScrollBottomEvent+  , SelectOldestMessageEvent++  , SelectUpEvent+  , SelectDownEvent++  , ActivateListItemEvent++  , SearchSelectUpEvent+  , SearchSelectDownEvent++  , FlagMessageEvent+  , PinMessageEvent+  , ViewMessageEvent+  , FillGapEvent+  , YankMessageEvent+  , YankWholeMessageEvent+  , DeleteMessageEvent+  , EditMessageEvent+  , ReplyMessageEvent+  , ReactToMessageEvent+  , AttachmentListAddEvent+  , AttachmentListDeleteEvent+  , AttachmentOpenEvent+  , FormSubmitEvent+  ]++eventToBinding :: Vty.Event -> Binding+eventToBinding (Vty.EvKey k mods) = Binding mods k+eventToBinding k = error $ "BUG: invalid keybinding " <> show k++data Binding = Binding+  { kbMods :: [Vty.Modifier]+  , kbKey  :: Vty.Key+  } deriving (Eq, Show, Ord)++data BindingState =+    BindingList [Binding]+    | Unbound+    deriving (Show, Eq, Ord)++type KeyConfig = M.Map KeyEvent BindingState++parseBinding :: Text -> Either String Binding+parseBinding kb = go (T.splitOn "-" $ T.toLower kb) []+  where go [k] mods = do+          key <- pKey k+          return Binding { kbMods = mods, kbKey = key }+        go (k:ks) mods = do+          m <- case k of+            "s"       -> return Vty.MShift+            "shift"   -> return Vty.MShift+            "m"       -> return Vty.MMeta+            "meta"    -> return Vty.MMeta+            "a"       -> return Vty.MAlt+            "alt"     -> return Vty.MAlt+            "c"       -> return Vty.MCtrl+            "ctrl"    -> return Vty.MCtrl+            "control" -> return Vty.MCtrl+            _         -> Left ("Unknown modifier prefix: " ++ show k)+          go ks (m:mods)+        go [] _ = Left "Empty keybinding not allowed"+        pKey "esc"       = return Vty.KEsc+        pKey "backspace" = return Vty.KBS+        pKey "enter"     = return Vty.KEnter+        pKey "left"      = return Vty.KLeft+        pKey "right"     = return Vty.KRight+        pKey "up"        = return Vty.KUp+        pKey "down"      = return Vty.KDown+        pKey "upleft"    = return Vty.KUpLeft+        pKey "upright"   = return Vty.KUpRight+        pKey "downleft"  = return Vty.KDownLeft+        pKey "downright" = return Vty.KDownRight+        pKey "center"    = return Vty.KCenter+        pKey "backtab"   = return Vty.KBackTab+        pKey "printscreen" = return Vty.KPrtScr+        pKey "pause"     = return Vty.KPause+        pKey "insert"    = return Vty.KIns+        pKey "home"      = return Vty.KHome+        pKey "pgup"      = return Vty.KPageUp+        pKey "del"       = return Vty.KDel+        pKey "end"       = return Vty.KEnd+        pKey "pgdown"    = return Vty.KPageDown+        pKey "begin"     = return Vty.KBegin+        pKey "menu"      = return Vty.KMenu+        pKey "space"     = return (Vty.KChar ' ')+        pKey "tab"       = return (Vty.KChar '\t')+        pKey t+          | Just (c, "") <- T.uncons t =+              return (Vty.KChar c)+          | Just n <- T.stripPrefix "f" t =+              case readMaybe (T.unpack n) of+                  Nothing -> Left ("Unknown keybinding: " ++ show t)+                  Just i -> return (Vty.KFun i)+          | otherwise = Left ("Unknown keybinding: " ++ show t)++ppBinding :: Binding -> Text+ppBinding (Binding mods k) =+    T.intercalate "-" $ (ppMod <$> mods) <> [ppKey k]++ppKey :: Vty.Key -> Text+ppKey (Vty.KChar c)   = ppChar c+ppKey (Vty.KFun n)    = "F" <> (T.pack $ show n)+ppKey Vty.KBackTab    = "BackTab"+ppKey Vty.KEsc        = "Esc"+ppKey Vty.KBS         = "Backspace"+ppKey Vty.KEnter      = "Enter"+ppKey Vty.KUp         = "Up"+ppKey Vty.KDown       = "Down"+ppKey Vty.KLeft       = "Left"+ppKey Vty.KRight      = "Right"+ppKey Vty.KHome       = "Home"+ppKey Vty.KEnd        = "End"+ppKey Vty.KPageUp     = "PgUp"+ppKey Vty.KPageDown   = "PgDown"+ppKey Vty.KDel        = "Del"+ppKey Vty.KUpLeft     = "UpLeft"+ppKey Vty.KUpRight    = "UpRight"+ppKey Vty.KDownLeft   = "DownLeft"+ppKey Vty.KDownRight  = "DownRight"+ppKey Vty.KCenter     = "Center"+ppKey Vty.KPrtScr     = "PrintScreen"+ppKey Vty.KPause      = "Pause"+ppKey Vty.KIns        = "Insert"+ppKey Vty.KBegin      = "Begin"+ppKey Vty.KMenu       = "Menu"++nonCharKeys :: [Text]+nonCharKeys = map ppKey+  [ Vty.KBackTab, Vty.KEsc, Vty.KBS, Vty.KEnter, Vty.KUp, Vty.KDown+  , Vty.KLeft, Vty.KRight, Vty.KHome, Vty.KEnd, Vty.KPageDown+  , Vty.KPageUp, Vty.KDel, Vty.KUpLeft, Vty.KUpRight, Vty.KDownLeft+  , Vty.KDownRight, Vty.KCenter, Vty.KPrtScr, Vty.KPause, Vty.KIns+  , Vty.KBegin, Vty.KMenu+  ]++ppChar :: Char -> Text+ppChar '\t' = "Tab"+ppChar ' '  = "Space"+ppChar c    = T.singleton c++ppMod :: Vty.Modifier -> Text+ppMod Vty.MMeta  = "M"+ppMod Vty.MAlt   = "A"+ppMod Vty.MCtrl  = "C"+ppMod Vty.MShift = "S"++parseBindingList :: Text -> Either String BindingState+parseBindingList t =+    if T.toLower t == "unbound"+    then return Unbound+    else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," t)++keyEventFromName :: Text -> Either String KeyEvent+keyEventFromName t =+    let mapping = M.fromList [ (keyEventName e, e) | e <- allEvents ]+    in case M.lookup t mapping of+        Just e -> return e+        Nothing -> Left ("Unknown event: " ++ show t)++keyEventName :: KeyEvent -> Text+keyEventName ev = case ev of+  QuitEvent                 -> "quit"+  VtyRefreshEvent           -> "vty-refresh"+  ClearUnreadEvent          -> "clear-unread"+  CancelEvent               -> "cancel"++  ToggleMessagePreviewEvent -> "toggle-message-preview"+  InvokeEditorEvent         -> "invoke-editor"+  ToggleMultiLineEvent      -> "toggle-multiline"+  ReplyRecentEvent          -> "reply-recent"++  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"++  SelectNextTabEvent        -> "select-next-tab"+  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"+  ToggleExpandedChannelTopicsEvent -> "toggle-expanded-channel-topics"+  ShowHelpEvent             -> "show-help"+  EnterSelectModeEvent      -> "select-mode"+  EnterOpenURLModeEvent     -> "enter-url-open"++  LoadMoreEvent             -> "load-more"+  OpenMessageURLEvent       -> "open-message-url"++  ScrollUpEvent     -> "scroll-up"+  ScrollDownEvent   -> "scroll-down"+  ScrollLeftEvent   -> "scroll-left"+  ScrollRightEvent  -> "scroll-right"+  PageUpEvent       -> "page-up"+  PageDownEvent     -> "page-down"+  PageLeftEvent     -> "page-left"+  PageRightEvent    -> "page-right"+  ScrollTopEvent    -> "scroll-top"+  ScrollBottomEvent -> "scroll-bottom"+  SelectOldestMessageEvent -> "select-oldest-message"++  SelectUpEvent   -> "select-up"+  SelectDownEvent -> "select-down"++  SearchSelectUpEvent   -> "search-select-up"+  SearchSelectDownEvent -> "search-select-down"++  ActivateListItemEvent -> "activate-list-item"++  FlagMessageEvent   -> "flag-message"+  PinMessageEvent   -> "pin-message"+  ViewMessageEvent   -> "view-message"+  FillGapEvent       -> "fetch-for-gap"+  YankMessageEvent   -> "yank-message"+  YankWholeMessageEvent   -> "yank-whole-message"+  DeleteMessageEvent -> "delete-message"+  EditMessageEvent   -> "edit-message"+  ReplyMessageEvent  -> "reply-message"+  ReactToMessageEvent -> "react-to-message"++  AttachmentListAddEvent    -> "add-to-attachment-list"+  AttachmentListDeleteEvent -> "delete-from-attachment-list"+  AttachmentOpenEvent       -> "open-attachment"++  FormSubmitEvent -> "submit-form"
+ src/Matterhorn/Types/Messages.hs view
@@ -0,0 +1,750 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++{-|++The 'Message' is a single displayed event in a Channel.  All Messages+have a date/time, and messages that represent posts to the channel+have a (hash) ID, and displayable text, along with other attributes.++All Messages are sorted chronologically.  There is no assumption that+the server date/time is synchronized with the local date/time, so all+of the Message ordering uses the server's date/time.++The mattermost-api retrieves a 'Post' from the server, briefly encodes+the useful portions of that as a 'ClientPost' object and then converts+it to a 'Message' inserting this result it into the collection of+Messages associated with a Channel.  The PostID of the message+uniquely identifies that message and can be used to interact with the+server for subsequent operations relative to that message's 'Post'.+The date/time associated with these messages is generated by the+server.++There are also "messages" generated directly by the Matterhorn client+which can be used to display additional, client-related information to+the user. Examples of these client messages are: date boundaries, the+"new messages" marker, errors from invoking the browser, etc.  These+client-generated messages will have a date/time although it is locally+generated (usually by relation to an associated Post).++Most other Matterhorn operations primarily are concerned with+user-posted messages (@case mMessageId of Just _@ or @case mType of CP+_@), but others will include client-generated messages (@case mMessageId+of Nothing@ or @case mType of C _@).++--}++module Matterhorn.Types.Messages+  ( -- * Message and operations on a single Message+    Message(..)+  , isDeletable, isReplyable, isReactable, isEditable, isReplyTo, isGap, isFlaggable+  , isPinnable, isEmote, isJoinLeave, isTransition, isNewMessagesTransition+  , mText, mUser, mDate, mType, mPending, mDeleted, mPinned+  , mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged+  , mOriginalPost, mChannelId, mMarkdownSource+  , isBotMessage+  , MessageType(..)+  , MessageId(..)+  , ThreadState(..)+  , MentionedUser(..)+  , isPostMessage+  , messagePostId+  , messageIdPostId+  , UserRef(..)+  , ReplyState(..)+  , clientMessageToMessage+  , clientPostToMessage+  , clientPostReactionUserIds+  , newMessageOfType+    -- * Message Collections+  , Messages+  , ChronologicalMessages+  , RetrogradeMessages+  , MessageOps (..)+  , noMessages+  , messagesLength+  , filterMessages+  , reverseMessages+  , unreverseMessages+  , splitMessages+  , splitDirSeqOn+  , chronologicalMsgsWithThreadStates+  , retrogradeMsgsWithThreadStates+  , findMessage+  , getRelMessageId+  , messagesHead+  , messagesDrop+  , getNextMessage+  , getPrevMessage+  , getNextMessageId+  , getPrevMessageId+  , getNextPostId+  , getPrevPostId+  , getEarliestPostMsg+  , getLatestPostMsg+  , getEarliestSelectableMessage+  , getLatestSelectableMessage+  , findLatestUserMessage+  -- * Operations on any Message type+  , messagesAfter+  , removeMatchesFromSubset+  , withFirstMessage+  , msgURLs++  , LinkTarget(..)+  , LinkChoice(LinkChoice, _linkTarget)+  , linkUser+  , linkTarget+  , linkTime+  , linkLabel+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Control.Monad+import qualified Data.Foldable as F+import           Data.Hashable ( Hashable )+import qualified Data.Map.Strict as Map+import           Data.Sequence as Seq+import qualified Data.Set as S+import           Data.Tuple+import           Data.UUID ( UUID )+import           GHC.Generics ( Generic )+import           Lens.Micro.Platform ( makeLenses )++import           Network.Mattermost.Types ( ChannelId, PostId, Post+                                          , ServerTime, UserId, FileId+                                          )++import           Matterhorn.Types.DirectionalSeq+import           Matterhorn.Types.Posts+import           Matterhorn.Types.RichText ( RichTextBlock(..), Element(..)+                                , ElementData(..), findUsernames, blockGetURLs+                                , ElementStyle(..), URL(..), parseMarkdown+                                , TeamURLName+                                )+++-- | The state of a message's thread context.+data ThreadState =+    NoThread+    -- ^ The message is not in a thread at all.+    | InThreadShowParent+    -- ^ The message is in a thread, and the thread's root message+    -- (parent) should be displayed above this message.+    | InThread+    -- ^ The message is in a thread but the thread's root message should+    -- not be displayed above this message.+    deriving (Show, Eq)++-- ----------------------------------------------------------------------+-- * Messages++data MessageId = MessagePostId PostId+               | MessageUUID UUID+               deriving (Eq, Read, Show, Generic, Hashable)++messageIdPostId :: MessageId -> Maybe PostId+messageIdPostId (MessagePostId p) = Just p+messageIdPostId _ = Nothing++-- | A 'Message' is any message we might want to render, either from+--   Mattermost itself or from a client-internal source.+data Message = Message+  { _mText          :: Seq RichTextBlock+  , _mMarkdownSource :: Text+  , _mUser          :: UserRef+  , _mDate          :: ServerTime+  , _mType          :: MessageType+  , _mPending       :: Bool+  , _mDeleted       :: Bool+  , _mAttachments   :: Seq Attachment+  , _mInReplyToMsg  :: ReplyState+  , _mMessageId     :: Maybe MessageId+  , _mReactions     :: Map.Map Text (S.Set UserId)+  , _mOriginalPost  :: Maybe Post+  , _mFlagged       :: Bool+  , _mPinned        :: Bool+  , _mChannelId     :: Maybe ChannelId+  } deriving (Show)++isPostMessage :: Message -> Bool+isPostMessage m =+    isJust (_mMessageId m >>= messageIdPostId)++messagePostId :: Message -> Maybe PostId+messagePostId m = do+    mId <- _mMessageId m+    messageIdPostId mId++isDeletable :: Message -> Bool+isDeletable m =+    isJust (messagePostId m) &&+    case _mType m of+      CP NormalPost -> True+      CP Emote -> True+      _ -> False++isFlaggable :: Message -> Bool+isFlaggable = isJust . messagePostId++isPinnable :: Message -> Bool+isPinnable = isJust . messagePostId++isReplyable :: Message -> Bool+isReplyable m =+    isJust (messagePostId m) &&+    case _mType m of+      CP NormalPost -> True+      CP Emote -> True+      _ -> False++isReactable :: Message -> Bool+isReactable m =+    isJust (messagePostId m) &&+    case _mType m of+      CP NormalPost -> True+      CP Emote -> True+      _ -> False++isEditable :: Message -> Bool+isEditable m =+    isJust (messagePostId m) &&+    case _mType m of+      CP NormalPost -> True+      CP Emote -> True+      _ -> False++isReplyTo :: PostId -> Message -> Bool+isReplyTo expectedParentId m =+    case _mInReplyToMsg m of+        NotAReply                -> False+        InReplyTo actualParentId -> actualParentId == expectedParentId++isGap :: Message -> Bool+isGap m = case _mType m of+            C UnknownGapBefore -> True+            C UnknownGapAfter -> True+            _ -> False++isTransition :: Message -> Bool+isTransition m = case _mType m of+                   C DateTransition -> True+                   C NewMessagesTransition -> True+                   _ -> False++isNewMessagesTransition :: Message -> Bool+isNewMessagesTransition m = case _mType m of+    C NewMessagesTransition -> True+    _ -> False++isEmote :: Message -> Bool+isEmote m = case _mType m of+              CP Emote -> True+              _ -> False++isJoinLeave :: Message -> Bool+isJoinLeave m = case _mType m of+                  CP Join -> True+                  CP Leave -> True+                  _ -> False++-- | A 'Message' is the representation we use for storage and+--   rendering, so it must be able to represent either a+--   post from Mattermost or an internal message. This represents+--   the union of both kinds of post types.+data MessageType = C ClientMessageType+                 | CP ClientPostType+                 deriving (Show)++-- | There may be no user (usually an internal message), a reference to+-- a user (by Id), or the server may have supplied a specific username+-- (often associated with bots). The boolean flag indicates whether the+-- user reference is for a message from a bot.+data UserRef = NoUser | UserI Bool UserId | UserOverride Bool Text+               deriving (Eq, Show, Ord)++isBotMessage :: Message -> Bool+isBotMessage m =+    case _mUser m of+        UserI bot _        -> bot+        UserOverride bot _ -> bot+        NoUser             -> False++-- | The 'ReplyState' of a message represents whether a message+--   is a reply, and if so, to what message+data ReplyState =+    NotAReply+    | InReplyTo PostId+    deriving (Show, Eq)++data LinkTarget =+    LinkURL URL+    | LinkFileId FileId+    | LinkPermalink TeamURLName PostId+    deriving (Eq, Show, Ord)++-- | This type represents links to things in the 'open links' view.+data LinkChoice =+    LinkChoice { _linkTime   :: ServerTime+               , _linkUser   :: UserRef+               , _linkLabel  :: Maybe (Seq Element)+               , _linkTarget :: LinkTarget+               } deriving (Eq, Show)++makeLenses ''LinkChoice++-- | Convert a 'ClientMessage' to a 'Message'.  A 'ClientMessage' is+-- one that was generated by the Matterhorn client and which the+-- server knows nothing about.  For example, an error message+-- associated with passing a link to the local browser.+clientMessageToMessage :: ClientMessage -> Message+clientMessageToMessage cm = Message+  { _mText          = parseMarkdown Nothing (cm^.cmText)+  , _mMarkdownSource = cm^.cmText+  , _mUser          = NoUser+  , _mDate          = cm^.cmDate+  , _mType          = C $ cm^.cmType+  , _mPending       = False+  , _mDeleted       = False+  , _mAttachments   = Seq.empty+  , _mInReplyToMsg  = NotAReply+  , _mMessageId     = Nothing+  , _mReactions     = Map.empty+  , _mOriginalPost  = Nothing+  , _mFlagged       = False+  , _mPinned        = False+  , _mChannelId     = Nothing+  }+++data MentionedUser =+    UsernameMention Text+    | UserIdMention UserId+    deriving (Eq, Show, Ord)++clientPostReactionUserIds :: ClientPost -> S.Set UserId+clientPostReactionUserIds cp =+    S.unions $ F.toList $ cp^.cpReactions++-- | Builds a message from a ClientPost and also returns the set of+-- usernames mentioned in the text of the message.+clientPostToMessage :: ClientPost -> (Message, S.Set MentionedUser)+clientPostToMessage cp = (m, mentions)+    where+        mentions =+            S.fromList $+                (UsernameMention <$> (F.toList $ findUsernames $ cp^.cpText)) <>+                (UserIdMention <$> (F.toList $ clientPostReactionUserIds cp))+        m = Message { _mText = cp^.cpText+                    , _mMarkdownSource = cp^.cpMarkdownSource+                    , _mUser =+                        case cp^.cpUserOverride of+                            Just n | cp^.cpType == NormalPost -> UserOverride (cp^.cpFromWebhook) n+                            _ -> maybe NoUser (UserI (cp^.cpFromWebhook)) $ cp^.cpUser+                    , _mDate = cp^.cpDate+                    , _mType = CP $ cp^.cpType+                    , _mPending = cp^.cpPending+                    , _mDeleted = cp^.cpDeleted+                    , _mAttachments = cp^.cpAttachments+                    , _mInReplyToMsg =+                        case cp^.cpInReplyToPost of+                            Nothing  -> NotAReply+                            Just pId -> InReplyTo pId+                    , _mMessageId = Just $ MessagePostId $ cp^.cpPostId+                    , _mReactions = cp^.cpReactions+                    , _mOriginalPost = Just $ cp^.cpOriginalPost+                    , _mFlagged = False+                    , _mPinned = cp^.cpPinned+                    , _mChannelId = Just $ cp^.cpChannelId+                    }+++newMessageOfType :: Text -> MessageType -> ServerTime -> Message+newMessageOfType text typ d = Message+  { _mText         = parseMarkdown Nothing text+  , _mMarkdownSource = text+  , _mUser         = NoUser+  , _mDate         = d+  , _mType         = typ+  , _mPending      = False+  , _mDeleted      = False+  , _mAttachments  = Seq.empty+  , _mInReplyToMsg = NotAReply+  , _mMessageId    = Nothing+  , _mReactions    = Map.empty+  , _mOriginalPost = Nothing+  , _mFlagged      = False+  , _mPinned       = False+  , _mChannelId    = Nothing+  }++-- ** 'Message' Lenses++makeLenses ''Message++-- ----------------------------------------------------------------------++-- * Message Collections++-- | A wrapper for an ordered, unique list of 'Message' values.+--+-- This type has (and promises) the following instances: Show,+-- Functor, Monoid, Foldable, Traversable+type ChronologicalMessages = DirectionalSeq Chronological Message+type Messages = ChronologicalMessages++-- | There are also cases where the list of 'Message' values are kept+-- in reverse order (most recent -> oldest); these cases are+-- represented by the `RetrogradeMessages` type.+type RetrogradeMessages = DirectionalSeq Retrograde Message++-- ** Common operations on Messages++filterMessages :: SeqDirection seq+               => (a -> Bool)+               -> DirectionalSeq seq a+               -> DirectionalSeq seq a+filterMessages f = onDirectedSeq (Seq.filter f)++class MessageOps a where+    -- | addMessage inserts a date in proper chronological order, with+    -- the following extra functionality:+    --     * no duplication (by PostId)+    --     * no duplication (adjacent UnknownGap entries)+    addMessage :: Message -> a -> a++instance MessageOps ChronologicalMessages where+    addMessage m ml =+        case viewr (dseq ml) of+            EmptyR -> DSeq $ singleton m+            _ :> l ->+                case compare (m^.mDate) (l^.mDate) of+                  GT -> DSeq $ dseq ml |> m+                  EQ -> if m^.mMessageId == l^.mMessageId && isJust (m^.mMessageId)+                        then ml+                        else dirDateInsert m ml+                  LT -> dirDateInsert m ml++dirDateInsert :: Message -> ChronologicalMessages -> ChronologicalMessages+dirDateInsert m = onDirectedSeq $ finalize . foldr insAfter initial+   where initial = (Just m, mempty)+         insAfter c (Nothing, l) = (Nothing, c <| l)+         insAfter c (Just n, l) =+             case compare (n^.mDate) (c^.mDate) of+               GT -> (Nothing, c <| (n <| l))+               EQ -> if n^.mMessageId == c^.mMessageId && isJust (c^.mMessageId)+                     then (Nothing, c <| l)+                     else (Just n, c <| l)+               LT -> (Just n, c <| l)+         finalize (Just n, l) = n <| l+         finalize (_, l) = l++noMessages :: Messages+noMessages = DSeq mempty++messagesLength :: DirectionalSeq seq a -> Int+messagesLength (DSeq ms) = Seq.length ms++-- | Reverse the order of the messages+reverseMessages :: Messages -> RetrogradeMessages+reverseMessages = DSeq . Seq.reverse . dseq++-- | Unreverse the order of the messages+unreverseMessages :: RetrogradeMessages -> Messages+unreverseMessages = DSeq . Seq.reverse . dseq++splitDirSeqOn :: SeqDirection d+              => (a -> Bool)+              -> DirectionalSeq d a+              -> (Maybe a, (DirectionalSeq (ReverseDirection d) a,+                            DirectionalSeq d a))+splitDirSeqOn f msgs =+    let (removed, remaining) = dirSeqBreakl f msgs+        devomer = DSeq $ Seq.reverse $ dseq removed+    in (withDirSeqHead id remaining, (devomer, onDirectedSeq (Seq.drop 1) remaining))++-- ----------------------------------------------------------------------+-- * Operations on Posted Messages++-- | Searches for the specified MessageId and returns a tuple where the+-- first element is the Message associated with the MessageId (if it+-- exists), and the second element is another tuple: the first element+-- of the second is all the messages from the beginning of the list to+-- the message just before the MessageId message (or all messages if not+-- found) *in reverse order*, and the second element of the second are+-- all the messages that follow the found message (none if the message+-- was never found) in *forward* order.+splitMessages :: Maybe MessageId+              -> DirectionalSeq Chronological (Message, ThreadState)+              -> (Maybe (Message, ThreadState),+                   ( DirectionalSeq Retrograde (Message, ThreadState),+                     DirectionalSeq Chronological (Message, ThreadState)))+splitMessages mid msgs = splitDirSeqOn (\(m, _) -> isJust mid && m^.mMessageId == mid) msgs++-- | Given a message and its chronological predecessor, return+-- the thread state of the specified message with respect to its+-- predecessor.+threadStateFor :: Message+               -- ^ The message whose state is to be obtained.+               -> Message+               -- ^ The message's predecessor.+               -> ThreadState+threadStateFor msg prev = case msg^.mInReplyToMsg of+    InReplyTo rootId ->+        if | (prev^.mMessageId) == Just (MessagePostId rootId) ->+               InThread+           | prev^.mInReplyToMsg == msg^.mInReplyToMsg ->+               InThread+           | otherwise ->+               InThreadShowParent+    _ -> NoThread++retrogradeMsgsWithThreadStates :: RetrogradeMessages -> DirectionalSeq Retrograde (Message, ThreadState)+retrogradeMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs)+    where+        getMessagePredecessor ms =+                let visiblePredMsg m = not (isTransition m || m^.mDeleted) in+                case Seq.viewl ms of+                    prev Seq.:< rest ->+                        if visiblePredMsg prev+                        then Just prev+                        else getMessagePredecessor rest+                    Seq.EmptyL -> Nothing++        checkAdjacentMessages s = case Seq.viewl s of+            Seq.EmptyL -> mempty+            m Seq.:< t ->+                let new_m = case getMessagePredecessor t of+                        Just prev -> (m, threadStateFor m prev)+                        Nothing -> case m^.mInReplyToMsg of+                            InReplyTo _ -> (m, InThreadShowParent)+                            _           -> (m, NoThread)+                in new_m Seq.<| checkAdjacentMessages t++chronologicalMsgsWithThreadStates :: Messages -> DirectionalSeq Chronological (Message, ThreadState)+chronologicalMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs)+    where+        getMessagePredecessor ms =+                let visiblePredMsg m = not (isTransition m || m^.mDeleted) in+                case Seq.viewr ms of+                    rest Seq.:> prev ->+                        if visiblePredMsg prev+                        then Just prev+                        else getMessagePredecessor rest+                    Seq.EmptyR -> Nothing++        checkAdjacentMessages s = case Seq.viewr s of+            Seq.EmptyR -> mempty+            t Seq.:> m ->+                let new_m = case getMessagePredecessor t of+                        Just prev -> (m, threadStateFor m prev)+                        Nothing -> case m^.mInReplyToMsg of+                            InReplyTo _ -> (m, InThreadShowParent)+                            _           -> (m, NoThread)+                in checkAdjacentMessages t Seq.|> new_m++-- | findMessage searches for a specific message as identified by the+-- PostId.  The search starts from the most recent messages because+-- that is the most likely place the message will occur.+findMessage :: MessageId -> Messages -> Maybe Message+findMessage mid msgs =+    findIndexR (\m -> m^.mMessageId == Just mid) (dseq msgs)+    >>= Just . Seq.index (dseq msgs)++-- | Look forward for the first Message with an ID that follows the+-- specified Id and return it.  If no input Id supplied, get the+-- latest (most recent chronologically) Message in the input set.+getNextMessage :: Maybe MessageId -> Messages -> Maybe Message+getNextMessage = getRelMessageId++-- | Look backward for the first Message with an ID that follows the+-- specified MessageId and return it.  If no input MessageId supplied,+-- get the latest (most recent chronologically) Message in the input+-- set.+getPrevMessage :: Maybe MessageId -> Messages -> Maybe Message+getPrevMessage mId = getRelMessageId mId . reverseMessages++messagesHead :: (SeqDirection seq) => DirectionalSeq seq a -> Maybe a+messagesHead = withDirSeqHead id++messagesDrop :: (SeqDirection seq) => Int -> DirectionalSeq seq a -> DirectionalSeq seq a+messagesDrop i = onDirectedSeq (Seq.drop i)++-- | Look forward for the first Message with an ID that follows the+-- specified MessageId and return that found Message's ID; if no input+-- MessageId is specified, return the latest (most recent+-- chronologically) MessageId (if any) in the input set.+getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId+getNextMessageId mId = _mMessageId <=< getNextMessage mId++-- | Look backwards for the first Message with an ID that comes before+-- the specified MessageId and return that found Message's ID; if no+-- input MessageId is specified, return the latest (most recent+-- chronologically) MessageId (if any) in the input set.+getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId+getPrevMessageId mId = _mMessageId <=< getPrevMessage mId++-- | Look forward for the first Message with an ID that follows the+-- specified PostId and return that found Message's PostID; if no+-- input PostId is specified, return the latest (most recent+-- chronologically) PostId (if any) in the input set.+getNextPostId :: Maybe PostId -> Messages -> Maybe PostId+getNextPostId pid = messagePostId <=< getNextMessage (MessagePostId <$> pid)++-- | Look backwards for the first Post with an ID that comes before+-- the specified PostId.+getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId+getPrevPostId pid = messagePostId <=< getPrevMessage (MessagePostId <$> pid)+++getRelMessageId :: SeqDirection dir =>+                   Maybe MessageId+                -> DirectionalSeq dir Message+                -> Maybe Message+getRelMessageId mId =+  let isMId = const ((==) mId . _mMessageId) <$> mId+  in getRelMessage isMId++-- | Internal worker function to return a different user message in+-- relation to either the latest point or a specific message.+getRelMessage :: SeqDirection dir =>+                 Maybe (Message -> Bool)+              -> DirectionalSeq dir Message+              -> Maybe Message+getRelMessage matcher msgs =+  let after = case matcher of+                Just matchFun -> case splitDirSeqOn matchFun msgs of+                                   (_, (_, ms)) -> ms+                Nothing -> msgs+  in withDirSeqHead id $ filterMessages validSelectableMessage after++-- | Find the most recent message that is a Post (as opposed to a+-- local message) (if any).+getLatestPostMsg :: Messages -> Maybe Message+getLatestPostMsg msgs =+    case viewr $ dropWhileR (not . validUserMessage) (dseq msgs) of+      EmptyR -> Nothing+      _ :> m -> Just m++-- | Find the oldest message that is a message with an ID.+getEarliestSelectableMessage :: Messages -> Maybe Message+getEarliestSelectableMessage msgs =+    case viewl $ dropWhileL (not . validSelectableMessage) (dseq msgs) of+      EmptyL -> Nothing+      m :< _ -> Just m++-- | Find the most recent message that is a message with an ID.+getLatestSelectableMessage :: Messages -> Maybe Message+getLatestSelectableMessage msgs =+    case viewr $ dropWhileR (not . validSelectableMessage) (dseq msgs) of+      EmptyR -> Nothing+      _ :> m -> Just m++-- | Find the earliest message that is a Post (as opposed to a+-- local message) (if any).+getEarliestPostMsg :: Messages -> Maybe Message+getEarliestPostMsg msgs =+    case viewl $ dropWhileL (not . validUserMessage) (dseq msgs) of+      EmptyL -> Nothing+      m :< _ -> Just m++-- | Find the most recent message that is a message posted by a user+-- that matches the test (if any), skipping local client messages and+-- any user event that is not a message (i.e. find a normal message or+-- an emote).+findLatestUserMessage :: (Message -> Bool) -> Messages -> Maybe Message+findLatestUserMessage f ml =+    case viewr $ dropWhileR (\m -> not (validUserMessage m && f m)) $ dseq ml of+      EmptyR -> Nothing+      _ :> m -> Just m++validUserMessage :: Message -> Bool+validUserMessage m =+    not (m^.mDeleted) && case m^.mMessageId of+        Just (MessagePostId _) -> True+        _ -> False++validSelectableMessage :: Message -> Bool+validSelectableMessage m = (not $ m^.mDeleted) && (isJust $ m^.mMessageId)++-- ----------------------------------------------------------------------+-- * Operations on any Message type++-- | Return all messages that were posted after the specified date/time.+messagesAfter :: ServerTime -> Messages -> Messages+messagesAfter viewTime = onDirectedSeq $ takeWhileR (\m -> m^.mDate > viewTime)++-- | Removes any Messages (all types) for which the predicate is true+-- from the specified subset of messages (identified by a starting and+-- ending MessageId, inclusive) and returns the resulting list (from+-- start to finish, irrespective of 'firstId' and 'lastId') and the+-- list of removed items.+--+--    start       | end          |  operates-on              | (test) case+--   --------------------------------------------------------|-------------+--   Nothing      | Nothing      | entire list               |  C1+--   Nothing      | Just found   | start --> found]          |  C2+--   Nothing      | Just missing | nothing [suggest invalid] |  C3+--   Just found   | Nothing      | [found --> end            |  C4+--   Just found   | Just found   | [found --> found]         |  C5+--   Just found   | Just missing | [found --> end            |  C6+--   Just missing | Nothing      | nothing [suggest invalid] |  C7+--   Just missing | Just found   | start --> found]          |  C8+--   Just missing | Just missing | nothing [suggest invalid] |  C9+--+--  @removeMatchesFromSubset matchPred fromId toId msgs = (remaining, removed)@+--+removeMatchesFromSubset :: (Message -> Bool) -> Maybe MessageId -> Maybe MessageId+                        -> Messages -> (Messages, Messages)+removeMatchesFromSubset matching firstId lastId msgs =+    let knownIds = fmap (^.mMessageId) msgs+    in if isNothing firstId && isNothing lastId+       then swap $ dirSeqPartition matching msgs+       else if isJust firstId && firstId `elem` knownIds+            then onDirSeqSubset+                (\m -> m^.mMessageId == firstId)+                (if isJust lastId then \m -> m^.mMessageId == lastId else const False)+                (swap . dirSeqPartition matching) msgs+            else if isJust lastId && lastId `elem` knownIds+                 then onDirSeqSubset+                     (const True)+                     (\m -> m^.mMessageId == lastId)+                     (swap . dirSeqPartition matching) msgs+                 else (msgs, noMessages)++-- | Performs an operation on the first Message, returning just the+-- result of that operation, or Nothing if there were no messages.+-- Note that the message is not necessarily a posted user message.+withFirstMessage :: SeqDirection dir+                 => (Message -> r)+                 -> DirectionalSeq dir Message+                 -> Maybe r+withFirstMessage = withDirSeqHead++msgURLs :: Message -> Seq LinkChoice+msgURLs msg =+  let uRef = msg^.mUser+      mkTarget (Right url) = LinkURL url+      mkTarget (Left (tName, pId)) = LinkPermalink tName pId+      mkEntry (val, text) = LinkChoice (msg^.mDate) uRef text (mkTarget val)+      msgUrls = mkEntry <$> (Seq.fromList $ mconcat $ blockGetURLs <$> (toList $ msg^.mText))+      attachmentURLs = (\ a ->+                          LinkChoice+                            (msg^.mDate)+                            uRef+                            (Just $ attachmentLabel a)+                            (LinkFileId $ a^.attachmentFileId))+                       <$> (msg^.mAttachments)+      attachmentLabel a =+          Seq.fromList [ Element Normal $ EText "attachment"+                       , Element Normal ESpace+                       , Element Code $ EText $ a^.attachmentName+                       ]+  in msgUrls <> attachmentURLs
+ src/Matterhorn/Types/Posts.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}+module Matterhorn.Types.Posts+  ( ClientMessage+  , newClientMessage+  , cmDate+  , cmType+  , cmText++  , ClientMessageType(..)++  , Attachment+  , mkAttachment+  , attachmentName+  , attachmentFileId+  , attachmentURL++  , ClientPostType(..)++  , ClientPost+  , toClientPost+  , cpUserOverride+  , cpMarkdownSource+  , cpUser+  , cpText+  , cpType+  , cpReactions+  , cpPending+  , cpOriginalPost+  , cpFromWebhook+  , cpInReplyToPost+  , cpDate+  , cpChannelId+  , cpAttachments+  , cpDeleted+  , cpPostId+  , cpPinned++  , unEmote++  , postIsLeave+  , postIsJoin+  , postIsTopicChange+  , postIsEmote+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq+import qualified Data.Text as T+import qualified Data.Set as S+import           Data.Time.Clock ( getCurrentTime )+import           Lens.Micro.Platform ( makeLenses )++import           Network.Mattermost.Lenses+import           Network.Mattermost.Types++import           Matterhorn.Types.Common+import           Matterhorn.Types.RichText ( RichTextBlock(Blockquote), parseMarkdown+                                           , TeamBaseURL+                                           )+++-- * Client Messages++-- | A 'ClientMessage' is a message given to us by our client,+--   like help text or an error message.+data ClientMessage = ClientMessage+  { _cmText :: Text+  , _cmDate :: ServerTime+  , _cmType :: ClientMessageType+  } deriving (Show)++-- | Create a new 'ClientMessage' value.  This is a message generated+-- by this Matterhorn client and not by (or visible to) the Server.+-- These should be visible, but not necessarily integrated into any+-- special position in the output stream (i.e., they should generally+-- appear at the bottom of the messages display, but subsequent+-- messages should follow them), so this is a special place where+-- there is an assumed approximation of equality between local time+-- and server time.+newClientMessage :: (MonadIO m) => ClientMessageType -> Text -> m ClientMessage+newClientMessage ty msg = do+  now <- liftIO getCurrentTime+  return (ClientMessage msg (ServerTime now) ty)++-- | We format 'ClientMessage' values differently depending on+--   their 'ClientMessageType'+data ClientMessageType =+    Informative+    | Error+    | DateTransition+    | NewMessagesTransition+    | UnknownGapBefore -- ^ a region where the server may have+                       -- messages before the given timestamp that are+                       -- not known locally by this client+    | UnknownGapAfter  -- ^ a region where server may have messages+                       -- after the given timestamp that are not known+                       -- locally by this client+    deriving (Show)++-- ** 'ClientMessage' Lenses++makeLenses ''ClientMessage++-- * Mattermost Posts++-- | A 'ClientPost' is a temporary internal representation of+--   the Mattermost 'Post' type, with unnecessary information+--   removed and some preprocessing done.+data ClientPost = ClientPost+  { _cpText          :: Seq RichTextBlock+  , _cpMarkdownSource :: Text+  , _cpUser          :: Maybe UserId+  , _cpUserOverride  :: Maybe Text+  , _cpDate          :: ServerTime+  , _cpType          :: ClientPostType+  , _cpPending       :: Bool+  , _cpDeleted       :: Bool+  , _cpAttachments   :: Seq Attachment+  , _cpInReplyToPost :: Maybe PostId+  , _cpPostId        :: PostId+  , _cpChannelId     :: ChannelId+  , _cpReactions     :: Map.Map Text (S.Set UserId)+  , _cpOriginalPost  :: Post+  , _cpFromWebhook   :: Bool+  , _cpPinned        :: Bool+  } deriving (Show)++-- | An attachment has a very long URL associated, as well as+--   an actual file URL+data Attachment = Attachment+  { _attachmentName   :: Text+  , _attachmentURL    :: Text+  , _attachmentFileId :: FileId+  } deriving (Eq, Show)++mkAttachment :: Text -> Text -> FileId -> Attachment+mkAttachment = Attachment++-- | A Mattermost 'Post' value can represent either a normal+--   chat message or one of several special events.+data ClientPostType =+    NormalPost+    | Emote+    | Join+    | Leave+    | TopicChange+    deriving (Eq, Show)++-- ** Creating 'ClientPost' Values++-- | Determine the internal 'PostType' based on a 'Post'+postClientPostType :: Post -> ClientPostType+postClientPostType cp =+    if | postIsEmote cp       -> Emote+       | postIsJoin  cp       -> Join+       | postIsLeave cp       -> Leave+       | postIsTopicChange cp -> TopicChange+       | otherwise            -> NormalPost++-- | Find out whether a 'Post' represents a topic change+postIsTopicChange :: Post -> Bool+postIsTopicChange p = postType p == PostTypeHeaderChange++-- | Find out whether a 'Post' is from a @/me@ command+postIsEmote :: Post -> Bool+postIsEmote p =+    and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::Text)+        , ("*" `T.isPrefixOf` (sanitizeUserText $ postMessage p))+        , ("*" `T.isSuffixOf` (sanitizeUserText $ postMessage p))+        ]++-- | Find out whether a 'Post' is a user joining a channel+postIsJoin :: Post -> Bool+postIsJoin p =+  p^.postTypeL == PostTypeJoinChannel++-- | Find out whether a 'Post' is a user leaving a channel+postIsLeave :: Post -> Bool+postIsLeave p =+  p^.postTypeL == PostTypeLeaveChannel++-- | Undo the automatic formatting of posts generated by @/me@-commands+unEmote :: ClientPostType -> Text -> Text+unEmote Emote t = if "*" `T.isPrefixOf` t && "*" `T.isSuffixOf` t+                  then T.init $ T.tail t+                  else t+unEmote _ t = t++-- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a+--   'ParentId' if it has a known one.+toClientPost :: TeamBaseURL -> Post -> Maybe PostId -> ClientPost+toClientPost baseUrl p parentId =+  let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p+  in ClientPost { _cpText          = parseMarkdown (Just baseUrl) src <> getAttachmentText p+                , _cpMarkdownSource = src+                , _cpUser          = postUserId p+                , _cpUserOverride  = p^.postPropsL.postPropsOverrideUsernameL+                , _cpDate          = postCreateAt p+                , _cpType          = postClientPostType p+                , _cpPending       = False+                , _cpDeleted       = False+                , _cpPinned        = fromMaybe False $ postPinned p+                , _cpAttachments   = Seq.empty+                , _cpInReplyToPost = parentId+                , _cpPostId        = p^.postIdL+                , _cpChannelId     = p^.postChannelIdL+                , _cpReactions     = Map.empty+                , _cpOriginalPost  = p+                , _cpFromWebhook   = fromMaybe False $ p^.postPropsL.postPropsFromWebhookL+                }++-- | Right now, instead of treating 'attachment' properties specially, we're+--   just going to roll them directly into the message text+getAttachmentText :: Post -> Seq RichTextBlock+getAttachmentText p =+  case p^.postPropsL.postPropsAttachmentsL of+    Nothing -> Seq.empty+    Just attachments ->+      fmap (Blockquote . render) attachments+  where render att = parseMarkdown Nothing (att^.ppaTextL) <>+                     parseMarkdown Nothing (att^.ppaFallbackL)++-- ** 'ClientPost' Lenses++makeLenses ''Attachment+makeLenses ''ClientPost
+ src/Matterhorn/Types/RichText.hs view
@@ -0,0 +1,486 @@+-- | This module provides a set of data types to represent message text.+-- The types here are based loosely on the @cheapskate@ package's types+-- but provide higher-level support for the kinds of things we find in+-- Mattermost messages such as user and channel references.+--+-- To parse a Markdown document, use 'parseMarkdown'. To actually render+-- text in this representation, see the module 'Draw.RichText'.+module Matterhorn.Types.RichText+  ( RichTextBlock(..)+  , ListType(..)+  , CodeBlockInfo(..)+  , NumDecoration(..)+  , Element(..)+  , ElementData(..)+  , ElementStyle(..)+  , TeamBaseURL(..)+  , TeamURLName(..)++  , URL(..)+  , unURL++  , parseMarkdown+  , setElementStyle++  , findUsernames+  , blockGetURLs+  , findVerbatimChunk++  -- Exposed for testing only:+  , fromMarkdownBlocks+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Cheapskate as C+import           Data.Char ( isAlphaNum, isAlpha )+import qualified Data.Foldable as F+import           Data.Monoid (First(..))+import qualified Data.Set as S+import qualified Data.Sequence as Seq+import           Data.Sequence ( (<|), ViewL((:<)) )+import qualified Data.Text as T++import           Network.Mattermost.Types ( PostId(..), Id(..), ServerBaseURL(..) )++import           Matterhorn.Constants ( userSigil, normalChannelSigil )++-- | A team name found in a Mattermost post URL+data TeamURLName = TeamURLName Text+                 deriving (Eq, Show, Ord)++-- | A server base URL with a team name.+data TeamBaseURL = TeamBaseURL TeamURLName ServerBaseURL+                 deriving (Eq, Show)++-- | A block in a rich text document.+data RichTextBlock =+    Para (Seq Element)+    -- ^ A paragraph.+    | Header Int (Seq Element)+    -- ^ A section header with specified depth and contents.+    | Blockquote (Seq RichTextBlock)+    -- ^ A blockquote.+    | List Bool ListType (Seq (Seq RichTextBlock))+    -- ^ An itemized list.+    | CodeBlock CodeBlockInfo Text+    -- ^ A code block.+    | HTMLBlock Text+    -- ^ A fragment of raw HTML.+    | HRule+    -- ^ A horizontal rule.+    deriving (Show)++-- | The type of itemized list items.+data ListType =+    Bullet Char+    -- ^ Decorate the items with bullet using the specified character.+    | Numbered NumDecoration Int+    -- ^ Number the items starting at the specified number; use the+    -- indicated decoration following the number.+    deriving (Eq, Show, Ord)++-- | Information about a code block.+data CodeBlockInfo =+    CodeBlockInfo { codeBlockLanguage :: Maybe Text+                  -- ^ The language of the source code in the code+                  -- block, if any. This is encoded in Markdown as a+                  -- sequence of non-whitespace characters following the+                  -- fenced code block opening backticks.+                  , codeBlockInfo :: Maybe Text+                  -- ^ Any text that comes after the language token.+                  -- This text is separated from the language token by+                  -- whitespace.+                  }+                  deriving (Eq, Show, Ord)++-- | Ways to decorate numbered itemized list items. The decoration+-- follows the list item number.+data NumDecoration =+    Paren+    | Period+    deriving (Eq, Show, Ord)++-- | A single logical inline element in a rich text block.+data Element =+    Element { eStyle :: ElementStyle+            -- ^ The element's visual style.+            , eData :: ElementData+            -- ^ The element's data.+            }+            deriving (Show, Eq, Ord)++setElementStyle :: ElementStyle -> Element -> Element+setElementStyle s e = e { eStyle = s }++-- | A URL.+newtype URL = URL Text+            deriving (Eq, Show, Ord)++unURL :: URL -> Text+unURL (URL url) = url++-- | The kinds of data that can appear in rich text elements.+data ElementData =+    EText Text+    -- ^ A sequence of non-whitespace characters.+    | ESpace+    -- ^ A single space.+    | ESoftBreak+    -- ^ A soft line break.+    | ELineBreak+    -- ^ A hard line break.+    | ERawHtml Text+    -- ^ Raw HTML.+    | EEditSentinel Bool+    -- ^ A sentinel indicating that some text has been edited (used+    -- to indicate that mattermost messages have been edited by their+    -- authors). This has no parsable representation; it is only used+    -- to annotate a message prior to rendering to add a visual editing+    -- indicator. The boolean indicates whether the edit was "recent"+    -- (True) or not (False).+    | EUser Text+    -- ^ A user reference. The text here includes only the username, not+    -- the sigil.+    | EChannel Text+    -- ^ A channel reference. The text here includes only the channel+    -- name, not the sigil.+    | EHyperlink URL (Maybe (Seq Element))+    -- ^ A hyperlink to the specified URL. Optionally provides an+    -- element sequence indicating the URL's text label; if absent, the+    -- label is understood to be the URL itself.+    | EImage URL (Maybe (Seq Element))+    -- ^ An image at the specified URL. Optionally provides an element+    -- sequence indicating the image's "alt" text label; if absent, the+    -- label is understood to be the URL itself.+    | EEmoji Text+    -- ^ An emoji reference. The text here includes only the text+    -- portion, not the colons, e.g. "foo" instead of ":foo:".+    | ENonBreaking (Seq Element)+    -- ^ A sequence of elements that must never be separated during line+    -- wrapping.+    | EPermalink TeamURLName PostId (Maybe (Seq Element))+    -- ^ A permalink to the specified team (name) and post ID with an+    -- optional label.+    deriving (Show, Eq, Ord)++-- | Element visual styles.+data ElementStyle =+    Normal+    -- ^ Normal text+    | Emph+    -- ^ Emphasized text+    | Strikethrough+    -- ^ Strikethrough text+    | Strong+    -- ^ Bold text+    | Code+    -- ^ Inline code segment or code block+    | Hyperlink URL ElementStyle+    -- ^ A terminal hyperlink to the specified URL, composed with+    -- another element style+    | Permalink+    -- ^ A post permalink+    deriving (Eq, Show, Ord)++parseMarkdown :: Maybe TeamBaseURL -> T.Text -> Seq RichTextBlock+parseMarkdown baseUrl t =+    fromMarkdownBlocks baseUrl bs where C.Doc _ bs = C.markdown C.def t++-- | Convert a sequence of markdown (Cheapskate) blocks into rich text+-- blocks.+fromMarkdownBlocks :: Maybe TeamBaseURL -> C.Blocks -> Seq RichTextBlock+fromMarkdownBlocks baseUrl = fmap (fromMarkdownBlock baseUrl)++-- | Convert a single markdown block into a single rich text block.+fromMarkdownBlock :: Maybe TeamBaseURL -> C.Block -> RichTextBlock+fromMarkdownBlock baseUrl (C.Para is) =+    Para $ fromMarkdownInlines baseUrl is+fromMarkdownBlock baseUrl (C.Header level is) =+    Header level $ fromMarkdownInlines baseUrl is+fromMarkdownBlock baseUrl (C.Blockquote bs) =+    Blockquote $ fromMarkdownBlock baseUrl <$> bs+fromMarkdownBlock baseUrl (C.List f ty bss) =+    List f (fromMarkdownListType ty) $ fmap (fromMarkdownBlock baseUrl) <$> Seq.fromList bss+fromMarkdownBlock _ (C.CodeBlock attr body) =+    CodeBlock (fromMarkdownCodeAttr attr) body+fromMarkdownBlock _ (C.HtmlBlock body) =+    HTMLBlock body+fromMarkdownBlock _ C.HRule =+    HRule++fromMarkdownCodeAttr :: C.CodeAttr -> CodeBlockInfo+fromMarkdownCodeAttr (C.CodeAttr lang info) =+    let strippedLang = T.strip lang+        strippedInfo = T.strip info+        maybeText t = if T.null t then Nothing else Just t+    in CodeBlockInfo (maybeText strippedLang)+                     (maybeText strippedInfo)++fromMarkdownListType :: C.ListType -> ListType+fromMarkdownListType (C.Bullet c) =+    Bullet c+fromMarkdownListType (C.Numbered wrap i) =+    let dec = case wrap of+                  C.PeriodFollowing -> Period+                  C.ParenFollowing -> Paren+    in Numbered dec i++-- | Remove hyperlinks from an inline sequence. This should only be used+-- for sequences that are themselves used as labels for hyperlinks; this+-- prevents them from embedding their own hyperlinks, which is nonsense.+--+-- Any hyperlinks found in the sequence will be replaced with a text+-- represent of their URL (if they have no label) or the label itself+-- otherwise.+removeHyperlinks :: Seq C.Inline -> Seq C.Inline+removeHyperlinks is =+    case Seq.viewl is of+        h :< t ->+            case h of+                C.Link label theUrl _ ->+                    if Seq.null label+                    then C.Str theUrl <| removeHyperlinks t+                    else removeHyperlinks label <> removeHyperlinks t+                _ -> h <| removeHyperlinks t+        Seq.EmptyL -> mempty++-- | Convert a sequence of Markdown inline values to a sequence of+-- Elements.+--+-- This conversion converts sequences of Markdown AST fragments into+-- RichText elements. In particular, this function may determine that+-- some sequences of Markdown text fragments belong together, such as+-- the sequence @["@", "joe", "-", "user"]@, which should be treated as+-- a single "@joe-user" token due to username character validation. When+-- appropriate, this function does such consolidation when converting to+-- RichText elements.+--+-- This function is also partially responsible for paving the way for+-- line-wrapping later on when RichText is rendered. This means that,+-- when possible, the elements produced by this function need to be as+-- small as possible, without losing structure information. An example+-- of this is Markdown inline code fragments, such as "`this is code`".+-- This function will convert that one Markdown inline code fragment+-- into a sequence of five RichText elements, each with a "Code" style+-- assigned: @[EText "this", ESpace, EText "is", ESpace, EText "code"]@.+-- This "flattening" of the original Markdown structure makes it much+-- easier to do line-wrapping without losing style information because+-- it is possible to gather up tokens that do not exceed line widths+-- without losing style information. This is key to rendering the text+-- with the right terminal attributes.+--+-- However, there are a couple of cases where such flattening does *not*+-- happen: hyperlinks and images. In these cases we do not flatten the+-- (arbitrary) text label structure of links and images because we need+-- to be able to recover those labels to gather up URLs to show to the+-- user in the URL list. So we leave the complete text structure of+-- those labels behind in the 'EHyperlink' and 'EImage' constructors as+-- sequences of Elements. This means that logic in 'Draw.RichText' that+-- does line-wrapping will have to explicitly break up link and image+-- labels across line breaks.+fromMarkdownInlines :: Maybe TeamBaseURL -> Seq C.Inline -> Seq Element+fromMarkdownInlines baseUrl inlines =+    let go sty is = case Seq.viewl is of+          C.Str "~" :< xs ->+              case Seq.viewl xs of+                  C.Str "~" :< xs2 ->+                      case takeUntilStrikethroughEnd xs2 of+                          Nothing -> Element sty (EText "~") <|+                                     go sty xs+                          Just (strikethroughInlines, rest) ->+                              go Strikethrough strikethroughInlines <>+                              go sty rest+                  _ ->+                      let (cFrags, rest) = Seq.spanl isNameFragment xs+                          cn = T.concat (unsafeGetStr <$> F.toList cFrags)+                      in if not (T.null cn)+                         then Element sty (EChannel cn) <| go sty rest+                         else Element sty (EText normalChannelSigil) <| go sty xs+          C.Str ":" :< xs ->+              let validEmojiFragment (C.Str f) =+                      f `elem` ["_", "-"] || T.all isAlphaNum f+                  validEmojiFragment _ = False+                  (emojiFrags, rest) = Seq.spanl validEmojiFragment xs+                  em = T.concat $ unsafeGetStr <$> F.toList emojiFrags+              in case Seq.viewl rest of+                  C.Str ":" :< rest2 ->+                      Element Normal (EEmoji em) <| go sty rest2+                  _ ->+                      Element sty (EText ":") <| go sty xs+          C.Str t :< xs | userSigil `T.isPrefixOf` t ->+              let (uFrags, rest) = Seq.spanl isNameFragment xs+                  t' = T.concat $ t : (unsafeGetStr <$> F.toList uFrags)+                  u = T.drop 1 t'+              in Element sty (EUser u) <| go sty rest+          C.Str t :< xs ->+              -- When we encounter a string node, we go ahead and+              -- process the rest of the nodes in the sequence. If the+              -- new sequence starts with *another* string node with+              -- the same style, we merge them. We do this because+              -- Cheapskate will parse things like punctuation as+              -- individual string nodes, but we want to keep those+              -- together with any text is adjacent to them to avoid+              -- e.g. breaking up quotes from quoted text when doing+              -- line-wrapping. It's important to make sure we only do+              -- this for adjacent string (i.e. not whitespace) nodes+              -- and that we make sure we only merge when they have the+              -- same style.+              let rest = go sty xs+                  e = Element sty (EText t)+              in case Seq.viewl rest of+                  Element sty2 (EText t2) :< tail_ | sty2 == sty ->+                      (Element sty (EText (t <> t2))) <| tail_+                  _ ->+                      e <| rest+          C.Space :< xs ->+              Element sty ESpace <| go sty xs+          C.SoftBreak :< xs ->+              Element sty ESoftBreak <| go sty xs+          C.LineBreak :< xs ->+              Element sty ELineBreak <| go sty xs+          C.Link label theUrl _ :< xs ->+              let mLabel = if Seq.null label+                           then Nothing+                           else case F.toList label of+                               [C.Str u] | u == theUrl -> Nothing+                               _ -> Just $ fromMarkdownInlines baseUrl $ removeHyperlinks label+                  rest = go sty xs+                  this = case flip getPermalink theUrl =<< baseUrl of+                      Nothing ->+                          let url = URL theUrl+                          in Element (Hyperlink url sty) $ EHyperlink url mLabel+                      Just (tName, pId) ->+                          Element Permalink $ EPermalink tName pId mLabel+              in this <| rest+          C.Image altIs theUrl _ :< xs ->+              let mLabel = if Seq.null altIs+                           then Nothing+                           else Just $ fromMarkdownInlines baseUrl altIs+                  url = URL theUrl+              in (Element (Hyperlink url sty) $ EImage url mLabel) <| go sty xs+          C.RawHtml t :< xs ->+              Element sty (ERawHtml t) <| go sty xs+          C.Code t :< xs ->+              -- We turn a single code string into individual Elements+              -- so we can perform line-wrapping on the inline code+              -- text.+              let ts = [ Element Code frag+                       | wd <- T.split (== ' ') t+                       , frag <- case wd of+                           "" -> [ESpace]+                           _  -> [ESpace, EText wd]+                       ]+                  ts' = case ts of+                    (Element _ ESpace:rs) -> rs+                    _                     -> ts+              in Seq.fromList ts' <> go sty xs+          C.Emph as :< xs ->+              go Emph as <> go sty xs+          C.Strong as :< xs ->+              go Strong as <> go sty xs+          C.Entity t :< xs ->+              Element sty (EText t) <| go sty xs+          Seq.EmptyL -> mempty++    in go Normal inlines++takeUntilStrikethroughEnd :: Seq C.Inline -> Maybe (Seq C.Inline, Seq C.Inline)+takeUntilStrikethroughEnd is =+    let go pos s = case Seq.viewl s of+            C.Str "~" :< rest ->+                case Seq.viewl rest of+                    C.Str "~" :< _ ->+                        Just pos+                    _ -> go (pos + 1) rest+            _ :< rest -> go (pos + 1) rest+            Seq.EmptyL -> Nothing+    in do+        pos <- go 0 is+        let (h, t) = Seq.splitAt pos is+        return (h, Seq.drop 2 t)++-- | If the specified URL matches the active server base URL and team+-- and refers to a post, extract the team name and post ID values and+-- return them.+getPermalink :: TeamBaseURL -> Text -> Maybe (TeamURLName, PostId)+getPermalink (TeamBaseURL tName (ServerBaseURL baseUrl)) url =+    let newBaseUrl = if "/" `T.isSuffixOf` baseUrl+                     then baseUrl+                     else baseUrl <> "/"+    in if not $ newBaseUrl `T.isPrefixOf` url+       then Nothing+       else let rest = T.drop (T.length newBaseUrl) url+                (tName', rawPIdStr) = T.breakOn "/pl/" rest+                pIdStr = T.drop 4 rawPIdStr+            in if tName == TeamURLName tName' && not (T.null pIdStr)+               then Just (tName, PI $ Id pIdStr)+               else Nothing+++unsafeGetStr :: C.Inline -> Text+unsafeGetStr (C.Str t) = t+unsafeGetStr _ = error "BUG: unsafeGetStr called on non-Str Inline"++-- | Obtain all username references in a sequence of rich text blocks.+findUsernames :: Seq RichTextBlock -> S.Set T.Text+findUsernames = S.unions . F.toList . fmap blockFindUsernames++blockFindUsernames :: RichTextBlock -> S.Set T.Text+blockFindUsernames (Para is) =+    elementFindUsernames $ F.toList is+blockFindUsernames (Header _ is) =+    elementFindUsernames $ F.toList is+blockFindUsernames (Blockquote bs) =+    findUsernames bs+blockFindUsernames (List _ _ bs) =+    S.unions $ F.toList $ findUsernames <$> bs+blockFindUsernames _ =+    mempty++elementFindUsernames :: [Element] -> S.Set T.Text+elementFindUsernames [] = mempty+elementFindUsernames (e : es) =+    case eData e of+        EUser u -> S.insert u $ elementFindUsernames es+        _ -> elementFindUsernames es++-- | Obtain all URLs (and optional labels) in a rich text block.+blockGetURLs :: RichTextBlock -> [(Either (TeamURLName, PostId) URL, Maybe (Seq Element))]+blockGetURLs (Para is) =+    catMaybes $ elementGetURL <$> toList is+blockGetURLs (Header _ is) =+    catMaybes $ elementGetURL <$> toList is+blockGetURLs (Blockquote bs) =+    mconcat $ blockGetURLs <$> toList bs+blockGetURLs (List _ _ bss) =+    mconcat $ mconcat $+    (fmap blockGetURLs . F.toList) <$> F.toList bss+blockGetURLs _ =+    mempty++elementGetURL :: Element -> Maybe (Either (TeamURLName, PostId) URL, Maybe (Seq Element))+elementGetURL (Element _ (EHyperlink url label)) =+    Just (Right url, label)+elementGetURL (Element _ (EImage url label)) =+    Just (Right url, label)+elementGetURL (Element _ (EPermalink tName pId label)) =+    Just (Left (tName, pId), label)+elementGetURL _ =+    Nothing++-- | Find the first code block in a sequence of rich text blocks.+findVerbatimChunk :: Seq RichTextBlock -> Maybe Text+findVerbatimChunk = getFirst . F.foldMap go+  where go (CodeBlock _ t) = First (Just t)+        go _               = First Nothing++isValidNameChar :: Char -> Bool+isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-'++isNameFragment :: C.Inline -> Bool+isNameFragment (C.Str t) =+    not (T.null t) && isValidNameChar (T.head t)+isNameFragment _ = False
+ src/Matterhorn/Types/Users.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DeriveFunctor #-}++module Matterhorn.Types.Users+  ( UserInfo(..)+  , UserStatus(..)+  , Users   -- constructor remains internal+  -- * Lenses created for accessing UserInfo fields+  , uiName, uiId, uiStatus, uiInTeam, uiNickName, uiFirstName, uiLastName, uiEmail+  , uiDeleted+  -- * Various operations on UserInfo+  -- * Creating UserInfo objects+  , userInfoFromUser+  -- * Miscellaneous+  , getUsernameSet+  , trimUserSigil+  , statusFromText+  , findUserById+  , findUserByUsername+  , findUserByNickname+  , noUsers, addUser, allUsers+  , modifyUserById+  , userDeleted+  , TypingUsers+  , noTypingUsers+  , addTypingUser+  , allTypingUsers+  , expireTypingUsers+  , getAllUserIds+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.HashMap.Strict as HM+import qualified Data.Set as S+import           Data.Semigroup ( Max(..) )+import qualified Data.Text as T+import           Lens.Micro.Platform ( (%~), makeLenses, ix )++import           Network.Mattermost.Types ( UserId(..), User(..) )++import           Matterhorn.Types.Common+import           Matterhorn.Constants ( userSigil )++-- * 'UserInfo' Values++-- | A 'UserInfo' value represents everything we need to know at+--   runtime about a user+data UserInfo = UserInfo+  { _uiName      :: Text+  , _uiId        :: UserId+  , _uiStatus    :: UserStatus+  , _uiInTeam    :: Bool+  , _uiNickName  :: Maybe Text+  , _uiFirstName :: Text+  , _uiLastName  :: Text+  , _uiEmail     :: Text+  , _uiDeleted   :: Bool+  } deriving (Eq, Show)++-- | Is this user deleted?+userDeleted :: User -> Bool+userDeleted u =+    case userCreateAt u of+        Nothing -> False+        Just c -> userDeleteAt u > c++-- | Create a 'UserInfo' value from a Mattermost 'User' value+userInfoFromUser :: User -> Bool -> UserInfo+userInfoFromUser up inTeam = UserInfo+  { _uiName      = userUsername up+  , _uiId        = userId up+  , _uiStatus    = Offline+  , _uiInTeam    = inTeam+  , _uiNickName  =+      let nick = sanitizeUserText $ userNickname up+      in if T.null nick then Nothing else Just nick+  , _uiFirstName = sanitizeUserText $ userFirstName up+  , _uiLastName  = sanitizeUserText $ userLastName up+  , _uiEmail     = sanitizeUserText $ userEmail up+  , _uiDeleted   = userDeleted up+  }++-- | The 'UserStatus' value represents possible current status for+--   a user+data UserStatus+  = Online+  | Away+  | Offline+  | DoNotDisturb+  | Other Text+    deriving (Eq, Show)++statusFromText :: Text -> UserStatus+statusFromText t = case t of+  "online"  -> Online+  "offline" -> Offline+  "away"    -> Away+  "dnd"     -> DoNotDisturb+  _         -> Other t++-- ** 'UserInfo' lenses++makeLenses ''UserInfo++-- ** Manage the collection of all Users++-- | Define a binary kinded type to allow derivation of functor.+data AllMyUsers a =+    AllUsers { _ofUsers :: HashMap UserId a+             , _usernameSet :: S.Set Text+             }+             deriving Functor++makeLenses ''AllMyUsers++-- | Define the exported typename which universally binds the+-- collection to the UserInfo type.+type Users = AllMyUsers UserInfo++getUsernameSet :: Users -> S.Set Text+getUsernameSet = _usernameSet++-- | Initial collection of Users with no members+noUsers :: Users+noUsers = AllUsers HM.empty mempty++getAllUserIds :: Users -> [UserId]+getAllUserIds = HM.keys . _ofUsers++-- | Add a member to the existing collection of Users+addUser :: UserInfo -> Users -> Users+addUser userinfo u =+    u & ofUsers %~ HM.insert (userinfo^.uiId) userinfo+      & usernameSet %~ S.insert (userinfo^.uiName)++-- | Get a list of all known users+allUsers :: Users -> [UserInfo]+allUsers = HM.elems . _ofUsers++-- | Define the exported typename to represent the collection of users+-- | who are currently typing. The values kept against the user id keys are the+-- | latest timestamps of typing events from the server.+type TypingUsers = AllMyUsers (Max UTCTime)++-- | Initial collection of TypingUsers with no members+noTypingUsers :: TypingUsers+noTypingUsers = AllUsers HM.empty mempty++-- | Add a member to the existing collection of TypingUsers+addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers+addTypingUser uId ts = ofUsers %~ HM.insertWith (<>) uId (Max ts)++-- | Get a list of all typing users+allTypingUsers :: TypingUsers -> [UserId]+allTypingUsers = HM.keys . _ofUsers++-- | Remove all the expired users from the collection of TypingUsers.+-- | Expiry is decided by the given timestamp.+expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers+expireTypingUsers expiryTimestamp =+    ofUsers %~ HM.filter (\(Max ts') -> ts' >= expiryTimestamp)++-- | Get the User information given the UserId+findUserById :: UserId -> Users -> Maybe UserInfo+findUserById uId = HM.lookup uId . _ofUsers++-- | Get the User information given the user's name. This is an exact+-- match on the username field. It will automatically trim a user sigil+-- from the input.+findUserByUsername :: Text -> Users -> Maybe (UserId, UserInfo)+findUserByUsername name allusers =+  case filter ((== trimUserSigil name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of+    (usr : []) -> Just usr+    _ -> Nothing++-- | Get the User information given the user's name. This is an exact+-- match on the nickname field, not necessarily the presented name. It+-- will automatically trim a user sigil from the input.+findUserByNickname:: Text -> Users -> Maybe (UserId, UserInfo)+findUserByNickname nick us =+  case filter ((== (Just $ trimUserSigil nick)) . _uiNickName . snd) $ HM.toList $ _ofUsers us of+    (pair : []) -> Just pair+    _ -> Nothing++trimUserSigil :: Text -> Text+trimUserSigil n+    | userSigil `T.isPrefixOf` n = T.tail n+    | otherwise                  = n++-- | Extract a specific user from the collection and perform an+-- endomorphism operation on it, then put it back into the collection.+modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users+modifyUserById uId f = ofUsers.ix(uId) %~ f
+ src/Matterhorn/Util.hs view
@@ -0,0 +1,25 @@+module Matterhorn.Util+  ( nubOn+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import qualified Data.Set as Set+++-- | The 'nubOn' function removes duplicate elements from a list. In+-- particular, it keeps only the /last/ occurrence of each+-- element. The equality of two elements in a call to @nub f@ is+-- determined using @f x == f y@, and the resulting elements must have+-- an 'Ord' instance in order to make this function more efficient.+nubOn :: (Ord b) => (a -> b) -> [a] -> [a]+nubOn f = snd . go Set.empty+  where go before [] = (before, [])+        go before (x:xs) =+          let (before', xs') = go before xs+              key = f x in+          if key `Set.member` before'+            then (before', xs')+            else (Set.insert key before', x : xs')
+ src/Matterhorn/Windows/ViewMessage.hs view
@@ -0,0 +1,218 @@+module Matterhorn.Windows.ViewMessage+  ( viewMessageWindowTemplate+  , viewMessageKeybindings+  , viewMessageKeyHandlers+  , viewMessageReactionsKeybindings+  , viewMessageReactionsKeyHandlers+  )+where++import           Prelude ()+import           Matterhorn.Prelude++import           Brick+import           Brick.Widgets.Border++import qualified Data.Set as S+import qualified Data.Map as M+import           Data.Maybe ( fromJust )+import qualified Data.Text as T+import qualified Data.Foldable as F+import qualified Graphics.Vty as Vty+import           Lens.Micro.Platform ( to )++import           Matterhorn.Constants+import           Matterhorn.Events.Keybindings+import           Matterhorn.Themes+import           Matterhorn.Types+import           Matterhorn.Draw.RichText+import           Matterhorn.Draw.Messages ( nameForUserRef )++-- | The template for "View Message" windows triggered by message+-- selection mode.+viewMessageWindowTemplate :: TabbedWindowTemplate ViewMessageWindowTab+viewMessageWindowTemplate =+    TabbedWindowTemplate { twtEntries = [ messageEntry+                                        , reactionsEntry+                                        ]+                         , twtTitle = const $ txt "View Message"+                         }++messageEntry :: TabbedWindowEntry ViewMessageWindowTab+messageEntry =+    TabbedWindowEntry { tweValue = VMTabMessage+                      , tweRender = renderTab+                      , tweHandleEvent = handleEvent+                      , tweTitle = tabTitle+                      , tweShowHandler = onShow+                      }++reactionsEntry :: TabbedWindowEntry ViewMessageWindowTab+reactionsEntry =+    TabbedWindowEntry { tweValue = VMTabReactions+                      , tweRender = renderTab+                      , tweHandleEvent = handleEvent+                      , tweTitle = tabTitle+                      , tweShowHandler = onShow+                      }++tabTitle :: ViewMessageWindowTab -> Bool -> T.Text+tabTitle VMTabMessage _ = "Message"+tabTitle VMTabReactions _ = "Reactions"++-- When we show the tabs, we need to reset the viewport scroll position+-- for viewports in that tab. This is because an older View Message+-- window used the same handle for the viewport and we don't want that+-- old state affecting this window. This also means that switching tabs+-- in an existing window resets this state, too.+onShow :: ViewMessageWindowTab -> MH ()+onShow VMTabMessage = resetVp ViewMessageArea+onShow VMTabReactions = resetVp ViewMessageArea++resetVp :: Name -> MH ()+resetVp n = do+    let vs = viewportScroll n+    mh $ do+        vScrollToBeginning vs+        hScrollToBeginning vs++renderTab :: ViewMessageWindowTab -> ChatState -> Widget Name+renderTab tab cs =+    let latestMessage = case cs^.csViewedMessage of+          Nothing -> error "BUG: no message to show, please report!"+          Just (m, _) -> getLatestMessage cs m+    in case tab of+        VMTabMessage -> viewMessageBox cs latestMessage+        VMTabReactions -> reactionsText cs latestMessage++getLatestMessage :: ChatState -> Message -> Message+getLatestMessage cs m =+    case m^.mMessageId of+        Nothing -> m+        Just mId -> fromJust $ findMessage mId $ cs^.csCurrentChannel.ccContents.cdMessages++handleEvent :: ViewMessageWindowTab -> Vty.Event -> MH ()+handleEvent VMTabMessage =+    void . handleKeyboardEvent viewMessageKeybindings (const $ return ())+handleEvent VMTabReactions =+    void . handleKeyboardEvent viewMessageReactionsKeybindings (const $ return ())++reactionsText :: ChatState -> Message -> Widget Name+reactionsText st m = viewport ViewMessageReactionsArea Vertical body+    where+        body = case null reacList of+            True -> txt "This message has no reactions."+            False -> vBox $ mkEntry <$> reacList+        reacList = M.toList (m^.mReactions)+        mkEntry (reactionName, userIdSet) =+            let count = str $ "(" <> show (S.size userIdSet) <> ")"+                name = withDefAttr emojiAttr $ txt $ ":" <> reactionName <> ":"+                usernameList = usernameText userIdSet+            in (name <+> (padLeft (Pad 1) count)) <=>+               (padLeft (Pad 2) usernameList)++        hs = getHighlightSet st++        usernameText uids =+            renderText' Nothing (myUsername st) hs $+            T.intercalate ", " $+            fmap (userSigil <>) $+            catMaybes (lookupUsername <$> F.toList uids)++        lookupUsername uid = usernameForUserId uid st++viewMessageBox :: ChatState -> Message -> Widget Name+viewMessageBox st msg =+    let maybeWarn = if not (msg^.mDeleted) then id else warn+        warn w = vBox [w, hBorder, deleteWarning]+        deleteWarning = withDefAttr errorMessageAttr $+                        txtWrap $ "Alert: this message has been deleted and " <>+                                  "will no longer be accessible once this window " <>+                                  "is closed."+        mkBody vpWidth =+            let hs = getHighlightSet st+                parent = case msg^.mInReplyToMsg of+                     NotAReply -> Nothing+                     InReplyTo pId -> getMessageForPostId st pId+                md = MessageData { mdEditThreshold     = Nothing+                                 , mdShowOlderEdits    = False+                                 , mdMessage           = msg+                                 , mdUserName          = msg^.mUser.to (nameForUserRef st)+                                 , mdParentMessage     = parent+                                 , mdParentUserName    = parent >>= (^.mUser.to (nameForUserRef st))+                                 , mdRenderReplyParent = True+                                 , mdHighlightSet      = hs+                                 , mdIndentBlocks      = True+                                 , mdThreadState       = NoThread+                                 , mdShowReactions     = False+                                 , mdMessageWidthLimit = Just vpWidth+                                 , mdMyUsername        = myUsername st+                                 , mdWrapNonhighlightedCodeBlocks = False+                                 }+            in renderMessage md++    in Widget Greedy Greedy $ do+        ctx <- getContext+        render $ maybeWarn $ viewport ViewMessageArea Both $ mkBody (ctx^.availWidthL)++viewMessageKeybindings :: KeyConfig -> KeyHandlerMap+viewMessageKeybindings = mkKeybindings viewMessageKeyHandlers++viewMessageKeyHandlers :: [KeyEventHandler]+viewMessageKeyHandlers =+    let vs = viewportScroll ViewMessageArea+    in [ mkKb PageUpEvent "Page up" $+           mh $ vScrollBy vs (-1 * pageAmount)++       , mkKb PageDownEvent "Page down" $+           mh $ vScrollBy vs pageAmount++       , mkKb PageLeftEvent "Page left" $+           mh $ hScrollBy vs (-2 * pageAmount)++       , mkKb PageRightEvent "Page right" $+           mh $ hScrollBy vs (2 * pageAmount)++       , mkKb ScrollUpEvent "Scroll up" $+           mh $ vScrollBy vs (-1)++       , mkKb ScrollDownEvent "Scroll down" $+           mh $ vScrollBy vs 1++       , mkKb ScrollLeftEvent "Scroll left" $+           mh $ hScrollBy vs (-1)++       , mkKb ScrollRightEvent "Scroll right" $+           mh $ hScrollBy vs 1++       , mkKb ScrollBottomEvent "Scroll to the end of the message" $+           mh $ vScrollToEnd vs++       , mkKb ScrollTopEvent "Scroll to the beginning of the message" $+           mh $ vScrollToBeginning vs+       ]++viewMessageReactionsKeybindings :: KeyConfig -> KeyHandlerMap+viewMessageReactionsKeybindings = mkKeybindings viewMessageReactionsKeyHandlers++viewMessageReactionsKeyHandlers :: [KeyEventHandler]+viewMessageReactionsKeyHandlers =+    let vs = viewportScroll ViewMessageReactionsArea+    in [ mkKb PageUpEvent "Page up" $+           mh $ vScrollBy vs (-1 * pageAmount)++       , mkKb PageDownEvent "Page down" $+           mh $ vScrollBy vs pageAmount++       , mkKb ScrollUpEvent "Scroll up" $+           mh $ vScrollBy vs (-1)++       , mkKb ScrollDownEvent "Scroll down" $+           mh $ vScrollBy vs 1++       , mkKb ScrollBottomEvent "Scroll to the end of the reactions list" $+           mh $ vScrollToEnd vs++       , mkKb ScrollTopEvent "Scroll to the beginning of the reactions list" $+           mh $ vScrollToBeginning vs+       ]
+ src/Matterhorn/Zipper.hs view
@@ -0,0 +1,119 @@+module Matterhorn.Zipper+  ( Zipper+  , fromList+  , toList+  , focus+  , unsafeFocus+  , left+  , leftL+  , right+  , rightL+  , findRight+  , maybeFindRight+  , updateList+  , updateListBy+  , filterZipper+  , maybeMapZipper+  , isEmpty+  )+where++import           Prelude ()+import           Matterhorn.Prelude hiding (toList)++import           Data.Maybe ( fromJust )+import qualified Data.Foldable as F+import qualified Data.Sequence as Seq+import qualified Data.CircularList as C+import           Lens.Micro.Platform++data Zipper a b =+    Zipper { zRing :: C.CList b+           , zTrees :: Seq.Seq (a, Seq.Seq b)+           }++instance F.Foldable (Zipper a) where+    foldMap f = foldMap f .+                F.toList .+                mconcat .+                F.toList .+                fmap snd .+                zTrees++instance Functor (Zipper a) where+    fmap f z =+        Zipper { zRing = f <$> zRing z+               , zTrees = zTrees z & mapped._2.mapped %~ f+               }++isEmpty :: Zipper a b -> Bool+isEmpty = C.isEmpty . zRing++-- Move the focus one element to the left+left :: Zipper a b -> Zipper a b+left z = z { zRing = C.rotL (zRing z) }++-- A lens on the zipper moved to the left+leftL :: Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)+leftL = lens left (\ _ b -> right b)++-- Move the focus one element to the right+right :: Zipper a b -> Zipper a b+right z = z { zRing = C.rotR (zRing z) }++-- A lens on the zipper moved to the right+rightL :: Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)+rightL = lens right (\ _ b -> left b)++-- Return the focus element+focus :: Zipper a b -> Maybe b+focus = C.focus . zRing++unsafeFocus :: Zipper a b -> b+unsafeFocus = fromJust . focus++-- Turn a list into a wraparound zipper, focusing on the head+fromList :: (Eq b) => [(a, [b])] -> Zipper a b+fromList xs =+    let ts = Seq.fromList $ xs & mapped._2 %~ Seq.fromList+        tsList = F.toList $ mconcat $ F.toList $ snd <$> ts+        maybeFocus = if null tsList+                     then id+                     else fromJust . C.rotateTo (tsList !! 0)+    in Zipper { zRing = maybeFocus $ C.fromList tsList+              , zTrees = ts+              }++toList :: Zipper a b -> [(a, [b])]+toList z = F.toList $ zTrees z & mapped._2 %~ F.toList++-- Shift the focus until a given element is found, or return the+-- same zipper if none applies+findRight :: (b -> Bool) -> Zipper a b -> Zipper a b+findRight f z = fromMaybe z $ maybeFindRight f z++-- Shift the focus until a given element is found, or return+-- Nothing if none applies+maybeFindRight :: (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)+maybeFindRight f z = do+    newRing <- C.findRotateTo f (zRing z)+    return z { zRing = newRing }++updateList :: (Eq b) => [(a, [b])] -> Zipper a b -> Zipper a b+updateList newList oldZip = updateListBy (\old b -> old == Just b) newList oldZip++updateListBy :: (Eq b) => (Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b+updateListBy f newList oldZip = findRight (f (focus oldZip)) $ fromList newList++maybeMapZipper :: (Eq c) => (b -> Maybe c) -> Zipper a b -> Zipper a c+maybeMapZipper f z =+    let oldTrees = zTrees z+        newTrees = F.toList $ oldTrees & mapped._2 %~ (catMaybes . F.toList . fmap f)+    in fromList newTrees++filterZipper :: (Eq b) => (b -> Bool) -> Zipper a b -> Zipper a b+filterZipper f oldZip = maintainFocus newZip+  where maintainFocus = findRight ((== focus oldZip) . Just)+        newZip = Zipper { zTrees = zTrees oldZip & mapped._2 %~ Seq.filter f+                        , zRing = C.filterR f (zRing oldZip)+                        }
− src/Options.hs 
@@ -1,156 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Options where--import Prelude ()-import Prelude.MH--import Config-import Data.Char ( toLower )-import Data.Foldable (traverse_)-import Data.Tuple ( swap )-import Data.Version ( showVersion )-import Development.GitRev-import Network.Mattermost.Version ( mmApiVersion )-import Paths_matterhorn ( version )-import System.Console.GetOpt-import System.Environment ( getArgs )-import System.Exit ( exitFailure, exitSuccess )-import System.IO ( hPutStrLn, stderr )---data Behaviour-  = Normal-  | ShowVersion-  | ShowHelp-  | CheckConfig-    deriving (Eq, Show)--data PrintFormat =-    Markdown | Plain deriving (Eq, Show)--data Options = Options-  { optConfLocation     :: Maybe FilePath-  , optLogLocation      :: Maybe FilePath-  , optBehaviour        :: Behaviour-  , optIgnoreConfig     :: Bool-  , optPrintKeybindings :: Bool-  , optPrintCommands    :: Bool-  , optPrintFormat      :: PrintFormat-  } deriving (Eq, Show)--defaultOptions :: Options-defaultOptions = Options-  { optConfLocation     = Nothing-  , optLogLocation      = Nothing-  , optBehaviour        = Normal-  , optIgnoreConfig     = False-  , optPrintKeybindings = False-  , optPrintCommands    = False-  , optPrintFormat      = Plain-  }--optDescrs :: [OptDescr (Options -> Options)]-optDescrs =-  [ Option ['c'] ["config"]-    (ReqArg (\ path c -> c { optConfLocation = Just path }) "PATH")-    "Path to the configuration file"-  , Option ['l'] ["logs"]-    (ReqArg (\ path c -> c { optLogLocation = Just path }) "PATH")-    "Debug log output path"-  , Option ['v'] ["version"]-    (NoArg (\ c -> c { optBehaviour = ShowVersion }))-    "Print version information and exit"-  , Option ['h'] ["help"]-    (NoArg (\ c -> c { optBehaviour = ShowHelp }))-    "Print help for command-line flags and exit"-  , Option ['i'] ["ignore-config"]-    (NoArg (\ c -> c { optIgnoreConfig = True }))-    "Start with no configuration"-  , Option ['k'] ["keybindings"]-    (NoArg (\ c -> c { optPrintKeybindings = True }))-    "Print keybindings effective for the current configuration"-  , Option ['m'] ["commands"]-    (NoArg (\ c -> c { optPrintCommands = True }))-    "Print available commands"-  , Option ['f'] ["format"]-    (ReqArg handleFormat "FORMAT")-    ("Print keybinding or command output in the specified format " <>-     "(options: " <> formatChoicesStr <> ", default: " <>-     formatStringFor (optPrintFormat defaultOptions) <> ")")-  , Option [] ["check-config"]-    (NoArg (\ c -> c { optBehaviour = CheckConfig }))-    "Validate configuration file"-  ]--formatChoices :: [(String, PrintFormat)]-formatChoices =-    [ ("plain", Plain)-    , ("markdown", Markdown)-    ]--formatStringFor :: PrintFormat -> String-formatStringFor fmt =-    case lookup fmt (swap <$> formatChoices) of-        Nothing -> error $ "BUG: no format string for " <> show fmt-        Just s -> s--formatChoicesStr :: String-formatChoicesStr = intercalate ", " $ fst <$> formatChoices--handleFormat :: String -> Options -> Options-handleFormat fmtStr c =-    let fmt = case lookup (toLower <$> fmtStr) formatChoices of-            Just f -> f-            Nothing ->-                error $ "Invalid format: " <> show fmtStr <> ", choices: " <>-                        formatChoicesStr-    in c { optPrintFormat = fmt }--mhVersion :: String-mhVersion-  | $(gitHash) == ("UNKNOWN" :: String) = "matterhorn " ++ showVersion version-  | otherwise = "matterhorn " ++ showVersion version ++ " (" ++-                $(gitBranch) ++ "@" ++ take 7 $(gitHash) ++ ")"--fullVersionString :: String-fullVersionString = mhVersion ++ "\n using " ++ mmApiVersion--usage :: IO ()-usage = putStr (usageInfo "matterhorn" optDescrs)--grabOptions :: IO Options-grabOptions = do-  args <- getArgs-  case getOpt Permute optDescrs args of-    (aps, [], []) -> do-      let rs = foldr (.) id aps defaultOptions-      case optBehaviour rs of-        Normal -> return rs-        ShowHelp -> usage >> exitSuccess-        ShowVersion -> putStrLn fullVersionString >> exitSuccess-        CheckConfig -> checkConfiguration (optConfLocation rs)-    (_, _, errs) -> do-      mapM_ putStr errs-      usage-      exitFailure--checkConfiguration :: Maybe FilePath -> IO a-checkConfiguration mb =-  do res <- findConfig mb-     let writeLn = hPutStrLn stderr-         printLocation Nothing = "No configuration file"-         printLocation (Just fp) = "Location: " ++ fp-     case res of-       Left e ->-         do writeLn e-            exitFailure-       Right ([], config) ->-         do writeLn "Configuration file valid"-            writeLn (printLocation (configAbsPath config))-            exitSuccess-       Right (ws, config) ->-         do writeLn "Configuration file generated warnings"-            writeLn (printLocation (configAbsPath config))-            traverse_ writeLn ws-            exitFailure
− src/Prelude/MH.hs 
@@ -1,115 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE CPP #-}--{-| This module is for internal re-exports of commonly-used-  functions. This also lets us avoid churn between versions of GHC by-  putting changed functions behind CPP in a single place.--}--{--  GHC version <--> base version (https://wiki.haskell.org/Base_package) includes:-     8.0.1      4.9.0.0-     8.2.1      4.10.0.0-     8.4.1      4.11.0.0--  GHC distributions include a set of core packages; overriding these-  with new versions is unwise.  Core packages include (see-  https://downloads.haskell.org/~ghc/X.Y.Z/docs/html/users_guide/X.Y.Z-notes.html#included-libraries-  ):--    base, Cabal, array, bytestring, containers, deepseq, directory,-    filepath, mtl, parsec, process, text, time, unix--}--module Prelude.MH-  ( module P-#if !MIN_VERSION_base(4,9,0)-  , (<>)-#endif-  , (<|>)-  -- commonly-used functions from Maybe-  , Maybe.isJust-  , Maybe.isNothing-  , Maybe.listToMaybe-  , Maybe.maybeToList-  , Maybe.fromMaybe-  , Maybe.catMaybes--  -- a non-partial Read function-  , Read.readMaybe--  -- commonly-used functions from Monad-  , Monad.forM-  , Monad.forM_-  , Monad.filterM-  , Monad.when-  , Monad.unless-  , Monad.void-  , Monad.join-  , Monad.forever-  , Monad.foldM-  , Monad.MonadIO(..)--  -- commonly-used functions from List-  , Foldable.toList-  , List.find-  , List.sort-  , List.intercalate-  , Exts.sortWith-  , Exts.groupWith--  -- common read-only lens operators-  , (Lens.&)-  , (Lens.^.)-  , Lens.use--  -- not available in all versions of GHC currently in use-#if MIN_VERSION_base(4,10,0)-  , Clock.nominalDay-#else-  , nominalDay-#endif--  -- various type aliases-  , Text-  , HashMap-  , Seq-  , Set-  , Time.UTCTime-  , Time.TimeZoneSeries-  , Time.NominalDiffTime-  )-where---#if !MIN_VERSION_base(4,11,0)-import           Data.Semigroup ( (<>) )-#endif--import           Control.Applicative ( (<|>) )-import qualified Control.Monad as Monad-import qualified Control.Monad.IO.Class as Monad-import qualified Data.Foldable as Foldable-import qualified Data.List as List-import qualified Data.Maybe as Maybe-import qualified Data.Time as Time-#if MIN_VERSION_base(4,10,0)-import qualified Data.Time.Clock as Clock-#endif-import qualified Data.Time.LocalTime.TimeZone.Series as Time-import qualified GHC.Exts as Exts-import qualified Lens.Micro.Platform as Lens-import           Prelude.Compat-import qualified Prelude.Compat as P-import qualified Text.Read as Read---- these below we import only for type aliases-import           Data.HashMap.Strict ( HashMap )-import           Data.Sequence ( Seq )-import           Data.Set ( Set )-import           Data.Text ( Text )--#if !MIN_VERSION_base(4,10,0)-nominalDay :: Time.NominalDiffTime-nominalDay = 86400-#endif
− src/Scripts.hs 
@@ -1,81 +0,0 @@-module Scripts-  ( findAndRunScript-  , listScripts-  )-where--import           Prelude ()-import           Prelude.MH--import           Control.Concurrent ( takeMVar, newEmptyMVar )-import qualified Control.Concurrent.STM as STM-import qualified Data.Text as T-import           System.Exit ( ExitCode(..) )--import           Network.Mattermost.Types ( ChannelId )--import           FilePaths ( Script(..), getAllScripts, locateScriptPath )-import           State.Common-import           State.Messages ( sendMessage )-import           Types---findAndRunScript :: ChannelId -> Text -> Text -> MH ()-findAndRunScript cId scriptName input = do-    fpMb <- liftIO $ locateScriptPath (T.unpack scriptName)-    outputChan <- use (csResources.crSubprocessLog)-    case fpMb of-      ScriptPath scriptPath -> do-        doAsyncWith Preempt $ runScript cId outputChan scriptPath input-      NonexecScriptPath scriptPath -> do-        let msg = ("The script `" <> T.pack scriptPath <> "` cannot be " <>-             "executed. Try running\n" <>-             "```\n" <>-             "$ chmod u+x " <> T.pack scriptPath <> "\n" <>-             "```\n" <>-             "to correct this error. " <> scriptHelpAddendum)-        mhError $ GenericError msg-      ScriptNotFound -> do-        mhError $ NoSuchScript scriptName--runScript :: ChannelId -> STM.TChan ProgramOutput -> FilePath -> Text -> IO (Maybe (MH ()))-runScript cId outputChan fp text = do-  outputVar <- newEmptyMVar-  runLoggedCommand True outputChan fp [] (Just $ T.unpack text) (Just outputVar)-  po <- takeMVar outputVar-  return $ case programExitCode po of-    ExitSuccess -> do-        case null $ programStderr po of-            True -> Just $ do-                mode <- use (csEditState.cedEditMode)-                sendMessage cId mode (T.pack $ programStdout po) []-            False -> Nothing-    ExitFailure _ -> Nothing--listScripts :: MH ()-listScripts = do-  (execs, nonexecs) <- liftIO getAllScripts-  let scripts = ("Available scripts are:\n" <>-                 mconcat [ "  - " <> T.pack cmd <> "\n"-                         | cmd <- execs-                         ])-  postInfoMessage scripts-  case nonexecs of-    [] -> return ()-    _  -> do-      let errMsg = ("Some non-executable script files are also " <>-                    "present. If you want to run these as scripts " <>-                    "in Matterhorn, mark them executable with \n" <>-                    "```\n" <>-                    "$ chmod u+x [script path]\n" <>-                    "```\n" <>-                    "\n" <>-                    mconcat [ "  - " <> T.pack cmd <> "\n"-                            | cmd <- nonexecs-                            ] <> "\n" <> scriptHelpAddendum)-      mhError $ GenericError errMsg--scriptHelpAddendum :: Text-scriptHelpAddendum =-  "For more help with scripts, run the command\n" <>-  "```\n/help scripts\n```\n"
− src/State/Async.hs 
@@ -1,161 +0,0 @@-module State.Async-  ( AsyncPriority(..)-  , doAsync-  , doAsyncIO-  , doAsyncWith-  , doAsyncChannelMM-  , doAsyncWithIO-  , doAsyncMM-  , tryMM-  , endAsyncNOP-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Control.Concurrent.STM as STM-import           Control.Exception ( try )--import           Network.Mattermost.Types--import           Types----- | Try to run a computation, posting an informative error---   message if it fails with a 'MattermostServerError'.-tryMM :: IO a-      -- ^ The action to try (usually a MM API call)-      -> (a -> IO (Maybe (MH ())))-      -- ^ What to do on success-      -> IO (Maybe (MH ()))-tryMM act onSuccess = do-    result <- liftIO $ try act-    case result of-        Left e -> return $ Just $ mhError $ ServerError e-        Right value -> liftIO $ onSuccess value---- * Background Computation---- $background_computation------ The main context for Matterhorn is the EventM context provided by--- the 'Brick' library.  This context is normally waiting for user--- input (or terminal resizing, etc.) which gets turned into an--- MHEvent and the 'onEvent' event handler is called to process that--- event, after which the display is redrawn as necessary and brick--- awaits the next input.------ However, it is often convenient to communicate with the Mattermost--- server in the background, so that large numbers of--- synchronously-blocking events (e.g. on startup) or refreshes can--- occur whenever needed and without negatively impacting the UI--- updates or responsiveness.  This is handled by a 'forkIO' context--- that waits on an STM channel for work to do, performs the work, and--- then sends brick an MHEvent containing the completion or failure--- information for that work.------ The /doAsyncWith/ family of functions here facilitates that--- asynchronous functionality.  This is typically used in the--- following fashion:------ > doSomething :: MH ()--- > doSomething = do--- >    got <- something--- >    doAsyncWith Normal $ do--- >       r <- mmFetchR ....--- >       return $ do--- >          csSomething.here %= processed r------ The second argument is an IO monad operation (because 'forkIO' runs--- in the IO Monad context), but it returns an MH monad operation.--- The IO monad has access to the closure of 'doSomething' (e.g. the--- 'got' value), but it should be aware that the state of the MH monad--- may have been changed by the time the IO monad runs in the--- background, so the closure is a snapshot of information at the time--- the 'doAsyncWith' was called.------ Similarly, the returned MH monad operation is *not* run in the--- context of the 'forkIO' background, but it is instead passed via an--- MHEvent back to the main brick thread, where it is executed in an--- EventM handler's MH monad context.  This operation therefore has--- access to the combined closure of the pre- 'doAsyncWith' code and--- the closure of the IO operation.  It is important that the final MH--- monad operation should *re-obtain* state information from the MH--- monad instead of using or setting the state obtained prior to the--- 'doAsyncWith' call.---- | Priority setting for asynchronous work items. Preempt means that--- the queued item will be the next work item begun (i.e. it goes to the--- front of the queue); normal means it will go last in the queue.-data AsyncPriority = Preempt | Normal---- | Run a computation in the background, ignoring any results from it.-doAsync :: AsyncPriority -> IO () -> MH ()-doAsync prio act = doAsyncWith prio (act >> return Nothing)---- | Run a computation in the background, returning a computation to be--- called on the 'ChatState' value.-doAsyncWith :: AsyncPriority -> IO (Maybe (MH ())) -> MH ()-doAsyncWith prio act = do-    let putChan = case prio of-          Preempt -> STM.unGetTChan-          Normal  -> STM.writeTChan-    queue <- use (csResources.crRequestQueue)-    liftIO $ STM.atomically $ putChan queue act--doAsyncIO :: AsyncPriority -> ChatState -> IO () -> IO ()-doAsyncIO prio st act =-  doAsyncWithIO prio st (act >> return Nothing)---- | Run a computation in the background, returning a computation to be--- called on the 'ChatState' value.-doAsyncWithIO :: AsyncPriority -> ChatState -> IO (Maybe (MH ())) -> IO ()-doAsyncWithIO prio st act = do-    let putChan = case prio of-          Preempt -> STM.unGetTChan-          Normal  -> STM.writeTChan-    let queue = st^.csResources.crRequestQueue-    STM.atomically $ putChan queue act---- | Performs an asynchronous IO operation. On completion, the final--- argument a completion function is executed in an MH () context in the--- main (brick) thread.-doAsyncMM :: AsyncPriority-          -- ^ the priority for this async operation-          -> (Session -> IO a)-          -- ^ the async MM channel-based IO operation-          -> (a -> Maybe (MH ()))-          -- ^ function to process the results in brick event handling-          -- context-          -> MH ()-doAsyncMM prio mmOp eventHandler = do-  session <- getSession-  doAsyncWith prio $ do-    r <- mmOp session-    return $ eventHandler r---- | Helper type for a function to perform an asynchronous MM operation--- on a channel and then invoke an MH completion event.-type DoAsyncChannelMM a =-    AsyncPriority-    -- ^ the priority for this async operation-    -> ChannelId-    -- ^ The channel-    -> (Session -> ChannelId -> IO a)-    -- ^ the asynchronous Mattermost channel-based IO operation-    -> (ChannelId -> a -> Maybe (MH ()))-    -- ^ function to process the results in brick event handling context-    -> MH ()---- | Performs an asynchronous IO operation on a specific channel. On--- completion, the final argument a completion function is executed in--- an MH () context in the main (brick) thread.-doAsyncChannelMM :: DoAsyncChannelMM a-doAsyncChannelMM prio cId mmOp eventHandler =-  doAsyncMM prio (\s -> mmOp s cId) (eventHandler cId)---- | Use this convenience function if no operation needs to be--- performed in the MH state after an async operation completes.-endAsyncNOP :: ChannelId -> a -> Maybe (MH ())-endAsyncNOP _ _ = Nothing
− src/State/Attachments.hs 
@@ -1,53 +0,0 @@-module State.Attachments-  ( showAttachmentList-  , resetAttachmentList-  , showAttachmentFileBrowser-  )-where--import           Prelude ()-import           Prelude.MH-import qualified Control.Exception as E-import           Data.Either ( isRight )-import           System.Directory ( doesDirectoryExist, getDirectoryContents )-import           Data.Bool ( bool )--import           Brick ( vScrollToBeginning, viewportScroll )-import qualified Brick.Widgets.List as L-import qualified Brick.Widgets.FileBrowser as FB-import           Lens.Micro.Platform ( (.=) )--import           Types--validateAttachmentPath :: FilePath -> IO (Maybe FilePath)-validateAttachmentPath path = bool Nothing (Just path) <$> do-    ex <- doesDirectoryExist path-    case ex of-        False -> return False-        True -> do-            result :: Either E.SomeException [FilePath]-                   <- E.try $ getDirectoryContents path-            return $ isRight result--defaultAttachmentsPath :: Config -> IO (Maybe FilePath)-defaultAttachmentsPath = maybe (return Nothing) validateAttachmentPath . configDefaultAttachmentPath--showAttachmentList :: MH ()-showAttachmentList = do-    lst <- use (csEditState.cedAttachmentList)-    case length (L.listElements lst) of-        0 -> showAttachmentFileBrowser-        _ -> setMode ManageAttachments--resetAttachmentList :: MH ()-resetAttachmentList = do-    csEditState.cedAttachmentList .= L.list AttachmentList mempty 1-    mh $ vScrollToBeginning $ viewportScroll AttachmentList--showAttachmentFileBrowser :: MH ()-showAttachmentFileBrowser = do-    config <- use (csResources.crConfiguration)-    filePath <- liftIO $ defaultAttachmentsPath config-    browser <- liftIO $ Just <$> FB.newFileBrowser FB.selectNonDirectories AttachmentFileBrowser filePath-    csEditState.cedFileBrowser .= browser-    setMode ManageAttachmentsBrowseFiles
− src/State/Autocomplete.hs 
@@ -1,263 +0,0 @@-module State.Autocomplete-  ( AutocompleteContext(..)-  , checkForAutocompletion-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( viewportScroll, vScrollToBeginning )-import           Brick.Widgets.Edit ( editContentsL )-import qualified Brick.Widgets.List as L-import           Data.Char ( isSpace )-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HM-import           Data.List ( sortBy, partition )-import qualified Data.Map as M-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import qualified Data.Text.Zipper as Z-import qualified Data.Vector as V-import           Lens.Micro.Platform ( (%=), (.=), (.~), _Just, preuse )-import qualified Skylighting.Types as Sky--import           Network.Mattermost.Types (userId, channelId)-import qualified Network.Mattermost.Endpoints as MM--import           Constants ( userSigil, normalChannelSigil )-import {-# SOURCE #-} Command ( commandList, printArgSpec )-import           State.Common-import {-# SOURCE #-} State.Editing ( Direction(..), tabComplete )-import           Types hiding ( newState )-import           Emoji---data AutocompleteContext =-    AutocompleteContext { autocompleteManual :: Bool-                        -- ^ Whether the autocompletion was manual-                        -- (True) or automatic (False). The automatic-                        -- case is the case where the autocomplete-                        -- lookups and UI are triggered merely by-                        -- entering some initial text (such as "@").-                        -- The manual case is the case where the-                        -- autocomplete lookups and UI are triggered-                        -- explicitly by a user's TAB keypress.-                        , autocompleteFirstMatch :: Bool-                        -- ^ Once the results of the autocomplete lookup-                        -- are available, this flag determines whether-                        -- the user's input is replaced immediately-                        -- with the first available match (True) or not-                        -- (False).-                        }---- | Check for whether the currently-edited word in the message editor--- should cause an autocompletion UI to appear. If so, initiate a server--- query or local cache lookup to present the completion alternatives--- for the word at the cursor.-checkForAutocompletion :: AutocompleteContext -> MH ()-checkForAutocompletion ctx = do-    result <- getCompleterForInput ctx-    case result of-        Nothing -> resetAutocomplete-        Just (ty, runUpdater, searchString) -> do-            prevResult <- use (csEditState.cedAutocomplete)-            -- 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 ty ctx searchString--getCompleterForInput :: AutocompleteContext-                     -> MH (Maybe (AutocompletionType, AutocompletionType -> AutocompleteContext -> Text -> MH (), Text))-getCompleterForInput ctx = do-    z <- use (csEditState.cedEditor.editContentsL)--    let col = snd $ Z.cursorPosition z-        curLine = Z.currentLine z--    return $ case wordAtColumn col curLine of-        Just (startCol, w)-            | userSigil `T.isPrefixOf` w ->-                Just (ACUsers, doUserAutoCompletion, T.tail w)-            | normalChannelSigil `T.isPrefixOf` w ->-                Just (ACChannels, doChannelAutoCompletion, T.tail w)-            | ":" `T.isPrefixOf` w && autocompleteManual ctx ->-                Just (ACEmoji, doEmojiAutoCompletion, T.tail w)-            | "```" `T.isPrefixOf` w ->-                Just (ACCodeBlockLanguage, doSyntaxAutoCompletion, T.drop 3 w)-            | "/" `T.isPrefixOf` w && startCol == 0 ->-                Just (ACCommands, doCommandAutoCompletion, T.tail w)-        _ -> Nothing---- Completion implementations--doEmojiAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()-doEmojiAutoCompletion ty ctx searchString = do-    session <- getSession-    em <- use (csResources.crEmoji)-    withCachedAutocompleteResults ctx ty searchString $-        doAsyncWith Preempt $ do-            results <- getMatchingEmoji session em searchString-            let alts = EmojiCompletion <$> results-            return $ Just $ setCompletionAlternatives ctx searchString alts ty--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 ty--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-                isBPrefix = searchString `T.isPrefixOf` cmdName b-            in if isAPrefix && isBPrefix-               then compare (cmdName a) (cmdName b)-               else if isAPrefix-                    then LT-                    else GT-        lowerSearch = T.toLower searchString-        matches c = lowerSearch `T.isInfixOf` (cmdName c) ||-                    lowerSearch `T.isInfixOf` (T.toLower $ cmdDescr c)-        mkAlt (Cmd name desc args _) =-            CommandCompletion name (printArgSpec args) desc-    setCompletionAlternatives ctx searchString alts ty--doUserAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()-doUserAutoCompletion ty ctx searchString = do-    session <- getSession-    myTid <- gets myTeamId-    myUid <- gets myUserId-    cId <- use csCurrentChannelId--    withCachedAutocompleteResults ctx ty searchString $-        doAsyncWith Preempt $ do-            ac <- MM.mmAutocompleteUsers (Just myTid) (Just cId) searchString session--            let active = Seq.filter (\u -> userId u /= myUid && (not $ userDeleted u))-                alts = F.toList $-                       ((\u -> UserCompletion u True) <$> (active $ MM.userAutocompleteUsers ac)) <>-                       (maybe mempty (fmap (\u -> UserCompletion u False) . active) $-                              MM.userAutocompleteOutOfChannel ac)--                specials = [ MentionAll-                           , MentionChannel-                           ]-                extras = [ SpecialMention m | m <- specials-                         , (T.toLower searchString) `T.isPrefixOf` specialMentionName m-                         ]--            return $ Just $ setCompletionAlternatives ctx searchString (alts <> extras) ty--doChannelAutoCompletion :: AutocompletionType -> AutocompleteContext -> Text -> MH ()-doChannelAutoCompletion ty ctx searchString = do-    session <- getSession-    tId <- gets myTeamId-    cs <- use csChannels--    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 ty---- 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-                                  , _acCachedResponses = HM.fromList [(searchString, alts)]-                                  , _acType = ty-                                  }--    pending <- use (csEditState.cedAutocompletePending)-    case pending of-        Just val | val == searchString -> do--            -- If there is already state, update it, but also cache the-            -- search results.-            csEditState.cedAutocomplete %= \prev ->-                let newState = case prev of-                        Nothing ->-                            state-                        Just oldState ->-                            state & acCachedResponses .~-                                HM.insert searchString alts (oldState^.acCachedResponses)-                in Just newState--            mh $ vScrollToBeginning $ viewportScroll CompletionList--            when (autocompleteFirstMatch ctx) $-                tabComplete Forwards-        _ ->-            -- Do not update the state if this result does not-            -- correspond to the search string we used most recently.-            -- This happens when the editor changes faster than the-            -- async completion responses arrive from the server. If we-            -- don't check this, we show completion results that are-            -- wrong for the editor state.-            return ()--wordAtColumn :: Int -> Text -> Maybe (Int, Text)-wordAtColumn i t =-    let tokens = T.groupBy (\a b -> isSpace a == isSpace b) t-        go _ j _ | j < 0 = Nothing-        go col j ts = case ts of-            [] -> Nothing-            (w:rest) | j <= T.length w && not (isSpace $ T.head w) -> Just (col, w)-                     | otherwise -> go (col + T.length w) (j - T.length w) rest-    in go 0 i tokens
− src/State/ChannelListOverlay.hs 
@@ -1,82 +0,0 @@-module State.ChannelListOverlay-  ( enterChannelListOverlayMode--  , channelListSelectDown-  , channelListSelectUp-  , channelListPageDown-  , channelListPageUp-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Brick.Widgets.List as L-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--import           State.ListOverlay-import           State.Channels-import           Types---enterChannelListOverlayMode :: MH ()-enterChannelListOverlayMode = do-    myTId <- gets myTeamId-    myChannels <- use (csChannels.to (filteredChannelIds (const True)))-    enterListOverlayMode csChannelListOverlay ChannelListOverlay-        AllChannels enterHandler (fetchResults myTId myChannels)--enterHandler :: Channel -> MH Bool-enterHandler chan = do-    joinChannel (getId chan)-    return True--fetchResults :: TeamId-             -> [ChannelId]-             -- ^ The channels to exclude from the results-             -> ChannelSearchScope-             -- ^ The scope to search-             -> Session-             -- ^ The connection session-             -> Text-             -- ^ The search string-             -> IO (Vec.Vector Channel)-fetchResults myTId exclude AllChannels session searchString = do-    resultChans <- MM.mmSearchChannels myTId searchString session-    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.-channelListSelectUp :: MH ()-channelListSelectUp = channelListMove L.listMoveUp---- | Move the selection down in the channel list overlay by one channel.-channelListSelectDown :: MH ()-channelListSelectDown = channelListMove L.listMoveDown---- | Move the selection up in the channel list overlay by a page of channels--- (channelListPageSize).-channelListPageUp :: MH ()-channelListPageUp = channelListMove (L.listMoveBy (-1 * channelListPageSize))---- | Move the selection down in the channel list overlay by a page of channels--- (channelListPageSize).-channelListPageDown :: MH ()-channelListPageDown = channelListMove (L.listMoveBy channelListPageSize)---- | Transform the channel list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-channelListMove :: (L.List Name Channel -> L.List Name Channel) -> MH ()-channelListMove = listOverlayMove csChannelListOverlay---- | The number of channels in a "page" for cursor movement purposes.-channelListPageSize :: Int-channelListPageSize = 10
− src/State/ChannelSelect.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module State.ChannelSelect-  ( beginChannelSelect-  , updateChannelSelectMatches-  , channelSelectNext-  , channelSelectPrevious-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Widgets.Edit ( getEditContents )-import           Data.Char ( isUpper )-import qualified Data.Text as T-import           Lens.Micro.Platform--import qualified Network.Mattermost.Types as MM--import           Constants ( userSigil, normalChannelSigil )-import           Types-import qualified Zipper as Z--beginChannelSelect :: MH ()-beginChannelSelect = do-    setMode ChannelSelect-    csChannelSelectState .= emptyChannelSelectState-    updateChannelSelectMatches--    -- Preserve the current channel selection when initializing channel-    -- selection mode-    zipper <- use csFocus-    let isCurrentFocus m = Just (matchEntry m) == Z.focus zipper-    csChannelSelectState.channelSelectMatches %= Z.findRight isCurrentFocus---- Select the next match in channel selection mode.-channelSelectNext :: MH ()-channelSelectNext = updateSelectedMatch Z.right---- Select the previous match in channel selection mode.-channelSelectPrevious :: MH ()-channelSelectPrevious = updateSelectedMatch Z.left--updateChannelSelectMatches :: MH ()-updateChannelSelectMatches = do-    st <- use id--    input <- use (csChannelSelectState.channelSelectInput)-    cconfig <- use csClientConfig-    prefs <- use (csResources.crUserPreferences)--    let pat = parseChannelSelectPattern $ T.concat $ getEditContents input-        chanNameMatches e = case pat of-            Nothing -> const Nothing-            Just p -> applySelectPattern p e-        patTy = case pat of-            Nothing -> Nothing-            Just CSPAny -> Nothing-            Just (CSP ty _) -> Just ty--    let chanMatches e chan =-            if patTy == Just PrefixDMOnly-            then Nothing-            else if chan^.ccInfo.cdType /= MM.Group-                 then chanNameMatches e $ chan^.ccInfo.cdDisplayName-                 else Nothing-        groupChanMatches e chan =-            if patTy == Just PrefixNonDMOnly-            then Nothing-            else if chan^.ccInfo.cdType == MM.Group-                 then chanNameMatches e $ chan^.ccInfo.cdDisplayName-                 else Nothing-        displayName uInfo = displayNameForUser uInfo cconfig prefs-        userMatches e uInfo =-            if patTy == Just PrefixNonDMOnly-            then Nothing-            else (chanNameMatches e . displayName) uInfo-        matches e@(CLChannel cId) = findChannelById cId (st^.csChannels) >>= chanMatches e-        matches e@(CLUserDM _ uId) = userById uId st >>= userMatches e-        matches e@(CLGroupDM cId) = findChannelById cId (st^.csChannels) >>= groupChanMatches e--        preserveFocus Nothing _ = False-        preserveFocus (Just m) m2 = matchEntry m == matchEntry m2--    csChannelSelectState.channelSelectMatches %= (Z.updateListBy preserveFocus $ Z.toList $ Z.maybeMapZipper matches (st^.csFocus))--applySelectPattern :: ChannelSelectPattern -> ChannelListEntry -> Text -> Maybe ChannelSelectMatch-applySelectPattern CSPAny entry chanName = do-    return $ ChannelSelectMatch "" "" chanName chanName entry-applySelectPattern (CSP ty pat) entry chanName = do-    let applyType Infix | pat `T.isInfixOf` normalizedChanName =-            case T.breakOn pat normalizedChanName of-                (pre, _) ->-                    return ( T.take (T.length pre) chanName-                           , T.take (T.length pat) $ T.drop (T.length pre) chanName-                           , T.drop (T.length pat + T.length pre) chanName-                           )--        applyType Prefix | pat `T.isPrefixOf` normalizedChanName = do-            let (b, a) = T.splitAt (T.length pat) chanName-            return ("", b, a)--        applyType PrefixDMOnly | pat `T.isPrefixOf` normalizedChanName = do-            let (b, a) = T.splitAt (T.length pat) chanName-            return ("", b, a)--        applyType PrefixNonDMOnly | pat `T.isPrefixOf` normalizedChanName = do-            let (b, a) = T.splitAt (T.length pat) chanName-            return ("", b, a)--        applyType Suffix | pat `T.isSuffixOf` normalizedChanName = do-            let (b, a) = T.splitAt (T.length chanName - T.length pat) chanName-            return (b, a, "")--        applyType Equal  | pat == normalizedChanName =-            return ("", chanName, "")--        applyType _ = Nothing--        caseSensitive = T.any isUpper pat-        normalizedChanName = if caseSensitive-                             then chanName-                             else T.toLower chanName--    (pre, m, post) <- applyType ty-    return $ ChannelSelectMatch pre m post chanName entry--parseChannelSelectPattern :: Text -> Maybe ChannelSelectPattern-parseChannelSelectPattern "" = return CSPAny-parseChannelSelectPattern pat = do-    let only = if | userSigil `T.isPrefixOf` pat -> Just $ CSP PrefixDMOnly $ T.tail pat-                  | normalChannelSigil `T.isPrefixOf` pat -> Just $ CSP PrefixNonDMOnly $ T.tail pat-                  | otherwise -> Nothing--    (pat1, pfx) <- case "^" `T.isPrefixOf` pat of-        True  -> return (T.tail pat, Just Prefix)-        False -> return (pat, Nothing)--    (pat2, sfx) <- case "$" `T.isSuffixOf` pat1 of-        True  -> return (T.init pat1, Just Suffix)-        False -> return (pat1, Nothing)--    only <|> case (pfx, sfx) of-        (Nothing, Nothing)         -> return $ CSP Infix  pat2-        (Just Prefix, Nothing)     -> return $ CSP Prefix pat2-        (Nothing, Just Suffix)     -> return $ CSP Suffix pat2-        (Just Prefix, Just Suffix) -> return $ CSP Equal  pat2-        tys                        -> error $ "BUG: invalid channel select case: " <> show tys---- Update the channel selection mode match cursor. The argument function--- determines how to navigate to the next item.-updateSelectedMatch :: (Z.Zipper ChannelListGroup ChannelSelectMatch -> Z.Zipper ChannelListGroup ChannelSelectMatch)-                    -> MH ()-updateSelectedMatch nextItem =-    csChannelSelectState.channelSelectMatches %= nextItem
− src/State/Channels.hs 
@@ -1,1082 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiWayIf #-}-module State.Channels-  ( updateSidebar-  , updateViewed-  , updateViewedChan-  , refreshChannel-  , refreshChannelsAndUsers-  , setFocus-  , refreshChannelById-  , applyPreferenceChange-  , leaveChannel-  , leaveCurrentChannel-  , getNextUnreadChannel-  , getNextUnreadUserOrChannel-  , nextUnreadChannel-  , nextUnreadUserOrChannel-  , createOrFocusDMChannel-  , clearChannelUnreadStatus-  , prevChannel-  , nextChannel-  , recentChannel-  , setReturnChannel-  , resetReturnChannel-  , hideDMChannel-  , createGroupChannel-  , showGroupChannelPref-  , channelHistoryForward-  , channelHistoryBackward-  , handleNewChannel-  , createOrdinaryChannel-  , handleChannelInvite-  , addUserByNameToCurrentChannel-  , addUserToCurrentChannel-  , removeUserFromCurrentChannel-  , removeChannelFromState-  , isRecentChannel-  , isReturnChannel-  , isCurrentChannel-  , deleteCurrentChannel-  , startLeaveCurrentChannel-  , joinChannel-  , joinChannelByName-  , changeChannelByName-  , setChannelTopic-  , setChannelPurpose-  , beginCurrentChannelDeleteConfirm-  , toggleChannelListVisibility-  , showChannelInSidebar-  , updateChannelNotifyProps-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( getVtyHandle, viewportScroll, vScrollToBeginning-                            , invalidateCache, invalidateCacheEntry )-import           Brick.Widgets.Edit ( applyEdit, getEditContents, editContentsL )-import           Control.Concurrent.Async ( runConcurrently, Concurrently(..) )-import           Control.Exception ( SomeException, try )-import           Data.Char ( isAlphaNum )-import qualified Data.HashMap.Strict as HM-import qualified Data.Foldable as F-import           Data.List ( nub )-import           Data.Maybe ( fromJust )-import qualified Data.Set as S-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import           Data.Text.Zipper ( textZipper, clearZipper, insertMany, gotoEOL )-import           Data.Time.Clock ( getCurrentTime )-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform--import qualified Network.Mattermost.Endpoints as MM-import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           Constants ( normalChannelSigil )-import           InputHistory-import           State.Common-import {-# SOURCE #-} State.Messages ( fetchVisibleIfNeeded )-import           State.Users-import           State.Flagging-import           Types-import           Types.Common-import           Zipper ( Zipper )-import qualified Zipper as Z---updateSidebar :: MH ()-updateSidebar = do-    -- Invalidate the cached sidebar rendering since we are about to-    -- change the underlying state-    mh $ invalidateCacheEntry ChannelSidebar--    -- Get the currently-focused channel ID so we can compare after the-    -- zipper is rebuilt-    cconfig <- use csClientConfig-    oldCid <- use csCurrentChannelId--    -- Update the zipper-    cs <- use csChannels-    us <- getUsers-    prefs <- use (csResources.crUserPreferences)-    now <- liftIO getCurrentTime-    config <- use (csResources.crConfiguration)--    let zl = mkChannelZipperList now config cconfig prefs cs us-    csFocus %= Z.updateList zl--    -- Schedule the current sidebar for user status updates at the end-    -- of this MH action.-    newZ <- use csFocus-    myId <- gets myUserId-    scheduleUserStatusFetches $ myId : userIdsFromZipper newZ--    -- Update the window title based on the unread status of the-    -- channels.-    let anyUnread = any channelListGroupHasUnread $ fst <$> zl-        title = "matterhorn" <> if anyUnread then "(*)" else ""--    vty <- mh getVtyHandle-    liftIO $ Vty.setWindowTitle vty title--    -- If the zipper rebuild caused the current channel to change, such-    -- as when the previously-focused channel was removed, we need to-    -- call fetchVisibleIfNeeded on the newly-focused channel to ensure-    -- that it gets loaded.-    newCid <- use csCurrentChannelId-    when (newCid /= oldCid) $-        fetchVisibleIfNeeded--updateViewed :: Bool -> MH ()-updateViewed updatePrev = do-    csCurrentChannel.ccInfo.cdMentionCount .= 0-    updateViewedChan updatePrev =<< use csCurrentChannelId---- | When a new channel has been selected for viewing, this will--- notify the server of the change, and also update the local channel--- state to set the last-viewed time for the previous channel and--- update the viewed time to now for the newly selected channel.------ The boolean argument indicates whether the view time of the previous--- channel (if any) should be updated, too. We typically want to do that--- only on channel switching; when we just want to update the view time--- of the specified channel, False should be provided.-updateViewedChan :: Bool -> ChannelId -> MH ()-updateViewedChan updatePrev cId = use csConnectionStatus >>= \case-    Connected -> do-        -- Only do this if we're connected to avoid triggering noisy-        -- exceptions.-        pId <- if updatePrev-               then use csRecentChannel-               else return Nothing-        doAsyncChannelMM Preempt cId-          (\s c -> MM.mmViewChannel UserMe c pId s)-          (\c () -> Just $ setLastViewedFor pId c)-    Disconnected ->-        -- Cannot update server; make no local updates to avoid getting-        -- out of sync with the server. Assumes that this is a temporary-        -- break in connectivity and that after the connection is-        -- restored, the user's normal activities will update state as-        -- appropriate. If connectivity is permanently lost, managing-        -- this state is irrelevant.-        return ()--toggleChannelListVisibility :: MH ()-toggleChannelListVisibility = do-    mh invalidateCache-    csShowChannelList %= not---- | If the current channel is a DM channel with a single user or a--- group of users, hide it from the sidebar and adjust the server-side--- preference to hide it persistently.------ If the current channel is any other kind of channel, complain with a--- usage error.-hideDMChannel :: ChannelId -> MH ()-hideDMChannel cId = do-    me <- gets myUser-    session <- getSession-    withChannel cId $ \chan -> do-        case chan^.ccInfo.cdType of-            Direct -> do-                let pref = showDirectChannelPref (me^.userIdL) uId False-                    Just uId = chan^.ccInfo.cdDMUserId-                csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing-                doAsyncWith Preempt $ do-                    MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session-                    return Nothing-            Group -> do-                let pref = hideGroupChannelPref cId (me^.userIdL)-                csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing-                doAsyncWith Preempt $ do-                    MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session-                    return Nothing-            _ -> do-                mhError $ GenericError "Cannot hide this channel. Consider using /leave instead."---- | Called on async completion when the currently viewed channel has--- been updated (i.e., just switched to this channel) to update local--- state.-setLastViewedFor :: Maybe ChannelId -> ChannelId -> MH ()-setLastViewedFor prevId cId = do-    chan <- use (csChannels.to (findChannelById cId))-    -- Update new channel's viewed time, creating the channel if needed-    case chan of-        Nothing ->-            -- It's possible for us to get spurious WMChannelViewed-            -- events from the server, e.g. for channels that have been-            -- deleted. So here we ignore the request since it's hard to-            -- detect it before this point.-            return ()-        Just _  ->-          -- The server has been sent a viewed POST update, but there is-          -- no local information on what timestamp the server actually-          -- recorded. There are a couple of options for setting the-          -- local value of the viewed time:-          ---          --   1. Attempting to locally construct a value, which would-          --      involve scanning all (User) messages in the channel-          --      to find the maximum of the created date, the modified-          --      date, or the deleted date, and assuming that maximum-          --      mostly matched the server's viewed time.-          ---          --   2. Issuing a channel metadata request to get the server's-          --      new concept of the viewed time.-          ---          --   3. Having the "chan/viewed" POST that was just issued-          --      return a value from the server. See-          --      https://github.com/mattermost/platform/issues/6803.-          ---          -- Method 3 would be the best and most lightweight. Until that-          -- is available, Method 2 will be used. The downside to Method-          -- 2 is additional client-server messaging, and a delay in-          -- updating the client data, but it's also immune to any new-          -- or removed Message date fields, or anything else that would-          -- contribute to the viewed/updated times on the server.-          doAsyncChannelMM Preempt cId (\ s _ ->-                                           (,) <$> MM.mmGetChannel cId s-                                               <*> MM.mmGetChannelMember cId UserMe s)-          (\pcid (cwd, member) -> Just $ csChannel(pcid).ccInfo %= channelInfoFromChannelWithData cwd member)--    -- Update the old channel's previous viewed time (allows tracking of-    -- new messages)-    case prevId of-      Nothing -> return ()-      Just p -> clearChannelUnreadStatus p---- | Refresh information about all channels and users. This is usually--- triggered when a reconnect event for the WebSocket to the server--- occurs.-refreshChannelsAndUsers :: MH ()-refreshChannelsAndUsers = do-    session <- getSession-    myTId <- gets myTeamId-    me <- gets myUser-    knownUsers <- gets allUserIds-    doAsyncWith Preempt $ do-      (chans, datas) <- runConcurrently $ (,)-                       <$> Concurrently (MM.mmGetChannelsForUser UserMe myTId session)-                       <*> Concurrently (MM.mmGetChannelMembersForUser UserMe myTId session)--      -- Collect all user IDs associated with DM channels so we can-      -- bulk-fetch their user records.-      let dmUsers = catMaybes $ flip map (F.toList chans) $ \chan ->-              case chan^.channelTypeL of-                  Direct -> case userIdForDMChannel (userId me) (sanitizeUserText $ channelName chan) of-                        Nothing -> Nothing-                        Just otherUserId -> Just otherUserId-                  _ -> Nothing-          uIdsToFetch = nub $ userId me : knownUsers <> dmUsers--          dataMap = HM.fromList $ toList $ (\d -> (channelMemberChannelId d, d)) <$> datas-          mkPair chan = (chan, fromJust $ HM.lookup (channelId chan) dataMap)-          chansWithData = mkPair <$> chans--      return $ Just $-          -- Fetch user data associated with DM channels-          handleNewUsers (Seq.fromList uIdsToFetch) $ do-              -- Then refresh all loaded channels-              forM_ chansWithData $ uncurry (refreshChannel SidebarUpdateDeferred)-              updateSidebar---- | Refresh information about a specific channel.  The channel--- metadata is refreshed, and if this is a loaded channel, the--- scrollback is updated as well.------ The sidebar update argument indicates whether this refresh should--- also update the sidebar. Ordinarily you want this, so pass--- SidebarUpdateImmediate unless you are very sure you know what you are--- doing, i.e., you are very sure that a call to refreshChannel will--- be followed immediately by a call to updateSidebar. We provide this--- control so that channel refreshes can be batched and then a single--- updateSidebar call can be used instead of the default behavior of--- calling it once per refreshChannel call, which is the behavior if the--- immediate setting is passed here.-refreshChannel :: SidebarUpdate -> Channel -> ChannelMember -> MH ()-refreshChannel upd chan member = do-    let cId = getId chan-    myTId <- gets myTeamId-    let ourTeam = channelTeamId chan == Nothing ||-                  Just myTId == channelTeamId chan--    case not ourTeam of-        True -> return ()-        False -> do-            -- If this channel is unknown, register it first.-            mChan <- preuse (csChannel(cId))-            when (isNothing mChan) $-                handleNewChannel False upd chan member--            updateChannelInfo cId chan member--handleNewChannel :: Bool -> SidebarUpdate -> Channel -> ChannelMember -> MH ()-handleNewChannel = handleNewChannel_ True--handleNewChannel_ :: Bool-                  -- ^ Whether to permit this call to recursively-                  -- schedule itself for later if it can't locate-                  -- a DM channel user record. This is to prevent-                  -- uncontrolled recursion.-                  -> Bool-                  -- ^ Whether to switch to the new channel once it has-                  -- been installed.-                  -> SidebarUpdate-                  -- ^ Whether to update the sidebar, in case the caller-                  -- wants to batch these before updating it. Pass-                  -- SidebarUpdateImmediate unless you know what-                  -- you are doing, i.e., unless you intend to call-                  -- updateSidebar yourself after calling this.-                  -> Channel-                  -- ^ The channel to install.-                  -> ChannelMember-                  -> MH ()-handleNewChannel_ permitPostpone switch sbUpdate nc member = do-    -- Only add the channel to the state if it isn't already known.-    me <- gets myUser-    mChan <- preuse (csChannel(getId nc))-    case mChan of-        Just _ -> when switch $ setFocus (getId nc)-        Nothing -> do-            -- Create a new ClientChannel structure-            cChannel <- (ccInfo %~ channelInfoFromChannelWithData nc member) <$>-                       makeClientChannel (me^.userIdL) nc--            st <- use id--            -- Add it to the message map, and to the name map so we-            -- can look it up by name. The name we use for the channel-            -- depends on its type:-            let chType = nc^.channelTypeL--            -- Get the channel name. If we couldn't, that means we have-            -- async work to do before we can register this channel (in-            -- which case abort because we got rescheduled).-            register <- case chType of-                Direct -> case userIdForDMChannel (myUserId st) (sanitizeUserText $ channelName nc) of-                    Nothing -> return True-                    Just otherUserId ->-                        case userById otherUserId st of-                            -- If we found a user ID in the channel-                            -- name string but don't have that user's-                            -- metadata, postpone adding this channel-                            -- until we have fetched the metadata. This-                            -- can happen when we have a channel record-                            -- for a user that is no longer in the-                            -- current team. To avoid recursion due to a-                            -- problem, ensure that the rescheduled new-                            -- channel handler is not permitted to try-                            -- this again.-                            ---                            -- If we're already in a recursive attempt-                            -- to register this channel and still-                            -- couldn't find a username, just bail and-                            -- use the synthetic name (this has the same-                            -- problems as above).-                            Nothing -> do-                                case permitPostpone of-                                    False -> return True-                                    True -> do-                                        mhLog LogAPI $ T.pack $ "handleNewChannel_: about to call handleNewUsers for " <> show otherUserId-                                        handleNewUsers (Seq.singleton otherUserId) (return ())-                                        doAsyncWith Normal $-                                            return $ Just $ handleNewChannel_ False switch sbUpdate nc member-                                        return False-                            Just _ -> return True-                _ -> return True--            when register $ do-                csChannels %= addChannel (getId nc) cChannel-                when (sbUpdate == SidebarUpdateImmediate) $ do-                    -- Note that we only check for whether we should-                    -- switch to this channel when doing a sidebar-                    -- update, since that's the only case where it's-                    -- possible to do so.-                    updateSidebar--                    -- Finally, set our focus to the newly created-                    -- channel if the caller requested a change of-                    -- channel. Also consider the last join request-                    -- state field in case this is an asynchronous-                    -- channel addition triggered by a /join.-                    pending1 <- checkPendingChannelChange (ChangeByChannelId $ getId nc)-                    pending2 <- case cChannel^.ccInfo.cdDMUserId of-                        Nothing -> return False-                        Just uId -> checkPendingChannelChange (ChangeByUserId uId)--                    when (switch || pending1 || pending2) $ setFocus (getId nc)---- | Check to see whether the specified channel has been queued up to--- be switched to.  Note that this condition is only cleared by the--- actual setFocus switch to the channel because there may be multiple--- operations that must complete before the channel is fully ready for--- display/use.-checkPendingChannelChange :: PendingChannelChange -> MH Bool-checkPendingChannelChange change = (==) (Just change) <$> use csPendingChannelChange---- | Update the indicated Channel entry with the new data retrieved from--- the Mattermost server. Also update the channel name if it changed.-updateChannelInfo :: ChannelId -> Channel -> ChannelMember -> MH ()-updateChannelInfo cid new member = do-    mh $ invalidateCacheEntry $ ChannelMessages cid-    csChannel(cid).ccInfo %= channelInfoFromChannelWithData new member-    updateSidebar--setFocus :: ChannelId -> MH ()-setFocus cId = do-    showChannelInSidebar cId True-    setFocusWith True (Z.findRight ((== cId) . channelListEntryChannelId)) (return ())--showChannelInSidebar :: ChannelId -> Bool -> MH ()-showChannelInSidebar cId setPending = do-    mChan <- preuse $ csChannel cId-    me <- gets myUser-    prefs <- use (csResources.crUserPreferences)-    session <- getSession--    case mChan of-        Nothing ->-          -- The requested channel doesn't actually exist yet, so no-          -- action can be taken.  It's likely that this is a-          -- pendingChannel situation and not all of the operations to-          -- locally define the channel have completed, in which case-          -- this code will be re-entered later and the mChan will be-          -- known.-          return ()-        Just ch -> do--            -- Able to successfully switch to a known channel.  This-            -- should clear any pending channel intention.  If the-            -- intention was for this channel, then: done.  If the-            -- intention was for a different channel, reaching this-            -- point means that the pending is still outstanding but-            -- that the user identified a new channel which *was*-            -- displayable, and the UI should always prefer to SATISFY-            -- the user's latest request over any pending/background-            -- task.-            csPendingChannelChange .= Nothing--            now <- liftIO getCurrentTime-            csChannel(cId).ccInfo.cdSidebarShowOverride .= Just now-            updateSidebar--            case ch^.ccInfo.cdType of-                Direct -> do-                    let Just uId = ch^.ccInfo.cdDMUserId-                    case dmChannelShowPreference prefs uId of-                        Just False -> do-                            let pref = showDirectChannelPref (me^.userIdL) uId True-                            when setPending $-                                csPendingChannelChange .= Just (ChangeByChannelId $ ch^.ccInfo.cdChannelId)-                            doAsyncWith Preempt $ do-                                MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session-                                return Nothing-                        _ -> return ()--                Group ->-                    case groupChannelShowPreference prefs cId of-                        Just False -> do-                            let pref = showGroupChannelPref cId (me^.userIdL)-                            when setPending $-                                csPendingChannelChange .= Just (ChangeByChannelId $ ch^.ccInfo.cdChannelId)-                            doAsyncWith Preempt $ do-                                MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session-                                return Nothing-                        _ -> return ()--                _ -> return ()--setFocusWith :: Bool-             -> (Zipper ChannelListGroup ChannelListEntry-             -> Zipper ChannelListGroup ChannelListEntry)-             -> MH ()-             -> MH ()-setFocusWith updatePrev f onNoChange = do-    oldZipper <- use csFocus-    let newZipper = f oldZipper-        newFocus = Z.focus newZipper-        oldFocus = Z.focus oldZipper--    -- If we aren't changing anything, skip all the book-keeping because-    -- we'll end up clobbering things like csRecentChannel.-    if newFocus /= oldFocus-       then do-          mh $ invalidateCacheEntry ChannelSidebar-          resetAutocomplete-          preChangeChannelCommon-          csFocus .= newZipper--          now <- liftIO getCurrentTime-          newCid <- use csCurrentChannelId-          csChannel(newCid).ccInfo.cdSidebarShowOverride .= Just now--          updateViewed updatePrev-          postChangeChannelCommon-       else onNoChange--postChangeChannelCommon :: MH ()-postChangeChannelCommon = do-    resetEditorState-    updateChannelListScroll-    loadLastEdit-    fetchVisibleIfNeeded--loadLastEdit :: MH ()-loadLastEdit = do-    cId <- use csCurrentChannelId--    oldEphemeral <- preuse (csChannel(cId).ccEditState)-    case oldEphemeral of-        Nothing -> return ()-        Just e -> csEditState.cedEphemeral .= e--    loadLastChannelInput--loadLastChannelInput :: MH ()-loadLastChannelInput = do-    cId <- use csCurrentChannelId-    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)-    case inputHistoryPos of-        Just i -> loadHistoryEntryToEditor cId i-        Nothing -> do-            (lastEdit, lastEditMode) <- use (csEditState.cedEphemeral.eesLastInput)-            csEditState.cedEditor %= (applyEdit $ insertMany lastEdit . clearZipper)-            csEditState.cedEditMode .= lastEditMode--updateChannelListScroll :: MH ()-updateChannelListScroll = do-    mh $ vScrollToBeginning (viewportScroll ChannelList)--preChangeChannelCommon :: MH ()-preChangeChannelCommon = do-    cId <- use csCurrentChannelId-    csRecentChannel .= Just cId-    saveCurrentEdit--resetEditorState :: MH ()-resetEditorState = do-    csEditState.cedEditMode .= NewPost-    clearEditor--clearEditor :: MH ()-clearEditor = csEditState.cedEditor %= applyEdit clearZipper--saveCurrentEdit :: MH ()-saveCurrentEdit = do-    saveCurrentChannelInput--    oldEphemeral <- use (csEditState.cedEphemeral)-    cId <- use csCurrentChannelId-    csChannel(cId).ccEditState .= oldEphemeral--saveCurrentChannelInput :: MH ()-saveCurrentChannelInput = do-    cmdLine <- use (csEditState.cedEditor)-    mode <- use (csEditState.cedEditMode)--    -- Only save the editor contents if the user is not navigating the-    -- history.-    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)--    when (isNothing inputHistoryPos) $-        csEditState.cedEphemeral.eesLastInput .=-           (T.intercalate "\n" $ getEditContents $ cmdLine, mode)--hideGroupChannelPref :: ChannelId -> UserId -> Preference-hideGroupChannelPref cId uId =-    Preference { preferenceCategory = PreferenceCategoryGroupChannelShow-               , preferenceValue = PreferenceValue "false"-               , preferenceName = PreferenceName $ idString cId-               , preferenceUserId = uId-               }--showGroupChannelPref :: ChannelId -> UserId -> Preference-showGroupChannelPref cId uId =-    Preference { preferenceCategory = PreferenceCategoryGroupChannelShow-               , preferenceValue = PreferenceValue "true"-               , preferenceName = PreferenceName $ idString cId-               , preferenceUserId = uId-               }--showDirectChannelPref :: UserId -> UserId -> Bool -> Preference-showDirectChannelPref myId otherId s =-    Preference { preferenceCategory = PreferenceCategoryDirectChannelShow-               , preferenceValue = if s then PreferenceValue "true"-                                        else PreferenceValue "false"-               , preferenceName = PreferenceName $ idString otherId-               , preferenceUserId = myId-               }--applyPreferenceChange :: Preference -> MH ()-applyPreferenceChange pref = do-    -- always update our user preferences accordingly-    csResources.crUserPreferences %= setUserPreferences (Seq.singleton pref)--    -- Invalidate the entire rendering cache since many things depend on-    -- user preferences-    mh invalidateCache--    if-      | Just f <- preferenceToFlaggedPost pref -> do-          updateMessageFlag (flaggedPostId f) (flaggedPostStatus f)--      | Just d <- preferenceToDirectChannelShowStatus pref -> do-          updateSidebar--          cs <- use csChannels--          -- We need to check on whether this preference was to show a-          -- channel and, if so, whether it was the one we attempted to-          -- switch to (thus triggering the preference change). If so,-          -- we need to switch to it now.-          let Just cId = getDmChannelFor (directChannelShowUserId d) cs-          case directChannelShowValue d of-              True -> do-                  pending <- checkPendingChannelChange $ ChangeByChannelId cId-                  when pending $ setFocus cId-              False -> do-                  csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing--      | Just g <- preferenceToGroupChannelPreference pref -> do-          updateSidebar--          -- We need to check on whether this preference was to show a-          -- channel and, if so, whether it was the one we attempted to-          -- switch to (thus triggering the preference change). If so,-          -- we need to switch to it now.-          let cId = groupChannelId g-          case groupChannelShow g of-              True -> do-                  pending <- checkPendingChannelChange $ ChangeByChannelId cId-                  when pending $ setFocus cId-              False -> do-                  csChannel(cId).ccInfo.cdSidebarShowOverride .= Nothing--      | otherwise -> return ()--refreshChannelById :: ChannelId -> MH ()-refreshChannelById cId = do-    session <- getSession-    doAsyncWith Preempt $ do-        cwd <- MM.mmGetChannel cId session-        member <- MM.mmGetChannelMember cId UserMe session-        return $ Just $ do-            refreshChannel SidebarUpdateImmediate cwd member--removeChannelFromState :: ChannelId -> MH ()-removeChannelFromState cId = do-    withChannel cId $ \ chan -> do-        when (chan^.ccInfo.cdType /= Direct) $ do-            origFocus <- use csCurrentChannelId-            when (origFocus == cId) nextChannelSkipPrevView-            -- Update input history-            csEditState.cedInputHistory         %= removeChannelHistory cId-            -- Update msgMap-            csChannels                          %= removeChannel cId-            -- Remove from focus zipper-            csFocus %= Z.filterZipper ((/= cId) . channelListEntryChannelId)-            updateSidebar--nextChannel :: MH ()-nextChannel = do-    resetReturnChannel-    setFocusWith True Z.right (return ())---- | This is almost never what you want; we use this when we delete a--- channel and we don't want to update the deleted channel's view time.-nextChannelSkipPrevView :: MH ()-nextChannelSkipPrevView = setFocusWith False Z.right (return ())--prevChannel :: MH ()-prevChannel = do-    resetReturnChannel-    setFocusWith True Z.left (return ())--recentChannel :: MH ()-recentChannel = do-  recent <- use csRecentChannel-  case recent of-    Nothing  -> return ()-    Just cId -> do-        ret <- use csReturnChannel-        when (ret == Just cId) resetReturnChannel-        setFocus cId--resetReturnChannel :: MH ()-resetReturnChannel = do-  val <- use csReturnChannel-  case val of-      Nothing -> return ()-      Just _ -> do-          mh $ invalidateCacheEntry ChannelSidebar-          csReturnChannel .= Nothing--gotoReturnChannel :: MH ()-gotoReturnChannel = do-  ret <- use csReturnChannel-  case ret of-    Nothing  -> return ()-    Just cId -> do-        resetReturnChannel-        setFocus cId--setReturnChannel :: MH ()-setReturnChannel = do-  ret <- use csReturnChannel-  case ret of-    Nothing  -> do-        cId <- use csCurrentChannelId-        csReturnChannel .= Just cId-        mh $ invalidateCacheEntry ChannelSidebar-    Just _ -> return ()--nextUnreadChannel :: MH ()-nextUnreadChannel = do-    st <- use id-    setReturnChannel-    setFocusWith True (getNextUnreadChannel st) gotoReturnChannel--nextUnreadUserOrChannel :: MH ()-nextUnreadUserOrChannel = do-    st <- use id-    setReturnChannel-    setFocusWith True (getNextUnreadUserOrChannel st) gotoReturnChannel--leaveChannel :: ChannelId -> MH ()-leaveChannel cId = leaveChannelIfPossible cId False--leaveChannelIfPossible :: ChannelId -> Bool -> MH ()-leaveChannelIfPossible cId delete = do-    st <- use id-    me <- gets myUser-    let isMe u = u^.userIdL == me^.userIdL--    case st ^? csChannel(cId).ccInfo of-        Nothing -> return ()-        Just cInfo -> case canLeaveChannel cInfo of-            False -> return ()-            True ->-                -- The server will reject an attempt to leave a private-                -- channel if we're the only member. To check this, we-                -- just ask for the first two members of the channel.-                -- If there is only one, it must be us: hence the "all-                -- isMe" check below. If there are two members, it-                -- doesn't matter who they are, because we just know-                -- that we aren't the only remaining member, so we can't-                -- delete the channel.-                doAsyncChannelMM Preempt cId-                    (\s _ ->-                      let query = MM.defaultUserQuery-                           { MM.userQueryPage = Just 0-                           , MM.userQueryPerPage = Just 2-                           , MM.userQueryInChannel = Just cId-                           }-                      in toList <$> MM.mmGetUsers query s)-                    (\_ members -> Just $ do-                        -- If the channel is private:-                        -- * leave it if we aren't the last member.-                        -- * delete it if we are.-                        ---                        -- Otherwise:-                        -- * leave (or delete) the channel as specified-                        -- by the delete argument.-                        let func = case cInfo^.cdType of-                                Private -> case all isMe members of-                                    True -> (\ s c -> MM.mmDeleteChannel c s)-                                    False -> (\ s c -> MM.mmRemoveUserFromChannel c UserMe s)-                                Group ->-                                    \s _ ->-                                        let pref = hideGroupChannelPref cId (me^.userIdL)-                                        in MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) s-                                _ -> if delete-                                     then (\ s c -> MM.mmDeleteChannel c s)-                                     else (\ s c -> MM.mmRemoveUserFromChannel c UserMe s)--                        doAsyncChannelMM Preempt cId func endAsyncNOP-                    )--getNextUnreadChannel :: ChatState-                     -> (Zipper a ChannelListEntry -> Zipper a ChannelListEntry)-getNextUnreadChannel st =-    -- The next channel with unread messages must also be a channel-    -- other than the current one, since the zipper may be on a channel-    -- that has unread messages and will stay that way until we leave-    -- it- so we need to skip that channel when doing the zipper search-    -- for the next candidate channel.-    Z.findRight (\e ->-                let cId = channelListEntryChannelId e-                in hasUnread st cId && (cId /= st^.csCurrentChannelId))--getNextUnreadUserOrChannel :: ChatState-                           -> Zipper a ChannelListEntry-                           -> Zipper a ChannelListEntry-getNextUnreadUserOrChannel st z =-    -- Find the next unread channel, prefering direct messages-    let cur = st^.csCurrentChannelId-        matches e = entryIsDMEntry e && isFresh (channelListEntryChannelId e)-        isFresh c = hasUnread st c && (c /= cur)-    in fromMaybe (Z.findRight (isFresh . channelListEntryChannelId) z)-                 (Z.maybeFindRight matches z)--leaveCurrentChannel :: MH ()-leaveCurrentChannel = use csCurrentChannelId >>= leaveChannel--createGroupChannel :: Text -> MH ()-createGroupChannel usernameList = do-    me <- gets myUser-    session <- getSession-    cs <- use csChannels--    doAsyncWith Preempt $ do-        let usernames = Seq.fromList $ fmap trimUserSigil $ T.words usernameList-        results <- MM.mmGetUsersByUsernames usernames session--        -- If we found all of the users mentioned, then create the group-        -- channel.-        case length results == length usernames of-            True -> do-                chan <- MM.mmCreateGroupMessageChannel (userId <$> results) session-                return $ Just $ do-                    case findChannelById (channelId chan) cs of-                      Just _ ->-                          -- If we already know about the channel ID,-                          -- that means the channel already exists so-                          -- we can just switch to it.-                          setFocus (channelId chan)-                      Nothing -> do-                          csPendingChannelChange .= (Just $ ChangeByChannelId $ channelId chan)-                          let pref = showGroupChannelPref (channelId chan) (me^.userIdL)-                          doAsyncWith Normal $ do-                            MM.mmSaveUsersPreferences UserMe (Seq.singleton pref) session-                            return $ Just $ applyPreferenceChange pref-            False -> do-                let foundUsernames = userUsername <$> results-                    missingUsernames = S.toList $-                                       S.difference (S.fromList $ F.toList usernames)-                                                    (S.fromList $ F.toList foundUsernames)-                return $ Just $ do-                    forM_ missingUsernames (mhError . NoSuchUser)--channelHistoryForward :: MH ()-channelHistoryForward = do-    cId <- use csCurrentChannelId-    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)-    case inputHistoryPos of-        Just i-          | i == 0 -> do-            -- Transition out of history navigation-            csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing-            loadLastChannelInput-          | otherwise -> do-            let newI = i - 1-            loadHistoryEntryToEditor cId newI-            csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)-        _ -> return ()--loadHistoryEntryToEditor :: ChannelId -> Int -> MH ()-loadHistoryEntryToEditor cId idx = do-    inputHistory <- use (csEditState.cedInputHistory)-    case getHistoryEntry cId idx inputHistory of-        Nothing -> return ()-        Just entry -> do-            let eLines = T.lines entry-                mv = if length eLines == 1 then gotoEOL else id-            csEditState.cedEditor.editContentsL .= (mv $ textZipper eLines Nothing)--channelHistoryBackward :: MH ()-channelHistoryBackward = do-    cId <- use csCurrentChannelId-    inputHistoryPos <- use (csEditState.cedEphemeral.eesInputHistoryPosition)-    saveCurrentChannelInput--    let newI = maybe 0 (+ 1) inputHistoryPos-    loadHistoryEntryToEditor cId newI-    csEditState.cedEphemeral.eesInputHistoryPosition .= (Just newI)--createOrdinaryChannel :: Bool -> Text -> MH ()-createOrdinaryChannel public name = do-    session <- getSession-    myTId <- gets myTeamId-    doAsyncWith Preempt $ do-        -- create a new chat channel-        let slug = T.map (\ c -> if isAlphaNum c then c else '-') (T.toLower name)-            minChannel = MinChannel-              { minChannelName        = slug-              , minChannelDisplayName = name-              , minChannelPurpose     = Nothing-              , minChannelHeader      = Nothing-              , minChannelType        = if public then Ordinary else Private-              , minChannelTeamId      = myTId-              }-        tryMM (do c <- MM.mmCreateChannel minChannel session-                  chan <- MM.mmGetChannel (getId c) session-                  member <- MM.mmGetChannelMember (getId c) UserMe session-                  return (chan, member)-              )-              (return . Just . uncurry (handleNewChannel True SidebarUpdateImmediate))---- | When we are added to a channel not locally known about, we need--- to fetch the channel info for that channel.-handleChannelInvite :: ChannelId -> MH ()-handleChannelInvite cId = do-    session <- getSession-    doAsyncWith Normal $ do-        member <- MM.mmGetChannelMember cId UserMe session-        tryMM (MM.mmGetChannel cId session)-              (\cwd -> return $ Just $ do-                  pending <- checkPendingChannelChange $ ChangeByChannelId cId-                  handleNewChannel pending SidebarUpdateImmediate cwd member)--addUserByNameToCurrentChannel :: Text -> MH ()-addUserByNameToCurrentChannel uname =-    withFetchedUser (UserFetchByUsername uname) addUserToCurrentChannel--addUserToCurrentChannel :: UserInfo -> MH ()-addUserToCurrentChannel u = do-    cId <- use csCurrentChannelId-    session <- getSession-    let channelMember = MinChannelMember (u^.uiId) cId-    doAsyncWith Normal $ do-        tryMM (void $ MM.mmAddUser cId channelMember session)-              (const $ return Nothing)--removeUserFromCurrentChannel :: Text -> MH ()-removeUserFromCurrentChannel uname =-    withFetchedUser (UserFetchByUsername uname) $ \u -> do-        cId <- use csCurrentChannelId-        session <- getSession-        doAsyncWith Normal $ do-            tryMM (void $ MM.mmRemoveUserFromChannel cId (UserById $ u^.uiId) session)-                  (const $ return Nothing)--startLeaveCurrentChannel :: MH ()-startLeaveCurrentChannel = do-    cInfo <- use (csCurrentChannel.ccInfo)-    case cInfo^.cdType of-        Direct -> hideDMChannel (cInfo^.cdChannelId)-        Group -> hideDMChannel (cInfo^.cdChannelId)-        _ -> setMode LeaveChannelConfirm--deleteCurrentChannel :: MH ()-deleteCurrentChannel = do-    setMode Main-    cId <- use csCurrentChannelId-    leaveChannelIfPossible cId True--isCurrentChannel :: ChatState -> ChannelId -> Bool-isCurrentChannel st cId = st^.csCurrentChannelId == cId--isRecentChannel :: ChatState -> ChannelId -> Bool-isRecentChannel st cId = st^.csRecentChannel == Just cId--isReturnChannel :: ChatState -> ChannelId -> Bool-isReturnChannel st cId = st^.csReturnChannel == Just cId--joinChannelByName :: Text -> MH ()-joinChannelByName rawName = do-    session <- getSession-    tId <- gets myTeamId-    doAsyncWith Preempt $ do-        result <- try $ MM.mmGetChannelByName tId (trimChannelSigil rawName) session-        return $ Just $ case result of-            Left (_::SomeException) -> mhError $ NoSuchChannel rawName-            Right chan -> joinChannel $ getId chan---- | If the user is not a member of the specified channel, submit a--- request to join it. Otherwise switch to the channel.-joinChannel :: ChannelId -> MH ()-joinChannel chanId = do-    setMode Main-    mChan <- preuse (csChannel(chanId))-    case mChan of-        Just _ -> setFocus chanId-        Nothing -> do-            myId <- gets myUserId-            let member = MinChannelMember myId chanId-            csPendingChannelChange .= (Just $ ChangeByChannelId chanId)-            doAsyncChannelMM Preempt chanId (\ s c -> MM.mmAddUser c member s) endAsyncNOP--createOrFocusDMChannel :: UserInfo -> Maybe (ChannelId -> MH ()) -> MH ()-createOrFocusDMChannel user successAct = do-    cs <- use csChannels-    case getDmChannelFor (user^.uiId) cs of-        Just cId -> do-            setFocus cId-            case successAct of-                Nothing -> return ()-                Just act -> act cId-        Nothing -> do-            -- We have a user of that name but no channel. Time to make one!-            myId <- gets myUserId-            session <- getSession-            csPendingChannelChange .= (Just $ ChangeByUserId $ user^.uiId)-            doAsyncWith Normal $ do-                -- create a new channel-                chan <- MM.mmCreateDirectMessageChannel (user^.uiId, myId) session-                return $ successAct <*> pure (channelId chan)---- | This switches to the named channel or creates it if it is a missing--- but valid user channel.-changeChannelByName :: Text -> MH ()-changeChannelByName name = do-    mCId <- gets (channelIdByChannelName name)-    mDMCId <- gets (channelIdByUsername name)--    withFetchedUserMaybe (UserFetchByUsername name) $ \foundUser -> do-        let err = mhError $ AmbiguousName name-        case (mCId, mDMCId) of-          (Nothing, Nothing) ->-              case foundUser of-                  -- We know about the user but there isn't already a DM-                  -- channel, so create one.-                  Just user -> createOrFocusDMChannel user Nothing-                  -- There were no matches of any kind.-                  Nothing -> mhError $ NoSuchChannel name-          (Just cId, Nothing)-              -- We matched a channel and there was an explicit sigil, so we-              -- don't care about the username match.-              | normalChannelSigil `T.isPrefixOf` name -> setFocus cId-              -- We matched both a channel and a user, even though there is-              -- no DM channel.-              | Just _ <- foundUser -> err-              -- We matched a channel only.-              | otherwise -> setFocus cId-          (Nothing, Just cId) ->-              -- We matched a DM channel only.-              setFocus cId-          (Just _, Just _) ->-              -- We matched both a channel and a DM channel.-              err--setChannelTopic :: Text -> MH ()-setChannelTopic msg = do-    cId <- use csCurrentChannelId-    let patch = defaultChannelPatch { channelPatchHeader = Just msg }-    doAsyncChannelMM Preempt cId-        (\s _ -> MM.mmPatchChannel cId patch s)-        (\_ _ -> Nothing)--setChannelPurpose :: Text -> MH ()-setChannelPurpose msg = do-    cId <- use csCurrentChannelId-    let patch = defaultChannelPatch { channelPatchPurpose = Just msg }-    doAsyncChannelMM Preempt cId-        (\s _ -> MM.mmPatchChannel cId patch s)-        (\_ _ -> Nothing)--beginCurrentChannelDeleteConfirm :: MH ()-beginCurrentChannelDeleteConfirm = do-    cId <- use csCurrentChannelId-    withChannel cId $ \chan -> do-        let chType = chan^.ccInfo.cdType-        if chType /= Direct-            then setMode DeleteChannelConfirm-            else mhError $ GenericError "Direct message channels cannot be deleted."--updateChannelNotifyProps :: ChannelId -> ChannelNotifyProps -> MH ()-updateChannelNotifyProps cId notifyProps = do-    mh $ invalidateCacheEntry ChannelSidebar-    csChannel(cId).ccInfo.cdNotifyProps .= notifyProps
− src/State/Common.hs 
@@ -1,383 +0,0 @@-module State.Common-  (-  -- * System interface-    openURL-  , runLoggedCommand--  -- * Posts-  , installMessagesFromPosts-  , updatePostMap--  -- * Utilities-  , postInfoMessage-  , postErrorMessageIO-  , postErrorMessage'-  , addEmoteFormatting-  , removeEmoteFormatting--  , fetchMentionedUsers-  , doPendingUserFetches-  , doPendingUserStatusFetches--  , module State.Async-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( invalidateCacheEntry )-import           Control.Concurrent ( MVar, putMVar, forkIO )-import           Control.Concurrent.Async ( concurrently )-import qualified Control.Concurrent.STM as STM-import           Control.Exception ( SomeException, try )-import qualified Data.ByteString as BS-import qualified Data.HashMap.Strict as HM-import qualified Data.Sequence as Seq-import qualified Data.Set as Set-import qualified Data.Text as T-import           Lens.Micro.Platform ( (.=), (%=), (%~), (.~) )-import           System.Directory ( createDirectoryIfMissing )-import           System.Environment.XDG.BaseDir ( getUserCacheDir )-import           System.Exit ( ExitCode(..) )-import           System.FilePath-import           System.IO ( hGetContents, hFlush, hPutStrLn )-import           System.Process ( proc, std_in, std_out, std_err, StdStream(..)-                                , createProcess, waitForProcess )--import           Network.Mattermost.Endpoints-import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           FilePaths ( xdgName )-import           State.Async-import           Types-import           Types.Common-import           Types.RichText ( unURL )----- * Client Messages---- | Given a collection of posts from the server, save the posts in the--- global post map. Also convert the posts to Matterhorn's Message type--- and return them along with the set of all usernames mentioned in the--- text of the resulting messages.------ This also sets the mFlagged field of each message based on whether--- its post ID is a flagged post according to crFlaggedPosts at the time--- of this call.-installMessagesFromPosts :: Posts -> MH Messages-installMessagesFromPosts postCollection = do-  flags <- use (csResources.crFlaggedPosts)--  -- Add all posts in this collection to the global post cache-  updatePostMap postCollection--  -- Build the ordered list of posts. Note that postsOrder lists the-  -- posts most recent first, but we want most recent last.-  let postsInOrder = findPost <$> (Seq.reverse $ postsOrder postCollection)-      mkClientPost p = toClientPost p (postId <$> parent p)-      clientPosts = mkClientPost <$> postsInOrder--      addNext cp (msgs, us) =-          let (msg, mUsernames) = clientPostToMessage cp-          in (addMessage (maybeFlag flags msg) msgs, Set.union us mUsernames)-      (ms, mentions) = foldr addNext (noMessages, mempty) clientPosts--  fetchMentionedUsers mentions-  return ms-    where-        maybeFlag flagSet msg-          | Just (MessagePostId pId) <- msg^.mMessageId, pId `Set.member` flagSet-            = msg & mFlagged .~ True-          | otherwise = msg-        parent x = do-            parentId <- x^.postRootIdL-            HM.lookup parentId (postCollection^.postsPostsL)-        findPost pId = case HM.lookup pId (postsPosts postCollection) of-            Nothing -> error $ "BUG: could not find post for post ID " <> show pId-            Just post -> post---- Add all posts in this collection to the global post cache-updatePostMap :: Posts -> MH ()-updatePostMap postCollection = do-  -- Build a map from post ID to Matterhorn message, then add the new-  -- messages to the global post map. We use the "postsPosts" field for-  -- this because that might contain more messages than the "postsOrder"-  -- list, since the former can contain other messages in threads that-  -- the server sent us, even if those messages are not part of the-  -- ordered post listing of "postsOrder."-  let postMap = HM.fromList-          [ ( pId-            , fst $ clientPostToMessage (toClientPost x Nothing)-            )-          | (pId, x) <- HM.toList (postCollection^.postsPostsL)-          ]-  csPostMap %= HM.union postMap---- | Add a 'ClientMessage' to the current channel's message list-addClientMessage :: ClientMessage -> MH ()-addClientMessage msg = do-  cid <- use csCurrentChannelId-  uuid <- generateUUID-  let addCMsg = ccContents.cdMessages %~-          (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid))-  csChannels %= modifyChannelById cid addCMsg-  mh $ invalidateCacheEntry $ ChannelMessages cid-  mh $ invalidateCacheEntry ChannelSidebar--  let msgTy = case msg^.cmType of-        Error -> LogError-        _     -> LogGeneral--  mhLog msgTy $ T.pack $ show msg---- | Add a new 'ClientMessage' representing an error message to---   the current channel's message list-postInfoMessage :: Text -> MH ()-postInfoMessage info =-    addClientMessage =<< newClientMessage Informative (sanitizeUserText' info)---- | Add a new 'ClientMessage' representing an error message to---   the current channel's message list-postErrorMessage' :: Text -> MH ()-postErrorMessage' err =-    addClientMessage =<< newClientMessage Error (sanitizeUserText' err)--postErrorMessageIO :: Text -> ChatState -> IO ChatState-postErrorMessageIO err st = do-  msg <- newClientMessage Error err-  uuid <- generateUUID_IO-  let cId = st ^. csCurrentChannelId-      addEMsg = ccContents.cdMessages %~-          (addMessage $ clientMessageToMessage msg & mMessageId .~ Just (MessageUUID uuid))-  return $ st & csChannels %~ modifyChannelById cId addEMsg--openURL :: OpenInBrowser -> MH Bool-openURL thing = do-    cfg <- use (csResources.crConfiguration)-    case configURLOpenCommand cfg of-        Nothing ->-            return False-        Just urlOpenCommand -> do-            session <- getSession--            -- Is the URL referring to an attachment?-            let act = case thing of-                    OpenLinkChoice link ->-                        case link^.linkFileId of-                            Nothing -> prepareLink link-                            Just fId -> prepareAttachment fId session-                    OpenLocalFile path ->-                        return [path]--            -- Is the URL-opening command interactive? If so, pause-            -- Matterhorn and run the opener interactively. Otherwise-            -- run the opener asynchronously and continue running-            -- Matterhorn interactively.-            case configURLOpenCommandInteractive cfg of-                False -> do-                    outputChan <- use (csResources.crSubprocessLog)-                    doAsyncWith Preempt $ do-                        args <- act-                        runLoggedCommand False outputChan (T.unpack urlOpenCommand)-                                         args Nothing Nothing-                        return Nothing-                True -> do-                    -- If there isn't a new message cutoff showing in-                    -- the current channel, set one. This way, while the-                    -- user is gone using their interactive URL opener,-                    -- when they return, any messages that arrive in the-                    -- current channel will be displayed as new.-                    curChan <- use csCurrentChannel-                    let msgs = curChan^.ccContents.cdMessages-                    case findLatestUserMessage isEditable msgs of-                        Nothing -> return ()-                        Just m ->-                            case m^.mOriginalPost of-                                Nothing -> return ()-                                Just p ->-                                    case curChan^.ccInfo.cdNewMessageIndicator of-                                        Hide ->-                                            csCurrentChannel.ccInfo.cdNewMessageIndicator .= (NewPostsAfterServerTime (p^.postCreateAtL))-                                        _ -> return ()-                    -- No need to add a gap here: the websocket-                    -- disconnect/reconnect events will automatically-                    -- handle management of messages delivered while-                    -- suspended.--                    mhSuspendAndResume $ \st -> do-                        args <- act-                        result <- runInteractiveCommand (T.unpack urlOpenCommand) args--                        let waitForKeypress = do-                                putStrLn "Press any key to return to Matterhorn."-                                void getChar--                        case result of-                            Right ExitSuccess -> return ()-                            Left err -> do-                                putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <>-                                           " could not be run: " <> err-                                waitForKeypress-                            Right (ExitFailure code) -> do-                                putStrLn $ "URL opener subprocess " <> (show urlOpenCommand) <>-                                           " exited with non-zero status " <> show code-                                waitForKeypress--                        return $ setMode' Main st--            return True--runInteractiveCommand :: String-                      -> [String]-                      -> IO (Either String ExitCode)-runInteractiveCommand cmd args = do-    let opener = (proc cmd args) { std_in = Inherit-                                 , std_out = Inherit-                                 , std_err = Inherit-                                 }-    result <- try $ createProcess opener-    case result of-        Left (e::SomeException) -> return $ Left $ show e-        Right (_, _, _, ph) -> do-            ec <- waitForProcess ph-            return $ Right ec--runLoggedCommand :: Bool-                 -- ^ Whether stdout output is expected for this program-                 -> STM.TChan ProgramOutput-                 -- ^ The output channel to send the output to-                 -> String-                 -- ^ The program name-                 -> [String]-                 -- ^ Arguments-                 -> Maybe String-                 -- ^ The stdin to send, if any-                 -> Maybe (MVar ProgramOutput)-                 -- ^ Where to put the program output when it is ready-                 -> IO ()-runLoggedCommand stdoutOkay outputChan cmd args mInput mOutputVar = void $ forkIO $ do-    let stdIn = maybe NoStream (const CreatePipe) mInput-        opener = (proc cmd args) { std_in = stdIn-                                 , std_out = CreatePipe-                                 , std_err = CreatePipe-                                 }-    result <- try $ createProcess opener-    case result of-        Left (e::SomeException) -> do-            let po = ProgramOutput cmd args "" stdoutOkay (show e) (ExitFailure 1)-            STM.atomically $ STM.writeTChan outputChan po-            maybe (return ()) (flip putMVar po) mOutputVar-        Right (stdinResult, Just outh, Just errh, ph) -> do-            case stdinResult of-                Just inh -> do-                    let Just input = mInput-                    hPutStrLn inh input-                    hFlush inh-                Nothing -> return ()--            ec <- waitForProcess ph-            outResult <- hGetContents outh-            errResult <- hGetContents errh-            let po = ProgramOutput cmd args outResult stdoutOkay errResult ec-            STM.atomically $ STM.writeTChan outputChan po-            maybe (return ()) (flip putMVar po) mOutputVar-        Right _ ->-            error $ "BUG: createProcess returned unexpected result, report this at " <>-                    "https://github.com/matterhorn-chat/matterhorn"--prepareLink :: LinkChoice -> IO [String]-prepareLink link = return [T.unpack $ unURL $ link^.linkURL]--prepareAttachment :: FileId -> Session -> IO [String]-prepareAttachment fId sess = do-    -- The link is for an attachment, so fetch it and then-    -- open the local copy.--    (info, contents) <- concurrently (mmGetMetadataForFile fId sess) (mmGetFile fId sess)-    cacheDir <- getUserCacheDir xdgName--    let dir   = cacheDir </> "files" </> T.unpack (idString fId)-        fname = dir </> T.unpack (fileInfoName info)--    createDirectoryIfMissing True dir-    BS.writeFile fname contents-    return [fname]--removeEmoteFormatting :: T.Text -> T.Text-removeEmoteFormatting t-    | "*" `T.isPrefixOf` t &&-      "*" `T.isSuffixOf` t = T.init $ T.drop 1 t-    | otherwise = t--addEmoteFormatting :: T.Text -> T.Text-addEmoteFormatting t = "*" <> t <> "*"--fetchMentionedUsers :: Set.Set MentionedUser -> MH ()-fetchMentionedUsers ms-    | Set.null ms = return ()-    | otherwise = do-        let convertMention (UsernameMention u) = UserFetchByUsername u-            convertMention (UserIdMention i) = UserFetchById i-        scheduleUserFetches $ convertMention <$> Set.toList ms--doPendingUserStatusFetches :: MH ()-doPendingUserStatusFetches = do-    mz <- getScheduledUserStatusFetches-    case mz of-        Nothing -> return ()-        Just z -> do-            statusChan <- use (csResources.crStatusUpdateChan)-            liftIO $ STM.atomically $ STM.writeTChan statusChan z--doPendingUserFetches :: MH ()-doPendingUserFetches = do-    fs <- getScheduledUserFetches--    let getUsername (UserFetchByUsername u) = Just u-        getUsername _ = Nothing--        getUserId (UserFetchById i) = Just i-        getUserId _ = Nothing--    fetchUsers (catMaybes $ getUsername <$> fs) (catMaybes $ getUserId <$> fs)---- | Given a list of usernames, ensure that we have a user record for--- each one in the state, either by confirming that a local record--- exists or by issuing a request for user records.-fetchUsers :: [Text] -> [UserId] -> MH ()-fetchUsers rawUsernames uids = do-    st <- use id-    session <- getSession-    let usernames = trimUserSigil <$> rawUsernames-        missingUsernames = filter isMissing usernames-        isMissing n = and [ not $ T.null n-                          , not $ isSpecialMention n-                          , isNothing $ userByUsername n st-                          ]-        missingIds = filter (\i -> isNothing $ userById i st) uids--    when (not $ null missingUsernames) $ do-        mhLog LogGeneral $ T.pack $ "fetchUsers: getting " <> show missingUsernames--    when (not $ null missingIds) $ do-        mhLog LogGeneral $ T.pack $ "fetchUsers: getting " <> show missingIds--    when ((not $ null missingUsernames) || (not $ null missingIds)) $ do-        doAsyncWith Normal $ do-            act1 <- case null missingUsernames of-                True -> return $ return ()-                False -> do-                    results <- mmGetUsersByUsernames (Seq.fromList missingUsernames) session-                    return $ do-                        forM_ results (\u -> addNewUser $ userInfoFromUser u True)--            act2 <- case null missingIds of-                True -> return $ return ()-                False -> do-                    results <- mmGetUsersByIds (Seq.fromList missingIds) session-                    return $ do-                        forM_ results (\u -> addNewUser $ userInfoFromUser u True)--            return $ Just $ act1 >> act2
− src/State/Editing.hs 
@@ -1,524 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}-module State.Editing-  ( requestSpellCheck-  , editingKeybindings-  , editingKeyHandlers-  , messageEditingKeybindings-  , toggleMultilineEditing-  , invokeExternalEditor-  , handlePaste-  , handleInputSubmission-  , getEditorContent-  , handleEditingInput-  , cancelAutocompleteOrReplyOrEdit-  , replyToLatestMessage-  , Direction(..)-  , tabComplete-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( invalidateCache, invalidateCacheEntry )-import           Brick.Widgets.Edit ( Editor, applyEdit , handleEditorEvent-                                    , getEditContents, editContentsL )-import qualified Brick.Widgets.List as L-import qualified Codec.Binary.UTF8.Generic as UTF8-import           Control.Arrow-import qualified Control.Concurrent.STM as STM-import qualified Data.ByteString as BS-import           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(..) )-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-import qualified System.IO.Temp as Sys-import qualified System.Process as Sys-import           Text.Aspell ( AspellResponse(..), mistakeWord, askAspell )--import           Network.Mattermost.Types ( Post(..), ChannelId )--import           Config-import {-# SOURCE #-} Command ( dispatchCommand )-import           InputHistory-import           Events.Keybindings-import           State.Common-import           State.Autocomplete-import           State.Attachments-import           State.Messages-import           Types hiding ( newState )-import           Types.Common ( sanitizeUserText' )---startMultilineEditing :: MH ()-startMultilineEditing = do-    mh invalidateCache-    csEditState.cedEphemeral.eesMultiline .= True--toggleMultilineEditing :: MH ()-toggleMultilineEditing = do-    mh invalidateCache-    csEditState.cedEphemeral.eesMultiline %= not--    -- If multiline is now disabled and there is more than one line in-    -- the editor, that means we're showing the multiline message status-    -- (see Draw.Main.renderUserCommandBox.commandBox) so we want to be-    -- sure no autocomplete UI is present in case the cursor was left on-    -- a word that would otherwise show completion alternatives.-    multiline <- use (csEditState.cedEphemeral.eesMultiline)-    numLines <- use (csEditState.cedEditor.to getEditContents.to length)-    when (not multiline && numLines > 1) resetAutocomplete--invokeExternalEditor :: MH ()-invokeExternalEditor = do-    -- If EDITOR is in the environment, write the current message to a-    -- temp file, invoke EDITOR on it, read the result, remove the temp-    -- file, and update the program state.-    ---    -- If EDITOR is not present, fall back to 'vi'.-    mEnv <- liftIO $ Sys.lookupEnv "EDITOR"-    let editorProgram = maybe "vi" id mEnv--    mhSuspendAndResume $ \ st -> 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-        Sys.hClose tmpFileHandle--        -- Run the editor-        status <- Sys.system (editorProgram <> " " <> tmpFileName)--        -- On editor exit, if exited with zero status, read temp file.-        -- If non-zero status, skip temp file read.-        case status of-            Sys.ExitSuccess -> do-                tmpBytes <- BS.readFile tmpFileName-                case T.decodeUtf8' tmpBytes of-                    Left _ -> do-                        postErrorMessageIO "Failed to decode file contents as UTF-8" st-                    Right t -> do-                        let tmpLines = T.lines $ sanitizeUserText' t-                        return $ st & csEditState.cedEditor.editContentsL .~ (Z.textZipper tmpLines Nothing)-            Sys.ExitFailure _ -> return st--handlePaste :: BS.ByteString -> MH ()-handlePaste bytes = do-  let pasteStr = T.pack (UTF8.toString bytes)-  csEditState.cedEditor %= applyEdit (Z.insertMany (sanitizeUserText' pasteStr))-  contents <- use (csEditState.cedEditor.to getEditContents)-  case length contents > 1 of-      True -> startMultilineEditing-      False -> return ()--editingPermitted :: ChatState -> Bool-editingPermitted st =-    (length (getEditContents $ st^.csEditState.cedEditor) == 1) ||-    st^.csEditState.cedEphemeral.eesMultiline--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-      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)-      editor %= applyEdit (Z.insertMany buf)-  ]--getEditorContent :: MH Text-getEditorContent = do-    cmdLine <- use (csEditState.cedEditor)-    let (line:rest) = getEditContents cmdLine-    return $ T.intercalate "\n" $ line : rest---- | Handle an input submission in the message editor.------ This handles the specified input text as if it were user input for--- the specified channel. This means that if the specified input text--- contains a command ("/...") then it is executed as normal. Otherwise--- the text is sent as a message to the specified channel.------ However, this function assumes that the message editor is the--- *source* of the text, so it also takes care of clearing the editor,--- resetting the edit mode, updating the input history for the specified--- channel, etc.-handleInputSubmission :: ChannelId -> Text -> MH ()-handleInputSubmission cId content = do-    -- We clean up before dispatching the command or sending the message-    -- since otherwise the command could change the state and then doing-    -- cleanup afterwards could clean up the wrong things.-    csEditState.cedEditor %= applyEdit Z.clearZipper-    csEditState.cedInputHistory %= addHistoryEntry content cId-    csEditState.cedEphemeral.eesInputHistoryPosition .= Nothing--    case T.uncons content of-      Just ('/', cmd) ->-          dispatchCommand cmd-      _ -> do-          attachments <- use (csEditState.cedAttachmentList.L.listElementsL)-          mode <- use (csEditState.cedEditMode)-          sendMessage cId mode content $ F.toList attachments--    -- Reset the autocomplete UI-    resetAutocomplete--    -- Empty the attachment list-    resetAttachmentList--    -- Reset the edit mode *after* handling the input so that the input-    -- handler can tell whether we're editing, replying, etc.-    csEditState.cedEditMode .= NewPost--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:-    -- if multiline mode is off, or if there is only one line of text-    -- in the editor. This means we skip input this catch-all handler-    -- if we're *not* in multiline mode *and* there are multiple lines,-    -- 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--    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-          -- composition-          EvKey KBS [] | (not $ editingPermitted st) ->-            csEditState.cedEditor %= applyEdit Z.clearZipper--          -- Backspace in editing mode with smart pair insertion means-          -- smart pair removal when possible-          EvKey KBS [] | editingPermitted st && smartBacktick ->-              let backspace = csEditState.cedEditor %= applyEdit Z.deletePrevChar-              in case cursorAtOneOf smartChars (st^.csEditState.cedEditor) of-                  Nothing -> backspace-                  Just ch ->-                      -- Smart char removal:-                      if | (cursorAtChar ch $ applyEdit Z.moveLeft $ st^.csEditState.cedEditor) &&-                           (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->-                             csEditState.cedEditor %= applyEdit (Z.deleteChar >>> Z.deletePrevChar)-                         | otherwise -> backspace--          EvKey (KChar ch) []-            | editingPermitted st && smartBacktick && ch `elem` smartChars ->-              -- Smart char insertion:-              let doInsertChar = do-                    csEditState.cedEditor %= applyEdit (Z.insertChar ch)-                    sendUserTypingAction-                  curLine = Z.currentLine $ st^.csEditState.cedEditor.editContentsL-              -- First case: if the cursor is at the end of the current-              -- line and it contains "``" and the user entered a third-              -- "`", enable multi-line mode since they're likely typing-              -- a code block.-              in if | (cursorIsAtEnd $ st^.csEditState.cedEditor) &&-                         curLine == "``" &&-                         ch == '`' -> do-                        csEditState.cedEditor %= applyEdit (Z.insertMany (T.singleton ch))-                        csEditState.cedEphemeral.eesMultiline .= True-                    -- Second case: user entered some smart character-                    -- (don't care which) on an empty line or at the end-                    -- of the line after whitespace, so enter a pair of-                    -- the smart chars and put the cursor between them.-                    | (editorEmpty $ st^.csEditState.cedEditor) ||-                         ((cursorAtChar ' ' (applyEdit Z.moveLeft $ st^.csEditState.cedEditor)) &&-                          (cursorIsAtEnd $ st^.csEditState.cedEditor)) ->-                        csEditState.cedEditor %= applyEdit (Z.insertMany (T.pack $ ch:ch:[]) >>> Z.moveLeft)-                    -- Third case: the cursor is already on a smart-                    -- character and that character is the last one-                    -- on the line, so instead of inserting a new-                    -- character, just move past it.-                    | (cursorAtChar ch $ st^.csEditState.cedEditor) &&-                      (cursorIsAtEnd $ applyEdit Z.moveRight $ st^.csEditState.cedEditor) ->-                        csEditState.cedEditor %= applyEdit Z.moveRight-                    -- Fall-through case: just insert one of the chars-                    -- without doing anything smart.-                    | otherwise -> doInsertChar-            | editingPermitted st -> do--              -- 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-              sendUserTypingAction-            | otherwise -> return ()--    let ctx = AutocompleteContext { autocompleteManual = False-                                  , autocompleteFirstMatch = False-                                  }-    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.-sendUserTypingAction :: MH ()-sendUserTypingAction = do-  st <- use id-  when (configShowTypingIndicator (st^.csResources.crConfiguration)) $-    case st^.csConnectionStatus of-      Connected -> do-        let pId = case st^.csEditState.cedEditMode of-                    Replying _ post -> Just $ postId post-                    _               -> Nothing-        liftIO $ do-          now <- getCurrentTime-          let action = UserTyping now (st^.csCurrentChannelId) pId-          STM.atomically $ STM.writeTChan (st^.csResources.crWebsocketActionChan) action-      Disconnected -> return ()---- Kick off an async request to the spell checker for the current editor--- contents.-requestSpellCheck :: MH ()-requestSpellCheck = do-    st <- use id-    case st^.csEditState.cedSpellChecker of-        Nothing -> return ()-        Just (checker, _) -> do-            -- Get the editor contents.-            contents <- getEditContents <$> use (csEditState.cedEditor)-            doAsyncWith Preempt $ do-                -- For each line in the editor, submit an aspell request.-                let query = concat <$> mapM (askAspell checker) contents-                    postMistakes :: [AspellResponse] -> MH ()-                    postMistakes responses = do-                        let getMistakes AllCorrect = []-                            getMistakes (Mistakes ms) = mistakeWord <$> ms-                            allMistakes = S.fromList $ concat $ getMistakes <$> responses-                        csEditState.cedMisspellings .= allMistakes--                tryMM query (return . Just . postMistakes)--editorEmpty :: Editor Text a -> Bool-editorEmpty e = cursorIsAtEnd e &&-                cursorIsAtBeginning e--cursorIsAtEnd :: Editor Text a -> Bool-cursorIsAtEnd e =-    let col = snd $ Z.cursorPosition z-        curLine = Z.currentLine z-        z = e^.editContentsL-    in col == T.length curLine--cursorIsAtBeginning :: Editor Text a -> Bool-cursorIsAtBeginning e =-    let col = snd $ Z.cursorPosition z-        z = e^.editContentsL-    in col == 0--cursorAtOneOf :: [Char] -> Editor Text a -> Maybe Char-cursorAtOneOf [] _ = Nothing-cursorAtOneOf (c:cs) e =-    if cursorAtChar c e-    then Just c-    else cursorAtOneOf cs e--cursorAtChar :: Char -> Editor Text a -> Bool-cursorAtChar ch e =-    let col = snd $ Z.cursorPosition z-        curLine = Z.currentLine z-        z = e^.editContentsL-    in (T.singleton ch) `T.isPrefixOf` T.drop col curLine--gotoHome :: Z.TextZipper Text -> Z.TextZipper Text-gotoHome = Z.moveCursor (0, 0)--gotoEnd :: Z.TextZipper Text -> Z.TextZipper Text-gotoEnd z =-    let zLines = Z.getText z-        numLines = length zLines-        lastLineLength = T.length $ last zLines-    in if numLines > 0-       then Z.moveCursor (numLines - 1, lastLineLength) z-       else z--cancelAutocompleteOrReplyOrEdit :: MH ()-cancelAutocompleteOrReplyOrEdit = do-    cId <- use csCurrentChannelId-    mh $ invalidateCacheEntry $ ChannelMessages cId-    ac <- use (csEditState.cedAutocomplete)-    case ac of-        Just _ -> do-            resetAutocomplete-        Nothing -> do-            mode <- use (csEditState.cedEditMode)-            case mode of-                NewPost -> return ()-                _ -> do-                    csEditState.cedEditMode .= NewPost-                    csEditState.cedEditor %= applyEdit Z.clearZipper-                    resetAttachmentList--replyToLatestMessage :: MH ()-replyToLatestMessage = do-  msgs <- use (csCurrentChannel . ccContents . cdMessages)-  case findLatestUserMessage isReplyable msgs of-    Just msg | isReplyable msg ->-        do let Just p = msg^.mOriginalPost-           setMode Main-           cId <- use csCurrentChannelId-           mh $ invalidateCacheEntry $ ChannelMessages cId-           csEditState.cedEditMode .= Replying msg p-    _ -> return ()--data Direction = Forwards | Backwards--tabComplete :: Direction -> MH ()-tabComplete dir = do-    let transform list =-            let len = list^.L.listElementsL.to length-            in case dir of-                Forwards ->-                    if (L.listSelected list == Just (len - 1)) ||-                       (L.listSelected list == Nothing && len > 0)-                    then L.listMoveTo 0 list-                    else L.listMoveBy 1 list-                Backwards ->-                    if (L.listSelected list == Just 0) ||-                       (L.listSelected list == Nothing && len > 0)-                    then L.listMoveTo (len - 1) list-                    else L.listMoveBy (-1) list-    csEditState.cedAutocomplete._Just.acCompletionList %= transform--    mac <- use (csEditState.cedAutocomplete)-    case mac of-        Nothing -> do-            let ctx = AutocompleteContext { autocompleteManual = True-                                          , autocompleteFirstMatch = True-                                          }-            checkForAutocompletion ctx-        Just ac -> do-            case ac^.acCompletionList.to L.listSelectedElement of-                Nothing -> return ()-                Just (_, alternative) -> do-                    let replacement = autocompleteAlternativeReplacement alternative-                        maybeEndOfWord z =-                            if maybe True isSpace (Z.currentChar z)-                            then z-                            else Z.moveWordRight z-                    csEditState.cedEditor %=-                        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/Editing.hs-boot 
@@ -1,10 +0,0 @@-module State.Editing-  ( Direction(..)-  , tabComplete-  )-where--import Types ( MH )--data Direction = Forwards | Backwards-tabComplete :: Direction -> MH ()
− src/State/Flagging.hs 
@@ -1,66 +0,0 @@-module State.Flagging-  ( loadFlaggedMessages-  , updateMessageFlag-  )-where--import           Prelude ()-import           Prelude.MH--import           Data.Function ( on )-import qualified Data.Set as Set-import           Lens.Micro.Platform--import           Network.Mattermost.Types--import           State.Common-import           Types---loadFlaggedMessages :: Seq FlaggedPost -> ChatState -> IO ()-loadFlaggedMessages prefs st = doAsyncWithIO Normal st $ do-  return $ Just $ do-      sequence_ [ updateMessageFlag (flaggedPostId fp) True-                | fp <- toList prefs-                , flaggedPostStatus fp-                ]----- | Update the UI to reflect the flagged/unflagged state of a--- message. This __does not__ talk to the Mattermost server, but--- rather is the function we call when the Mattermost server notifies--- us of flagged or unflagged messages.-updateMessageFlag :: PostId -> Bool -> MH ()-updateMessageFlag pId f = do-  if f-    then csResources.crFlaggedPosts %= Set.insert pId-    else csResources.crFlaggedPosts %= Set.delete pId-  msgMb <- use (csPostMap.at(pId))-  case msgMb of-    Just msg-      | Just cId <- msg^.mChannelId -> do-      let isTargetMessage m = m^.mMessageId == Just (MessagePostId pId)-      csChannel(cId).ccContents.cdMessages.traversed.filtered isTargetMessage.mFlagged .= f-      csPostMap.ix(pId).mFlagged .= f-      -- We also want to update the post overlay if this happens while-      -- we're we're observing it-      mode <- gets appMode-      case mode of-        PostListOverlay PostListFlagged-          | f ->-              csPostListOverlay.postListPosts %=-                addMessage (msg & mFlagged .~ True)-          -- deleting here is tricky, because it means that we need to-          -- move the focus somewhere: we'll try moving it _up_ unless-          -- we can't, in which case we'll try moving it down.-          | otherwise -> do-              selId <- use (csPostListOverlay.postListSelected)-              posts <- use (csPostListOverlay.postListPosts)-              let nextId = case getNextPostId selId posts of-                    Nothing -> getPrevPostId selId posts-                    Just x  -> Just x-              csPostListOverlay.postListSelected .= nextId-              csPostListOverlay.postListPosts %=-                filterMessages (((/=) `on` _mMessageId) msg)-        _ -> return ()-    _ -> return ()
− src/State/Help.hs 
@@ -1,21 +0,0 @@-module State.Help-  ( showHelpScreen-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( viewportScroll, vScrollToBeginning )--import           Types---showHelpScreen :: HelpTopic -> MH ()-showHelpScreen topic = do-    curMode <- gets appMode-    case curMode of-        ShowHelp {} -> return ()-        _ -> do-            mh $ vScrollToBeginning (viewportScroll HelpViewport)-            setMode $ ShowHelp topic curMode
− src/State/ListOverlay.hs 
@@ -1,144 +0,0 @@-{-# LANGUAGE RankNTypes #-}-module State.ListOverlay-  ( listOverlayActivateCurrent-  , listOverlaySearchString-  , listOverlayMove-  , exitListOverlay-  , enterListOverlayMode-  , resetListOverlaySearch-  , onEventListOverlay-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Brick.Widgets.List as L-import qualified Brick.Widgets.Edit as E-import qualified Data.Text.Zipper as Z-import qualified Data.Vector as Vec-import           Lens.Micro.Platform ( Lens', (%=), (.=) )-import           Network.Mattermost.Types ( Session )-import qualified Graphics.Vty as Vty--import           Types-import           State.Common-import           State.Editing ( editingKeybindings )-import           Events.Keybindings ( KeyConfig, KeyHandlerMap, handleKeyboardEvent )----- | Activate the specified list overlay's selected item by invoking the--- overlay's configured enter keypress handler function.-listOverlayActivateCurrent :: Lens' ChatState (ListOverlayState a b) -> MH ()-listOverlayActivateCurrent which = do-  mItem <- L.listSelectedElement <$> use (which.listOverlaySearchResults)-  case mItem of-      Nothing -> return ()-      Just (_, val) -> do-          handler <- use (which.listOverlayEnterHandler)-          activated <- handler val-          if activated-             then setMode Main-             else return ()---- | Get the current search string for the specified overlay.-listOverlaySearchString :: Lens' ChatState (ListOverlayState a b) -> MH Text-listOverlaySearchString which =-    (head . E.getEditContents) <$> use (which.listOverlaySearchInput)---- | Move the list cursor in the specified overlay.-listOverlayMove :: Lens' ChatState (ListOverlayState a b)-                -- ^ Which overlay-                -> (L.List Name a -> L.List Name a)-                -- ^ How to transform the list in the overlay-                -> MH ()-listOverlayMove which how = which.listOverlaySearchResults %= how---- | Clear the state of the specified list overlay and return to the--- Main mode.-exitListOverlay :: Lens' ChatState (ListOverlayState a b)-                -- ^ Which overlay to reset-                -> MH ()-exitListOverlay which = do-    newList <- use (which.listOverlayNewList)-    which.listOverlaySearchResults .= newList mempty-    which.listOverlayEnterHandler .= (const $ return False)-    setMode Main---- | Initialize a list overlay with the specified arguments and switch--- to the specified mode.-enterListOverlayMode :: (Lens' ChatState (ListOverlayState a b))-                     -- ^ Which overlay to initialize-                     -> Mode-                     -- ^ The mode to change to-                     -> b-                     -- ^ The overlay's initial search scope-                     -> (a -> MH Bool)-                     -- ^ The overlay's enter keypress handler-                     -> (b -> Session -> Text -> IO (Vec.Vector a))-                     -- ^ The overlay's results fetcher function-                     -> MH ()-enterListOverlayMode which mode scope enterHandler fetcher = do-    which.listOverlaySearchScope .= scope-    which.listOverlaySearchInput.E.editContentsL %= Z.clearZipper-    which.listOverlayEnterHandler .= enterHandler-    which.listOverlayFetchResults .= fetcher-    which.listOverlaySearching .= False-    newList <- use (which.listOverlayNewList)-    which.listOverlaySearchResults .= newList mempty-    setMode mode-    resetListOverlaySearch which---- | Reset the overlay's search by initiating a new search request for--- the string that is currently in the overlay's editor. This does--- nothing if a search for this overlay is already in progress.-resetListOverlaySearch :: Lens' ChatState (ListOverlayState a b) -> MH ()-resetListOverlaySearch which = do-    searchPending <- use (which.listOverlaySearching)--    when (not searchPending) $ do-        searchString <- listOverlaySearchString which-        which.listOverlaySearching .= True-        newList <- use (which.listOverlayNewList)-        session <- getSession-        scope <- use (which.listOverlaySearchScope)-        fetcher <- use (which.listOverlayFetchResults)-        doAsyncWith Preempt $ do-            results <- fetcher scope session searchString-            return $ Just $ do-                which.listOverlaySearchResults .= newList results-                which.listOverlaySearching .= False--                -- Now that the results are available, check to see if the-                -- search string changed since this request was submitted.-                -- If so, issue another search.-                afterSearchString <- listOverlaySearchString which-                when (searchString /= afterSearchString) $ resetListOverlaySearch which---- | Generically handle an event for the list overlay state targeted--- by the specified lens. Automatically dispatches new searches in the--- overlay's editor if the editor contents change.-onEventListOverlay :: Lens' ChatState (ListOverlayState a b)-                   -- ^ Which overlay to dispatch to?-                   -> (KeyConfig -> KeyHandlerMap)-                   -- ^ The keybinding builder-                   -> Vty.Event-                   -- ^ The event-                   -> MH Bool-onEventListOverlay which keybindings =-    handleKeyboardEvent keybindings $ \e -> do-        -- Get the editor content before the event.-        before <- listOverlaySearchString which--        -- 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.-        after <- listOverlaySearchString which-        when (before /= after) $ resetListOverlaySearch which
− src/State/Logging.hs 
@@ -1,33 +0,0 @@-module State.Logging-  ( startLogging-  , stopLogging-  , logSnapshot-  , getLogDestination-  )-where--import           Prelude ()-import           Prelude.MH--import           Types---startLogging :: FilePath -> MH ()-startLogging path = do-    mgr <- use (csResources.crLogManager)-    liftIO $ startLoggingToFile mgr path--stopLogging :: MH ()-stopLogging = do-    mgr <- use (csResources.crLogManager)-    liftIO $ stopLoggingToFile mgr--logSnapshot :: FilePath -> MH ()-logSnapshot path = do-    mgr <- use (csResources.crLogManager)-    liftIO $ requestLogSnapshot mgr path--getLogDestination :: MH ()-getLogDestination = do-    mgr <- use (csResources.crLogManager)-    liftIO $ requestLogDestination mgr
− src/State/MessageSelect.hs 
@@ -1,294 +0,0 @@-module State.MessageSelect-  (-  -- * Message selection mode-    beginMessageSelect-  , flagSelectedMessage-  , pinSelectedMessage-  , viewSelectedMessage-  , fillSelectedGap-  , yankSelectedMessageVerbatim-  , yankSelectedMessage-  , openSelectedMessageURLs-  , beginConfirmDeleteSelectedMessage-  , messageSelectUp-  , messageSelectUpBy-  , messageSelectDown-  , messageSelectDownBy-  , messageSelectFirst-  , messageSelectLast-  , deleteSelectedMessage-  , beginReplyCompose-  , beginEditMessage-  , flagMessage-  , getSelectedMessage-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Widgets.Edit ( applyEdit )-import           Data.Text.Zipper ( clearZipper, insertMany )-import           Lens.Micro.Platform--import qualified Network.Mattermost.Endpoints as MM-import           Network.Mattermost.Types--import           Clipboard ( copyToClipboard )-import           State.Common-import           State.Messages-import           Types-import           Types.RichText ( findVerbatimChunk )-import           Types.Common-import           Windows.ViewMessage----- | In these modes, we allow access to the selected message state.-messageSelectCompatibleModes :: [Mode]-messageSelectCompatibleModes =-    [ MessageSelect-    , MessageSelectDeleteConfirm-    , ReactionEmojiListOverlay-    ]--getSelectedMessage :: ChatState -> Maybe Message-getSelectedMessage st-    | not (appMode st `elem` messageSelectCompatibleModes) = Nothing-    | otherwise = do-        selMsgId <- selectMessageId $ st^.csMessageSelect-        let chanMsgs = st ^. csCurrentChannel . ccContents . cdMessages-        findMessage selMsgId chanMsgs--beginMessageSelect :: MH ()-beginMessageSelect = do-    -- Get the number of messages in the current channel and set the-    -- currently selected message index to be the most recently received-    -- message that corresponds to a Post (i.e. exclude informative-    -- messages).-    ---    -- If we can't find one at all, we ignore the mode switch request-    -- and just return.-    chanMsgs <- use(csCurrentChannel . ccContents . cdMessages)-    let recentMsg = getLatestSelectableMessage chanMsgs--    when (isJust recentMsg) $ do-        setMode MessageSelect-        csMessageSelect .= MessageSelectState (recentMsg >>= _mMessageId)---- | Tell the server that the message we currently have selected--- should have its flagged state toggled.-flagSelectedMessage :: MH ()-flagSelectedMessage = do-  selected <- use (to getSelectedMessage)-  case selected of-    Just msg-      | isFlaggable msg, Just pId <- messagePostId msg ->-        flagMessage pId (not (msg^.mFlagged))-    _        -> return ()---- | Tell the server that the message we currently have selected--- should have its pinned state toggled.-pinSelectedMessage :: MH ()-pinSelectedMessage = do-  selected <- use (to getSelectedMessage)-  case selected of-    Just msg-      | isPinnable msg, Just pId <- messagePostId msg ->-        pinMessage pId (not (msg^.mPinned))-    _ -> return ()--viewSelectedMessage :: MH ()-viewSelectedMessage = do-  selected <- use (to getSelectedMessage)-  case selected of-    Just msg-      | not (isGap msg) -> viewMessage msg-    _        -> return ()--fillSelectedGap :: MH ()-fillSelectedGap = do-  selected <- use (to getSelectedMessage)-  case selected of-    Just msg-      | isGap msg -> do cId <- use csCurrentChannelId-                        asyncFetchMessagesForGap cId msg-    _        -> return ()--viewMessage :: Message -> MH ()-viewMessage m = do-    let w = tabbedWindow VMTabMessage viewMessageWindowTemplate Main (78, 25)-    csViewedMessage .= Just (m, w)-    runTabShowHandlerFor (twValue w) w-    setMode ViewMessage--yankSelectedMessageVerbatim :: MH ()-yankSelectedMessageVerbatim = do-    selectedMessage <- use (to getSelectedMessage)-    case selectedMessage of-        Nothing -> return ()-        Just m -> do-            setMode Main-            case findVerbatimChunk (m^.mText) of-                Just txt -> copyToClipboard txt-                Nothing  -> return ()--yankSelectedMessage :: MH ()-yankSelectedMessage = do-    selectedMessage <- use (to getSelectedMessage)-    case selectedMessage of-        Nothing -> return ()-        Just m -> do-            setMode Main-            copyToClipboard $ m^.mMarkdownSource--openSelectedMessageURLs :: MH ()-openSelectedMessageURLs = whenMode MessageSelect $ do-    mCurMsg <- use (to getSelectedMessage)-    curMsg <- case mCurMsg of-        Nothing -> error "BUG: openSelectedMessageURLs: no selected message available"-        Just m -> return m--    remainInSelectMode <- use (csResources.crConfiguration.to configMessageSelectAfterURLOpen)--    let urls = msgURLs curMsg-    when (not (null urls)) $ do-        openedAll <- and <$> mapM (openURL . OpenLinkChoice) urls-        case openedAll of-            True -> when (not remainInSelectMode) $ setMode Main-            False ->-                mhError $ ConfigOptionMissing "urlOpenCommand"--beginConfirmDeleteSelectedMessage :: MH ()-beginConfirmDeleteSelectedMessage = do-    st <- use id-    selected <- use (to getSelectedMessage)-    case selected of-        Just msg | isDeletable msg && isMine st msg ->-            setMode MessageSelectDeleteConfirm-        _ -> return ()--messageSelectUp :: MH ()-messageSelectUp = do-    mode <- gets appMode-    selected <- use (csMessageSelect.to selectMessageId)-    case selected of-        Just _ | mode == MessageSelect -> do-            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)-            let nextMsgId = getPrevMessageId selected chanMsgs-            csMessageSelect .= MessageSelectState (nextMsgId <|> selected)-        _ -> return ()--messageSelectDown :: MH ()-messageSelectDown = do-    selected <- use (csMessageSelect.to selectMessageId)-    case selected of-        Just _ -> whenMode MessageSelect $ do-            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)-            let nextMsgId = getNextMessageId selected chanMsgs-            csMessageSelect .= MessageSelectState (nextMsgId <|> selected)-        _ -> return ()--messageSelectDownBy :: Int -> MH ()-messageSelectDownBy amt-    | amt <= 0 = return ()-    | otherwise =-        messageSelectDown >> messageSelectDownBy (amt - 1)--messageSelectUpBy :: Int -> MH ()-messageSelectUpBy amt-    | amt <= 0 = return ()-    | otherwise =-      messageSelectUp >> messageSelectUpBy (amt - 1)--messageSelectFirst :: MH ()-messageSelectFirst = do-    selected <- use (csMessageSelect.to selectMessageId)-    case selected of-        Just _ -> whenMode MessageSelect $ do-            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)-            case getEarliestSelectableMessage chanMsgs of-              Just firstMsg ->-                csMessageSelect .= MessageSelectState (firstMsg^.mMessageId <|> selected)-              Nothing -> mhLog LogError "No first message found from current message?!"-        _ -> return ()--messageSelectLast :: MH ()-messageSelectLast = do-    selected <- use (csMessageSelect.to selectMessageId)-    case selected of-        Just _ -> whenMode MessageSelect $ do-            chanMsgs <- use (csCurrentChannel.ccContents.cdMessages)-            case getLatestSelectableMessage chanMsgs of-              Just lastSelMsg ->-                csMessageSelect .= MessageSelectState (lastSelMsg^.mMessageId <|> selected)-              Nothing -> mhLog LogError "No last message found from current message?!"-        _ -> return ()--deleteSelectedMessage :: MH ()-deleteSelectedMessage = do-    selectedMessage <- use (to getSelectedMessage)-    st <- use id-    cId <- use csCurrentChannelId-    case selectedMessage of-        Just msg | isMine st msg && isDeletable msg ->-            case msg^.mOriginalPost of-              Just p ->-                  doAsyncChannelMM Preempt cId-                      (\s _ -> MM.mmDeletePost (postId p) s)-                      (\_ _ -> Just $ do-                          csEditState.cedEditMode .= NewPost-                          setMode Main)-              Nothing -> return ()-        _ -> return ()--beginReplyCompose :: MH ()-beginReplyCompose = do-    selected <- use (to getSelectedMessage)-    case selected of-        Just msg | isReplyable msg -> do-            let Just p = msg^.mOriginalPost-            setMode Main-            csEditState.cedEditMode .= Replying msg p-        _ -> return ()--beginEditMessage :: MH ()-beginEditMessage = do-    selected <- use (to getSelectedMessage)-    st <- use id-    case selected of-        Just msg | isMine st msg && isEditable msg -> do-            let Just p = msg^.mOriginalPost-            setMode Main-            csEditState.cedEditMode .= Editing p (msg^.mType)-            -- If the post that we're editing is an emote, we need-            -- to strip the formatting because that's only there to-            -- indicate that the post is an emote. This is annoying and-            -- can go away one day when there is an actual post type-            -- value of "emote" that we can look at. Note that the-            -- removed formatting needs to be reinstated just prior to-            -- issuing the API call to update the post.-            let sanitized = sanitizeUserText $ postMessage p-            let toEdit = if isEmote msg-                         then removeEmoteFormatting sanitized-                         else sanitized-            csEditState.cedEditor %= applyEdit (insertMany toEdit . clearZipper)-        _ -> return ()---- | Tell the server that we have flagged or unflagged a message.-flagMessage :: PostId -> Bool -> MH ()-flagMessage pId f = do-  session <- getSession-  myId <- gets myUserId-  doAsyncWith Normal $ do-    let doFlag = if f then MM.mmFlagPost else MM.mmUnflagPost-    doFlag myId pId session-    return Nothing---- | Tell the server that we have pinned or unpinned a message.-pinMessage :: PostId -> Bool -> MH ()-pinMessage pId f = do-  session <- getSession-  doAsyncWith Normal $ do-    let doPin = if f then MM.mmPinPostToChannel else MM.mmUnpinPostToChannel-    void $ doPin pId session-    return Nothing
− src/State/Messages.hs 
@@ -1,871 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module State.Messages-  ( PostToAdd(..)-  , addDisconnectGaps-  , lastMsg-  , sendMessage-  , editMessage-  , deleteMessage-  , addNewPostedMessage-  , addObtainedMessages-  , asyncFetchMoreMessages-  , asyncFetchMessagesForGap-  , asyncFetchMessagesSurrounding-  , fetchVisibleIfNeeded-  , disconnectChannels-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( getVtyHandle, invalidateCacheEntry )-import qualified Brick.Widgets.FileBrowser as FB-import qualified Data.Foldable as F-import qualified Data.HashMap.Strict as HM-import qualified Data.Set as Set-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import           Graphics.Vty ( outputIface )-import           Graphics.Vty.Output.Interface ( ringTerminalBell )-import           Lens.Micro.Platform ( Traversal', (.=), (%=), (%~), (.~), (^?)-                                     , to, at, traversed, filtered, ix, _1 )--import           Network.Mattermost-import qualified Network.Mattermost.Endpoints as MM-import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           Constants-import           State.Channels-import           State.Common-import           State.Reactions-import           State.Users-import           TimeUtils-import           Types-import           Types.Common ( sanitizeUserText )-import           Types.DirectionalSeq ( DirectionalSeq, SeqDirection )----- ------------------------------------------------------------------------- Message gaps----- | Called to add an UnknownGap to the end of the Messages collection--- for all channels when the client has become disconnected from the--- server.  This gaps will later be removed by successful fetching--- overlaps if the connection is re-established.  Note that the--- disconnect is re-iterated periodically via a re-connect timer--- attempt, so do not duplicate gaps.  Also clear any flags--- representing a pending exchange with the server (which will now--- never complete).-addDisconnectGaps :: MH ()-addDisconnectGaps = mapM_ onEach . filteredChannelIds (const True) =<< use csChannels-    where onEach c = do addEndGap c-                        clearPendingFlags c-                        mh $ invalidateCacheEntry (ChannelMessages c)---- | Websocket was disconnected, so all channels may now miss some--- messages-disconnectChannels :: MH ()-disconnectChannels = addDisconnectGaps--clearPendingFlags :: ChannelId -> MH ()-clearPendingFlags c = csChannel(c).ccContents.cdFetchPending .= False--addEndGap :: ChannelId -> MH ()-addEndGap cId = withChannel cId $ \chan ->-    let lastmsg_ = chan^.ccContents.cdMessages.to reverseMessages.to lastMsg-        lastIsGap = maybe False isGap lastmsg_-        gapMsg = newGapMessage timeJustAfterLast-        timeJustAfterLast = maybe t0 (justAfter . _mDate) lastmsg_-        t0 = ServerTime $ originTime  -- use any time for a channel with no messages yet-        newGapMessage = newMessageOfType-                        (T.pack "Disconnected. Will refresh when connected.")-                        (C UnknownGapAfter)-    in unless lastIsGap-           (csChannels %= modifyChannelById cId (ccContents.cdMessages %~ addMessage gapMsg))--lastMsg :: RetrogradeMessages -> Maybe Message-lastMsg = withFirstMessage id---- | Send a message and attachments to the specified channel.-sendMessage :: ChannelId -> EditMode -> Text -> [AttachmentData] -> MH ()-sendMessage chanId mode msg attachments =-    when (not $ shouldSkipMessage msg) $ do-        status <- use csConnectionStatus-        case status of-            Disconnected -> do-                let m = T.concat [ "Cannot send messages while disconnected. Enable logging to "-                                 , "get disconnection information. If Matterhorn's reconnection "-                                 , "attempts are failing, use `/reconnect` to attempt to "-                                 , "reconnect manually."-                                 ]-                mhError $ GenericError m-            Connected -> do-                session <- getSession-                doAsync Preempt $ do-                    -- Upload attachments-                    fileInfos <- forM attachments $ \a -> do-                        MM.mmUploadFile chanId (FB.fileInfoFilename $ attachmentDataFileInfo a)-                            (attachmentDataBytes a) session--                    let fileIds = Seq.fromList $-                                  fmap fileInfoId $-                                  concat $-                                  (F.toList . MM.uploadResponseFileInfos) <$> fileInfos--                    case mode of-                        NewPost -> do-                            let pendingPost = (rawPost msg chanId) { rawPostFileIds = fileIds }-                            void $ MM.mmCreatePost pendingPost session-                        Replying _ p -> do-                            let pendingPost = (rawPost msg chanId) { rawPostRootId = postRootId p <|> (Just $ postId p)-                                                                   , rawPostFileIds = fileIds-                                                                   }-                            void $ MM.mmCreatePost pendingPost session-                        Editing p ty -> do-                            let body = case ty of-                                         CP Emote -> addEmoteFormatting msg-                                         _ -> msg-                                update = (postUpdateBody body) { postUpdateFileIds = if null fileIds-                                                                                     then Nothing-                                                                                     else Just fileIds-                                                               }-                            void $ MM.mmPatchPost (postId p) update session--shouldSkipMessage :: Text -> Bool-shouldSkipMessage "" = True-shouldSkipMessage s = T.all (`elem` (" \t"::String)) s--editMessage :: Post -> MH ()-editMessage new = do-    myId <- gets myUserId-    let isEditedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL)-        (msg, mentionedUsers) = clientPostToMessage (toClientPost new (new^.postRootIdL))-        chan = csChannel (new^.postChannelIdL)-    chan . ccContents . cdMessages . traversed . filtered isEditedMessage .= msg-    mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)--    fetchMentionedUsers mentionedUsers--    when (postUserId new /= Just myId) $-        chan %= adjustEditedThreshold new--    csPostMap.ix(postId new) .= msg-    asyncFetchReactionsForPost (postChannelId new) new-    asyncFetchAttachments new--deleteMessage :: Post -> MH ()-deleteMessage new = do-    let isDeletedMessage m = m^.mMessageId == Just (MessagePostId $ new^.postIdL) ||-                             isReplyTo (new^.postIdL) m-        chan :: Traversal' ChatState ClientChannel-        chan = csChannel (new^.postChannelIdL)-    chan.ccContents.cdMessages.traversed.filtered isDeletedMessage %= (& mDeleted .~ True)-    chan %= adjustUpdated new-    mh $ invalidateCacheEntry (ChannelMessages $ new^.postChannelIdL)--addNewPostedMessage :: PostToAdd -> MH ()-addNewPostedMessage p =-    addMessageToState True True p >>= postProcessMessageAdd---- | Adds the set of Posts to the indicated channel.  The Posts must--- all be for the specified Channel.  The reqCnt argument indicates--- how many posts were requested, which will determine whether a gap--- message is added to either end of the posts list or not.------ The addTrailingGap is only True when fetching the very latest messages--- for the channel, and will suppress the generation of a Gap message--- following the added block of messages.-addObtainedMessages :: ChannelId -> Int -> Bool -> Posts -> MH PostProcessMessageAdd-addObtainedMessages cId reqCnt addTrailingGap posts =-  if null $ posts^.postsOrderL-  then do when addTrailingGap $-            -- Fetched at the end of the channel, but nothing was-            -- available.  This is common if this is a new channel-            -- with no messages in it.  Need to remove any gaps that-            -- exist at the end of the channel.-            csChannels %= modifyChannelById cId-              (ccContents.cdMessages %~-               \msgs -> let startPoint = join $ _mMessageId <$> getLatestPostMsg msgs-                        in fst $ removeMatchesFromSubset isGap startPoint Nothing msgs)-          return NoAction-  else-    -- Adding a block of server-provided messages, which are known to-    -- be contiguous.  Locally this may overlap with some UnknownGap-    -- messages, which can therefore be removed.  Alternatively the-    -- new block may be discontiguous with the local blocks, in which-    -- case the new block should be surrounded by UnknownGaps.-    withChannelOrDefault cId NoAction $ \chan -> do-        let pIdList = toList (posts^.postsOrderL)-            -- the first and list PostId in the batch to be added-            earliestPId = last pIdList-            latestPId = head pIdList-            earliestDate = postCreateAt $ (posts^.postsPostsL) HM.! earliestPId-            latestDate = postCreateAt $ (posts^.postsPostsL) HM.! latestPId--            localMessages = chan^.ccContents . cdMessages--            -- Get a list of the duplicated message PostIds between-            -- the messages already in the channel and the new posts-            -- to be added.--            match = snd $ removeMatchesFromSubset-                          (\m -> maybe False (\p -> p `elem` pIdList) (messagePostId m))-                          (Just (MessagePostId earliestPId))-                          (Just (MessagePostId latestPId))-                          localMessages--            accum m l =-                case messagePostId m of-                    Just pId -> pId : l-                    Nothing -> l-            dupPIds = foldr accum [] match--            -- If there were any matches, then there was overlap of-            -- the new messages with existing messages.--            -- Don't re-add matching messages (avoid overhead like-            -- re-checking/re-fetching related post information, and-            -- do not signal action needed for notifications), and-            -- remove any gaps in the overlapping region.--            newGapMessage d isOlder =-              -- newGapMessage is a helper for generating a gap-              -- message-              do uuid <- generateUUID-                 let txt = "Load " <>-                           (if isOlder then "older" else "newer") <>-                           " messages" <>-                           (if isOlder then "  ↥↥↥" else "  ↧↧↧")-                     ty = if isOlder-                          then C UnknownGapBefore-                          else C UnknownGapAfter-                 return (newMessageOfType txt ty d-                         & mMessageId .~ Just (MessageUUID uuid))--            -- If this batch contains the latest known messages, do-            -- not add a following gap.  A gap at this point is added-            -- by a websocket disconnect, and any fetches thereafter-            -- are assumed to be the most current information (until-            -- another disconnect), so no gap is needed.-            -- Additionally, the presence of a gap at the end for a-            -- connected client causes a fetch of messages at this-            -- location, so adding the gap here would cause an-            -- infinite update loop.--            addingAtEnd = maybe True (latestDate >=) $-                          (^.mDate) <$> getLatestPostMsg localMessages--            addingAtStart = maybe True (earliestDate <=) $-                            (^.mDate) <$> getEarliestPostMsg localMessages-            removeStart = if addingAtStart && noMoreBefore-                          then Nothing-                          else Just (MessagePostId earliestPId)-            removeEnd = if addTrailingGap || (addingAtEnd && noMoreAfter)-                        then Nothing-                        else Just (MessagePostId latestPId)--            noMoreBefore = reqCnt < 0 && length pIdList < (-reqCnt)-            noMoreAfter = addTrailingGap || reqCnt > 0 && length pIdList < reqCnt--            reAddGapBefore = earliestPId `elem` dupPIds || noMoreBefore-            -- addingAtEnd used to be in reAddGapAfter but does not-            -- seem to be needed.  I may have missed a specific use-            -- case/scenario, so I've left it commented out here for-            -- debug assistance.-            reAddGapAfter = latestPId `elem` dupPIds || {- addingAtEnd || -} noMoreAfter--        -- The post map returned by the server will *already* have-        -- all thread messages for each post that is part of a-        -- thread. By calling installMessagesFromPosts here, we go ahead-        -- and populate the csPostMap with those posts so that below, in-        -- addMessageToState, we notice that we already know about reply-        -- parent messages and can avoid fetching them. This converts-        -- the posts to Messages and stores those and also returns-        -- them, but we don't need them here. We just want the post-        -- map update. This also gathers up the set of all mentioned-        -- usernames in the text of the messages which we need to use to-        -- submit a single batch request for user metadata so we don't-        -- submit one request per mention.-        void $ installMessagesFromPosts posts--        -- Add all the new *unique* posts into the existing channel-        -- corpus, generating needed fetches of data associated with-        -- the post, and determining an notification action to be-        -- taken (if any).-        action <- foldr andProcessWith NoAction <$>-          mapM (addMessageToState False False . OldPost)-                   [ (posts^.postsPostsL) HM.! p-                   | p <- toList (posts^.postsOrderL)-                   , not (p `elem` dupPIds)-                   ]--        -- The channel messages now include all the fetched messages.-        -- Things to do at this point are:-        ---        --   1. Remove any duplicates just added, as well as any gaps-        --   2. Add new gaps (if needed) at either end of the added-        --      messages.-        --   3. Update the "current selection" if it was on a removed message.-        ---        -- Do this with the updated copy of the channel's messages.--        withChannelOrDefault cId () $ \updchan -> do-          let updMsgs = updchan ^. ccContents . cdMessages--          -- Remove any gaps in the added region.  If there was an-          -- active message selection and it is one of the removed-          -- gaps, reset the selection to the beginning or end of the-          -- added region (if there are any added selectable messages,-          -- otherwise just the end if the message list in it's-          -- entirety, or no selection at all).--          let (resultMessages, removedMessages) =-                removeMatchesFromSubset isGap removeStart removeEnd updMsgs-          csChannels %= modifyChannelById cId-            (ccContents.cdMessages .~ resultMessages)--          -- Determine if the current selected message was one of the-          -- removed messages.--          selMsgId <- use (csMessageSelect.to selectMessageId)-          let rmvdSel = do-                i <- selMsgId -- :: Maybe MessageId-                findMessage i removedMessages-              rmvdSelType = _mType <$> rmvdSel--          case rmvdSel of-            Nothing -> return ()-            Just rm ->-              if isGap rm-              then return ()  -- handled during gap insertion below-              else do-                -- Replaced a selected message that wasn't a gap.-                -- This is unlikely, but may occur if the previously-                -- selected message was just deleted by another user-                -- and is in the fetched region.  The choices here are-                -- to move the selection, or cancel the selection.-                -- Both will be unpleasant surprises for the user, but-                -- cancelling the selection is probably the better-                -- choice than allowing the user to perform select-                -- actions on a message that isn't the one they just-                -- selected.-                setMode Main-                csMessageSelect .= MessageSelectState Nothing--          -- Add a gap at each end of the newly fetched data, unless:-          --   1. there is an overlap-          --   2. there is no more in the indicated direction-          --      a. indicated by adding messages later than any currently-          --         held messages (see note above re 'addingAtEnd').-          --      b. the amount returned was less than the amount requested--          if reAddGapBefore-            then-              -- No more gaps.  If the selected gap was removed, move-              -- select to first (earliest) message)-              case rmvdSelType of-                Just (C UnknownGapBefore) ->-                  csMessageSelect .= MessageSelectState (pure $ MessagePostId earliestPId)-                _ -> return ()-            else do-              -- add a gap at the start of the newly fetched block and-              -- make that the active selection if this fetch removed-              -- the previously selected gap in this direction.-              gapMsg <- newGapMessage (justBefore earliestDate) True-              csChannels %= modifyChannelById cId-                (ccContents.cdMessages %~ addMessage gapMsg)-              -- Move selection from old gap to new gap-              case rmvdSelType of-                Just (C UnknownGapBefore) -> do-                  csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)-                _ -> return ()--          if reAddGapAfter-            then-              -- No more gaps.  If the selected gap was removed, move-              -- select to last (latest) message.-              case rmvdSelType of-                Just (C UnknownGapAfter) ->-                  csMessageSelect .= MessageSelectState (pure $ MessagePostId latestPId)-                _ -> return ()-            else do-              -- add a gap at the end of the newly fetched block and-              -- make that the active selection if this fetch removed-              -- the previously selected gap in this direction.-              gapMsg <- newGapMessage (justAfter latestDate) False-              csChannels %= modifyChannelById cId-                (ccContents.cdMessages %~ addMessage gapMsg)-              -- Move selection from old gap to new gap-              case rmvdSelType of-                Just (C UnknownGapAfter) ->-                  csMessageSelect .= MessageSelectState (gapMsg^.mMessageId)-                _ -> return ()--        -- Now initiate fetches for use information for any-        -- as-yet-unknown users related to this new set of messages--        let users = foldr (\post s -> maybe s (flip Set.insert s) (postUserId post))-                          Set.empty (posts^.postsPostsL)-            addUnknownUsers inputUserIds = do-                knownUserIds <- Set.fromList <$> gets allUserIds-                let unknownUsers = Set.difference inputUserIds knownUserIds-                if Set.null unknownUsers-                   then return ()-                   else handleNewUsers (Seq.fromList $ toList unknownUsers) (return ())--        addUnknownUsers users--        -- Return the aggregated user notification action needed-        -- relative to the set of added messages.--        return action---- | Adds a possibly new message to the associated channel contents.--- Returns an indicator of whether the user should be potentially--- notified of a change (a new message not posted by this user, a--- mention of the user, etc.).  This operation has no effect on any--- existing UnknownGap entries and should be called when those are--- irrelevant.------ The first boolean argument ('doFetchMentionedUsers') indicates--- whether this function should schedule a fetch for any mentioned--- users in the message. This is provided so that callers can batch--- this operation if a large collection of messages is being added--- together, in which case we don't want this function to schedule a--- single request per message (worst case). If you're calling this as--- part of scrollback processing, you should pass False. Otherwise if--- you're adding only a single message, you should pass True.------ The second boolean argument ('fetchAuthor') is similar to the first--- boolean argument but it refers to the author of the message instead--- of any user mentions within the message body.------ The third argument ('newPostData') indicates whether this message--- is being added as part of a fetch of old messages (e.g. scrollback)--- or if ti is a new message and affects things like whether--- notifications are generated and if the "New Messages" marker gets--- updated.-addMessageToState :: Bool -> Bool -> PostToAdd -> MH PostProcessMessageAdd-addMessageToState doFetchMentionedUsers fetchAuthor newPostData = do-    let (new, wasMentioned) = case newPostData of-          -- A post from scrollback history has no mention data, and-          -- that's okay: we only need to track mentions to tell the-          -- user that recent posts contained mentions.-          OldPost p      -> (p, False)-          RecentPost p m -> (p, m)--    st <- use id-    case st ^? csChannel(postChannelId new) of-        Nothing -> do-            session <- getSession-            doAsyncWith Preempt $ do-                nc <- MM.mmGetChannel (postChannelId new) session-                member <- MM.mmGetChannelMember (postChannelId new) UserMe session--                let chType = nc^.channelTypeL-                    pref = showGroupChannelPref (postChannelId new) (myUserId st)--                -- If the channel has been archived, we don't want to-                -- post this message or add the channel to the state.-                case channelDeleted nc of-                    True -> return Nothing-                    False -> return $ Just $ do-                        -- If the incoming message is for a group-                        -- channel we don't know about, that's because-                        -- it was previously hidden by the user. We need-                        -- to show it, and to do that we need to update-                        -- the server-side preference. (That, in turn,-                        -- triggers a channel refresh.)-                        if chType == Group-                            then applyPreferenceChange pref-                            else refreshChannel SidebarUpdateImmediate nc member--                        addMessageToState doFetchMentionedUsers fetchAuthor newPostData >>=-                            postProcessMessageAdd--            return NoAction-        Just _ -> do-            let cp = toClientPost new (new^.postRootIdL)-                fromMe = (cp^.cpUser == (Just $ myUserId st)) &&-                         (isNothing $ cp^.cpUserOverride)-                userPrefs = st^.csResources.crUserPreferences-                isJoinOrLeave = case cp^.cpType of-                  Join  -> True-                  Leave -> True-                  _     -> False-                ignoredJoinLeaveMessage =-                  not (userPrefs^.userPrefShowJoinLeave) && isJoinOrLeave-                cId = postChannelId new--                doAddMessage = do-                    -- Do we have the user data for the post author?-                    case cp^.cpUser of-                        Nothing -> return ()-                        Just authorId -> when fetchAuthor $ do-                            authorResult <- gets (userById authorId)-                            when (isNothing authorResult) $-                                handleNewUsers (Seq.singleton authorId) (return ())--                    currCId <- use csCurrentChannelId-                    flags <- use (csResources.crFlaggedPosts)-                    let (msg', mentionedUsers) = clientPostToMessage cp-                                 & _1.mFlagged .~ ((cp^.cpPostId) `Set.member` flags)--                    when doFetchMentionedUsers $-                        fetchMentionedUsers mentionedUsers--                    csPostMap.at(postId new) .= Just msg'-                    mh $ invalidateCacheEntry (ChannelMessages cId)-                    csChannels %= modifyChannelById cId-                      ((ccContents.cdMessages %~ addMessage msg') .-                       (if not ignoredJoinLeaveMessage then adjustUpdated new else id) .-                       (\c -> if currCId == cId-                              then c-                              else case newPostData of-                                     OldPost _ -> c-                                     RecentPost _ _ ->-                                       updateNewMessageIndicator new c) .-                       (\c -> if wasMentioned-                              then c & ccInfo.cdMentionCount %~ succ-                              else c)-                      )-                    asyncFetchReactionsForPost cId new-                    asyncFetchAttachments new-                    postedChanMessage--                doHandleAddedMessage = do-                    -- If the message is in reply to another message,-                    -- try to find it in the scrollback for the post's-                    -- channel. If the message isn't there, fetch it. If-                    -- we have to fetch it, don't post this message to the-                    -- channel until we have fetched the parent.-                    case cp^.cpInReplyToPost of-                        Just parentId ->-                            case getMessageForPostId st parentId of-                                Nothing -> do-                                    doAsyncChannelMM Preempt cId-                                        (\s _ -> MM.mmGetThread parentId s)-                                        (\_ p -> Just $ updatePostMap p)-                                _ -> return ()-                        _ -> return ()--                    doAddMessage--                postedChanMessage =-                  withChannelOrDefault (postChannelId new) NoAction $ \chan -> do-                      currCId <- use csCurrentChannelId--                      let notifyPref = notifyPreference (myUser st) chan-                          curChannelAction = if postChannelId new == currCId-                                             then UpdateServerViewed-                                             else NoAction-                          originUserAction =-                            if | fromMe                            -> NoAction-                               | ignoredJoinLeaveMessage           -> NoAction-                               | notifyPref == NotifyOptionAll     -> NotifyUser [newPostData]-                               | notifyPref == NotifyOptionMention-                                   && wasMentioned                 -> NotifyUser [newPostData]-                               | otherwise                         -> NoAction--                      return $ curChannelAction `andProcessWith` originUserAction--            doHandleAddedMessage---- | PostProcessMessageAdd is an internal value that informs the main--- code whether the user should be notified (e.g., ring the bell) or--- the server should be updated (e.g., that the channel has been--- viewed).  This is a monoid so that it can be folded over when there--- are multiple inbound posts to be processed.-data PostProcessMessageAdd = NoAction-                           | NotifyUser [PostToAdd]-                           | UpdateServerViewed-                           | NotifyUserAndServer [PostToAdd]--andProcessWith-  :: PostProcessMessageAdd -> PostProcessMessageAdd -> PostProcessMessageAdd-andProcessWith NoAction x                                        = x-andProcessWith x NoAction                                        = x-andProcessWith (NotifyUserAndServer p) UpdateServerViewed        = NotifyUserAndServer p-andProcessWith (NotifyUserAndServer p1) (NotifyUser p2)          = NotifyUserAndServer (p1 <> p2)-andProcessWith (NotifyUserAndServer p1) (NotifyUserAndServer p2) = NotifyUserAndServer (p1 <> p2)-andProcessWith (NotifyUser p1) (NotifyUserAndServer p2)          = NotifyUser (p1 <> p2)-andProcessWith (NotifyUser p1) (NotifyUser p2)                   = NotifyUser (p1 <> p2)-andProcessWith (NotifyUser p) UpdateServerViewed                 = NotifyUserAndServer p-andProcessWith UpdateServerViewed UpdateServerViewed             = UpdateServerViewed-andProcessWith UpdateServerViewed (NotifyUserAndServer p)        = NotifyUserAndServer p-andProcessWith UpdateServerViewed (NotifyUser p)                 = NotifyUserAndServer p---- | postProcessMessageAdd performs the actual actions indicated by--- the corresponding input value.-postProcessMessageAdd :: PostProcessMessageAdd -> MH ()-postProcessMessageAdd ppma = postOp ppma-    where-        postOp NoAction                = return ()-        postOp UpdateServerViewed      = updateViewed False-        postOp (NotifyUser p)          = maybeRingBell >> mapM_ maybeNotify p-        postOp (NotifyUserAndServer p) = updateViewed False >> maybeRingBell >> mapM_ maybeNotify p--maybeNotify :: PostToAdd -> MH ()-maybeNotify (OldPost _) = do-    return ()-maybeNotify (RecentPost post mentioned) = runNotifyCommand post mentioned--maybeRingBell :: MH ()-maybeRingBell = do-    doBell <- use (csResources.crConfiguration.to configActivityBell)-    when doBell $ do-        vty <- mh getVtyHandle-        liftIO $ ringTerminalBell $ outputIface vty---- | When we add posts to the application state, we either get them--- from the server during scrollback fetches (here called 'OldPost') or--- we get them from websocket events when they are posted in real time--- (here called 'RecentPost').-data PostToAdd =-    OldPost Post-    -- ^ A post from the server's history-    | RecentPost Post Bool-    -- ^ A message posted to the channel since the user connected, along-    -- with a flag indicating whether the post triggered any of the-    -- user's mentions. We need an extra flag because the server-    -- determines whether the post has any mentions, and that data is-    -- only available in websocket events (and then provided to this-    -- constructor).--runNotifyCommand :: Post -> Bool -> MH ()-runNotifyCommand post mentioned = do-    outputChan <- use (csResources.crSubprocessLog)-    st <- use id-    notifyCommand <- use (csResources.crConfiguration.to configActivityNotifyCommand)-    case notifyCommand of-        Nothing -> return ()-        Just cmd ->-            doAsyncWith Preempt $ do-                let messageString = T.unpack $ sanitizeUserText $ postMessage post-                    notified = if mentioned then "1" else "2"-                    sender = T.unpack $ maybePostUsername st post-                runLoggedCommand False outputChan (T.unpack cmd)-                                 [notified, sender, messageString] Nothing Nothing-                return Nothing--maybePostUsername :: ChatState -> Post -> T.Text-maybePostUsername st p =-    fromMaybe T.empty $ do-        uId <- postUserId p-        usernameForUserId uId st---- | Fetches additional message history for the current channel.  This--- is generally called when in ChannelScroll mode, in which state the--- output is cached and seen via a scrolling viewport; new messages--- received in this mode are not normally shown, but this explicit--- user-driven fetch should be displayed, so this also invalidates the--- cache.------ This function assumes it is being called to add "older" messages to--- the message history (i.e. near the beginning of the known--- messages).  It will normally try to overlap the fetch with the--- known existing messages so that when the fetch results are--- processed (which should be a contiguous set of messages as provided--- by the server) there will be an overlap with existing messages; if--- there is no overlap, then a special "gap" must be inserted in the--- area between the existing messages and the newly fetched messages--- to indicate that this client does not know if there are missing--- messages there or not.------ In order to achieve an overlap, this code attempts to get the--- second oldest messages as the message ID to pass to the server as--- the "older than" marker ('postQueryBefore'), so that the oldest--- message here overlaps with the fetched results to ensure no gap--- needs to be inserted.  However, there may already be a gap between--- the oldest and second-oldest messages, so this code must actually--- search for the first set of two *contiguous* messages it is aware--- of to avoid adding additional gaps. (It's OK if gaps are added, but--- the user must explicitly request a check for messages in order to--- eliminate them, so it's better to avoid adding them in the first--- place).  This code is nearly always used to extend the older--- history of a channel that information has already been retrieved--- from, so it's almost certain that there are at least two contiguous--- messages to use as a starting point, but exceptions are new--- channels and empty channels.-asyncFetchMoreMessages :: MH ()-asyncFetchMoreMessages = do-    cId  <- use csCurrentChannelId-    withChannel cId $ \chan ->-        let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2-            page = offset `div` pageAmount-            usefulMsgs = getTwoContiguousPosts Nothing (chan^.ccContents.cdMessages.to reverseMessages)-            sndOldestId = (messagePostId . snd) =<< usefulMsgs-            query = MM.defaultPostQuery-                      { MM.postQueryPage = maybe (Just page) (const Nothing) sndOldestId-                      , MM.postQueryPerPage = Just pageAmount-                      , MM.postQueryBefore = sndOldestId-                      }-            addTrailingGap = MM.postQueryBefore query == Nothing &&-                             MM.postQueryPage query == Just 0-        in doAsyncChannelMM Preempt cId-               (\s c -> MM.mmGetPostsForChannel c query s)-               (\c p -> Just $ do-                   pp <- addObtainedMessages c (-pageAmount) addTrailingGap p-                   postProcessMessageAdd pp-                   mh $ invalidateCacheEntry (ChannelMessages cId))----- | Given a starting point and a direction to move from that point,--- returns the closest two adjacent messages on that direction (as a--- tuple of closest and next-closest), or Nothing if there are no--- adjacent messages in the indicated direction.-getTwoContiguousPosts :: SeqDirection dir =>-                         Maybe Message-                      -> DirectionalSeq dir Message-                      -> Maybe (Message, Message)-getTwoContiguousPosts startMsg msgs =-  let go start =-        do anchor <- getRelMessageId (_mMessageId =<< start) msgs-           hinge <- getRelMessageId (anchor^.mMessageId) msgs-           if isGap anchor || isGap hinge-             then go $ Just anchor-             else Just (anchor, hinge)-  in go startMsg---asyncFetchMessagesForGap :: ChannelId -> Message -> MH ()-asyncFetchMessagesForGap cId gapMessage =-  when (isGap gapMessage) $-  withChannel cId $ \chan ->-    let offset = max 0 $ length (chan^.ccContents.cdMessages) - 2-        page = offset `div` pageAmount-        chanMsgs = chan^.ccContents.cdMessages-        fromMsg = Just gapMessage-        fetchNewer = case gapMessage^.mType of-                       C UnknownGapAfter -> True-                       C UnknownGapBefore -> False-                       _ -> error "fetch gap messages: unknown gap message type"-        baseId = messagePostId . snd =<<-                 case gapMessage^.mType of-                    C UnknownGapAfter -> getTwoContiguousPosts fromMsg $-                                         reverseMessages chanMsgs-                    C UnknownGapBefore -> getTwoContiguousPosts fromMsg chanMsgs-                    _ -> error "fetch gap messages: unknown gap message type"-        query = MM.defaultPostQuery-                { MM.postQueryPage = maybe (Just page) (const Nothing) baseId-                , MM.postQueryPerPage = Just pageAmount-                , MM.postQueryBefore = if fetchNewer then Nothing else baseId-                , MM.postQueryAfter = if fetchNewer then baseId else Nothing-                }-        addTrailingGap = MM.postQueryBefore query == Nothing &&-                         MM.postQueryPage query == Just 0-    in doAsyncChannelMM Preempt cId-       (\s c -> MM.mmGetPostsForChannel c query s)-       (\c p -> Just $ do-           void $ addObtainedMessages c (-pageAmount) addTrailingGap p-           mh $ invalidateCacheEntry (ChannelMessages cId))---- | Given a particular message ID, this fetches n messages before and--- after immediately before and after the specified message in order--- to establish some context for that message.  This is frequently--- used as a background operation when looking at search or flag--- results so that jumping to message select mode for one of those--- messages will show a bit of context (and it also prevents showing--- gap messages for adjacent targets).------ The result will be adding at most 2n messages to the channel, with--- the input post ID being somewhere in the middle of the added--- messages.------ Note that this fetch will add messages to the channel, but it--- performs no notifications or updates of new-unread indicators--- because it is assumed to be used for non-current (previously-seen)--- messages in background mode.-asyncFetchMessagesSurrounding :: ChannelId -> PostId -> MH ()-asyncFetchMessagesSurrounding cId pId = do-    let query = MM.defaultPostQuery-          { MM.postQueryBefore = Just pId-          , MM.postQueryPerPage = Just reqAmt-          }-        reqAmt = 5  -- both before and after-    doAsyncChannelMM Preempt cId-      -- first get some messages before the target, no overlap-      (\s c -> MM.mmGetPostsForChannel c query s)-      (\c p -> Just $ do-          let last2ndId = secondToLastPostId p-          void $ addObtainedMessages c (-reqAmt) False p-          mh $ invalidateCacheEntry (ChannelMessages cId)-          -- now start 2nd from end of this fetch to fetch some-          -- messages forward, also overlapping with this fetch and-          -- the original message ID to eliminate all gaps in this-          -- surrounding set of messages.-          let query' = MM.defaultPostQuery-                       { MM.postQueryAfter = last2ndId-                       , MM.postQueryPerPage = Just $ reqAmt + 2-                       }-          doAsyncChannelMM Preempt cId-            (\s' c' -> MM.mmGetPostsForChannel c' query' s')-            (\c' p' -> Just $ do-                void $ addObtainedMessages c' (reqAmt + 2) False p'-                mh $ invalidateCacheEntry (ChannelMessages cId)-            )-      )-      where secondToLastPostId posts =-              let pl = toList $ postsOrder posts-              in if length pl > 1 then Just $ last $ init pl else Nothing---fetchVisibleIfNeeded :: MH ()-fetchVisibleIfNeeded = do-    sts <- use csConnectionStatus-    when (sts == Connected) $ do-        cId <- use csCurrentChannelId-        withChannel cId $ \chan ->-            let msgs = chan^.ccContents.cdMessages.to reverseMessages-                (numRemaining, gapInDisplayable, _, rel'pId, overlap) =-                    foldl gapTrail (numScrollbackPosts, False, Nothing, Nothing, 2) msgs-                gapTrail a@(_,  True, _, _, _) _ = a-                gapTrail a@(0,     _, _, _, _) _ = a-                gapTrail   (a, False, b, c, d) m | isGap m = (a, True, b, c, d)-                gapTrail (remCnt, _, prev'pId, prev''pId, ovl) msg =-                    (remCnt - 1, False, msg^.mMessageId <|> prev'pId, prev'pId <|> prev''pId,-                     ovl + if not (isPostMessage msg) then 1 else 0)-                numToReq = numRemaining + overlap-                query = MM.defaultPostQuery-                        { MM.postQueryPage    = Just 0-                        , MM.postQueryPerPage = Just numToReq-                        }-                finalQuery = case rel'pId of-                               Just (MessagePostId pid) -> query { MM.postQueryBefore = Just pid }-                               _ -> query-                op = \s c -> MM.mmGetPostsForChannel c finalQuery s-                addTrailingGap = MM.postQueryBefore finalQuery == Nothing &&-                                 MM.postQueryPage finalQuery == Just 0-            in when ((not $ chan^.ccContents.cdFetchPending) && gapInDisplayable) $ do-                      csChannel(cId).ccContents.cdFetchPending .= True-                      doAsyncChannelMM Preempt cId op-                          (\c p -> Just $ do-                              addObtainedMessages c (-numToReq) addTrailingGap p >>= postProcessMessageAdd-                              csChannel(c).ccContents.cdFetchPending .= False)--asyncFetchAttachments :: Post -> MH ()-asyncFetchAttachments p = do-    let cId = p^.postChannelIdL-        pId = p^.postIdL-    session <- getSession-    host <- use (csResources.crConn.cdHostnameL)-    F.forM_ (p^.postFileIdsL) $ \fId -> doAsyncWith Normal $ do-        info <- MM.mmGetMetadataForFile fId session-        let scheme = "https://"-            attUrl = scheme <> host <> urlForFile fId-            attachment = mkAttachment (fileInfoName info) attUrl fId-            addIfMissing a as =-                if isNothing $ Seq.elemIndexL a as-                then a Seq.<| as-                else as-            addAttachment m-                | m^.mMessageId == Just (MessagePostId pId) =-                    m & mAttachments %~ (addIfMissing attachment)-                | otherwise =-                    m-        return $ Just $ do-            csChannel(cId).ccContents.cdMessages.traversed %= addAttachment-            mh $ invalidateCacheEntry $ ChannelMessages cId
− src/State/Messages.hs-boot 
@@ -1,11 +0,0 @@-module State.Messages-  ( fetchVisibleIfNeeded-  )-where--import Types ( MH )---- State.Channels needs this in setFocusWith, but that creates an--- import cycle because several things in State.Messages need things in--- State.Channels.-fetchVisibleIfNeeded :: MH ()
− src/State/NotifyPrefs.hs 
@@ -1,87 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-module State.NotifyPrefs-    ( enterEditNotifyPrefsMode-    , exitEditNotifyPrefsMode-    )-where--import Prelude ()-import Prelude.MH--import Types--import Network.Mattermost.Types ( ChannelNotifyProps-                                , User(..)-                                , UserNotifyProps(..)-                                , Type(..)-                                , channelNotifyPropsMarkUnread-                                , channelNotifyPropsIgnoreChannelMentions-                                , WithDefault(..)-                                , NotifyOption(..)-                                )--import Brick-import Brick.Forms-import Lens.Micro.Platform ( Lens', (.=), lens )--muteLens :: Lens' ChannelNotifyProps Bool-muteLens = lens (\props -> props^.channelNotifyPropsMarkUnreadL == IsValue NotifyOptionMention)-           (\props muted -> props { channelNotifyPropsMarkUnread =-                                          if muted-                                          then IsValue NotifyOptionMention-                                          else IsValue NotifyOptionAll-                                  })--channelMentionLens :: Lens' ChannelNotifyProps Bool-channelMentionLens = lens (\props -> props^.channelNotifyPropsIgnoreChannelMentionsL == IsValue True)-                     (\props ignoreChannelMentions ->-                          props { channelNotifyPropsIgnoreChannelMentions = if ignoreChannelMentions-                                                                            then IsValue True-                                                                            else Default-                                })--notifyOptionName :: NotifyOption -> Text-notifyOptionName NotifyOptionAll = "All activity"-notifyOptionName NotifyOptionMention = "Mentions"-notifyOptionName NotifyOptionNone = "Never"--mkNotifyButtons :: ((WithDefault NotifyOption) -> Name)-                -> Lens' ChannelNotifyProps (WithDefault NotifyOption)-                -> NotifyOption-                -> ChannelNotifyProps-                -> FormFieldState ChannelNotifyProps e Name-mkNotifyButtons mkName l globalDefault =-    let optTuple opt = (IsValue opt, mkName $ IsValue opt, notifyOptionName opt)-        defaultField = (Default, mkName Default, "Global default (" <> notifyOptionName globalDefault <> ")")-        nonDefault = optTuple <$> [ NotifyOptionAll-                                  , NotifyOptionMention-                                  , NotifyOptionNone-                                  ]-    in radioField l (defaultField : nonDefault)--notifyPrefsForm :: UserNotifyProps -> ChannelNotifyProps -> Form ChannelNotifyProps e Name-notifyPrefsForm globalDefaults =-    newForm [ checkboxField muteLens MuteToggleField "Mute channel"-            , (padTop $ Pad 1) @@= checkboxField channelMentionLens ChannelMentionsField "Ignore channel mentions"-            , radioStyle "Desktop notifications" @@=-                mkNotifyButtons DesktopNotificationsField channelNotifyPropsDesktopL (userNotifyPropsDesktop globalDefaults)-            , radioStyle "Push notifications" @@=-                mkNotifyButtons PushNotificationsField channelNotifyPropsPushL (userNotifyPropsPush globalDefaults)-            ]-    where radioStyle label = (padTop $ Pad 1 ) . (str label <=>) . (padLeft $ Pad 1)--enterEditNotifyPrefsMode :: MH ()-enterEditNotifyPrefsMode = do-    chanInfo <- use (csCurrentChannel.ccInfo)-    case chanInfo^.cdType of-      Direct -> mhError $ GenericError "Cannot open notification preferences for DM channel."-      _ -> do-        let props = chanInfo^.cdNotifyProps-        user <- use csMe-        csNotifyPrefs .= (Just (notifyPrefsForm (userNotifyProps user) props))-        setMode EditNotifyPrefs--exitEditNotifyPrefsMode :: MH ()-exitEditNotifyPrefsMode = do-    setMode Main
− src/State/PostListOverlay.hs 
@@ -1,160 +0,0 @@-module State.PostListOverlay-  ( enterFlaggedPostListMode-  , enterPinnedPostListMode-  , enterSearchResultPostListMode-  , postListJumpToCurrent-  , postListSelectUp-  , postListSelectDown-  , postListUnflagSelected-  , exitPostListMode-  )-where--import           GHC.Exts ( IsList(..) )-import           Prelude ()-import           Prelude.MH--import qualified Data.Foldable as F-import qualified Data.Text as T-import           Lens.Micro.Platform ( (.=) )-import           Network.Mattermost.Endpoints-import           Network.Mattermost.Types--import           State.Channels-import           State.Common-import           State.MessageSelect-import           State.Messages ( addObtainedMessages-                                , asyncFetchMessagesSurrounding )-import           Types-import           Types.DirectionalSeq (emptyDirSeq)----- | Create a PostListOverlay with the given content description and--- with a specified list of messages.-enterPostListMode ::  PostListContents -> Messages -> MH ()-enterPostListMode contents msgs = do-  csPostListOverlay.postListPosts .= msgs-  let mlatest = getLatestPostMsg msgs-      pId = mlatest >>= messagePostId-      cId = mlatest >>= \m -> m^.mChannelId-  csPostListOverlay.postListSelected .= pId-  setMode $ PostListOverlay contents-  case (pId, cId) of-    (Just p, Just c) -> asyncFetchMessagesSurrounding c p-    _ -> return ()---- | Clear out the state of a PostListOverlay-exitPostListMode :: MH ()-exitPostListMode = do-  csPostListOverlay.postListPosts .= emptyDirSeq-  csPostListOverlay.postListSelected .= Nothing-  setMode Main---createPostList :: PostListContents -> (Session -> IO Posts) -> MH ()-createPostList contentsType fetchOp = do-  session <- getSession-  doAsyncWith Preempt $ do-    posts <- fetchOp session-    return $ Just $ do-      messages <- installMessagesFromPosts posts-      -- n.b. do not use addNewPostedMessage because these messages-      -- are not new, and so no notifications or channel highlighting-      -- or other post-processing should be performed.-      let plist = F.toList $ postsPosts posts-          postsSpec p = Posts { postsPosts = fromList [(postId p, p)]-                              , postsOrder = fromList [postId p]-                              }-      mapM_ (\p -> addObtainedMessages (postChannelId p) 0 False $ postsSpec p) plist-      enterPostListMode contentsType messages----- | Create a PostListOverlay with flagged messages from the server.-enterFlaggedPostListMode :: MH ()-enterFlaggedPostListMode = createPostList PostListFlagged $-                           mmGetListOfFlaggedPosts UserMe defaultFlaggedPostsQuery---- | Create a PostListOverlay with pinned messages from the server for--- the current channel.-enterPinnedPostListMode :: MH ()-enterPinnedPostListMode = do-    cId <- use csCurrentChannelId-    createPostList (PostListPinned cId) $ mmGetChannelPinnedPosts cId---- | Create a PostListOverlay with post search result messages from the--- server.-enterSearchResultPostListMode :: Text -> MH ()-enterSearchResultPostListMode terms-  | T.null (T.strip terms) = postInfoMessage "Search command requires at least one search term."-  | otherwise = do-      enterPostListMode (PostListSearch terms True) noMessages-      tId <- gets myTeamId-      createPostList (PostListSearch terms False) $-        mmSearchForTeamPosts tId (SearchPosts terms False)----- | Move the selection up in the PostListOverlay, which corresponds--- to finding a chronologically /newer/ message.-postListSelectUp :: MH ()-postListSelectUp = do-  selId <- use (csPostListOverlay.postListSelected)-  posts <- use (csPostListOverlay.postListPosts)-  let nextMsg = getNextMessage (MessagePostId <$> selId) posts-  case nextMsg of-    Nothing -> return ()-    Just m -> do-      let pId = m^.mMessageId >>= messageIdPostId-      csPostListOverlay.postListSelected .= pId-      case (m^.mChannelId, pId) of-        (Just c, Just p) -> asyncFetchMessagesSurrounding c p-        o -> mhLog LogError-             (T.pack $ "postListSelectUp" <>-              " unable to get channel or post ID: " <> show o)---- | Move the selection down in the PostListOverlay, which corresponds--- to finding a chronologically /old/ message.-postListSelectDown :: MH ()-postListSelectDown = do-  selId <- use (csPostListOverlay.postListSelected)-  posts <- use (csPostListOverlay.postListPosts)-  let prevMsg = getPrevMessage (MessagePostId <$> selId) posts-  case prevMsg of-    Nothing -> return ()-    Just m -> do-      let pId = m^.mMessageId >>= messageIdPostId-      csPostListOverlay.postListSelected .= pId-      case (m^.mChannelId, pId) of-        (Just c, Just p) -> asyncFetchMessagesSurrounding c p-        o -> mhLog LogError-             (T.pack $ "postListSelectDown" <>-              " unable to get channel or post ID: " <> show o)---- | Unflag the post currently selected in the PostListOverlay, if any-postListUnflagSelected :: MH ()-postListUnflagSelected = do-  msgId <- use (csPostListOverlay.postListSelected)-  case msgId of-    Nothing  -> return ()-    Just pId -> flagMessage pId False----- | Jumps to the specified message in the message's main channel--- display and changes to MessageSelectState.-postListJumpToCurrent :: MH ()-postListJumpToCurrent = do-  msgId <- use (csPostListOverlay.postListSelected)-  st <- use id-  case msgId of-    Nothing  -> return ()-    Just pId ->-      case getMessageForPostId st pId of-        Just msg ->-          case msg ^. mChannelId of-            Just cId -> do-              setFocus cId-              setMode MessageSelect-              csMessageSelect .= MessageSelectState (msg^.mMessageId)-            Nothing ->-              error "INTERNAL: selected Post ID not associated with a channel"-        Nothing ->-          error "INTERNAL: selected Post ID not added to global state!"
− src/State/ReactionEmojiListOverlay.hs 
@@ -1,125 +0,0 @@-{-# LANGUAGE TupleSections #-}-module State.ReactionEmojiListOverlay-  ( enterReactionEmojiListOverlayMode--  , reactionEmojiListSelectDown-  , reactionEmojiListSelectUp-  , reactionEmojiListPageDown-  , reactionEmojiListPageUp-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Brick.Widgets.List as L-import qualified Data.Vector as Vec-import qualified Data.Text as T-import qualified Data.Map as M-import qualified Data.Set as Set-import           Data.Function ( on )-import           Data.List ( nubBy )-import           Lens.Micro.Platform ( to )--import           Network.Mattermost.Types-import           Network.Mattermost.Endpoints ( mmPostReaction, mmDeleteReaction )--import           Emoji-import           State.ListOverlay-import           State.MessageSelect-import           State.Async-import           Types---enterReactionEmojiListOverlayMode :: MH ()-enterReactionEmojiListOverlayMode = do-    selectedMessage <- use (to getSelectedMessage)-    case selectedMessage of-        Nothing -> return ()-        Just msg -> do-            em <- use (csResources.crEmoji)-            myId <- gets myUserId-            enterListOverlayMode csReactionEmojiListOverlay ReactionEmojiListOverlay-                () enterHandler (fetchResults myId msg em)--enterHandler :: (Bool, T.Text) -> MH Bool-enterHandler (mine, e) = do-    session <- getSession-    myId <- gets myUserId--    selectedMessage <- use (to getSelectedMessage)-    case selectedMessage of-        Nothing -> return False-        Just m -> do-            case m^.mOriginalPost of-                Nothing -> return False-                Just p -> do-                    case mine of-                        False ->-                            doAsyncWith Preempt $ do-                                mmPostReaction (postId p) myId e session-                                return Nothing-                        True ->-                            doAsyncWith Preempt $ do-                                mmDeleteReaction (postId p) myId e session-                                return Nothing-                    return True--fetchResults :: UserId-             -- ^ My user ID, so we can see which reactions I haven't-             -- posted-             -> Message-             -- ^ The selected message, so we can include its current-             -- reactions in the list-             -> EmojiCollection-             -- ^ The emoji collection-             -> ()-             -- ^ The scope to search-             -> Session-             -- ^ The connection session-             -> Text-             -- ^ The search string-             -> IO (Vec.Vector (Bool, T.Text))-fetchResults myId msg em () session searchString = do-    let currentReactions = [ (myId `Set.member` uIds, k)-                           | (k, uIds) <- M.toList (msg^.mReactions)-                           ]-        matchingCurrentOtherReactions = [ (mine, r) | (mine, r) <- currentReactions-                                        , matchesEmoji searchString r-                                        , not mine-                                        ]-        matchingCurrentMyReactions = [ (mine, r) | (mine, r) <- currentReactions-                                     , matchesEmoji searchString r-                                     , mine-                                     ]-    serverMatches <- getMatchingEmoji session em searchString-    return $ Vec.fromList $ nubBy ((==) `on` snd) $-        matchingCurrentOtherReactions <> matchingCurrentMyReactions <> ((False,) <$> serverMatches)---- | Move the selection up in the emoji list overlay by one emoji.-reactionEmojiListSelectUp :: MH ()-reactionEmojiListSelectUp = reactionEmojiListMove L.listMoveUp---- | Move the selection down in the emoji list overlay by one emoji.-reactionEmojiListSelectDown :: MH ()-reactionEmojiListSelectDown = reactionEmojiListMove L.listMoveDown---- | Move the selection up in the emoji list overlay by a page of emoji--- (ReactionEmojiListPageSize).-reactionEmojiListPageUp :: MH ()-reactionEmojiListPageUp = reactionEmojiListMove (L.listMoveBy (-1 * reactionEmojiListPageSize))---- | Move the selection down in the emoji list overlay by a page of emoji--- (ReactionEmojiListPageSize).-reactionEmojiListPageDown :: MH ()-reactionEmojiListPageDown = reactionEmojiListMove (L.listMoveBy reactionEmojiListPageSize)---- | Transform the emoji list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-reactionEmojiListMove :: (L.List Name (Bool, T.Text) -> L.List Name (Bool, T.Text)) -> MH ()-reactionEmojiListMove = listOverlayMove csReactionEmojiListOverlay---- | The number of emoji in a "page" for cursor movement purposes.-reactionEmojiListPageSize :: Int-reactionEmojiListPageSize = 10
− src/State/Reactions.hs 
@@ -1,52 +0,0 @@-module State.Reactions-  ( asyncFetchReactionsForPost-  , addReactions-  , removeReaction-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Main ( invalidateCacheEntry )-import qualified Data.Map.Strict as Map-import           Lens.Micro.Platform-import qualified Data.Set as S--import           Network.Mattermost.Endpoints-import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           State.Async-import           State.Common ( fetchMentionedUsers )-import           Types---asyncFetchReactionsForPost :: ChannelId -> Post -> MH ()-asyncFetchReactionsForPost cId p-  | not (p^.postHasReactionsL) = return ()-  | otherwise = doAsyncChannelMM Normal cId-        (\s _ -> fmap toList (mmGetReactionsForPost (p^.postIdL) s))-        (\_ rs -> Just $ addReactions cId rs)--addReactions :: ChannelId -> [Reaction] -> MH ()-addReactions cId rs = do-    mh $ invalidateCacheEntry $ ChannelMessages cId-    csChannel(cId).ccContents.cdMessages %= fmap upd-    let mentions = S.fromList $ UserIdMention <$> reactionUserId <$> rs-    fetchMentionedUsers mentions-  where upd msg = msg & mReactions %~ insertAll (msg^.mMessageId)-        insert mId r-          | mId == Just (MessagePostId (r^.reactionPostIdL)) =-              Map.insertWith S.union (r^.reactionEmojiNameL) (S.singleton $ r^.reactionUserIdL)-          | otherwise = id-        insertAll mId msg = foldr (insert mId) msg rs--removeReaction :: Reaction -> ChannelId -> MH ()-removeReaction r cId = do-    mh $ invalidateCacheEntry $ ChannelMessages cId-    csChannel(cId).ccContents.cdMessages %= fmap upd-  where upd m | m^.mMessageId == Just (MessagePostId $ r^.reactionPostIdL) =-                  m & mReactions %~ (Map.alter delReaction (r^.reactionEmojiNameL))-              | otherwise = m-        delReaction mUs = S.delete (r^.reactionUserIdL) <$> mUs
− src/State/Setup.hs 
@@ -1,281 +0,0 @@-{-# LANGUAGE TypeFamilies #-}-module State.Setup-  ( setupState-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.BChan ( newBChan )-import           Brick.Themes ( themeToAttrMap, loadCustomizations )-import qualified Control.Concurrent.STM as STM-import           Data.Maybe ( fromJust )-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import           Data.Time.Clock ( getCurrentTime )-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( (.~) )-import           System.Exit ( exitFailure, exitSuccess )-import           System.FilePath ( (</>), isRelative, dropFileName )--import           Network.Mattermost.Endpoints-import           Network.Mattermost.Types--import           Config-import           InputHistory-import           LastRunState-import           Login-import           State.Flagging-import           State.Messages ( fetchVisibleIfNeeded )-import           State.Setup.Threads-import           TeamSelect-import           Themes-import           TimeUtils ( lookupLocalTimeZone )-import           Types-import           Types.Common-import           Emoji-import           FilePaths ( userEmojiJsonPath, bundledEmojiJsonPath )-import qualified Zipper as Z---incompleteCredentials :: Config -> ConnectionInfo-incompleteCredentials config = ConnectionInfo-  { _ciHostname = fromMaybe "" (configHost config)-  , _ciPort     = configPort config-  , _ciUrlPath  = fromMaybe "" (configUrlPath config)-  , _ciUsername = fromMaybe "" (configUser config)-  , _ciPassword = case configPass config of-                    Just (PasswordString s) -> s-                    _                       -> ""-  , _ciAccessToken = case configToken config of-                       Just (TokenString s) -> s-                       _                    -> ""-  , _ciType     = configConnectionType config-  }--apiLogEventToLogMessage :: LogEvent -> IO LogMessage-apiLogEventToLogMessage ev = do-    now <- getCurrentTime-    let msg = T.pack $ "Function: " <> logFunction ev <>-                       ", event: " <> show (logEventType ev)-    return $ LogMessage { logMessageCategory = LogAPI-                        , logMessageText = msg-                        , logMessageContext = Nothing-                        , logMessageTimestamp = now-                        }--setupState :: IO Vty.Vty -> Maybe FilePath -> Config -> IO (ChatState, Vty.Vty)-setupState mkVty mLogLocation config = do-  initialVty <- mkVty--  eventChan <- newBChan 2500-  logMgr <- newLogManager eventChan (configLogMaxBufferSize config)--  -- If we got an initial log location, start logging there.-  case mLogLocation of-      Nothing -> return ()-      Just loc -> startLoggingToFile logMgr loc--  let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr-      setLogger cd = cd `withLogger` logApiEvent--  (mLastAttempt, loginVty) <- interactiveGetLoginSession initialVty mkVty-                                                         setLogger-                                                         logMgr-                                                         (incompleteCredentials config)--  let shutdown vty = do-          Vty.shutdown vty-          exitSuccess--  (session, me, cd, mbTeam) <- case mLastAttempt of-      Nothing ->-          -- The user never attempted a connection and just chose to-          -- quit.-          shutdown loginVty-      Just (AttemptFailed {}) ->-          -- The user attempted a connection and failed, and then chose-          -- to quit.-          shutdown loginVty-      Just (AttemptSucceeded _ cd sess user mbTeam) ->-          -- The user attempted a connection and succeeded so continue-          -- with setup.-          return (sess, user, cd, mbTeam)--  teams <- mmGetUsersTeams UserMe session-  when (Seq.null teams) $ do-      putStrLn "Error: your account is not a member of any teams"-      exitFailure--  (myTeam, teamSelVty) <- do-      let foundTeam = do-             tName <- mbTeam <|> configTeam config-             let matchingTeam = listToMaybe $ filter matches $ toList teams-                 matches t = (sanitizeUserText $ teamName t) == tName-             matchingTeam--      case foundTeam of-          Just t -> return (t, loginVty)-          Nothing -> do-              (mTeam, vty) <- interactiveTeamSelection loginVty mkVty $ toList teams-              case mTeam of-                  Nothing -> shutdown vty-                  Just team -> return (team, vty)--  userStatusChan <- STM.newTChanIO-  slc <- STM.newTChanIO-  wac <- STM.newTChanIO--  prefs <- mmGetUsersPreferences UserMe session-  let userPrefs = setUserPreferences prefs defaultUserPreferences-      themeName = case configTheme config of-          Nothing -> internalThemeName defaultTheme-          Just t -> t-      baseTheme = internalTheme $ fromMaybe defaultTheme (lookupTheme themeName)--  -- Did the configuration specify a theme customization file? If so,-  -- load it and customize the theme.-  custTheme <- case configThemeCustomizationFile config of-      Nothing -> return baseTheme-      Just path ->-          -- If we have no configuration path (i.e. we used the default-          -- config) then ignore theme customization.-          let pathStr = T.unpack path-          in if isRelative pathStr && isNothing (configAbsPath config)-             then return baseTheme-             else do-                 let absPath = if isRelative pathStr-                               then (dropFileName $ fromJust $ configAbsPath config) </> pathStr-                               else pathStr-                 result <- loadCustomizations absPath baseTheme-                 case result of-                     Left e -> do-                         Vty.shutdown teamSelVty-                         putStrLn $ "Error loading theme customization from " <> show absPath <> ": " <> e-                         exitFailure-                     Right t -> return t--  requestChan <- STM.atomically STM.newTChan--  emoji <- either (const emptyEmojiCollection) id <$> do-      result1 <- loadEmoji =<< userEmojiJsonPath-      case result1 of-          Right e -> return $ Right e-          Left _ -> loadEmoji =<< bundledEmojiJsonPath--  let cr = ChatResources { _crSession             = session-                         , _crWebsocketThreadId   = Nothing-                         , _crConn                = cd-                         , _crRequestQueue        = requestChan-                         , _crEventQueue          = eventChan-                         , _crSubprocessLog       = slc-                         , _crWebsocketActionChan = wac-                         , _crTheme               = themeToAttrMap custTheme-                         , _crStatusUpdateChan    = userStatusChan-                         , _crConfiguration       = config-                         , _crFlaggedPosts        = mempty-                         , _crUserPreferences     = userPrefs-                         , _crSyntaxMap           = mempty-                         , _crLogManager          = logMgr-                         , _crEmoji               = emoji-                         }--  st <- initializeState cr myTeam me--  return (st, teamSelVty)--initializeState :: ChatResources -> Team -> User -> IO ChatState-initializeState cr myTeam me = do-  let session = getResourceSession cr-      requestChan = cr^.crRequestQueue-      myTId = getId myTeam--  -- Create a predicate to find the last selected channel by reading the-  -- run state file. If unable to read or decode or validate the file, this-  -- predicate is just `isTownSquare`.-  isLastSelectedChannel <- do-    result <- readLastRunState $ teamId myTeam-    case result of-      Right lrs | isValidLastRunState cr me lrs -> return $ \c ->-           channelId c == lrs^.lrsSelectedChannelId-      _ -> return isTownSquare--  -- Get all channels, but filter down to just the one we want to start-  -- in. We get all, rather than requesting by name or ID, because-  -- we don't know whether the server will give us a last-viewed preference.-  -- We first try to find a channel matching with the last selected channel ID,-  -- failing which we look for the Town Square channel by name.-  userChans <- mmGetChannelsForUser UserMe myTId session-  let lastSelectedChans = Seq.filter isLastSelectedChannel userChans-      chans = if Seq.null lastSelectedChans-                then Seq.filter isTownSquare userChans-                else lastSelectedChans--  -- Since the only channel we are dealing with is by construction the-  -- last channel, we don't have to consider other cases here:-  chanPairs <- forM (toList chans) $ \c -> do-      cChannel <- makeClientChannel (userId me) c-      return (getId c, cChannel)--  tz <- lookupLocalTimeZone-  hist <- do-      result <- readHistory-      case result of-          Left _ -> return newHistory-          Right h -> return h--  ---------------------------------------------------------------------  -- Start background worker threads:-  ---  -- * Syntax definition loader-  startSyntaxMapLoaderThread (cr^.crConfiguration) (cr^.crEventQueue)--  -- * Main async queue worker thread-  startAsyncWorkerThread (cr^.crConfiguration) (cr^.crRequestQueue) (cr^.crEventQueue)--  -- * User status thread-  startUserStatusUpdateThread (cr^.crStatusUpdateChan) session requestChan--  -- * Refresher for users who are typing currently-  when (configShowTypingIndicator (cr^.crConfiguration)) $-    startTypingUsersRefreshThread requestChan--  -- * Timezone change monitor-  startTimezoneMonitorThread tz requestChan--  -- * Subprocess logger-  startSubprocessLoggerThread (cr^.crSubprocessLog) requestChan--  -- * Spell checker and spell check timer, if configured-  spResult <- maybeStartSpellChecker (cr^.crConfiguration) (cr^.crEventQueue)--  -- End thread startup ------------------------------------------------  now <- getCurrentTime-  let chanIds = mkChannelZipperList now (cr^.crConfiguration) Nothing (cr^.crUserPreferences) clientChans noUsers-      chanZip = Z.fromList chanIds-      clientChans = foldr (uncurry addChannel) noChannels chanPairs-      startupState =-          StartupStateInfo { startupStateResources      = cr-                           , startupStateChannelZipper  = chanZip-                           , startupStateConnectedUser  = me-                           , startupStateTeam           = myTeam-                           , startupStateTimeZone       = tz-                           , startupStateInitialHistory = hist-                           , startupStateSpellChecker   = spResult-                           }--  initialState <- newState startupState-  let st = initialState & csChannels .~ clientChans--  loadFlaggedMessages (cr^.crUserPreferences.userPrefFlaggedPostList) st--  -- Trigger an initial websocket refresh-  writeBChan (cr^.crEventQueue) RefreshWebsocketEvent--  -- Refresh initial channel(s)-  writeBChan (cr^.crEventQueue) $ RespEvent $ do-      fetchVisibleIfNeeded--  return st
− src/State/Setup/Threads.hs 
@@ -1,372 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module State.Setup.Threads-  ( startUserStatusUpdateThread-  , startTypingUsersRefreshThread-  , startSubprocessLoggerThread-  , startTimezoneMonitorThread-  , maybeStartSpellChecker-  , startAsyncWorkerThread-  , startSyntaxMapLoaderThread-  , module State.Setup.Threads.Logging-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.BChan ( BChan )-import           Brick.Main ( invalidateCache )-import           Control.Concurrent ( threadDelay, forkIO )-import qualified Control.Concurrent.STM as STM-import           Control.Concurrent.STM.Delay-import           Control.Exception ( SomeException, try, fromException, catch )-import           Data.List ( isInfixOf )-import qualified Data.Map as M-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import           Data.Time ( getCurrentTime, addUTCTime )-import           Lens.Micro.Platform ( (.=), (%=), (%~), mapped )-import           Skylighting.Loader ( loadSyntaxesFromDir )-import           System.Directory ( getTemporaryDirectory )-import           System.Exit ( ExitCode(ExitSuccess) )-import           System.IO ( hPutStrLn, hFlush )-import           System.IO.Temp ( openTempFile )-import           System.Timeout ( timeout )-import           Text.Aspell ( Aspell, AspellOption(..), startAspell )--import           Network.Mattermost.Exceptions ( RateLimitException-                                               , rateLimitExceptionReset )-import           Network.Mattermost.Endpoints-import           Network.Mattermost.Types--import           Constants-import           State.Editing ( requestSpellCheck )-import           State.Setup.Threads.Logging-import           TimeUtils ( lookupLocalTimeZone )-import           Types---updateUserStatuses :: [UserId] -> Session -> IO (Maybe (MH ()))-updateUserStatuses uIds session =-    case null uIds of-        False -> do-            statuses <- mmGetUserStatusByIds (Seq.fromList uIds) session-            return $ Just $ do-                forM_ statuses $ \s ->-                    setUserStatus (statusUserId s) (statusStatus s)-        True -> return Nothing--startUserStatusUpdateThread :: STM.TChan [UserId] -> Session -> RequestChan -> IO ()-startUserStatusUpdateThread zipperChan session requestChan = void $ forkIO body-  where-      seconds = (* (1000 * 1000))-      userRefreshInterval = 30-      body = refresh []-      refresh prev = do-          result <- timeout (seconds userRefreshInterval) (STM.atomically $ STM.readTChan zipperChan)-          let (uIds, update) = case result of-                  Nothing -> (prev, True)-                  Just ids -> (ids, ids /= prev)--          when update $ do-              STM.atomically $ STM.writeTChan requestChan $ do-                  rs <- try $ updateUserStatuses uIds session-                  case rs of-                      Left (_ :: SomeException) -> return Nothing-                      Right upd -> return upd--          refresh uIds---- This thread refreshes the map of typing users every second, forever,--- to expire users who have stopped typing. Expiry time is 3 seconds.-startTypingUsersRefreshThread :: RequestChan -> IO ()-startTypingUsersRefreshThread requestChan = void $ forkIO $ forever refresh-  where-    seconds = (* (1000 * 1000))-    refreshIntervalMicros = ceiling $ seconds $ userTypingExpiryInterval / 2-    refresh = do-      STM.atomically $ STM.writeTChan requestChan $ return $ Just $ do-        now <- liftIO getCurrentTime-        let expiry = addUTCTime (- userTypingExpiryInterval) now-        let expireUsers c = c & ccInfo.cdTypingUsers %~ expireTypingUsers expiry-        csChannels . mapped %= expireUsers--      threadDelay refreshIntervalMicros--startSubprocessLoggerThread :: STM.TChan ProgramOutput -> RequestChan -> IO ()-startSubprocessLoggerThread logChan requestChan = do-    let logMonitor mPair = do-          ProgramOutput progName args out stdoutOkay err ec <--              STM.atomically $ STM.readTChan logChan--          -- If either stdout or stderr is non-empty or there was an exit-          -- failure, log it and notify the user.-          let emptyOutput s = null s || s == "\n"--          case ec == ExitSuccess && (emptyOutput out || stdoutOkay) && emptyOutput err of-              -- the "good" case, no output and exit sucess-              True -> logMonitor mPair-              False -> do-                  (logPath, logHandle) <- case mPair of-                      Just p ->-                          return p-                      Nothing -> do-                          tmp <- getTemporaryDirectory-                          openTempFile tmp "matterhorn-subprocess.log"--                  let unexpectedStdout = ec == ExitSuccess && (not $ emptyOutput out) && not stdoutOkay--                  hPutStrLn logHandle $-                      unlines [ "Program: " <> progName-                              , "Arguments: " <> show args-                              , "Exit code: " <> show ec-                              , if unexpectedStdout-                                then "Stdout (unexpected due to successful exit):"-                                else "Stdout:"-                              , out-                              , "Stderr:"-                              , err-                              ]-                  hFlush logHandle--                  STM.atomically $ STM.writeTChan requestChan $ do-                      return $ Just $ mhError $ ProgramExecutionFailed (T.pack progName) (T.pack logPath)--                  logMonitor (Just (logPath, logHandle))--    void $ forkIO $ logMonitor Nothing--startTimezoneMonitorThread :: TimeZoneSeries -> RequestChan -> IO ()-startTimezoneMonitorThread tz requestChan = do-  -- Start the timezone monitor thread-  let timezoneMonitorSleepInterval = minutes 5-      minutes = (* (seconds 60))-      seconds = (* (1000 * 1000))-      timezoneMonitor prevTz = do-        threadDelay timezoneMonitorSleepInterval--        newTz <- lookupLocalTimeZone-        when (newTz /= prevTz) $-            STM.atomically $ STM.writeTChan requestChan $ do-                return $ Just $ do-                    timeZone .= newTz-                    mh invalidateCache--        timezoneMonitor newTz--  void $ forkIO (timezoneMonitor tz)--maybeStartSpellChecker :: Config -> BChan MHEvent -> IO (Maybe (Aspell, IO ()))-maybeStartSpellChecker config eventQueue = do-  case configEnableAspell config of-      False -> return Nothing-      True -> do-          let aspellOpts = catMaybes [ UseDictionary <$> (configAspellDictionary config)-                                     ]-              spellCheckerTimeout = 500 * 1000 -- 500k us = 500ms-          asResult <- either (const Nothing) Just <$> startAspell aspellOpts-          case asResult of-              Nothing -> return Nothing-              Just as -> do-                  resetSCChan <- startSpellCheckerThread eventQueue spellCheckerTimeout-                  let resetSCTimer = STM.atomically $ STM.writeTChan resetSCChan ()-                  return $ Just (as, resetSCTimer)---- Start the background spell checker delay thread.------ The purpose of this thread is to postpone the spell checker query--- while the user is actively typing and only wait until they have--- stopped typing before bothering with a query. This is to avoid spell--- checker queries when the editor contents are changing rapidly.--- Avoiding such queries reduces system load and redraw frequency.------ We do this by starting a thread whose job is to wait for the event--- loop to tell it to schedule a spell check. Spell checks are scheduled--- by writing to the channel returned by this function. The scheduler--- thread reads from that channel and then works with another worker--- thread as follows:------ A wakeup of the main spell checker thread causes it to determine--- whether the worker thread is already waiting on a timer. When that--- timer goes off, a spell check will be requested. If there is already--- an active timer that has not yet expired, the timer's expiration is--- extended. This is the case where typing is occurring and we want to--- continue postponing the spell check. If there is not an active timer--- or the active timer has expired, we create a new timer and send it to--- the worker thread for waiting.------ The worker thread works by reading a timer from its queue, waiting--- until the timer expires, and then injecting an event into the main--- event loop to request a spell check.-startSpellCheckerThread :: BChan MHEvent-                        -- ^ The main event loop's event channel.-                        -> Int-                        -- ^ The number of microseconds to wait before-                        -- requesting a spell check.-                        -> IO (STM.TChan ())-startSpellCheckerThread eventChan spellCheckTimeout = do-  delayWakeupChan <- STM.atomically STM.newTChan-  delayWorkerChan <- STM.atomically STM.newTChan-  delVar <- STM.atomically $ STM.newTVar Nothing--  -- The delay worker actually waits on the delay to expire and then-  -- requests a spell check.-  void $ forkIO $ forever $ do-    STM.atomically $ waitDelay =<< STM.readTChan delayWorkerChan-    writeBChan eventChan (RespEvent requestSpellCheck)--  -- The delay manager waits for requests to start a delay timer and-  -- signals the worker to begin waiting.-  void $ forkIO $ forever $ do-    () <- STM.atomically $ STM.readTChan delayWakeupChan--    oldDel <- STM.atomically $ STM.readTVar delVar-    mNewDel <- case oldDel of-        Nothing -> Just <$> newDelay spellCheckTimeout-        Just del -> do-            -- It's possible that between this check for expiration and-            -- the updateDelay below, the timer will expire -- at which-            -- point this will mean that we won't extend the timer as-            -- originally desired. But that's alright, because future-            -- keystrokes will trigger another timer anyway.-            expired <- tryWaitDelayIO del-            case expired of-                True -> Just <$> newDelay spellCheckTimeout-                False -> do-                    updateDelay del spellCheckTimeout-                    return Nothing--    case mNewDel of-        Nothing -> return ()-        Just newDel -> STM.atomically $ do-            STM.writeTVar delVar $ Just newDel-            STM.writeTChan delayWorkerChan newDel--  return delayWakeupChan--startSyntaxMapLoaderThread :: Config -> BChan MHEvent -> IO ()-startSyntaxMapLoaderThread config eventChan = void $ forkIO $ do-    -- Iterate over the configured syntax directories, loading syntax-    -- maps. Ensure that entries loaded in earlier directories in the-    -- sequence take precedence over entries loaded later.-    mMaps <- forM (configSyntaxDirs config) $ \dir -> do-        result <- try $ loadSyntaxesFromDir dir-        case result of-            Left (_::SomeException) -> return Nothing-            Right (Left _)          -> return Nothing-            Right (Right m)         -> return $ Just m--    let maps = catMaybes mMaps-        finalMap = foldl M.union mempty maps--    writeBChan eventChan $ RespEvent $ do-        csResources.crSyntaxMap .= finalMap-        mh invalidateCache------------------------------------------------------------------------ Async worker thread--startAsyncWorkerThread :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()-startAsyncWorkerThread c r e = void $ forkIO $ asyncWorker c r e--asyncWorker :: Config -> STM.TChan (IO (Maybe (MH ()))) -> BChan MHEvent -> IO ()-asyncWorker c r e = forever $ doAsyncWork c r e--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-                     case chk of-                       Nothing -> do writeBChan eventChan BGIdle-                                     return $ writeBChan eventChan $ BGBusy Nothing-                       _ -> return $ return ()-        ActiveCount -> do-          chk <- STM.atomically $ do-            chanCopy <- STM.cloneTChan requestChan-            let cntMsgs = do m <- STM.tryReadTChan chanCopy-                             case m of-                               Nothing -> return 0-                               Just _ -> (1 +) <$> cntMsgs-            cntMsgs-          case chk of-            0 -> do writeBChan eventChan BGIdle-                    return (writeBChan eventChan $ BGBusy (Just 1))-            _ -> do writeBChan eventChan $ BGBusy (Just chk)-                    return $ return ()--    req <- STM.atomically $ STM.readTChan requestChan-    startWork-    -- 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-              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-              -- 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--- information.------ E.g.--- https://github.com/matterhorn-chat/matterhorn/issues/391-shouldIgnore :: SomeException -> Bool-shouldIgnore e =-    let eStr = show e-    in or [ "getAddrInfo" `isInfixOf` eStr-          , "Network.Socket.recvBuf" `isInfixOf` eStr-          , "Network.Socket.sendBuf" `isInfixOf` eStr-          , "resource vanished" `isInfixOf` eStr-          , "timeout" `isInfixOf` eStr-          ]
− src/State/Setup/Threads/Logging.hs 
@@ -1,317 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--- | This module implements the logging thread. This thread can--- optionally write logged messages to an output file. When the thread--- is created, it is initially not writing to any output file and--- must be told to do so by issuing a LogCommand using the LogManager--- interface.------ The logging thread has an internal bounded log message buffer. Logged--- messages always get written to the buffer (potentially evicting old--- messages to maintain the size bound). If the thread is also writing--- to a file, such messages also get written to the file. When the--- thread begins logging to a file, the entire buffer is written to the--- file so that a historical snapshot of log activity can be saved in--- cases where logging is turned on at runtime only once a problematic--- behavior is observed.-module State.Setup.Threads.Logging-  ( newLogManager-  , shutdownLogManager-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.BChan ( BChan )-import           Control.Concurrent.Async ( Async, async, wait )-import qualified Control.Concurrent.STM as STM-import           Control.Exception ( SomeException, try )-import           Control.Monad.State.Strict-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import           Data.Time ( getCurrentTime )-import           System.IO ( Handle, IOMode(AppendMode), hPutStr, hPutStrLn-                           , hFlush, openFile, hClose )--import           Types----- | Used to remember the last logging output point for various log output targets.-newtype LogMemory = LogMemory { logMem :: [(FilePath, LogMessage)] }--blankLogMemory :: LogMemory-blankLogMemory = LogMemory []---- | Adds or updates the last log message output to this destination.--- This is used for the case when logging is re-enabled to that--- destination to avoid repeating logging output.------ The number of log memories is limited by forgetting the oldest ones--- if over a threshold.  This handles a pathological case where the--- user has redirected output to a very large number of logfiles.--- This is very unlikely to happen (a script or bad paste buffer--- maybe?) but this provides defensive behavior to prevent--- uncontrolled memory consumption in this case.  The limit here is--- arbitrary, but it should suffice and once it's reached the--- degradation case is simply the potential for duplicated messages--- when returning to logfiles that haven't been recently logged to.-rememberOutputPoint :: FilePath -> LogMessage -> LogMemory -> LogMemory-rememberOutputPoint logPath logMsg oldLogMem =-  LogMemory $-  take 50 $ -- upper limit on number of logpath+message memories retained-  (logPath, logMsg) : filter ((/=) logPath . fst) (logMem oldLogMem)---- | Returns the last LogMessage logged to the specified output log--- file path if it was previously logged to.-memoryOfOutputPath :: FilePath -> LogMemory -> Maybe LogMessage-memoryOfOutputPath p = lookup p . logMem---- | The state of the logging thread.-data LogThreadState =-    LogThreadState { logThreadDestination :: Maybe (FilePath, Handle)-                   -- ^ The logging thread's active logging destination.-                   -- Nothing means log messages are not being written-                   -- anywhere except the internal buffer.-                   , logThreadEventChan :: BChan MHEvent-                   -- ^ The application event channel that we'll use to-                   -- notify of logging events.-                   , logThreadCommandChan :: STM.TChan LogCommand-                   -- ^ The channel on which the logging thread will-                   -- wait for logging commands.-                   , logThreadMessageBuffer :: Seq.Seq LogMessage-                   -- ^ The internal bounded log message buffer.-                   , logThreadMaxBufferSize :: Int-                   -- ^ The size bound of the logThreadMessageBuffer.-                   , logPreviousStopPoint :: LogMemory-                   -- ^ Previous logging stop points to avoid-                   -- duplication if logging is re-enabled to the same-                   -- output-                   }---- | Create a new log manager and start a logging thread for it.-newLogManager :: BChan MHEvent -> Int -> IO LogManager-newLogManager eventChan maxBufferSize = do-    chan <- STM.newTChanIO-    self <- startLoggingThread eventChan chan maxBufferSize-    let mgr = LogManager { logManagerCommandChannel = chan-                         , logManagerHandle = self-                         }-    return mgr---- | Shuts down the log manager and blocks until shutdown is complete.-shutdownLogManager :: LogManager -> IO ()-shutdownLogManager mgr = do-    STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) ShutdownLogging-    wait $ logManagerHandle mgr---- | The logging thread.-startLoggingThread :: BChan MHEvent -> STM.TChan LogCommand -> Int -> IO (Async ())-startLoggingThread eventChan logChan maxBufferSize = do-    let initialState = LogThreadState { logThreadDestination = Nothing-                                      , logThreadEventChan = eventChan-                                      , logThreadCommandChan = logChan-                                      , logThreadMessageBuffer = mempty-                                      , logThreadMaxBufferSize = maxBufferSize-                                      , logPreviousStopPoint = blankLogMemory-                                      }-    async $ void $ runStateT logThreadBody initialState--logThreadBody :: StateT LogThreadState IO ()-logThreadBody = do-    cmd <- nextLogCommand-    continue <- handleLogCommand cmd-    when continue logThreadBody---- | Get the next pending log thread command.-nextLogCommand :: StateT LogThreadState IO LogCommand-nextLogCommand = do-    chan <- gets logThreadCommandChan-    liftIO $ STM.atomically $ STM.readTChan chan--putMarkerMessage :: String -> Handle -> IO ()-putMarkerMessage msg h = do-    now <- getCurrentTime-    hPutStrLn h $ "[" <> show now <> "] " <> msg---- | Emit a log stop marker to the file.-putLogEndMarker :: Handle -> IO ()-putLogEndMarker = putMarkerMessage "<<< Logging end >>>"---- | Emit a log start marker to the file.-putLogStartMarker :: Handle -> IO ()-putLogStartMarker = putMarkerMessage "<<< Logging start >>>"---- | Emit a log stop marker to the file and close it, then notify the--- application that we have stopped logging.-finishLog :: BChan MHEvent -> FilePath -> Handle -> StateT LogThreadState IO ()-finishLog eventChan oldPath oldHandle = do-    liftIO $ do-        putLogEndMarker oldHandle-        hClose oldHandle-        writeBChan eventChan $ IEvent $ LoggingStopped oldPath-    modify $ \s ->-      let buf = logThreadMessageBuffer s-          lastLm = Seq.index buf (Seq.length buf - 1) -- n.b. putLogEndMarker ensures buf not empty-          stops = rememberOutputPoint oldPath lastLm $ logPreviousStopPoint s-      in s { logThreadDestination = Nothing-           , logPreviousStopPoint = stops-           }--stopLogOutput :: StateT LogThreadState IO ()-stopLogOutput = do-    oldDest <- gets logThreadDestination-    case oldDest of-        Nothing -> return ()-        Just (oldPath, oldHandle) -> do-            eventChan <- gets logThreadEventChan-            finishLog eventChan oldPath oldHandle---- | Handle a single logging command.-handleLogCommand :: LogCommand -> StateT LogThreadState IO Bool-handleLogCommand (LogSnapshot path) = do-    -- LogSnapshot: write the current log message buffer to the-    -- specified path. Ignore the request if it is for the path that we-    -- are already logging to.-    eventChan <- gets logThreadEventChan-    dest <- gets logThreadDestination--    let shouldWrite = case dest of-          Nothing -> True-          Just (curPath, _) -> curPath /= path--    when shouldWrite $ do-        result <- liftIO $ try $ openFile path AppendMode-        case result of-            Left (e::SomeException) -> do-                liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotFailed path (show e)-            Right handle -> do-                flushLogMessageBuffer path handle-                liftIO $ hClose handle-                liftIO $ writeBChan eventChan $ IEvent $ LogSnapshotSucceeded path--    return True-handleLogCommand GetLogDestination = do-    -- GetLogDestination: the application asked us to provide the-    -- current log destination.-    dest <- gets logThreadDestination-    eventChan <- gets logThreadEventChan-    liftIO $ writeBChan eventChan $ IEvent $ LogDestination $ fst <$> dest-    return True-handleLogCommand ShutdownLogging = do-    -- ShutdownLogging: if we were logging to a file, close it. Then-    -- unlock the shutdown lock.-    stopLogOutput-    return False-handleLogCommand StopLogging = do-    -- StopLogging: if we were logging to a file, close it and notify-    -- the application. Otherwise do nothing.-    stopLogOutput-    return True-handleLogCommand (LogToFile newPath) = do-    -- LogToFile: if we were logging to a file, close that file, notify-    -- the application, then attempt to open the new file. If that-    -- failed, notify the application of the error. If it succeeded,-    -- start logging and notify the application.-    eventChan <- gets logThreadEventChan-    oldDest <- gets logThreadDestination--    shouldChange <- case oldDest of-        Nothing ->-            return True-        Just (oldPath, _) ->-            return (oldPath /= newPath)--    when shouldChange $ do-        result <- liftIO $ try $ openFile newPath AppendMode-        case result of-            Left (e::SomeException) -> liftIO $ do-                let msg = "Error in log thread: could not open " <> show newPath <>-                          ": " <> show e-                writeBChan eventChan $ IEvent $ LogStartFailed newPath msg-            Right handle -> do-                stopLogOutput--                modify $ \s -> s { logThreadDestination = Just (newPath, handle) }-                flushLogMessageBuffer newPath handle-                liftIO $ putLogStartMarker handle-                liftIO $ writeBChan eventChan $ IEvent $ LoggingStarted newPath--    return True-handleLogCommand (LogAMessage lm) = do-    -- LogAMessage: log a single message. Write the message to the-    -- bounded internal buffer (which may cause an older message to be-    -- evicted). Then, if we are actively logging to a file, write the-    -- message to that file and flush the output stream.-    maxBufSize <- gets logThreadMaxBufferSize--    let addMessageToBuffer s =-            -- Ensure that newSeq is always at most maxBufSize elements-            -- long.-            let newSeq = s Seq.|> lm-                toDrop = Seq.length s - maxBufSize-            in Seq.drop toDrop newSeq--    -- Append the message to the internal buffer, maintaining the bound-    -- on the internal buffer size.-    modify $ \s -> s { logThreadMessageBuffer = addMessageToBuffer (logThreadMessageBuffer s) }--    -- If we have an active log destination, write the message to the-    -- output file.-    dest <- gets logThreadDestination-    case dest of-        Nothing -> return ()-        Just (_, handle) -> liftIO $ do-            hPutLogMessage handle lm-            hFlush handle--    return True---- | Write a single log message to the output handle.-hPutLogMessage :: Handle -> LogMessage -> IO ()-hPutLogMessage handle (LogMessage {..}) = do-    hPutStr handle $ "[" <> show logMessageTimestamp <> "] "-    hPutStr handle $ "[" <> show logMessageCategory <> "] "-    case logMessageContext of-        Nothing -> hPutStr handle "[*] "-        Just c  -> hPutStr handle $ "[" <> show c <> "] "-    hPutStrLn handle $ T.unpack logMessageText---- | Flush the contents of the internal log message buffer.-flushLogMessageBuffer :: FilePath -> Handle -> StateT LogThreadState IO ()-flushLogMessageBuffer pathOfHandle handle = do-    buf <- gets logThreadMessageBuffer-    when (not $ Seq.null buf) $ do-      lastPoint <- memoryOfOutputPath pathOfHandle <$> gets logPreviousStopPoint-      case lastPoint of-        Nothing ->-          -- never logged to this output point before, so dump the-          -- current internal buffer of log messages to the beginning of-          -- the output file.-          dumpBuf buf-        Just lm ->-          -- There was previous logging to this file.  If the log buffer-          -- contains the entirety of the log messages during the-          -- logging disable, then just dump that portion; otherwise-          -- dump the entire buffer and indicate there may be missing-          -- entries before the buffer.-          let unseen = Seq.takeWhileR (not . (==) lm) buf-              firstM = Seq.index buf 0 -- above ensures that buf is not empty here-          in do when (Seq.length buf == Seq.length unseen) $ liftIO $-                  hPutStrLn handle $ mkMsg (logMessageTimestamp firstM)-                                     "<<< Potentially missing log messages here... >>>"-                dumpBuf unseen-      where-        mkMsg t m = "[" <> show t <> "] " <> m-        dumpBuf buf = liftIO $ do-          let firstLm = Seq.index buf 0-              lastLm = Seq.index buf (Seq.length buf - 1)--          hPutStrLn handle $ mkMsg (logMessageTimestamp firstLm)-                             "<<< Log message buffer begin >>>"--          forM_ buf (hPutLogMessage handle)--          hPutStrLn handle $ mkMsg (logMessageTimestamp lastLm)-                                   "<<< Log message buffer end >>>"--          hFlush handle
− src/State/ThemeListOverlay.hs 
@@ -1,86 +0,0 @@-module State.ThemeListOverlay-  ( enterThemeListMode--  , themeListSelectDown-  , themeListSelectUp-  , themeListPageDown-  , themeListPageUp--  , setTheme-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick ( invalidateCache )-import           Brick.Themes ( themeToAttrMap )-import qualified Brick.Widgets.List as L-import qualified Data.Text as T-import qualified Data.Vector as Vec-import           Lens.Micro.Platform ( (.=) )--import           Network.Mattermost.Types--import           State.ListOverlay-import           Themes-import           Types----- | Show the user list overlay with the given search scope, and issue a--- request to gather the first search results.-enterThemeListMode :: MH ()-enterThemeListMode =-    enterListOverlayMode csThemeListOverlay ThemeListOverlay () setInternalTheme getThemesMatching---- | Move the selection up in the user list overlay by one user.-themeListSelectUp :: MH ()-themeListSelectUp = themeListMove L.listMoveUp---- | Move the selection down in the user list overlay by one user.-themeListSelectDown :: MH ()-themeListSelectDown = themeListMove L.listMoveDown---- | Move the selection up in the user list overlay by a page of users--- (themeListPageSize).-themeListPageUp :: MH ()-themeListPageUp = themeListMove (L.listMoveBy (-1 * themeListPageSize))---- | Move the selection down in the user list overlay by a page of users--- (themeListPageSize).-themeListPageDown :: MH ()-themeListPageDown = themeListMove (L.listMoveBy themeListPageSize)---- | Transform the user list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-themeListMove :: (L.List Name InternalTheme -> L.List Name InternalTheme) -> MH ()-themeListMove = listOverlayMove csThemeListOverlay---- | The number of users in a "page" for cursor movement purposes.-themeListPageSize :: Int-themeListPageSize = 10--getThemesMatching :: ()-                  -> Session-                  -> Text-                  -> IO (Vec.Vector InternalTheme)-getThemesMatching _ _ searchString = do-    let matching = filter matches internalThemes-        search = T.toLower searchString-        matches t = search `T.isInfixOf` T.toLower (internalThemeName t) ||-                    search `T.isInfixOf` T.toLower (internalThemeDesc t)-    return $ Vec.fromList matching--setInternalTheme :: InternalTheme -> MH Bool-setInternalTheme t = do-    setTheme $ internalThemeName t-    return False--setTheme :: Text -> MH ()-setTheme name =-    case lookupTheme name of-        Nothing -> enterThemeListMode-        Just it -> do-            mh invalidateCache-            csResources.crTheme .= (themeToAttrMap $ internalTheme it)
− src/State/UrlSelect.hs 
@@ -1,48 +0,0 @@-module State.UrlSelect-  (-  -- * URL selection mode-    startUrlSelect-  , stopUrlSelect-  , openSelectedURL-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick.Widgets.List ( list, listMoveTo, listSelectedElement )-import qualified Data.Vector as V-import           Lens.Micro.Platform ( (.=), to )--import           State.Common-import           Types-import           Util---startUrlSelect :: MH ()-startUrlSelect = do-    urls <- use (csCurrentChannel.to findUrls.to V.fromList)-    setMode UrlSelect-    csUrlList .= (listMoveTo (length urls - 1) $ list UrlList urls 2)--stopUrlSelect :: MH ()-stopUrlSelect = setMode Main--openSelectedURL :: MH ()-openSelectedURL = whenMode UrlSelect $ do-    selected <- use (csUrlList.to listSelectedElement)-    case selected of-        Nothing -> return ()-        Just (_, link) -> do-            opened <- openURL (OpenLinkChoice link)-            when (not opened) $ do-                mhError $ ConfigOptionMissing "urlOpenCommand"-                setMode Main--findUrls :: ClientChannel -> [LinkChoice]-findUrls chan =-    let msgs = chan^.ccContents.cdMessages-    in removeDuplicates $ concat $ toList $ toList <$> msgURLs <$> msgs--removeDuplicates :: [LinkChoice] -> [LinkChoice]-removeDuplicates = nubOn (\ l -> (l^.linkURL, l^.linkUser))
− src/State/UserListOverlay.hs 
@@ -1,174 +0,0 @@-module State.UserListOverlay-  ( enterChannelMembersUserList-  , enterChannelInviteUserList-  , enterDMSearchUserList--  , userListSelectDown-  , userListSelectUp-  , userListPageDown-  , userListPageUp-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Brick.Widgets.List as L-import qualified Data.HashMap.Strict as HM-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import qualified Data.Vector as Vec-import           Lens.Micro.Platform ( (.~), (.=) )--import qualified Network.Mattermost.Endpoints as MM-import qualified Network.Mattermost.Types.Config as MM-import           Network.Mattermost.Types--import           State.Async ( doAsyncWith, AsyncPriority(Preempt) )-import           State.Channels ( createOrFocusDMChannel, addUserToCurrentChannel )-import           State.ListOverlay-import           Types----- | Show the user list overlay for searching/showing members of the--- current channel.-enterChannelMembersUserList :: MH ()-enterChannelMembersUserList = do-    cId <- use csCurrentChannelId-    myId <- gets myUserId-    myTId <- gets myTeamId-    session <- getSession--    doAsyncWith Preempt $ do-        stats <- MM.mmGetChannelStatistics cId session-        return $ Just $ do-            enterUserListMode (ChannelMembers cId myTId) (Just $ channelStatsMemberCount stats)-              (\u -> case u^.uiId /= myId of-                True -> createOrFocusDMChannel u Nothing >> return True-                False -> return False-              )---- | Show the user list overlay for showing users that are not members--- of the current channel for the purpose of adding them to the--- channel.-enterChannelInviteUserList :: MH ()-enterChannelInviteUserList = do-    cId <- use csCurrentChannelId-    myId <- gets myUserId-    myTId <- gets myTeamId-    enterUserListMode (ChannelNonMembers cId myTId) Nothing-      (\u -> case u^.uiId /= myId of-        True -> addUserToCurrentChannel u >> return True-        False -> return False-      )---- | Show the user list overlay for showing all users for the purpose of--- starting a direct message channel with another user.-enterDMSearchUserList :: MH ()-enterDMSearchUserList = do-    myId <- gets myUserId-    myTId <- gets myTeamId-    config <- use csClientConfig-    let restrictTeam = case MM.clientConfigRestrictDirectMessage <$> config of-            Just MM.RestrictTeam -> Just myTId-            _ -> Nothing-    enterUserListMode (AllUsers restrictTeam) Nothing-      (\u -> case u^.uiId /= myId of-        True -> createOrFocusDMChannel u Nothing >> return True-        False -> return False-      )---- | Show the user list overlay with the given search scope, and issue a--- request to gather the first search results.-enterUserListMode :: UserSearchScope -> Maybe Int -> (UserInfo -> MH Bool) -> MH ()-enterUserListMode scope resultCount enterHandler = do-    csUserListOverlay.listOverlayRecordCount .= resultCount-    enterListOverlayMode csUserListOverlay UserListOverlay scope enterHandler getUserSearchResults--userInfoFromPair :: User -> Text -> UserInfo-userInfoFromPair u status =-    userInfoFromUser u True & uiStatus .~ statusFromText status---- | Move the selection up in the user list overlay by one user.-userListSelectUp :: MH ()-userListSelectUp = userListMove L.listMoveUp---- | Move the selection down in the user list overlay by one user.-userListSelectDown :: MH ()-userListSelectDown = userListMove L.listMoveDown---- | Move the selection up in the user list overlay by a page of users--- (userListPageSize).-userListPageUp :: MH ()-userListPageUp = userListMove (L.listMoveBy (-1 * userListPageSize))---- | Move the selection down in the user list overlay by a page of users--- (userListPageSize).-userListPageDown :: MH ()-userListPageDown = userListMove (L.listMoveBy userListPageSize)---- | Transform the user list results in some way, e.g. by moving the--- cursor, and then check to see whether the modification warrants a--- prefetch of more search results.-userListMove :: (L.List Name UserInfo -> L.List Name UserInfo) -> MH ()-userListMove = listOverlayMove csUserListOverlay---- | The number of users in a "page" for cursor movement purposes.-userListPageSize :: Int-userListPageSize = 10--getUserSearchResults :: UserSearchScope-                     -- ^ The scope to search-                     -> Session-                     -- ^ The connection session-                     -> Text-                     -- ^ The search string-                     -> IO (Vec.Vector UserInfo)-getUserSearchResults scope s searchString = do-    -- Unfortunately, we don't get pagination control when there is a-    -- search string in effect. We'll get at most 100 results from a-    -- search.-    let query = UserSearch { userSearchTerm = if T.null searchString then " " else searchString-                           -- Hack alert: Searching with the string " "-                           -- above is a hack to use the search-                           -- endpoint to get "all users" instead of-                           -- those matching a particular non-empty-                           -- non-whitespace string. This is because-                           -- only the search endpoint provides a-                           -- control to eliminate deleted users from-                           -- the results. If we don't do this, and-                           -- use the /users endpoint instead, we'll-                           -- get deleted users in those results and-                           -- then those deleted users will disappear-                           -- from the results once the user enters a-                           -- non-empty string string.-                           , userSearchAllowInactive = False-                           , userSearchWithoutTeam = False-                           , userSearchInChannelId = case scope of-                               ChannelMembers cId _ -> Just cId-                               _                    -> Nothing-                           , userSearchNotInTeamId = Nothing-                           , userSearchNotInChannelId = case scope of-                               ChannelNonMembers cId _ -> Just cId-                               _                       -> Nothing-                           , userSearchTeamId = case scope of-                               AllUsers tId            -> tId-                               ChannelMembers _ tId    -> Just tId-                               ChannelNonMembers _ tId -> Just tId-                           }-    users <- MM.mmSearchUsers query s--    let uList = toList users-        uIds = userId <$> uList--    -- Now fetch status info for the users we got.-    case null uList of-        False -> do-            statuses <- MM.mmGetUserStatusByIds (Seq.fromList uIds) s-            let statusMap = HM.fromList [ (statusUserId e, statusStatus e) | e <- toList statuses ]-                usersWithStatus = [ userInfoFromPair u (fromMaybe "" $ HM.lookup (userId u) statusMap)-                                  | u <- uList-                                  ]--            return $ Vec.fromList usersWithStatus-        True -> return mempty
− src/State/Users.hs 
@@ -1,100 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module State.Users-  ( handleNewUsers-  , handleTypingUser-  , withFetchedUser-  , withFetchedUserMaybe-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.Text as T-import qualified Data.Foldable as F-import qualified Data.Sequence as Seq-import           Data.Time ( getCurrentTime )-import           Lens.Micro.Platform--import qualified Network.Mattermost.Endpoints as MM-import           Network.Mattermost.Types--import           Config-import           Types--import           State.Common---handleNewUsers :: Seq UserId -> MH () -> MH ()-handleNewUsers newUserIds after = do-    doAsyncMM Preempt getUserInfo addNewUsers-    where getUserInfo session =-              do nUsers <- MM.mmGetUsersByIds newUserIds session-                 let usrInfo u = userInfoFromUser u True-                     usrList = toList nUsers-                 return $ usrInfo <$> usrList--          addNewUsers :: [UserInfo] -> Maybe (MH ())-          addNewUsers is = Just $ mapM_ addNewUser is >> after---- | Handle the typing events from the websocket to show the currently--- typing users on UI-handleTypingUser :: UserId -> ChannelId -> MH ()-handleTypingUser uId cId = do-    config <- use (csResources.crConfiguration)-    when (configShowTypingIndicator config) $ do-        withFetchedUser (UserFetchById uId) $ const $ do-            ts <- liftIO getCurrentTime-            csChannels %= modifyChannelById cId (addChannelTypingUser uId ts)---- | Given a user fetching strategy, locate the user in the state or--- fetch it from the server, and pass the result to the specified--- action. Assumes a single match is the only expected/valid result.-withFetchedUser :: UserFetch -> (UserInfo -> MH ()) -> MH ()-withFetchedUser fetch handle =-    withFetchedUserMaybe fetch $ \u -> do-        case u of-            Nothing -> postErrorMessage' "No such user"-            Just user -> handle user--withFetchedUserMaybe :: UserFetch -> (Maybe UserInfo -> MH ()) -> MH ()-withFetchedUserMaybe fetch handle = do-    st <- use id-    session <- getSession--    let localMatch = case fetch of-            UserFetchById uId -> userById uId st-            UserFetchByUsername uname -> userByUsername uname st-            UserFetchByNickname nick -> userByNickname nick st--    case localMatch of-        Just user -> handle $ Just user-        Nothing -> do-            mhLog LogGeneral $ T.pack $ "withFetchedUserMaybe: getting " <> show fetch-            doAsyncWith Normal $ do-                results <- case fetch of-                    UserFetchById uId ->-                        MM.mmGetUsersByIds (Seq.singleton uId) session-                    UserFetchByUsername uname ->-                        MM.mmGetUsersByUsernames (Seq.singleton $ trimUserSigil uname) session-                    UserFetchByNickname nick -> do-                        let req = UserSearch { userSearchTerm = trimUserSigil nick-                                             , userSearchAllowInactive = True-                                             , userSearchWithoutTeam = True-                                             , userSearchInChannelId = Nothing-                                             , userSearchNotInTeamId = Nothing-                                             , userSearchNotInChannelId = Nothing-                                             , userSearchTeamId = Nothing-                                             }-                        MM.mmSearchUsers req session--                return $ Just $ do-                    infos <- forM (F.toList results) $ \u -> do-                        let info = userInfoFromUser u True-                        addNewUser info-                        return info--                    case infos of-                        [match] -> handle $ Just match-                        [] -> handle Nothing-                        _ -> postErrorMessage' "Error: ambiguous user information"
− src/TeamSelect.hs 
@@ -1,90 +0,0 @@-module TeamSelect-  ( interactiveTeamSelection-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border-import           Brick.Widgets.Center-import           Brick.Widgets.List-import qualified Data.Function as F-import           Data.List ( sortBy )-import qualified Data.Vector as V-import           Graphics.Vty hiding (mkVty)-import qualified Data.Text as T--import           Network.Mattermost.Types--import           Draw.RichText-import           Types.Common---data State =-    State { appList :: List () Team-          , appCancelled :: Bool-          }--interactiveTeamSelection :: Vty -> IO Vty -> [Team] -> IO (Maybe Team, Vty)-interactiveTeamSelection vty mkVty teams = do-    let state = State { appList = list () (V.fromList sortedTeams) 1-                      , appCancelled = False-                      }-        sortedTeams = sortBy (compare `F.on` teamName) teams--    (finalSt, finalVty) <- customMainWithVty vty mkVty Nothing app state--    let result = if appCancelled finalSt-                 then Nothing-                 else snd <$> listSelectedElement (appList finalSt)--    return (result, finalVty)--app :: App State e ()-app = App-  { appDraw         = teamSelectDraw-  , appChooseCursor = neverShowCursor-  , appHandleEvent  = onEvent-  , appStartEvent   = return-  , appAttrMap      = const colorTheme-  }--colorTheme :: AttrMap-colorTheme = attrMap defAttr-  [ (listSelectedFocusedAttr, black `on` yellow)-  ]--teamSelectDraw :: State -> [Widget ()]-teamSelectDraw st =-    [ teamSelect st-    ]--teamSelect :: State -> Widget ()-teamSelect st =-    center $ hLimit 50 $ vLimit 15 $-    vBox [ hCenter $ txt "Welcome to Mattermost. Please select a team:"-         , txt " "-         , border theList-         , txt " "-         , renderText "Press Enter to select a team and connect or Esc to exit."-         ]-    where-    theList = renderList renderTeamItem True (appList st)--renderTeamItem :: Bool -> Team -> Widget ()-renderTeamItem _ t =-    padRight Max $ txt $ (sanitizeUserText $ teamName t) <>-        if not $ T.null (sanitizeUserText $ teamDisplayName t)-        then " (" <> (sanitizeUserText $ teamDisplayName t) <> ")"-        else ""--onEvent :: State -> BrickEvent () e -> EventM () (Next State)-onEvent st (VtyEvent (EvKey KEsc [])) = do-    halt $ st { appCancelled = True }-onEvent st (VtyEvent (EvKey KEnter [])) = halt st-onEvent st (VtyEvent e) = do-    list' <- handleListEvent e (appList st)-    continue $ st { appList = list' }-onEvent st _ = continue st
− src/Themes.hs 
@@ -1,772 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module Themes-  ( InternalTheme(..)--  , defaultTheme-  , internalThemes-  , lookupTheme-  , themeDocs--  -- * Attribute names-  , currentUserAttr-  , timeAttr-  , channelHeaderAttr-  , channelListHeaderAttr-  , currentChannelNameAttr-  , unreadChannelAttr-  , unreadGroupMarkerAttr-  , mentionsChannelAttr-  , urlAttr-  , codeAttr-  , emailAttr-  , emojiAttr-  , channelNameAttr-  , clientMessageAttr-  , clientHeaderAttr-  , clientEmphAttr-  , clientStrongAttr-  , dateTransitionAttr-  , pinnedMessageIndicatorAttr-  , newMessageTransitionAttr-  , gapMessageAttr-  , errorMessageAttr-  , helpAttr-  , helpEmphAttr-  , channelSelectPromptAttr-  , channelSelectMatchAttr-  , completionAlternativeListAttr-  , completionAlternativeCurrentAttr-  , dialogAttr-  , dialogEmphAttr-  , recentMarkerAttr-  , replyParentAttr-  , loadMoreAttr-  , urlListSelectedAttr-  , messageSelectAttr-  , messageSelectStatusAttr-  , misspellingAttr-  , editedMarkingAttr-  , editedRecentlyMarkingAttr-  , tabSelectedAttr-  , tabUnselectedAttr--  -- * Username formatting-  , colorUsername-  , attrForUsername-  , usernameColorHashBuckets-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Themes-import           Brick.Widgets.List-import qualified Brick.Widgets.FileBrowser as FB-import           Brick.Widgets.Skylighting ( attrNameForTokenType-                                           , attrMappingsForStyle-                                           , highlightedCodeBlockAttr-                                           )-import           Brick.Forms ( focusedFormInputAttr )-import           Data.Hashable ( hash )-import qualified Data.Map as M-import qualified Data.Text as T-import           Graphics.Vty-import qualified Skylighting.Styles as Sky-import           Skylighting.Types ( TokenType(..) )--import           Types ( InternalTheme(..), specialUserMentions )---helpAttr :: AttrName-helpAttr = "help"--helpEmphAttr :: AttrName-helpEmphAttr = "helpEmphasis"--recentMarkerAttr :: AttrName-recentMarkerAttr = "recentChannelMarker"--replyParentAttr :: AttrName-replyParentAttr = "replyParentPreview"--pinnedMessageIndicatorAttr :: AttrName-pinnedMessageIndicatorAttr = "pinnedMessageIndicator"--loadMoreAttr :: AttrName-loadMoreAttr = "loadMoreMessages"--urlListSelectedAttr :: AttrName-urlListSelectedAttr = "urlListCursor"--messageSelectAttr :: AttrName-messageSelectAttr = "messageSelectCursor"--editedMarkingAttr :: AttrName-editedMarkingAttr = "editedMarking"--editedRecentlyMarkingAttr :: AttrName-editedRecentlyMarkingAttr = "editedRecentlyMarking"--dialogAttr :: AttrName-dialogAttr = "dialog"--dialogEmphAttr :: AttrName-dialogEmphAttr = "dialogEmphasis"--channelSelectMatchAttr :: AttrName-channelSelectMatchAttr = "channelSelectMatch"--channelSelectPromptAttr :: AttrName-channelSelectPromptAttr = "channelSelectPrompt"--completionAlternativeListAttr :: AttrName-completionAlternativeListAttr = "tabCompletionAlternative"--completionAlternativeCurrentAttr :: AttrName-completionAlternativeCurrentAttr = "tabCompletionCursor"--timeAttr :: AttrName-timeAttr = "time"--currentUserAttr :: AttrName-currentUserAttr = "currentUser"--channelHeaderAttr :: AttrName-channelHeaderAttr = "channelHeader"--channelListHeaderAttr :: AttrName-channelListHeaderAttr = "channelListSectionHeader"--currentChannelNameAttr :: AttrName-currentChannelNameAttr = "currentChannelName"--channelNameAttr :: AttrName-channelNameAttr = "channelName"--unreadChannelAttr :: AttrName-unreadChannelAttr = "unreadChannel"--unreadGroupMarkerAttr :: AttrName-unreadGroupMarkerAttr = "unreadChannelGroupMarker"--mentionsChannelAttr :: AttrName-mentionsChannelAttr = "channelWithMentions"--tabSelectedAttr :: AttrName-tabSelectedAttr = "tabSelected"--tabUnselectedAttr :: AttrName-tabUnselectedAttr = "tabUnselected"--dateTransitionAttr :: AttrName-dateTransitionAttr = "dateTransition"--newMessageTransitionAttr :: AttrName-newMessageTransitionAttr = "newMessageTransition"--urlAttr :: AttrName-urlAttr = "url"--codeAttr :: AttrName-codeAttr = "codeBlock"--emailAttr :: AttrName-emailAttr = "email"--emojiAttr :: AttrName-emojiAttr = "emoji"--clientMessageAttr :: AttrName-clientMessageAttr = "clientMessage"--clientHeaderAttr :: AttrName-clientHeaderAttr = "markdownHeader"--clientEmphAttr :: AttrName-clientEmphAttr = "markdownEmph"--clientStrongAttr :: AttrName-clientStrongAttr = "markdownStrong"--errorMessageAttr :: AttrName-errorMessageAttr = "errorMessage"--gapMessageAttr :: AttrName-gapMessageAttr = "gapMessage"--misspellingAttr :: AttrName-misspellingAttr = "misspelling"--messageSelectStatusAttr :: AttrName-messageSelectStatusAttr = "messageSelectStatus"--lookupTheme :: Text -> Maybe InternalTheme-lookupTheme n = find ((== n) . internalThemeName) internalThemes--internalThemes :: [InternalTheme]-internalThemes = validateInternalTheme <$>-    [ darkColorTheme-    , darkColor256Theme-    , lightColorTheme-    , lightColor256Theme-    ]--validateInternalTheme :: InternalTheme -> InternalTheme-validateInternalTheme it =-    let un = undocumentedAttrNames (internalTheme it)-    in if not $ null un-       then error $ "Internal theme " <> show (T.unpack (internalThemeName it)) <>-                    " references undocumented attribute names: " <> show un-       else it--undocumentedAttrNames :: Theme -> [AttrName]-undocumentedAttrNames t =-    let noDocs k = isNothing $ attrNameDescription themeDocs k-    in filter noDocs (M.keys $ themeDefaultMapping t)--defaultTheme :: InternalTheme-defaultTheme = darkColorTheme--lightColorTheme :: InternalTheme-lightColorTheme = InternalTheme name theme desc-    where-        theme = newTheme def $ lightAttrs usernameColors16-        name = "builtin:light"-        def = black `on` white-        desc = "A color theme for terminal windows with light background colors"--lightColor256Theme :: InternalTheme-lightColor256Theme = InternalTheme name theme desc-    where-        theme = newTheme def $ lightAttrs usernameColors256-        name = "builtin:light256"-        def = black `on` white-        desc = "Like builtin:light, but with 256-color username colors"--lightAttrs :: [Attr] -> [(AttrName, Attr)]-lightAttrs usernameColors =-    let sty = Sky.kate-    in [ (timeAttr,                         fg black)-       , (currentUserAttr,                  defAttr `withStyle` bold)-       , (channelHeaderAttr,                fg black `withStyle` underline)-       , (channelListHeaderAttr,            fg cyan)-       , (currentChannelNameAttr,           black `on` yellow `withStyle` bold)-       , (unreadChannelAttr,                black `on` cyan   `withStyle` bold)-       , (unreadGroupMarkerAttr,            fg black `withStyle` bold)-       , (mentionsChannelAttr,              black `on` red    `withStyle` bold)-       , (urlAttr,                          fg brightYellow)-       , (emailAttr,                        fg yellow)-       , (codeAttr,                         fg magenta)-       , (emojiAttr,                        fg yellow)-       , (channelNameAttr,                  fg blue)-       , (clientMessageAttr,                fg black)-       , (clientEmphAttr,                   fg black `withStyle` bold)-       , (clientStrongAttr,                 fg black `withStyle` bold `withStyle` underline)-       , (clientHeaderAttr,                 fg red `withStyle` bold)-       , (dateTransitionAttr,               fg green)-       , (newMessageTransitionAttr,         black `on` yellow)-       , (errorMessageAttr,                 fg red)-       , (gapMessageAttr,                   fg red)-       , (helpAttr,                         fg black)-       , (pinnedMessageIndicatorAttr,       black `on` cyan)-       , (helpEmphAttr,                     fg blue `withStyle` bold)-       , (channelSelectMatchAttr,           black `on` magenta)-       , (channelSelectPromptAttr,          fg black)-       , (completionAlternativeListAttr,    white `on` blue)-       , (completionAlternativeCurrentAttr, black `on` yellow)-       , (dialogAttr,                       black `on` cyan)-       , (dialogEmphAttr,                   fg white)-       , (listSelectedFocusedAttr,          black `on` yellow)-       , (recentMarkerAttr,                 fg black `withStyle` bold)-       , (loadMoreAttr,                     black `on` cyan)-       , (urlListSelectedAttr,              black `on` yellow)-       , (messageSelectAttr,                black `on` yellow)-       , (messageSelectStatusAttr,          fg black)-       , (misspellingAttr,                  fg red `withStyle` underline)-       , (editedMarkingAttr,                fg yellow)-       , (editedRecentlyMarkingAttr,        black `on` yellow)-       , (tabSelectedAttr,                  black `on` yellow)-       , (focusedFormInputAttr,             black `on` yellow)-       , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue)-       , (FB.fileBrowserSelectionInfoAttr,  white `on` blue)-       , (FB.fileBrowserDirectoryAttr,      fg blue)-       , (FB.fileBrowserBlockDeviceAttr,    fg magenta)-       , (FB.fileBrowserCharacterDeviceAttr, fg green)-       , (FB.fileBrowserNamedPipeAttr,      fg yellow)-       , (FB.fileBrowserSymbolicLinkAttr,   fg cyan)-       , (FB.fileBrowserUnixSocketAttr,     fg red)-       ] <>-       ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..usernameColorHashBuckets-1] (cycle usernameColors)) <>-       (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty)--darkAttrs :: [Attr] -> [(AttrName, Attr)]-darkAttrs usernameColors =-  let sty = Sky.espresso-  in [ (timeAttr,                         fg white)-     , (currentUserAttr,                  defAttr `withStyle` bold)-     , (channelHeaderAttr,                fg white `withStyle` underline)-     , (channelListHeaderAttr,            fg cyan)-     , (currentChannelNameAttr,           black `on` yellow `withStyle` bold)-     , (unreadChannelAttr,                black `on` cyan   `withStyle` bold)-     , (unreadGroupMarkerAttr,            fg white `withStyle` bold)-     , (mentionsChannelAttr,              black `on` brightMagenta `withStyle` bold)-     , (urlAttr,                          fg yellow)-     , (emailAttr,                        fg yellow)-     , (codeAttr,                         fg magenta)-     , (emojiAttr,                        fg yellow)-     , (channelNameAttr,                  fg cyan)-     , (pinnedMessageIndicatorAttr,       fg cyan `withStyle` bold)-     , (clientMessageAttr,                fg white)-     , (clientEmphAttr,                   fg white `withStyle` bold)-     , (clientStrongAttr,                 fg white `withStyle` bold `withStyle` underline)-     , (clientHeaderAttr,                 fg red `withStyle` bold)-     , (dateTransitionAttr,               fg green)-     , (newMessageTransitionAttr,         fg yellow `withStyle` bold)-     , (errorMessageAttr,                 fg red)-     , (gapMessageAttr,                   black `on` yellow)-     , (helpAttr,                         fg white)-     , (helpEmphAttr,                     fg cyan `withStyle` bold)-     , (channelSelectMatchAttr,           black `on` magenta)-     , (channelSelectPromptAttr,          fg white)-     , (completionAlternativeListAttr,    white `on` blue)-     , (completionAlternativeCurrentAttr, black `on` yellow)-     , (dialogAttr,                       black `on` cyan)-     , (dialogEmphAttr,                   fg white)-     , (listSelectedFocusedAttr,          black `on` yellow)-     , (recentMarkerAttr,                 fg yellow `withStyle` bold)-     , (loadMoreAttr,                     black `on` cyan)-     , (urlListSelectedAttr,              black `on` yellow)-     , (messageSelectAttr,                black `on` yellow)-     , (messageSelectStatusAttr,          fg white)-     , (misspellingAttr,                  fg red `withStyle` underline)-     , (editedMarkingAttr,                fg yellow)-     , (editedRecentlyMarkingAttr,        black `on` yellow)-     , (tabSelectedAttr,                  black `on` yellow)-     , (focusedFormInputAttr,             black `on` yellow)-     , (FB.fileBrowserCurrentDirectoryAttr, white `on` blue)-     , (FB.fileBrowserSelectionInfoAttr,  white `on` blue)-     , (FB.fileBrowserDirectoryAttr,      fg blue)-     , (FB.fileBrowserBlockDeviceAttr,    fg magenta)-     , (FB.fileBrowserCharacterDeviceAttr, fg green)-     , (FB.fileBrowserNamedPipeAttr,      fg yellow)-     , (FB.fileBrowserSymbolicLinkAttr,   fg cyan)-     , (FB.fileBrowserUnixSocketAttr,     fg red)-     ] <>-     ((\(i, a) -> (usernameAttr i, a)) <$> zip [0..usernameColorHashBuckets-1] (cycle usernameColors)) <>-     (filter skipBaseCodeblockAttr $ attrMappingsForStyle sty)--skipBaseCodeblockAttr :: (AttrName, Attr) -> Bool-skipBaseCodeblockAttr = ((/= highlightedCodeBlockAttr) . fst)--darkColorTheme :: InternalTheme-darkColorTheme = InternalTheme name theme desc-    where-        theme = newTheme def $ darkAttrs usernameColors16-        name = "builtin:dark"-        def = defAttr-        desc = "A color theme for terminal windows with dark background colors"--darkColor256Theme :: InternalTheme-darkColor256Theme = InternalTheme name theme desc-    where-        theme = newTheme def $ darkAttrs usernameColors256-        name = "builtin:dark256"-        def = defAttr-        desc = "Like builtin:dark, but with 256-color username colors"--usernameAttr :: Int -> AttrName-usernameAttr i = "username" <> (attrName $ show i)---- | Render a string with a color chosen based on the text of a--- username.------ This function takes some display text and renders it using an--- attribute based on the username associated with the text. If the--- username associated with the text is equal to the username of--- the user running Matterhorn, the display text is formatted with--- 'currentAttr'. Otherwise it is formatted with an attribute chosen--- by hashing the associated username and choosing from amongst the--- username color hash buckets with 'usernameAttr'.------ Usually the first argument to this function will be @myUsername st@,--- where @st@ is a 'ChatState'.------ The most common way to call this function is------ @colorUsername (myUsername st) u u------ The third argument is allowed to vary from the second since sometimes--- we call this with the user's status sigil as the third argument.-colorUsername :: Text-              -- ^ The username for the user currently running-              -- Matterhorn-              -> Text-              -- ^ The username associated with the text to render-              -> Text-              -- ^ The text to render-              -> Widget a-colorUsername current username display =-    let aName = attrForUsername username-        maybeWithCurrentAttr = if current == username-                               then withAttr currentUserAttr-                               else id-    in withDefAttr aName $-       maybeWithCurrentAttr $-       txt (display)---- | Return the attribute name to use for the specified username.--- The input username is expected to be the username only (i.e. no--- sigil).------ If the input username is a special reserved username such as "all",--- the @clientEmphAttr@ attribute name will be returned. Otherwise--- a hash-bucket username attribute name will be returned based on--- the hash value of the username and the number of hash buckets--- (@usernameColorHashBuckets@).-attrForUsername :: Text-                -- ^ The username to get an attribute for-                -> AttrName-attrForUsername username =-    let normalizedUsername = T.toLower username-        aName = if normalizedUsername `elem` specialUserMentions-                then clientEmphAttr-                else usernameAttr h-        h = hash normalizedUsername `mod` usernameColorHashBuckets-    in aName---- | The number of hash buckets to use when hashing usernames to choose--- their colors.-usernameColorHashBuckets :: Int-usernameColorHashBuckets = 50--usernameColors16 :: [Attr]-usernameColors16 =-    [ fg red-    , fg green-    , fg yellow-    , fg blue-    , fg magenta-    , fg cyan-    , fg brightRed-    , fg brightGreen-    , fg brightYellow-    , fg brightBlue-    , fg brightMagenta-    , fg brightCyan-    ]--usernameColors256 :: [Attr]-usernameColors256 = mkColor <$> username256ColorChoices-    where-        mkColor (r, g, b) = defAttr `withForeColor` rgbColor r g b--username256ColorChoices :: [(Integer, Integer, Integer)]-username256ColorChoices =-    [ (255, 0, 86)-    , (158, 0, 142)-    , (14, 76, 161)-    , (255, 229, 2)-    , (149, 0, 58)-    , (255, 147, 126)-    , (164, 36, 0)-    , (98, 14, 0)-    , (0, 0, 255)-    , (106, 130, 108)-    , (0, 174, 126)-    , (194, 140, 159)-    , (0, 143, 156)-    , (95, 173, 78)-    , (255, 2, 157)-    , (255, 116, 163)-    , (152, 255, 82)-    , (167, 87, 64)-    , (254, 137, 0)-    , (1, 208, 255)-    , (187, 136, 0)-    , (117, 68, 177)-    , (165, 255, 210)-    , (122, 71, 130)-    , (0, 71, 84)-    , (181, 0, 255)-    , (144, 251, 146)-    , (189, 211, 147)-    , (229, 111, 254)-    , (222, 255, 116)-    , (0, 255, 120)-    , (0, 155, 255)-    , (0, 100, 1)-    , (0, 118, 255)-    , (133, 169, 0)-    , (0, 185, 23)-    , (120, 130, 49)-    , (0, 255, 198)-    , (255, 110, 65)-    ]---- Functions for dealing with Skylighting styles--attrNameDescription :: ThemeDocumentation -> AttrName -> Maybe Text-attrNameDescription td an = M.lookup an (themeDescriptions td)--themeDocs :: ThemeDocumentation-themeDocs = ThemeDocumentation $ M.fromList $-    [ ( timeAttr-      , "Timestamps on chat messages"-      )-    , ( channelHeaderAttr-      , "Channel headers displayed above chat message lists"-      )-    , ( channelListHeaderAttr-      , "The heading of the channel list sections"-      )-    , ( currentChannelNameAttr-      , "The currently selected channel in the channel list"-      )-    , ( unreadChannelAttr-      , "A channel in the channel list with unread messages"-      )-    , ( unreadGroupMarkerAttr-      , "The channel group marker indicating unread messages"-      )-    , ( mentionsChannelAttr-      , "A channel in the channel list with unread mentions"-      )-    , ( urlAttr-      , "A URL in a chat message"-      )-    , ( codeAttr-      , "A code block in a chat message with no language indication"-      )-    , ( emailAttr-      , "An e-mail address in a chat message"-      )-    , ( emojiAttr-      , "A text emoji indication in a chat message"-      )-    , ( channelNameAttr-      , "A channel name in a chat message"-      )-    , ( clientMessageAttr-      , "A Matterhorn diagnostic or informative message"-      )-    , ( clientHeaderAttr-      , "Markdown heading"-      )-    , ( clientEmphAttr-      , "Markdown 'emphasized' text"-      )-    , ( clientStrongAttr-      , "Markdown 'strong' text"-      )-    , ( dateTransitionAttr-      , "Date transition lines between chat messages on different days"-      )-    , ( pinnedMessageIndicatorAttr-      , "The indicator for messages that have been pinned"-      )-    , ( newMessageTransitionAttr-      , "The 'New Messages' line that appears above unread messages"-      )-    , ( tabSelectedAttr-      , "Selected tabs in tabbed windows"-      )-    , ( tabUnselectedAttr-      , "Unselected tabs in tabbed windows"-      )-    , ( errorMessageAttr-      , "Matterhorn error messages"-      )-    , ( gapMessageAttr-      , "Matterhorn message gap information"-      )-    , ( helpAttr-      , "The help screen text"-      )-    , ( helpEmphAttr-      , "The help screen's emphasized text"-      )-    , ( channelSelectPromptAttr-      , "Channel selection: prompt"-      )-    , ( channelSelectMatchAttr-      , "Channel selection: the portion of a channel name that matches"-      )-    , ( completionAlternativeListAttr-      , "Tab completion alternatives"-      )-    , ( completionAlternativeCurrentAttr-      , "The currently-selected tab completion alternative"-      )-    , ( dialogAttr-      , "Dialog box text"-      )-    , ( dialogEmphAttr-      , "Dialog box emphasized text"-      )-    , ( recentMarkerAttr-      , "The marker indicating the channel last visited"-      )-    , ( replyParentAttr-      , "The first line of parent messages appearing above reply messages"-      )-    , ( loadMoreAttr-      , "The 'Load More' line that appears at the top of a chat message list"-      )-    , ( urlListSelectedAttr-      , "URL list: the selected URL"-      )-    , ( messageSelectAttr-      , "Message selection: the currently-selected message"-      )-    , ( messageSelectStatusAttr-      , "Message selection: the message selection actions"-      )-    , ( misspellingAttr-      , "A misspelled word in the chat message editor"-      )-    , ( editedMarkingAttr-      , "The 'edited' marking that appears on edited messages"-      )-    , ( editedRecentlyMarkingAttr-      , "The 'edited' marking that appears on newly-edited messages"-      )-    , ( highlightedCodeBlockAttr-      , "The base attribute for syntax-highlighted code blocks"-      )-    , ( attrNameForTokenType KeywordTok-      , "Syntax highlighting: Keyword"-      )-    , ( attrNameForTokenType DataTypeTok-      , "Syntax highlighting: DataType"-      )-    , ( attrNameForTokenType DecValTok-      , "Syntax highlighting: Declaration"-      )-    , ( attrNameForTokenType BaseNTok-      , "Syntax highlighting: BaseN"-      )-    , ( attrNameForTokenType FloatTok-      , "Syntax highlighting: Float"-      )-    , ( attrNameForTokenType ConstantTok-      , "Syntax highlighting: Constant"-      )-    , ( attrNameForTokenType CharTok-      , "Syntax highlighting: Char"-      )-    , ( attrNameForTokenType SpecialCharTok-      , "Syntax highlighting: Special Char"-      )-    , ( attrNameForTokenType StringTok-      , "Syntax highlighting: String"-      )-    , ( attrNameForTokenType VerbatimStringTok-      , "Syntax highlighting: Verbatim String"-      )-    , ( attrNameForTokenType SpecialStringTok-      , "Syntax highlighting: Special String"-      )-    , ( attrNameForTokenType ImportTok-      , "Syntax highlighting: Import"-      )-    , ( attrNameForTokenType CommentTok-      , "Syntax highlighting: Comment"-      )-    , ( attrNameForTokenType DocumentationTok-      , "Syntax highlighting: Documentation"-      )-    , ( attrNameForTokenType AnnotationTok-      , "Syntax highlighting: Annotation"-      )-    , ( attrNameForTokenType CommentVarTok-      , "Syntax highlighting: Comment"-      )-    , ( attrNameForTokenType OtherTok-      , "Syntax highlighting: Other"-      )-    , ( attrNameForTokenType FunctionTok-      , "Syntax highlighting: Function"-      )-    , ( attrNameForTokenType VariableTok-      , "Syntax highlighting: Variable"-      )-    , ( attrNameForTokenType ControlFlowTok-      , "Syntax highlighting: Control Flow"-      )-    , ( attrNameForTokenType OperatorTok-      , "Syntax highlighting: Operator"-      )-    , ( attrNameForTokenType BuiltInTok-      , "Syntax highlighting: Built-In"-      )-    , ( attrNameForTokenType ExtensionTok-      , "Syntax highlighting: Extension"-      )-    , ( attrNameForTokenType PreprocessorTok-      , "Syntax highlighting: Preprocessor"-      )-    , ( attrNameForTokenType AttributeTok-      , "Syntax highlighting: Attribute"-      )-    , ( attrNameForTokenType RegionMarkerTok-      , "Syntax highlighting: Region Marker"-      )-    , ( attrNameForTokenType InformationTok-      , "Syntax highlighting: Information"-      )-    , ( attrNameForTokenType WarningTok-      , "Syntax highlighting: Warning"-      )-    , ( attrNameForTokenType AlertTok-      , "Syntax highlighting: Alert"-      )-    , ( attrNameForTokenType ErrorTok-      , "Syntax highlighting: Error"-      )-    , ( attrNameForTokenType NormalTok-      , "Syntax highlighting: Normal text"-      )-    , ( listSelectedFocusedAttr-      , "The selected channel"-      )-    , ( focusedFormInputAttr-      , "A form input that has focus"-      )-    , ( FB.fileBrowserAttr-      , "The base file browser attribute"-      )-    , ( FB.fileBrowserCurrentDirectoryAttr-      , "The file browser current directory attribute"-      )-    , ( FB.fileBrowserSelectionInfoAttr-      , "The file browser selection information attribute"-      )-    , ( FB.fileBrowserDirectoryAttr-      , "Attribute for directories in the file browser"-      )-    , ( FB.fileBrowserBlockDeviceAttr-      , "Attribute for block devices in the file browser"-      )-    , ( FB.fileBrowserRegularFileAttr-      , "Attribute for regular files in the file browser"-      )-    , ( FB.fileBrowserCharacterDeviceAttr-      , "Attribute for character devices in the file browser"-      )-    , ( FB.fileBrowserNamedPipeAttr-      , "Attribute for named pipes in the file browser"-      )-    , ( FB.fileBrowserSymbolicLinkAttr-      , "Attribute for symbolic links in the file browser"-      )-    , ( FB.fileBrowserUnixSocketAttr-      , "Attribute for Unix sockets in the file browser"-      )-    , ( currentUserAttr-      , "Attribute for the username of the user running Matterhorn"-      )-    ] <> [ (usernameAttr i, T.pack $ "Username color " <> show i)-         | i <- [0..usernameColorHashBuckets-1]-         ]
− src/TimeUtils.hs 
@@ -1,70 +0,0 @@-module TimeUtils-    ( lookupLocalTimeZone-    , startOfDay-    , justAfter, justBefore-    , asLocalTime-    , localTimeText-    , originTime-    )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.Text as T-import           Data.Time.Clock ( UTCTime(..) )-import           Data.Time.Format ( formatTime, defaultTimeLocale )-import           Data.Time.LocalTime ( LocalTime(..), TimeOfDay(..) )-import           Data.Time.LocalTime.TimeZone.Olson ( getTimeZoneSeriesFromOlsonFile )-import           Data.Time.LocalTime.TimeZone.Series ( localTimeToUTC'-                                                     , utcToLocalTime')--import           Network.Mattermost.Types ( ServerTime(..) )----- | Get the timezone series that should be used for converting UTC--- times into local times with appropriate DST adjustments.-lookupLocalTimeZone :: IO TimeZoneSeries-lookupLocalTimeZone = getTimeZoneSeriesFromOlsonFile "/etc/localtime"----- | Sometimes it is convenient to render a divider between messages;--- the 'justAfter' function can be used to get a time that is after--- the input time but by such a small increment that there is unlikely--- to be anything between (or at) the result.  Adding the divider--- using this timestamp value allows the general sorting based on--- timestamps to operate normally (whereas a type-match for a--- non-timestamp-entry in the sort operation would be considerably--- more complex).-justAfter :: ServerTime -> ServerTime-justAfter = ServerTime . justAfterUTC . withServerTime-    where justAfterUTC time = let UTCTime d t = time in UTCTime d (succ t)---- | Obtain a time value that is just moments before the input time;--- see the comment for the 'justAfter' function for more details.-justBefore :: ServerTime -> ServerTime-justBefore = ServerTime . justBeforeUTC . withServerTime-    where justBeforeUTC time = let UTCTime d t = time in UTCTime d (pred t)---- | The timestamp for the start of the day associated with the input--- timestamp.  If timezone information is supplied, then the returned--- value will correspond to when the day started in that timezone;--- otherwise it is the start of the day in a timezone aligned with--- UTC.-startOfDay :: Maybe TimeZoneSeries -> UTCTime -> UTCTime-startOfDay Nothing time = let UTCTime d _ = time in UTCTime d 0-startOfDay (Just tz) time = let lt = utcToLocalTime' tz time-                                ls = LocalTime (localDay lt) (TimeOfDay 0 0 0)-                            in localTimeToUTC' tz ls---- | Convert a UTC time value to a local time.-asLocalTime :: TimeZoneSeries -> UTCTime -> LocalTime-asLocalTime = utcToLocalTime'---- | Local time in displayable format-localTimeText :: Text -> LocalTime -> Text-localTimeText fmt time = T.pack $ formatTime defaultTimeLocale (T.unpack fmt) time---- | Provides a time value that can be used when there are no other times available-originTime :: UTCTime-originTime = UTCTime (toEnum 0) 0
− src/Types.hs 
@@ -1,2068 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-}-module Types-  ( ConnectionStatus(..)-  , HelpTopic(..)-  , MessageSelectState(..)-  , ProgramOutput(..)-  , MHEvent(..)-  , InternalEvent(..)-  , Name(..)-  , ChannelSelectMatch(..)-  , StartupStateInfo(..)-  , MHError(..)-  , AttachmentData(..)-  , CPUUsagePolicy(..)-  , tabbedWindow-  , getCurrentTabbedWindowEntry-  , tabbedWindowNextTab-  , tabbedWindowPreviousTab-  , runTabShowHandlerFor-  , TabbedWindow(..)-  , TabbedWindowEntry(..)-  , TabbedWindowTemplate(..)-  , OpenInBrowser(..)-  , ConnectionInfo(..)-  , SidebarUpdate(..)-  , PendingChannelChange(..)-  , ViewMessageWindowTab(..)-  , clearChannelUnreadStatus-  , ChannelListEntry(..)-  , channelListEntryChannelId-  , channelListEntryUserId-  , userIdsFromZipper-  , entryIsDMEntry-  , ciHostname-  , ciPort-  , ciUrlPath-  , ciUsername-  , ciPassword-  , ciType-  , ciAccessToken-  , Config(..)-  , HelpScreen(..)-  , PasswordSource(..)-  , TokenSource(..)-  , MatchType(..)-  , Mode(..)-  , ChannelSelectPattern(..)-  , PostListContents(..)-  , AuthenticationException(..)-  , BackgroundInfo(..)-  , RequestChan-  , UserFetch(..)-  , writeBChan-  , InternalTheme(..)--  , attrNameToConfig--  , mkChannelZipperList-  , ChannelListGroup(..)-  , channelListGroupHasUnread--  , trimChannelSigil--  , ChannelSelectState(..)-  , channelSelectMatches-  , channelSelectInput-  , emptyChannelSelectState--  , ChatState-  , newState-  , csResources-  , csFocus-  , csCurrentChannel-  , csCurrentChannelId-  , csUrlList-  , csShowMessagePreview-  , csShowChannelList-  , csPostMap-  , csRecentChannel-  , csReturnChannel-  , csThemeListOverlay-  , csPostListOverlay-  , csUserListOverlay-  , csChannelListOverlay-  , csReactionEmojiListOverlay-  , csMyTeam-  , csMessageSelect-  , csConnectionStatus-  , csWorkerIsBusy-  , csChannel-  , csChannels-  , csChannelSelectState-  , csEditState-  , csClientConfig-  , csPendingChannelChange-  , csViewedMessage-  , csNotifyPrefs-  , csMe-  , timeZone-  , whenMode-  , setMode-  , setMode'-  , appMode--  , ChatEditState-  , emptyEditState-  , cedAttachmentList-  , cedFileBrowser-  , cedYankBuffer-  , cedSpellChecker-  , cedMisspellings-  , cedEditMode-  , cedEphemeral-  , cedEditor-  , cedInputHistory-  , cedAutocomplete-  , cedAutocompletePending-  , cedJustCompleted--  , AutocompleteState(..)-  , acPreviousSearchString-  , acCompletionList-  , acCachedResponses-  , acType--  , AutocompletionType(..)--  , AutocompleteAlternative(..)-  , autocompleteAlternativeReplacement-  , SpecialMention(..)-  , specialMentionName-  , isSpecialMention--  , PostListOverlayState-  , postListSelected-  , postListPosts--  , UserSearchScope(..)-  , ChannelSearchScope(..)--  , ListOverlayState-  , listOverlaySearchResults-  , listOverlaySearchInput-  , listOverlaySearchScope-  , listOverlaySearching-  , listOverlayEnterHandler-  , listOverlayNewList-  , listOverlayFetchResults-  , listOverlayRecordCount--  , getUsers--  , ChatResources(..)-  , crUserPreferences-  , crEventQueue-  , crTheme-  , crStatusUpdateChan-  , crSubprocessLog-  , crWebsocketActionChan-  , crWebsocketThreadId-  , crRequestQueue-  , crFlaggedPosts-  , crConn-  , crConfiguration-  , crSyntaxMap-  , crLogManager-  , crEmoji-  , getSession-  , getResourceSession--  , specialUserMentions--  , UserPreferences(UserPreferences)-  , userPrefShowJoinLeave-  , userPrefFlaggedPostList-  , userPrefGroupChannelPrefs-  , userPrefDirectChannelPrefs-  , userPrefTeammateNameDisplayMode-  , dmChannelShowPreference-  , groupChannelShowPreference--  , defaultUserPreferences-  , setUserPreferences--  , WebsocketAction(..)--  , Cmd(..)-  , commandName-  , CmdArgs(..)--  , MH-  , runMHEvent-  , scheduleUserFetches-  , scheduleUserStatusFetches-  , getScheduledUserFetches-  , getScheduledUserStatusFetches-  , mh-  , generateUUID-  , generateUUID_IO-  , mhSuspendAndResume-  , mhHandleEventLensed-  , St.gets-  , mhError--  , mhLog-  , mhGetIOLogger-  , ioLogWithManager-  , LogContext(..)-  , withLogContext-  , withLogContextChannelId-  , getLogContext-  , LogMessage(..)-  , LogCommand(..)-  , LogCategory(..)--  , LogManager(..)-  , startLoggingToFile-  , stopLoggingToFile-  , requestLogSnapshot-  , requestLogDestination-  , sendLogMessage--  , requestQuit-  , getMessageForPostId-  , getParentMessage-  , resetSpellCheckTimer-  , withChannel-  , withChannelOrDefault-  , userList-  , resetAutocomplete-  , hasUnread-  , hasUnread'-  , isMine-  , setUserStatus-  , myUser-  , myUsername-  , myUserId-  , myTeamId-  , usernameForUserId-  , userByUsername-  , userByNickname-  , channelIdByChannelName-  , channelIdByUsername-  , channelByName-  , userById-  , allUserIds-  , addNewUser-  , useNickname-  , useNickname'-  , displayNameForUserId-  , displayNameForUser-  , raiseInternalEvent-  , getNewMessageCutoff-  , getEditedMessageCutoff--  , HighlightSet(..)-  , UserSet-  , ChannelSet-  , getHighlightSet--  , module Types.Channels-  , module Types.Messages-  , module Types.Posts-  , module Types.Users-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Graphics.Vty as Vty-import qualified Brick-import           Brick ( EventM, Next, Widget )-import           Brick.Themes ( Theme )-import           Brick.Main ( invalidateCache, invalidateCacheEntry )-import           Brick.AttrMap ( AttrMap )-import qualified Brick.BChan as BCH-import           Brick.Forms (Form)-import           Brick.Widgets.Edit ( Editor, editor )-import           Brick.Widgets.List ( List, list )-import qualified Brick.Widgets.FileBrowser as FB-import           Control.Concurrent ( ThreadId )-import           Control.Concurrent.Async ( Async )-import qualified Control.Concurrent.STM as STM-import           Control.Exception ( SomeException )-import qualified Control.Monad.Fail as MHF-import qualified Control.Monad.State as St-import qualified Control.Monad.Reader as R-import qualified Data.Set as Set-import qualified Data.ByteString as BS-import qualified Data.Foldable as F-import qualified Data.Kind as K-import           Data.Ord ( comparing )-import qualified Data.HashMap.Strict as HM-import           Data.List ( sortBy, nub, elemIndex )-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import           Data.Time.Clock ( getCurrentTime, addUTCTime )-import           Data.UUID ( UUID )-import qualified Data.Vector as Vec-import           Lens.Micro.Platform ( at, makeLenses, lens, (%~), (^?!), (.=)-                                     , (%=), (^?), (.~)-                                     , _Just, Traversal', preuse, to-                                     , SimpleGetter-                                     )-import           Network.Connection ( HostNotResolved, HostCannotConnect )-import           Skylighting.Types ( SyntaxMap )-import           System.Exit ( ExitCode )-import           System.Random ( randomIO )-import           Text.Aspell ( Aspell )--import           Network.Mattermost ( ConnectionData )-import           Network.Mattermost.Exceptions-import           Network.Mattermost.Lenses-import           Network.Mattermost.Types-import           Network.Mattermost.Types.Config-import           Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse )--import           Constants ( userSigil, normalChannelSigil )-import           InputHistory-import           Emoji-import           Types.Common-import           Types.Channels-import           Types.DirectionalSeq ( emptyDirSeq )-import           Types.KeyEvents-import           Types.Messages-import           Types.Posts-import           Types.Users-import           Zipper ( Zipper, toList, fromList, unsafeFocus )----- * Configuration---- | A user password is either given to us directly, or a command--- which we execute to find the password.-data PasswordSource =-    PasswordString Text-    | PasswordCommand Text-    deriving (Eq, Read, Show)---- | An access token source.-data TokenSource =-    TokenString Text-    | TokenCommand Text-    deriving (Eq, Read, Show)---- | The type of channel list group headings. Booleans indicate whether--- any channels in the group have unread activity.-data ChannelListGroup =-    ChannelGroupPublicChannels Bool-    | ChannelGroupPrivateChannels Bool-    | ChannelGroupDirectMessages Bool-    deriving (Eq)--channelListGroupHasUnread :: ChannelListGroup -> Bool-channelListGroupHasUnread (ChannelGroupPublicChannels u) = u-channelListGroupHasUnread (ChannelGroupPrivateChannels u) = u-channelListGroupHasUnread (ChannelGroupDirectMessages u) = u---- | The type of channel list entries.-data ChannelListEntry =-    CLChannel ChannelId-    -- ^ A non-DM entry-    | CLUserDM ChannelId UserId-    -- ^ A single-user DM entry-    | CLGroupDM ChannelId-    -- ^ A multi-user DM entry-    deriving (Eq, Show)---- | This is how we represent the user's configuration. Most fields--- correspond to configuration file settings (see Config.hs) but some--- are for internal book-keeping purposes only.-data Config =-    Config { configUser :: Maybe Text-           -- ^ The username to use when connecting.-           , configHost :: Maybe Text-           -- ^ The hostname to use when connecting.-           , configTeam :: Maybe Text-           -- ^ The team name to use when connecting.-           , configPort :: Int-           -- ^ The port to use when connecting.-           , configUrlPath :: Maybe Text-           -- ^ The server path to use when connecting.-           , configPass :: Maybe PasswordSource-           -- ^ The password source to use when connecting.-           , configToken :: Maybe TokenSource-           -- ^ The token source to use when connecting.-           , configTimeFormat :: Maybe Text-           -- ^ The format string for timestamps.-           , configDateFormat :: Maybe Text-           -- ^ The format string for dates.-           , configTheme :: Maybe Text-           -- ^ The name of the theme to use.-           , configThemeCustomizationFile :: Maybe Text-           -- ^ 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-           -- ^ Whether the URL-opening command is interactive (i.e.-           -- whether it should be given control of the terminal).-           , configActivityNotifyCommand :: Maybe T.Text-           -- ^ The command to run for activity notifications.-           , configActivityBell :: Bool-           -- ^ Whether to ring the terminal bell on activity.-           , configShowBackground :: BackgroundInfo-           -- ^ Whether to show async background worker thread info.-           , configShowMessagePreview :: Bool-           -- ^ Whether to show the message preview area.-           , configShowChannelList :: Bool-           -- ^ Whether to show the channel list.-           , configEnableAspell :: Bool-           -- ^ Whether to enable Aspell spell checking.-           , configAspellDictionary :: Maybe Text-           -- ^ A specific Aspell dictionary name to use.-           , configUnsafeUseHTTP :: Bool-           -- ^ Whether to permit an insecure HTTP connection.-           , configValidateServerCertificate :: Bool-           -- ^ Whether to validate TLS certificates.-           , configChannelListWidth :: Int-           -- ^ The width, in columns, of the channel list sidebar.-           , configLogMaxBufferSize :: Int-           -- ^ The maximum size, in log entries, of the internal log-           -- message buffer.-           , configShowOlderEdits :: Bool-           -- ^ Whether to highlight the edit indicator on edits made-           -- prior to the beginning of the current session.-           , configShowTypingIndicator :: Bool-           -- ^ Whether to show the typing indicator for other users,-           -- and whether to send typing notifications to other users.-           , configAbsPath :: Maybe FilePath-           -- ^ A book-keeping field for the absolute path to the-           -- configuration. (Not a user setting.)-           , configUserKeys :: KeyConfig-           -- ^ The user's keybinding configuration.-           , configHyperlinkingMode :: Bool-           -- ^ Whether to enable terminal hyperlinking mode.-           , configSyntaxDirs :: [FilePath]-           -- ^ The search path for syntax description XML files.-           , configDirectChannelExpirationDays :: Int-           -- ^ The number of days to show a user in the channel menu after a direct-           -- message with them.-           , configCpuUsagePolicy :: CPUUsagePolicy-           -- ^ The CPU usage policy for the application.-           , configDefaultAttachmentPath :: Maybe FilePath-           -- ^ The default path for browsing attachments-           , configMessageSelectAfterURLOpen :: Bool-           -- ^ Whether to remain in message selection mode after-           -- opening URL(s)-           } deriving (Eq, Show)---- | The policy for CPU usage.------ The idea is that Matterhorn can benefit from using multiple CPUs,--- but the exact number is application-determined. We expose this policy--- setting to the user in the configuration.-data CPUUsagePolicy =-    SingleCPU-    -- ^ Constrain the application to use one CPU.-    | MultipleCPUs-    -- ^ Permit the usage of multiple CPUs (the exact number is-    -- determined by the application).-    deriving (Eq, Show)---- | The state of the UI diagnostic indicator for the async worker--- thread.-data BackgroundInfo =-    Disabled-    -- ^ Disable (do not show) the indicator.-    | Active-    -- ^ Show the indicator when the thread is working.-    | ActiveCount-    -- ^ Show the indicator when the thread is working, but include the-    -- thread's work queue length.-    deriving (Eq, Show)--data UserPreferences =-    UserPreferences { _userPrefShowJoinLeave     :: Bool-                    , _userPrefFlaggedPostList   :: Seq FlaggedPost-                    , _userPrefGroupChannelPrefs :: HashMap ChannelId Bool-                    , _userPrefDirectChannelPrefs :: HashMap UserId Bool-                    , _userPrefTeammateNameDisplayMode :: Maybe TeammateNameDisplayMode-                    }--hasUnread :: ChatState -> ChannelId -> Bool-hasUnread st cId = fromMaybe False $-    hasUnread' <$> findChannelById cId (_csChannels st)--hasUnread' :: ClientChannel -> Bool-hasUnread' chan = fromMaybe False $ do-    let info = _ccInfo chan-    lastViewTime <- _cdViewed info-    return $ _cdMentionCount info > 0 ||-             (not (isMuted chan) &&-              (((_cdUpdated info) > lastViewTime) ||-               (isJust $ _cdEditedMessageThreshold info)))--mkChannelZipperList :: UTCTime-                    -> Config-                    -> Maybe ClientConfig-                    -> UserPreferences-                    -> ClientChannels-                    -> Users-                    -> [(ChannelListGroup, [ChannelListEntry])]-mkChannelZipperList now config cconfig prefs cs us =-    [ let (anyUnread, entries) = getChannelEntriesInOrder cs Ordinary-      in (ChannelGroupPublicChannels anyUnread, entries)-    , let (anyUnread, entries) = getChannelEntriesInOrder cs Private-      in (ChannelGroupPrivateChannels anyUnread, entries)-    , (ChannelGroupDirectMessages False, getDMChannelEntriesInOrder now config cconfig prefs us cs)-    ]--getChannelEntriesInOrder :: ClientChannels -> Type -> (Bool, [ChannelListEntry])-getChannelEntriesInOrder cs ty =-    let matches (_, info) = info^.ccInfo.cdType == ty-        pairs = filteredChannels matches cs-        anyUnread = or $ (hasUnread' . snd) <$> pairs-        entries = fmap (CLChannel . fst) $-                  sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) pairs-    in (anyUnread, entries)--getDMChannelEntriesInOrder :: UTCTime-                           -> Config-                           -> Maybe ClientConfig-                           -> UserPreferences-                           -> Users-                           -> ClientChannels-                           -> [ChannelListEntry]-getDMChannelEntriesInOrder now config cconfig prefs us cs =-    let oneOnOneDmChans = getDMChannelEntries now config cconfig prefs us cs-        groupChans = getGroupDMChannelEntries now config prefs cs-        allDmChans = groupChans <> oneOnOneDmChans-        sorter (u1, n1, _) (u2, n2, _) =-            if u1 == u2-            then compare n1 n2-            else if u1 && not u2-                 then LT-                 else GT-        sorted = sortBy sorter allDmChans-        third (_, _, c) = c-    in third <$> sorted--useNickname' :: Maybe ClientConfig -> UserPreferences -> Bool-useNickname' clientConfig prefs =-    let serverSetting = case clientConfig^?_Just.to clientConfigTeammateNameDisplay of-            Just TMNicknameOrFullname -> Just True-            _                         -> Nothing-        accountSetting = (== TMNicknameOrFullname) <$> (_userPrefTeammateNameDisplayMode prefs)-        fallback = False-    in fromMaybe fallback $ accountSetting <|> serverSetting--displayNameForUser :: UserInfo -> Maybe ClientConfig -> UserPreferences -> Text-displayNameForUser u clientConfig prefs-    | useNickname' clientConfig prefs =-        fromMaybe (u^.uiName) (u^.uiNickName)-    | otherwise =-        u^.uiName--getGroupDMChannelEntries :: UTCTime-                         -> Config-                         -> UserPreferences-                         -> ClientChannels-                         -> [(Bool, T.Text, ChannelListEntry)]-getGroupDMChannelEntries now config prefs cs =-    let matches (_, info) = info^.ccInfo.cdType == Group &&-                            groupChannelShouldAppear now config prefs info-    in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdDisplayName, CLGroupDM cId)) $-       filteredChannels matches cs--getDMChannelEntries :: UTCTime-                    -> Config-                    -> Maybe ClientConfig-                    -> UserPreferences-                    -> Users-                    -> ClientChannels-                    -> [(Bool, T.Text, ChannelListEntry)]-getDMChannelEntries now config cconfig prefs us cs =-    let mapping = allDmChannelMappings cs-        mappingWithUserInfo = catMaybes $ getInfo <$> mapping-        getInfo (uId, cId) = do-            c <- findChannelById cId cs-            u <- findUserById uId us-            case u^.uiDeleted of-                True -> Nothing-                False ->-                    if dmChannelShouldAppear now config prefs c-                    then return (hasUnread' c, displayNameForUser u cconfig prefs, CLUserDM cId uId)-                    else Nothing-    in mappingWithUserInfo---- Always show a DM channel if it has unread activity.------ If it has no unread activity and if the preferences explicitly say to--- hide it, hide it.------ Otherwise, only show it if at least one of the other conditions are--- met (see 'or' below).-dmChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool-dmChannelShouldAppear now config prefs c =-    let ndays = configDirectChannelExpirationDays config-        localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now-        cutoff = ServerTime localCutoff-        updated = c^.ccInfo.cdUpdated-        Just uId = c^.ccInfo.cdDMUserId-    in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)-       then True-       else case dmChannelShowPreference prefs uId of-           Just False -> False-           _ -> or [-                   -- The channel was updated recently enough-                     updated >= cutoff-                   ]--groupChannelShouldAppear :: UTCTime -> Config -> UserPreferences -> ClientChannel -> Bool-groupChannelShouldAppear now config prefs c =-    let ndays = configDirectChannelExpirationDays config-        localCutoff = addUTCTime (nominalDay * (-(fromIntegral ndays))) now-        cutoff = ServerTime localCutoff-        updated = c^.ccInfo.cdUpdated-    in if hasUnread' c || maybe False (>= localCutoff) (c^.ccInfo.cdSidebarShowOverride)-       then True-       else case groupChannelShowPreference prefs (c^.ccInfo.cdChannelId) of-           Just False -> False-           _ -> or [-                   -- The channel was updated recently enough-                     updated >= cutoff-                   ]--dmChannelShowPreference :: UserPreferences -> UserId -> Maybe Bool-dmChannelShowPreference ps uId = HM.lookup uId (_userPrefDirectChannelPrefs ps)--groupChannelShowPreference :: UserPreferences -> ChannelId -> Maybe Bool-groupChannelShowPreference ps cId = HM.lookup cId (_userPrefGroupChannelPrefs ps)---- * Internal Names and References---- | This 'Name' type is the type used in 'brick' to identify various--- parts of the interface.-data Name =-    ChannelMessages ChannelId-    | MessageInput-    | ChannelList-    | HelpViewport-    | HelpText-    | ScriptHelpText-    | ThemeHelpText-    | SyntaxHighlightHelpText-    | KeybindingHelpText-    | ChannelSelectString-    | CompletionAlternatives-    | CompletionList-    | JoinChannelList-    | UrlList-    | MessagePreviewViewport-    | ThemeListSearchInput-    | UserListSearchInput-    | JoinChannelListSearchInput-    | UserListSearchResults-    | ThemeListSearchResults-    | ViewMessageArea-    | ViewMessageReactionsArea-    | ChannelSidebar-    | ChannelSelectInput-    | AttachmentList-    | AttachmentFileBrowser-    | MessageReactionsArea-    | ReactionEmojiList-    | ReactionEmojiListInput-    | TabbedWindowTabBar-    | MuteToggleField-    | ChannelMentionsField-    | DesktopNotificationsField (WithDefault NotifyOption)-    | PushNotificationsField (WithDefault NotifyOption)-    deriving (Eq, Show, Ord)---- | The sum type of exceptions we expect to encounter on authentication--- failure. We encode them explicitly here so that we can print them in--- a more user-friendly manner than just 'show'.-data AuthenticationException =-    ConnectError HostCannotConnect-    | ResolveError HostNotResolved-    | AuthIOError IOError-    | LoginError LoginFailureException-    | OtherAuthError SomeException-    deriving (Show)---- | Our 'ConnectionInfo' contains exactly as much information as is--- necessary to start a connection with a Mattermost server. This is--- built up during interactive authentication and then is used to log--- in.------ If the access token field is non-empty, that value is used and the--- username and password values are ignored.-data ConnectionInfo =-    ConnectionInfo { _ciHostname :: Text-                   , _ciPort     :: Int-                   , _ciUrlPath  :: Text-                   , _ciUsername :: Text-                   , _ciPassword :: Text-                   , _ciAccessToken :: Text-                   , _ciType     :: ConnectionType-                   }---- | We want to continue referring to posts by their IDs, but we don't--- want to have to synthesize new valid IDs for messages from the client--- itself (like error messages or informative client responses). To that--- end, a PostRef can be either a PostId or a newly-generated client ID.-data PostRef-    = MMId PostId-    | CLId Int-    deriving (Eq, Show)---- ** Channel-matching types---- | A match in channel selection mode.-data ChannelSelectMatch =-    ChannelSelectMatch { nameBefore :: Text-                       -- ^ The content of the match before the user's-                       -- matching input.-                       , nameMatched :: Text-                       -- ^ The potion of the name that matched the-                       -- user's input.-                       , nameAfter :: Text-                       -- ^ The portion of the name that came after the-                       -- user's matching input.-                       , matchFull :: Text-                       -- ^ The full string for this entry so it doesn't-                       -- have to be reassembled from the parts above.-                       , matchEntry :: ChannelListEntry-                       -- ^ The original entry data corresponding to the-                       -- text match.-                       }-                       deriving (Eq, Show)--data ChannelSelectPattern = CSP MatchType Text-                          | CSPAny-                          deriving (Eq, Show)--data MatchType =-    Prefix-    | Suffix-    | Infix-    | Equal-    | PrefixDMOnly-    | PrefixNonDMOnly-    deriving (Eq, Show)---- * Application State Values--data ProgramOutput =-    ProgramOutput { program :: FilePath-                  , programArgs :: [String]-                  , programStdout :: String-                  , programStdoutExpected :: Bool-                  , programStderr :: String-                  , programExitCode :: ExitCode-                  }--defaultUserPreferences :: UserPreferences-defaultUserPreferences =-    UserPreferences { _userPrefShowJoinLeave     = True-                    , _userPrefFlaggedPostList   = mempty-                    , _userPrefGroupChannelPrefs = mempty-                    , _userPrefDirectChannelPrefs = mempty-                    , _userPrefTeammateNameDisplayMode = Nothing-                    }--setUserPreferences :: Seq Preference -> UserPreferences -> UserPreferences-setUserPreferences = flip (F.foldr go)-    where go p u-            | Just fp <- preferenceToFlaggedPost p =-              u { _userPrefFlaggedPostList =-                  _userPrefFlaggedPostList u Seq.|> fp-                }-            | Just gp <- preferenceToDirectChannelShowStatus p =-              u { _userPrefDirectChannelPrefs =-                  HM.insert-                    (directChannelShowUserId gp)-                    (directChannelShowValue gp)-                    (_userPrefDirectChannelPrefs u)-                }-            | Just gp <- preferenceToGroupChannelPreference p =-              u { _userPrefGroupChannelPrefs =-                  HM.insert-                    (groupChannelId gp)-                    (groupChannelShow gp)-                    (_userPrefGroupChannelPrefs u)-                }-            | preferenceName p == PreferenceName "join_leave" =-              u { _userPrefShowJoinLeave =-                  preferenceValue p /= PreferenceValue "false" }-            | preferenceCategory p == PreferenceCategoryDisplaySettings &&-              preferenceName p == PreferenceName "name_format" =-                  let PreferenceValue txt = preferenceValue p-                  in u { _userPrefTeammateNameDisplayMode = Just $ teammateDisplayModeFromText txt }-            | otherwise = u---- | Log message tags.-data LogCategory =-    LogGeneral-    | LogAPI-    | LogWebsocket-    | LogError-    | LogUserMark-    deriving (Eq, Show)---- | A log message.-data LogMessage =-    LogMessage { logMessageText :: !Text-               -- ^ The text of the log message.-               , logMessageContext :: !(Maybe LogContext)-               -- ^ The optional context information relevant to the log-               -- message.-               , logMessageCategory :: !LogCategory-               -- ^ The category of the log message.-               , logMessageTimestamp :: !UTCTime-               -- ^ The timestamp of the log message.-               }-               deriving (Eq, Show)---- | A logging thread command.-data LogCommand =-    LogToFile FilePath-    -- ^ Start logging to the specified path.-    | LogAMessage !LogMessage-    -- ^ Log the specified message.-    | StopLogging-    -- ^ Stop any active logging.-    | ShutdownLogging-    -- ^ Shut down.-    | GetLogDestination-    -- ^ Ask the logging thread about its active logging destination.-    | LogSnapshot FilePath-    -- ^ Ask the logging thread to dump the current buffer to the-    -- specified destination.-    deriving (Show)---- | A handle to the log manager thread.-data LogManager =-    LogManager { logManagerCommandChannel :: STM.TChan LogCommand-               , logManagerHandle :: Async ()-               }--startLoggingToFile :: LogManager -> FilePath -> IO ()-startLoggingToFile mgr loc = sendLogCommand mgr $ LogToFile loc--stopLoggingToFile :: LogManager -> IO ()-stopLoggingToFile mgr = sendLogCommand mgr StopLogging--requestLogSnapshot :: LogManager -> FilePath -> IO ()-requestLogSnapshot mgr path = sendLogCommand mgr $ LogSnapshot path--requestLogDestination :: LogManager -> IO ()-requestLogDestination mgr = sendLogCommand mgr GetLogDestination--sendLogMessage :: LogManager -> LogMessage -> IO ()-sendLogMessage mgr lm = sendLogCommand mgr $ LogAMessage lm--sendLogCommand :: LogManager -> LogCommand -> IO ()-sendLogCommand mgr c =-    STM.atomically $ STM.writeTChan (logManagerCommandChannel mgr) c---- | 'ChatResources' represents configuration and connection-related--- information, as opposed to current model or view information.--- Information that goes in the 'ChatResources' value should be limited--- to information that we read or set up prior to setting up the bulk of--- the application state.-data ChatResources =-    ChatResources { _crSession             :: Session-                  , _crWebsocketThreadId   :: Maybe ThreadId-                  , _crConn                :: ConnectionData-                  , _crRequestQueue        :: RequestChan-                  , _crEventQueue          :: BCH.BChan MHEvent-                  , _crSubprocessLog       :: STM.TChan ProgramOutput-                  , _crWebsocketActionChan :: STM.TChan WebsocketAction-                  , _crTheme               :: AttrMap-                  , _crStatusUpdateChan    :: STM.TChan [UserId]-                  , _crConfiguration       :: Config-                  , _crFlaggedPosts        :: Set PostId-                  , _crUserPreferences     :: UserPreferences-                  , _crSyntaxMap           :: SyntaxMap-                  , _crLogManager          :: LogManager-                  , _crEmoji               :: EmojiCollection-                  }---- | A "special" mention that does not map to a specific user, but is an--- alias that the server uses to notify users.-data SpecialMention =-    MentionAll-    -- ^ @all: notify everyone in the channel.-    | MentionChannel-    -- ^ @channel: notify everyone in the channel.--data AutocompleteAlternative =-    UserCompletion User Bool-    -- ^ User, plus whether the user is in the channel that triggered-    -- the autocomplete-    | SpecialMention SpecialMention-    -- ^ A special mention.-    | ChannelCompletion Bool Channel-    -- ^ Channel, plus whether the user is a member of the channel-    | SyntaxCompletion Text-    -- ^ Name of a skylighting syntax definition-    | CommandCompletion Text Text Text-    -- ^ Name of a slash command, argspec, and description-    | EmojiCompletion Text-    -- ^ The text of an emoji completion--specialMentionName :: SpecialMention -> Text-specialMentionName MentionChannel = "channel"-specialMentionName MentionAll = "all"--isSpecialMention :: T.Text -> Bool-isSpecialMention n = isJust $ lookup (T.toLower $ trimUserSigil n) pairs-    where-        pairs = mkPair <$> mentions-        mentions = [ MentionChannel-                   , MentionAll-                   ]-        mkPair v = (specialMentionName v, v)--autocompleteAlternativeReplacement :: AutocompleteAlternative -> Text-autocompleteAlternativeReplacement (EmojiCompletion e) =-    ":" <> e <> ":"-autocompleteAlternativeReplacement (SpecialMention m) =-    userSigil <> specialMentionName m-autocompleteAlternativeReplacement (UserCompletion u _) =-    userSigil <> userUsername u-autocompleteAlternativeReplacement (ChannelCompletion _ c) =-    normalChannelSigil <> (sanitizeUserText $ channelName c)-autocompleteAlternativeReplacement (SyntaxCompletion t) =-    "```" <> t-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-                      -- currently-displayed autocomplete results, for-                      -- use in deciding whether to issue another server-                      -- query-                      , _acCompletionList :: List Name AutocompleteAlternative-                      -- ^ The list of alternatives that the user-                      -- selects from-                      , _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.-                      -- The idea here is that users type quickly enough-                      -- (and edit their input) that would normally lead-                      -- to rapid consecutive requests, some for the-                      -- same strings during editing, that we can avoid-                      -- that by caching them here. Note that this cache-                      -- gets destroyed whenever autocompletion is not-                      -- on, so this cache does not live very long.-                      }---- | The 'ChatEditState' value contains the editor widget itself as well--- as history and metadata we need for editing-related operations.-data ChatEditState =-    ChatEditState { _cedEditor :: Editor Text Name-                  , _cedEditMode :: EditMode-                  , _cedEphemeral :: EphemeralEditState-                  , _cedInputHistory :: InputHistory-                  -- ^ The map of per-channel input history for the-                  -- application. We don't distribute the per-channel-                  -- history into the per-channel states (like we do-                  -- for other per-channel state) since keeping it-                  -- under the InputHistory banner lets us use a nicer-                  -- startup/shutdown disk file management API.-                  , _cedYankBuffer :: Text-                  , _cedSpellChecker :: Maybe (Aspell, IO ())-                  , _cedMisspellings :: Set Text-                  , _cedAutocomplete :: Maybe AutocompleteState-                  -- ^ The autocomplete state. The autocompletion UI is-                  -- showing only when this state is present.-                  , _cedAutocompletePending :: Maybe Text-                  -- ^ The search string associated with the latest-                  -- in-flight autocompletion request. This is used to-                  -- determine whether any (potentially late-arriving)-                  -- API responses are for stale queries since the user-                  -- can type more quickly than the server can get us-                  -- the results, and we wouldn't want to show results-                  -- associated with old editor states.-                  , _cedAttachmentList :: List Name AttachmentData-                  -- ^ The list of attachments to be uploaded with the-                  -- post being edited.-                  , _cedFileBrowser :: Maybe (FB.FileBrowser Name)-                  -- ^ The browser for selecting attachment files.-                  -- This is a Maybe because the instantiation of the-                  -- 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.-data AttachmentData =-    AttachmentData { attachmentDataFileInfo :: FB.FileInfo-                   , attachmentDataBytes :: BS.ByteString-                   }-                   deriving (Eq, Show)---- | We can initialize a new 'ChatEditState' value with just an edit--- history, which we save locally.-emptyEditState :: InputHistory -> Maybe (Aspell, IO ()) -> IO ChatEditState-emptyEditState hist sp =-    return ChatEditState { _cedEditor               = editor MessageInput Nothing ""-                         , _cedEphemeral            = defaultEphemeralEditState-                         , _cedInputHistory         = hist-                         , _cedEditMode             = NewPost-                         , _cedYankBuffer           = ""-                         , _cedSpellChecker         = sp-                         , _cedMisspellings         = mempty-                         , _cedAutocomplete         = Nothing-                         , _cedAutocompletePending  = Nothing-                         , _cedAttachmentList       = list AttachmentList mempty 1-                         , _cedFileBrowser          = Nothing-                         , _cedJustCompleted        = False-                         }---- | A 'RequestChan' is a queue of operations we have to perform in the--- background to avoid blocking on the main loop-type RequestChan = STM.TChan (IO (Maybe (MH ())))---- | The 'HelpScreen' type represents the set of possible 'Help'--- dialogues we have to choose from.-data HelpScreen =-    MainHelp-    | ScriptHelp-    | ThemeHelp-    | SyntaxHighlightHelp-    | KeybindingHelp-    deriving (Eq)---- | Help topics-data HelpTopic =-    HelpTopic { helpTopicName         :: Text-              , helpTopicDescription  :: Text-              , helpTopicScreen       :: HelpScreen-              , helpTopicViewportName :: Name-              }-              deriving (Eq)---- | Mode type for the current contents of the post list overlay-data PostListContents =-    PostListFlagged-    | PostListPinned ChannelId-    | PostListSearch Text Bool -- for the query and search status-    deriving (Eq)---- | The 'Mode' represents the current dominant UI activity-data Mode =-    Main-    | ShowHelp HelpTopic Mode-    | ChannelSelect-    | UrlSelect-    | LeaveChannelConfirm-    | DeleteChannelConfirm-    | MessageSelect-    | MessageSelectDeleteConfirm-    | PostListOverlay PostListContents-    | UserListOverlay-    | ReactionEmojiListOverlay-    | ChannelListOverlay-    | ThemeListOverlay-    | ViewMessage-    | ManageAttachments-    | ManageAttachmentsBrowseFiles-    | EditNotifyPrefs-    deriving (Eq)---- | We're either connected or we're not.-data ConnectionStatus = Connected | Disconnected deriving (Eq)---- | An entry in a tabbed window corresponding to a tab and its content.--- Parameterized over an abstract handle type ('a') for the tabs so we--- can give each a unique handle.-data TabbedWindowEntry a =-    TabbedWindowEntry { tweValue :: a-                      -- ^ The handle for this tab.-                      , tweRender :: a -> ChatState -> Widget Name-                      -- ^ The rendering function to use when this tab-                      -- is selected.-                      , tweHandleEvent :: a -> Vty.Event -> MH ()-                      -- ^ The event-handling function to use when this-                      -- tab is selected.-                      , tweTitle :: a -> Bool -> T.Text-                      -- ^ Title function for this tab, with a boolean-                      -- indicating whether this is the current tab.-                      , tweShowHandler :: a -> MH ()-                      -- ^ A handler to be invoked when this tab is-                      -- shown.-                      }---- | The definition of a tabbed window. Note that this does not track--- the *state* of the window; it merely provides a collection of tab--- window entries (see above). To track the state of a tabbed window,--- use a TabbedWindow.------ Parameterized over an abstract handle type ('a') for the tabs so we--- can give each a unique handle.-data TabbedWindowTemplate a =-    TabbedWindowTemplate { twtEntries :: [TabbedWindowEntry a]-                         -- ^ The entries in tabbed windows with this-                         -- structure.-                         , twtTitle :: a -> Widget Name-                         -- ^ The title-rendering function for this kind-                         -- of tabbed window.-                         }---- | An instantiated tab window. This is based on a template and tracks--- the state of the tabbed window (current tab).------ Parameterized over an abstract handle type ('a') for the tabs so we--- can give each a unique handle.-data TabbedWindow a =-    TabbedWindow { twValue :: a-                 -- ^ The handle of the currently-selected tab.-                 , twReturnMode :: Mode-                 -- ^ The mode to return to when the tab is closed.-                 , twTemplate :: TabbedWindowTemplate a-                 -- ^ The template to use as a basis for rendering the-                 -- window and handling user input.-                 , twWindowWidth :: Int-                 , twWindowHeight :: Int-                 -- ^ Window dimensions-                 }---- | Construct a new tabbed window from a template. This will raise an--- exception if the initially-selected tab does not exist in the window--- template, or if the window template has any duplicated tab handles.------ Note that the caller is responsible for determining whether to call--- the initially-selected tab's on-show handler.-tabbedWindow :: (Show a, Eq a)-             => a-             -- ^ The handle corresponding to the tab that should be-             -- selected initially.-             -> TabbedWindowTemplate a-             -- ^ The template for the window to construct.-             -> Mode-             -- ^ When the window is closed, return to this application-             -- mode.-             -> (Int, Int)-             -- ^ The window dimensions (width, height).-             -> TabbedWindow a-tabbedWindow initialVal t retMode (width, height) =-    let handles = tweValue <$> twtEntries t-    in if | null handles ->-              error "BUG: tabbed window template must provide at least one entry"-          | length handles /= length (nub handles) ->-              error "BUG: tabbed window should have one entry per handle"-          | not (initialVal `elem` handles) ->-              error $ "BUG: tabbed window handle " <>-                      show initialVal <> " not present in template"-          | otherwise ->-              TabbedWindow { twTemplate = t-                           , twValue = initialVal-                           , twReturnMode = retMode-                           , twWindowWidth = width-                           , twWindowHeight = height-                           }---- | Get the currently-selected tab entry for a tabbed window. Raise--- an exception if the window's selected tab handle is not found in its--- template (which is a bug in the tabbed window infrastructure).-getCurrentTabbedWindowEntry :: (Show a, Eq a)-                            => TabbedWindow a-                            -> TabbedWindowEntry a-getCurrentTabbedWindowEntry w =-    lookupTabbedWindowEntry (twValue w) w---- | Run the on-show handler for the window tab entry with the specified--- handle.-runTabShowHandlerFor :: (Eq a, Show a) => a -> TabbedWindow a -> MH ()-runTabShowHandlerFor handle w = do-    let entry = lookupTabbedWindowEntry handle w-    tweShowHandler entry handle---- | Look up a tabbed window entry by handle. Raises an exception if no--- such entry exists.-lookupTabbedWindowEntry :: (Eq a, Show a)-                        => a-                        -> TabbedWindow a-                        -> TabbedWindowEntry a-lookupTabbedWindowEntry handle w =-    let matchesVal e = tweValue e == handle-    in case filter matchesVal (twtEntries $ twTemplate w) of-        [e] -> e-        _ -> error $ "BUG: tabbed window entry for " <> show (twValue w) <>-                     " should have matched a single entry"---- | Switch a tabbed window's selected tab to its next tab, cycling back--- to the first tab if the last tab is the selected tab. This also--- invokes the on-show handler for the newly-selected tab.------ Note that this does nothing if the window has only one tab.-tabbedWindowNextTab :: (Show a, Eq a)-                    => TabbedWindow a-                    -> MH (TabbedWindow a)-tabbedWindowNextTab w | length (twtEntries $ twTemplate w) == 1 = return w-tabbedWindowNextTab w = do-    let curIdx = case elemIndex (tweValue curEntry) allHandles of-            Nothing ->-                error $ "BUG: tabbedWindowNextTab: could not find " <>-                        "current handle in handle list"-            Just i -> i-        nextIdx = if curIdx == length allHandles - 1-                  then 0-                  else curIdx + 1-        newHandle = allHandles !! nextIdx-        allHandles = tweValue <$> twtEntries (twTemplate w)-        curEntry = getCurrentTabbedWindowEntry w-        newWin = w { twValue = newHandle }--    runTabShowHandlerFor newHandle newWin-    return newWin---- | Switch a tabbed window's selected tab to its previous tab, cycling--- to the last tab if the first tab is the selected tab. This also--- invokes the on-show handler for the newly-selected tab.------ Note that this does nothing if the window has only one tab.-tabbedWindowPreviousTab :: (Show a, Eq a)-                        => TabbedWindow a-                        -> MH (TabbedWindow a)-tabbedWindowPreviousTab w | length (twtEntries $ twTemplate w) == 1 = return w-tabbedWindowPreviousTab w = do-    let curIdx = case elemIndex (tweValue curEntry) allHandles of-            Nothing ->-                error $ "BUG: tabbedWindowPreviousTab: could not find " <>-                        "current handle in handle list"-            Just i -> i-        nextIdx = if curIdx == 0-                  then length allHandles - 1-                  else curIdx - 1-        newHandle = allHandles !! nextIdx-        allHandles = tweValue <$> twtEntries (twTemplate w)-        curEntry = getCurrentTabbedWindowEntry w-        newWin = w { twValue = newHandle }--    runTabShowHandlerFor newHandle newWin-    return newWin---- | This is the giant bundle of fields that represents the current--- state of our application at any given time.-data ChatState =-    ChatState { _csResources :: ChatResources-              -- ^ Global application-wide resources that don't change-              -- much.-              , _csFocus :: Zipper ChannelListGroup ChannelListEntry-              -- ^ The channel sidebar zipper that tracks which channel-              -- is selected.-              , _csMe :: User-              -- ^ The authenticated user.-              , _csMyTeam :: Team-              -- ^ The active team of the authenticated user.-              , _csChannels :: ClientChannels-              -- ^ The channels that we are showing, including their-              -- message lists.-              , _csPostMap :: HashMap PostId Message-              -- ^ The map of post IDs to messages. This allows us to-              -- access messages by ID without having to linearly scan-              -- channel message lists.-              , _csUsers :: Users-              -- ^ All of the users we know about.-              , _timeZone :: TimeZoneSeries-              -- ^ The client time zone.-              , _csEditState :: ChatEditState-              -- ^ The state of the input box used for composing and-              -- editing messages and commands.-              , _csMode :: Mode-              -- ^ The current application mode. This is used to-              -- dispatch to different rendering and event handling-              -- routines.-              , _csShowMessagePreview :: Bool-              -- ^ Whether to show the message preview area.-              , _csShowChannelList :: Bool-              -- ^ Whether to show the channel list.-              , _csChannelSelectState :: ChannelSelectState-              -- ^ The state of the user's input and selection for-              -- channel selection mode.-              , _csRecentChannel :: Maybe ChannelId-              -- ^ The most recently-selected channel, if any.-              , _csReturnChannel :: Maybe ChannelId-              -- ^ The channel to return to after visiting one or more-              -- unread channels.-              , _csUrlList :: List Name LinkChoice-              -- ^ The URL list used to show URLs drawn from messages in-              -- a channel.-              , _csConnectionStatus :: ConnectionStatus-              -- ^ Our view of the connection status.-              , _csWorkerIsBusy :: Maybe (Maybe Int)-              -- ^ Whether the async worker thread is busy, and its-              -- queue length if so.-              , _csMessageSelect :: MessageSelectState-              -- ^ The state of message selection mode.-              , _csThemeListOverlay :: ListOverlayState InternalTheme ()-              -- ^ The state of the theme list overlay.-              , _csPostListOverlay :: PostListOverlayState-              -- ^ The state of the post list overlay.-              , _csUserListOverlay :: ListOverlayState UserInfo UserSearchScope-              -- ^ The state of the user list overlay.-              , _csChannelListOverlay :: ListOverlayState Channel ChannelSearchScope-              -- ^ The state of the user list overlay.-              , _csReactionEmojiListOverlay :: ListOverlayState (Bool, T.Text) ()-              -- ^ The state of the reaction emoji list overlay.-              , _csClientConfig :: Maybe ClientConfig-              -- ^ The Mattermost client configuration, as we understand it.-              , _csPendingChannelChange :: Maybe PendingChannelChange-              -- ^ A pending channel change that we need to apply once-              -- the channel in question is available. We set this up-              -- when we need to change to a channel in the sidebar, but-              -- it isn't even there yet because we haven't loaded its-              -- metadata.-              , _csViewedMessage :: Maybe (Message, TabbedWindow ViewMessageWindowTab)-              -- ^ Set when the ViewMessage mode is active. The message-              -- being viewed. Note that this stores a message, not-              -- a message ID. That's because not all messages have-              -- message IDs (e.g. client messages) and we still-              -- want to support viewing of those messages. It's the-              -- responsibility of code that uses this message to always-              -- consult the chat state for the latest *version* of any-              -- message with an ID here, to be sure that the latest-              -- version is used (e.g. if it gets edited, etc.).-              , _csNotifyPrefs :: Maybe (Form ChannelNotifyProps MHEvent Name)-              -- ^ A form for editing the notification preferences for-              -- the current channel. This is set when entering-              -- EditNotifyPrefs mode and updated when the user-              -- changes the form state.-              }---- | Handles for the View Message window's tabs.-data ViewMessageWindowTab =-    VMTabMessage-    -- ^ The message tab.-    | VMTabReactions-    -- ^ The reactions tab.-    deriving (Eq, Show)--data PendingChannelChange =-    ChangeByChannelId ChannelId-    | ChangeByUserId UserId-    deriving (Eq, Show)---- | Startup state information that is constructed prior to building a--- ChatState.-data StartupStateInfo =-    StartupStateInfo { startupStateResources      :: ChatResources-                     , startupStateChannelZipper  :: Zipper ChannelListGroup ChannelListEntry-                     , startupStateConnectedUser  :: User-                     , startupStateTeam           :: Team-                     , startupStateTimeZone       :: TimeZoneSeries-                     , startupStateInitialHistory :: InputHistory-                     , startupStateSpellChecker   :: Maybe (Aspell, IO ())-                     }--newState :: StartupStateInfo -> IO ChatState-newState (StartupStateInfo {..}) = do-    editState <- emptyEditState startupStateInitialHistory startupStateSpellChecker-    return ChatState { _csResources                   = startupStateResources-                     , _csFocus                       = startupStateChannelZipper-                     , _csMe                          = startupStateConnectedUser-                     , _csMyTeam                      = startupStateTeam-                     , _csChannels                    = noChannels-                     , _csPostMap                     = HM.empty-                     , _csUsers                       = noUsers-                     , _timeZone                      = startupStateTimeZone-                     , _csEditState                   = editState-                     , _csMode                        = Main-                     , _csShowMessagePreview          = configShowMessagePreview $ _crConfiguration startupStateResources-                     , _csShowChannelList             = configShowChannelList $ _crConfiguration startupStateResources-                     , _csChannelSelectState          = emptyChannelSelectState-                     , _csRecentChannel               = Nothing-                     , _csReturnChannel               = Nothing-                     , _csUrlList                     = list UrlList mempty 2-                     , _csConnectionStatus            = Connected-                     , _csWorkerIsBusy                = Nothing-                     , _csMessageSelect               = MessageSelectState Nothing-                     , _csThemeListOverlay            = nullThemeListOverlayState-                     , _csPostListOverlay             = PostListOverlayState emptyDirSeq Nothing-                     , _csUserListOverlay             = nullUserListOverlayState-                     , _csChannelListOverlay          = nullChannelListOverlayState-                     , _csReactionEmojiListOverlay    = nullEmojiListOverlayState-                     , _csClientConfig                = Nothing-                     , _csPendingChannelChange        = Nothing-                     , _csViewedMessage               = Nothing-                     , _csNotifyPrefs                 = Nothing-                     }--nullChannelListOverlayState :: ListOverlayState Channel ChannelSearchScope-nullChannelListOverlayState =-    let newList rs = list JoinChannelList rs 2-    in ListOverlayState { _listOverlaySearchResults  = newList mempty-                        , _listOverlaySearchInput    = editor JoinChannelListSearchInput (Just 1) ""-                        , _listOverlaySearchScope    = AllChannels-                        , _listOverlaySearching      = False-                        , _listOverlayEnterHandler   = const $ return False-                        , _listOverlayNewList        = newList-                        , _listOverlayFetchResults   = const $ const $ const $ return mempty-                        , _listOverlayRecordCount    = Nothing-                        }--nullThemeListOverlayState :: ListOverlayState InternalTheme ()-nullThemeListOverlayState =-    let newList rs = list ThemeListSearchResults rs 3-    in ListOverlayState { _listOverlaySearchResults  = newList mempty-                        , _listOverlaySearchInput    = editor ThemeListSearchInput (Just 1) ""-                        , _listOverlaySearchScope    = ()-                        , _listOverlaySearching      = False-                        , _listOverlayEnterHandler   = const $ return False-                        , _listOverlayNewList        = newList-                        , _listOverlayFetchResults   = const $ const $ const $ return mempty-                        , _listOverlayRecordCount    = Nothing-                        }--nullUserListOverlayState :: ListOverlayState UserInfo UserSearchScope-nullUserListOverlayState =-    let newList rs = list UserListSearchResults rs 1-    in ListOverlayState { _listOverlaySearchResults  = newList mempty-                        , _listOverlaySearchInput    = editor UserListSearchInput (Just 1) ""-                        , _listOverlaySearchScope    = AllUsers Nothing-                        , _listOverlaySearching      = False-                        , _listOverlayEnterHandler   = const $ return False-                        , _listOverlayNewList        = newList-                        , _listOverlayFetchResults   = const $ const $ const $ return mempty-                        , _listOverlayRecordCount    = Nothing-                        }--nullEmojiListOverlayState :: ListOverlayState (Bool, T.Text) ()-nullEmojiListOverlayState =-    let newList rs = list ReactionEmojiList rs 1-    in ListOverlayState { _listOverlaySearchResults  = newList mempty-                        , _listOverlaySearchInput    = editor ReactionEmojiListInput (Just 1) ""-                        , _listOverlaySearchScope    = ()-                        , _listOverlaySearching      = False-                        , _listOverlayEnterHandler   = const $ return False-                        , _listOverlayNewList        = newList-                        , _listOverlayFetchResults   = const $ const $ const $ return mempty-                        , _listOverlayRecordCount    = Nothing-                        }---- | The state of channel selection mode.-data ChannelSelectState =-    ChannelSelectState { _channelSelectInput :: Editor Text Name-                       , _channelSelectMatches :: Zipper ChannelListGroup ChannelSelectMatch-                       }--emptyChannelSelectState :: ChannelSelectState-emptyChannelSelectState =-    ChannelSelectState { _channelSelectInput = editor ChannelSelectInput (Just 1) ""-                       , _channelSelectMatches = fromList []-                       }---- | The state of message selection mode.-data MessageSelectState =-    MessageSelectState { selectMessageId :: Maybe MessageId-                       }---- | The state of the post list overlay.-data PostListOverlayState =-    PostListOverlayState { _postListPosts    :: Messages-                         , _postListSelected :: Maybe PostId-                         }--data InternalTheme =-    InternalTheme { internalThemeName :: Text-                  , internalTheme :: Theme-                  , internalThemeDesc :: Text-                  }---- | The state of the search result list overlay. Type 'a' is the type--- of data in the list. Type 'b' is the search scope type.-data ListOverlayState a b =-    ListOverlayState { _listOverlaySearchResults :: List Name a-                     -- ^ The list of search results currently shown in-                     -- the overlay.-                     , _listOverlaySearchInput :: Editor Text Name-                     -- ^ The editor for the overlay's search input.-                     , _listOverlaySearchScope :: b-                     -- ^ The overlay's current search scope.-                     , _listOverlaySearching :: Bool-                     -- ^ Whether a search is in progress (i.e. whether-                     -- we are currently awaiting a response from a-                     -- search query to the server).-                     , _listOverlayEnterHandler :: a -> MH Bool-                     -- ^ The handler to invoke on the selected element-                     -- when the user presses Enter.-                     , _listOverlayNewList :: Vec.Vector a -> List Name a-                     -- ^ The function to build a new brick List from a-                     -- vector of search results.-                     , _listOverlayFetchResults :: b -> Session -> Text -> IO (Vec.Vector a)-                     -- ^ The function to call to issue a search query-                     -- to the server.-                     , _listOverlayRecordCount :: Maybe Int-                     -- ^ The total number of available records, if known.-                     }---- | The scope for searching for users in a user list overlay.-data UserSearchScope =-    ChannelMembers ChannelId TeamId-    | ChannelNonMembers ChannelId TeamId-    | AllUsers (Maybe TeamId)---- | The scope for searching for channels to join.-data ChannelSearchScope =-    AllChannels---- | Actions that can be sent on the websocket to the server.-data WebsocketAction =-    UserTyping UTCTime ChannelId (Maybe PostId) -- ^ user typing in the input box-    deriving (Read, Show, Eq, Ord)---- * MH Monad---- | Logging context information, in the event that metadata should--- accompany a log message.-data LogContext =-    LogContext { logContextChannelId :: Maybe ChannelId-               }-               deriving (Eq, Show)---- | A user fetching strategy.-data UserFetch =-    UserFetchById UserId-    -- ^ Fetch the user with the specified ID.-    | UserFetchByUsername Text-    -- ^ Fetch the user with the specified username.-    | UserFetchByNickname Text-    -- ^ Fetch the user with the specified nickname.-    deriving (Eq, Show)--data MHState =-    MHState { mhCurrentState :: ChatState-            , mhNextAction :: ChatState -> EventM Name (Next ChatState)-            , mhUsersToFetch :: [UserFetch]-            , mhPendingStatusList :: Maybe [UserId]-            }---- | A value of type 'MH' @a@ represents a computation that can--- manipulate the application state and also request that the--- application quit-newtype MH a =-    MH { fromMH :: R.ReaderT (Maybe LogContext) (St.StateT MHState (EventM Name)) a }---- | Use a modified logging context for the duration of the specified MH--- action.-withLogContext :: (Maybe LogContext -> Maybe LogContext) -> MH a -> MH a-withLogContext modifyContext act =-    MH $ R.withReaderT modifyContext (fromMH act)--withLogContextChannelId :: ChannelId -> MH a -> MH a-withLogContextChannelId cId act =-    let f Nothing = Just $ LogContext (Just cId)-        f (Just c) = Just $ c { logContextChannelId = Just cId }-    in withLogContext f act---- | Get the current logging context.-getLogContext :: MH (Maybe LogContext)-getLogContext = MH R.ask---- | Log a message.-mhLog :: LogCategory -> Text -> MH ()-mhLog cat msg = do-    logger <- mhGetIOLogger-    liftIO $ logger cat msg---- | Get a logger suitable for use in IO. The logger always logs using--- the MH monad log context at the time of the call to mhGetIOLogger.-mhGetIOLogger :: MH (LogCategory -> Text -> IO ())-mhGetIOLogger = do-    ctx <- getLogContext-    mgr <- use (to (_crLogManager . _csResources))-    return $ ioLogWithManager mgr ctx--ioLogWithManager :: LogManager -> Maybe LogContext -> LogCategory -> Text -> IO ()-ioLogWithManager mgr ctx cat msg = do-    now <- getCurrentTime-    let lm = LogMessage { logMessageText = msg-                        , logMessageContext = ctx-                        , logMessageCategory = cat-                        , logMessageTimestamp = now-                        }-    sendLogMessage mgr lm---- | Run an 'MM' computation, choosing whether to continue or halt based--- on the resulting-runMHEvent :: ChatState -> MH () -> EventM Name (Next ChatState)-runMHEvent st (MH mote) = do-  let mhSt = MHState { mhCurrentState = st-                     , mhNextAction = Brick.continue-                     , mhUsersToFetch = []-                     , mhPendingStatusList = Nothing-                     }-  ((), st') <- St.runStateT (R.runReaderT mote Nothing) mhSt-  (mhNextAction st') (mhCurrentState st')--scheduleUserFetches :: [UserFetch] -> MH ()-scheduleUserFetches fs = MH $ do-    St.modify $ \s -> s { mhUsersToFetch = fs <> mhUsersToFetch s }--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 [UserId])-getScheduledUserStatusFetches = MH $ St.gets mhPendingStatusList---- | lift a computation in 'EventM' into 'MH'-mh :: EventM Name a -> MH a-mh = MH . R.lift . St.lift--generateUUID :: MH UUID-generateUUID = liftIO generateUUID_IO--generateUUID_IO :: IO UUID-generateUUID_IO = randomIO--mhHandleEventLensed :: Lens' ChatState b -> (e -> b -> EventM Name b) -> e -> MH ()-mhHandleEventLensed ln f event = MH $ do-    s <- St.get-    let st = mhCurrentState s-    n <- R.lift $ St.lift $ f event (st ^. ln)-    St.put (s { mhCurrentState = st & ln .~ n })--mhSuspendAndResume :: (ChatState -> IO ChatState) -> MH ()-mhSuspendAndResume mote = MH $ do-    s <- St.get-    St.put $ s { mhNextAction = \ _ -> Brick.suspendAndResume (mote $ mhCurrentState s) }---- | This will request that after this computation finishes the--- application should exit-requestQuit :: MH ()-requestQuit = MH $ do-    s <- St.get-    St.put $ s { mhNextAction = Brick.halt }--instance Functor MH where-    fmap f (MH x) = MH (fmap f x)--instance Applicative MH where-    pure x = MH (pure x)-    MH f <*> MH x = MH (f <*> x)--instance MHF.MonadFail MH where-    fail = MH . MHF.fail--instance Monad MH where-    return x = MH (return x)-    MH x >>= f = MH (x >>= \ x' -> fromMH (f x'))---- We want to pretend that the state is only the ChatState, rather--- than the ChatState and the Brick continuation-instance St.MonadState ChatState MH where-    get = mhCurrentState `fmap` MH St.get-    put st = MH $ do-        s <- St.get-        St.put $ s { mhCurrentState = st }--instance St.MonadIO MH where-    liftIO = MH . St.liftIO---- | This represents events that we handle in the main application loop.-data MHEvent =-    WSEvent WebsocketEvent-    -- ^ For events that arise from the websocket-    | WSActionResponse WebsocketActionResponse-    -- ^ For responses to websocket actions-    | RespEvent (MH ())-    -- ^ For the result values of async IO operations-    | RefreshWebsocketEvent-    -- ^ Tell our main loop to refresh the websocket connection-    | WebsocketParseError String-    -- ^ We failed to parse an incoming websocket event-    | WebsocketDisconnect-    -- ^ The websocket connection went down.-    | WebsocketConnect-    -- ^ The websocket connection came up.-    | BGIdle-    -- ^ 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---- | Internal application events.-data InternalEvent =-    DisplayError MHError-    -- ^ Some kind of application error occurred-    | LoggingStarted FilePath-    | LoggingStopped FilePath-    | LogStartFailed FilePath String-    | LogDestination (Maybe FilePath)-    | LogSnapshotSucceeded FilePath-    | LogSnapshotFailed FilePath String-    -- ^ Logging events from the logging thread---- | Application errors.-data MHError =-    GenericError T.Text-    -- ^ A generic error message constructor-    | NoSuchChannel T.Text-    -- ^ The specified channel does not exist-    | NoSuchUser T.Text-    -- ^ The specified user does not exist-    | AmbiguousName T.Text-    -- ^ The specified name matches both a user and a channel-    | ServerError MattermostError-    -- ^ A Mattermost server error occurred-    | ClipboardError T.Text-    -- ^ A problem occurred trying to deal with yanking or the system-    -- clipboard-    | ConfigOptionMissing T.Text-    -- ^ A missing config option is required to perform an operation-    | ProgramExecutionFailed T.Text T.Text-    -- ^ Args: program name, path to log file. A problem occurred when-    -- running the program.-    | NoSuchScript T.Text-    -- ^ The specified script was not found-    | NoSuchHelpTopic T.Text-    -- ^ The specified help topic was not found-    | AsyncErrEvent SomeException-    -- ^ For errors that arise in the course of async IO operations-    deriving (Show)---- ** Application State Lenses--makeLenses ''ChatResources-makeLenses ''ChatState-makeLenses ''ChatEditState-makeLenses ''AutocompleteState-makeLenses ''PostListOverlayState-makeLenses ''ListOverlayState-makeLenses ''ChannelSelectState-makeLenses ''UserPreferences-makeLenses ''ConnectionInfo--getSession :: MH Session-getSession = use (csResources.crSession)--getResourceSession :: ChatResources -> Session-getResourceSession = _crSession--whenMode :: Mode -> MH () -> MH ()-whenMode m act = do-    curMode <- use csMode-    when (curMode == m) act--setMode :: Mode -> MH ()-setMode m = do-    csMode .= m-    mh invalidateCache--setMode' :: Mode -> ChatState -> ChatState-setMode' m = csMode .~ m--appMode :: ChatState -> Mode-appMode = _csMode--resetSpellCheckTimer :: ChatEditState -> IO ()-resetSpellCheckTimer s =-    case s^.cedSpellChecker of-        Nothing -> return ()-        Just (_, reset) -> reset---- ** Utility Lenses-csCurrentChannelId :: SimpleGetter ChatState ChannelId-csCurrentChannelId = csFocus.to unsafeFocus.to channelListEntryChannelId--channelListEntryChannelId :: ChannelListEntry -> ChannelId-channelListEntryChannelId (CLChannel cId) = cId-channelListEntryChannelId (CLUserDM cId _) = cId-channelListEntryChannelId (CLGroupDM cId) = cId--channelListEntryUserId :: ChannelListEntry -> Maybe UserId-channelListEntryUserId (CLUserDM _ uId) = Just uId-channelListEntryUserId _ = Nothing--userIdsFromZipper :: Zipper ChannelListGroup ChannelListEntry -> [UserId]-userIdsFromZipper z =-    concat $ (catMaybes . fmap channelListEntryUserId . snd) <$> Zipper.toList z--entryIsDMEntry :: ChannelListEntry -> Bool-entryIsDMEntry (CLUserDM {}) = True-entryIsDMEntry (CLGroupDM {}) = True-entryIsDMEntry (CLChannel {}) = False--csCurrentChannel :: Lens' ChatState ClientChannel-csCurrentChannel =-    lens (\ st -> findChannelById (st^.csCurrentChannelId) (st^.csChannels) ^?! _Just)-         (\ st n -> st & csChannels %~ addChannel (st^.csCurrentChannelId) n)--csChannel :: ChannelId -> Traversal' ChatState ClientChannel-csChannel cId =-    csChannels . channelByIdL cId--withChannel :: ChannelId -> (ClientChannel -> MH ()) -> MH ()-withChannel cId = withChannelOrDefault cId ()--withChannelOrDefault :: ChannelId -> a -> (ClientChannel -> MH a) -> MH a-withChannelOrDefault cId deflt mote = do-    chan <- preuse (csChannel(cId))-    case chan of-        Nothing -> return deflt-        Just c  -> mote c---- ** 'ChatState' Helper Functions--raiseInternalEvent :: InternalEvent -> MH ()-raiseInternalEvent ev = do-    queue <- use (csResources.crEventQueue)-    writeBChan queue (IEvent ev)--writeBChan :: (MonadIO m) => BCH.BChan MHEvent -> MHEvent -> m ()-writeBChan chan e = do-    written <- liftIO $ BCH.writeBChanNonBlocking chan e-    when (not written) $-        error $ "mhSendEvent: BChan full, please report this as a bug!"---- | Log and raise an error.-mhError :: MHError -> MH ()-mhError err = do-    mhLog LogError $ T.pack $ show err-    raiseInternalEvent (DisplayError err)--isMine :: ChatState -> Message -> Bool-isMine st msg =-    case msg^.mUser of-        UserI _ uid -> uid == myUserId st-        _ -> False--getMessageForPostId :: ChatState -> PostId -> Maybe Message-getMessageForPostId st pId = st^.csPostMap.at(pId)--getParentMessage :: ChatState -> Message -> Maybe Message-getParentMessage st msg-    | InReplyTo pId <- msg^.mInReplyToMsg-      = st^.csPostMap.at(pId)-    | otherwise = Nothing--setUserStatus :: UserId -> Text -> MH ()-setUserStatus uId t = do-    csUsers %= modifyUserById uId (uiStatus .~ statusFromText t)-    mh $ invalidateCacheEntry ChannelSidebar--usernameForUserId :: UserId -> ChatState -> Maybe Text-usernameForUserId uId st = _uiName <$> findUserById uId (st^.csUsers)--displayNameForUserId :: UserId -> ChatState -> Maybe Text-displayNameForUserId uId st = do-    u <- findUserById uId (st^.csUsers)-    return $ displayNameForUser u (st^.csClientConfig) (st^.csResources.crUserPreferences)---- | Note: this only searches users we have already loaded. Be--- aware that if you think you need a user we haven't fetched, use--- withFetchedUser!-userIdForUsername :: Text -> ChatState -> Maybe UserId-userIdForUsername name st =-    fst <$> (findUserByUsername name $ st^.csUsers)--channelIdByChannelName :: Text -> ChatState -> Maybe ChannelId-channelIdByChannelName name st =-    let matches (_, cc) = cc^.ccInfo.cdName == (trimChannelSigil name)-    in listToMaybe $ fst <$> filteredChannels matches (st^.csChannels)--channelIdByUsername :: Text -> ChatState -> Maybe ChannelId-channelIdByUsername name st = do-    uId <- userIdForUsername name st-    getDmChannelFor uId (st^.csChannels)--useNickname :: ChatState -> Bool-useNickname st =-    useNickname' (st^.csClientConfig) (st^.csResources.crUserPreferences)--channelByName :: Text -> ChatState -> Maybe ClientChannel-channelByName n st = do-    cId <- channelIdByChannelName n st-    findChannelById cId (st^.csChannels)--trimChannelSigil :: Text -> Text-trimChannelSigil n-    | normalChannelSigil `T.isPrefixOf` n = T.tail n-    | otherwise = n--addNewUser :: UserInfo -> MH ()-addNewUser u = do-    csUsers %= addUser u-    -- Invalidate the cache because channel message rendering may need-    -- to get updated if this user authored posts in any channels.-    mh invalidateCache--data SidebarUpdate =-    SidebarUpdateImmediate-    | SidebarUpdateDeferred-    deriving (Eq, Show)---resetAutocomplete :: MH ()-resetAutocomplete = do-    csEditState.cedAutocomplete .= Nothing-    csEditState.cedAutocompletePending .= Nothing----- * Slash Commands---- | The 'CmdArgs' type represents the arguments to a slash-command; the--- type parameter represents the argument structure.-data CmdArgs :: K.Type -> K.Type where-    NoArg    :: CmdArgs ()-    LineArg  :: Text -> CmdArgs Text-    UserArg  :: CmdArgs rest -> CmdArgs (Text, rest)-    ChannelArg :: CmdArgs rest -> CmdArgs (Text, rest)-    TokenArg :: Text -> CmdArgs rest -> CmdArgs (Text, rest)---- | A 'CmdExec' value represents the implementation of a command when--- provided with its arguments-type CmdExec a = a -> MH ()---- | A 'Cmd' packages up a 'CmdArgs' specifier and the 'CmdExec'--- implementation with a name and a description.-data Cmd =-    forall a. Cmd { cmdName    :: Text-                  , cmdDescr   :: Text-                  , cmdArgSpec :: CmdArgs a-                  , cmdAction  :: CmdExec a-                  }---- | Helper function to extract the name out of a 'Cmd' value-commandName :: Cmd -> Text-commandName (Cmd name _ _ _ ) = name---- *  Channel Updates and Notifications--userList :: ChatState -> [UserInfo]-userList st = filter showUser $ allUsers (st^.csUsers)-    where showUser u = not (isSelf u) && (u^.uiInTeam)-          isSelf u = (myUserId st) == (u^.uiId)--allUserIds :: ChatState -> [UserId]-allUserIds st = getAllUserIds $ st^.csUsers---- BEWARE: you probably don't want this, but instead--- State.Users.withFetchedUser, since this only looks up users in the--- collection we have already loaded rather than all valid users on the--- server.-userById :: UserId -> ChatState -> Maybe UserInfo-userById uId st = findUserById uId (st^.csUsers)--myUserId :: ChatState -> UserId-myUserId st = myUser st ^. userIdL--myTeamId :: ChatState -> TeamId-myTeamId st = st ^. csMyTeam . teamIdL--myUser :: ChatState -> User-myUser st = st^.csMe--myUsername :: ChatState -> Text-myUsername st = userUsername $ st^.csMe---- BEWARE: you probably don't want this, but instead--- State.Users.withFetchedUser, since this only looks up users in the--- collection we have already loaded rather than all valid users on the--- server.-userByUsername :: Text -> ChatState -> Maybe UserInfo-userByUsername name st = do-    snd <$> (findUserByUsername name $ st^.csUsers)---- BEWARE: you probably don't want this, but instead--- State.Users.withFetchedUser, since this only looks up users in the--- collection we have already loaded rather than all valid users on the--- server.-userByNickname :: Text -> ChatState -> Maybe UserInfo-userByNickname name st =-    snd <$> (findUserByNickname name $ st^.csUsers)--getUsers :: MH Users-getUsers = use csUsers---- * HighlightSet--type UserSet = Set Text-type ChannelSet = Set Text---- | The set of usernames, channel names, and language names used for--- highlighting when rendering messages.-data HighlightSet =-    HighlightSet { hUserSet    :: Set Text-                 , hChannelSet :: Set Text-                 , hSyntaxMap  :: SyntaxMap-                 }--getHighlightSet :: ChatState -> HighlightSet-getHighlightSet st =-    HighlightSet { hUserSet = addSpecialUserMentions $ getUsernameSet $ st^.csUsers-                 , hChannelSet = getChannelNameSet $ st^.csChannels-                 , hSyntaxMap = st^.csResources.crSyntaxMap-                 }--attrNameToConfig :: Brick.AttrName -> Text-attrNameToConfig = T.pack . intercalate "." . Brick.attrNameComponents---- From: https://docs.mattermost.com/help/messaging/mentioning-teammates.html-specialUserMentions :: [T.Text]-specialUserMentions = ["all", "channel", "here"]--addSpecialUserMentions :: Set Text -> Set Text-addSpecialUserMentions s = foldr Set.insert s specialUserMentions--getNewMessageCutoff :: ChannelId -> ChatState -> Maybe NewMessageIndicator-getNewMessageCutoff cId st = do-    cc <- st^?csChannel(cId)-    return $ cc^.ccInfo.cdNewMessageIndicator--getEditedMessageCutoff :: ChannelId -> ChatState -> Maybe ServerTime-getEditedMessageCutoff cId st = do-    cc <- st^?csChannel(cId)-    cc^.ccInfo.cdEditedMessageThreshold--clearChannelUnreadStatus :: ChannelId -> MH ()-clearChannelUnreadStatus cId = do-    mh $ invalidateCacheEntry (ChannelMessages cId)-    csChannel(cId) %= (clearNewMessageIndicator .-                       clearEditedThreshold)--data OpenInBrowser =-    OpenLinkChoice LinkChoice-    | OpenLocalFile FilePath-    deriving (Eq, Show)
− src/Types/Channels.hs 
@@ -1,420 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE RankNTypes #-}--module Types.Channels-  ( ClientChannel(..)-  , ChannelContents(..)-  , ChannelInfo(..)-  , ClientChannels -- constructor remains internal-  , NewMessageIndicator(..)-  , EphemeralEditState(..)-  , EditMode(..)-  , eesMultiline, eesInputHistoryPosition, eesLastInput-  , defaultEphemeralEditState-  -- * Lenses created for accessing ClientChannel fields-  , ccContents, ccInfo, ccEditState-  -- * Lenses created for accessing ChannelInfo fields-  , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated-  , cdName, cdDisplayName, cdHeader, cdPurpose, cdType-  , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId-  , cdSidebarShowOverride, cdNotifyProps-  -- * Lenses created for accessing ChannelContents fields-  , cdMessages, cdFetchPending-  -- * Creating ClientChannel objects-  , makeClientChannel-  -- * Managing ClientChannel collections-  , noChannels, addChannel, removeChannel, findChannelById, modifyChannelById-  , channelByIdL, maybeChannelByIdL-  , filteredChannelIds-  , filteredChannels-  -- * Creating ChannelInfo objects-  , channelInfoFromChannelWithData-  -- * Channel State management-  , clearNewMessageIndicator-  , clearEditedThreshold-  , adjustUpdated-  , adjustEditedThreshold-  , updateNewMessageIndicator-  , addChannelTypingUser-  -- * Notification settings-  , notifyPreference-  , isMuted-  , channelNotifyPropsMarkUnreadL-  , channelNotifyPropsIgnoreChannelMentionsL-  , channelNotifyPropsDesktopL-  , channelNotifyPropsPushL-  -- * Miscellaneous channel-related operations-  , canLeaveChannel-  , preferredChannelName-  , isTownSquare-  , channelDeleted-  , getDmChannelFor-  , allDmChannelMappings-  , getChannelNameSet-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.HashMap.Strict as HM-import qualified Data.Set as S-import qualified Data.Text as T-import           Lens.Micro.Platform ( (%~), (.~), Traversal', Lens'-                                     , makeLenses, ix, at-                                     , to, non )--import           Network.Mattermost.Lenses hiding ( Lens' )-import           Network.Mattermost.Types ( Channel(..), UserId, ChannelId-                                          , ChannelMember(..)-                                          , Type(..)-                                          , Post-                                          , User(userNotifyProps)-                                          , ChannelNotifyProps-                                          , NotifyOption(..)-                                          , WithDefault(..)-                                          , ServerTime-                                          , emptyChannelNotifyProps-                                          )--import           Types.Messages ( Messages, noMessages, addMessage-                                , clientMessageToMessage, Message, MessageType )-import           Types.Posts ( ClientMessageType(UnknownGapBefore)-                             , newClientMessage )-import           Types.Users ( TypingUsers, noTypingUsers, addTypingUser )-import           Types.Common----- * Channel representations---- | A 'ClientChannel' contains both the message---   listing and the metadata about a channel-data ClientChannel = ClientChannel-  { _ccContents :: ChannelContents-    -- ^ A list of 'Message's in the channel-  , _ccInfo :: ChannelInfo-    -- ^ The 'ChannelInfo' for the channel-  , _ccEditState :: EphemeralEditState-    -- ^ Editor state that we swap in and out as the current channel is-    -- changed.-  }---- | The input state associated with the message editor.-data EditMode =-    NewPost-    -- ^ The input is for a new post.-    | Editing Post MessageType-    -- ^ The input is ultimately to replace the body of an existing post-    -- of the specified type.-    | Replying Message Post-    -- ^ The input is to be used as a new post in reply to the specified-    -- post.-    deriving (Show)--data EphemeralEditState =-    EphemeralEditState { _eesMultiline :: Bool-                       -- ^ Whether the editor is in multiline mode-                       , _eesInputHistoryPosition :: Maybe Int-                       -- ^ The input history position, if any-                       , _eesLastInput :: (T.Text, EditMode)-                       -- ^ The input entered into the text editor last-                       -- time the user was focused on the channel-                       -- associated with this state.-                       }---- Get a channel's name, depending on its type-preferredChannelName :: Channel -> Text-preferredChannelName ch-    | channelType ch == Group = sanitizeUserText $ channelDisplayName ch-    | otherwise               = sanitizeUserText $ channelName ch--data NewMessageIndicator =-    Hide-    | NewPostsAfterServerTime ServerTime-    | NewPostsStartingAt ServerTime-    deriving (Eq, Show)--initialChannelInfo :: UserId -> Channel -> ChannelInfo-initialChannelInfo myId chan =-    let updated  = chan ^. channelLastPostAtL-    in ChannelInfo { _cdChannelId              = chan^.channelIdL-                   , _cdViewed                 = Nothing-                   , _cdNewMessageIndicator    = Hide-                   , _cdEditedMessageThreshold = Nothing-                   , _cdMentionCount           = 0-                   , _cdUpdated                = updated-                   , _cdName                   = preferredChannelName chan-                   , _cdDisplayName            = sanitizeUserText $ channelDisplayName chan-                   , _cdHeader                 = sanitizeUserText $ chan^.channelHeaderL-                   , _cdPurpose                = sanitizeUserText $ chan^.channelPurposeL-                   , _cdType                   = chan^.channelTypeL-                   , _cdNotifyProps            = emptyChannelNotifyProps-                   , _cdTypingUsers            = noTypingUsers-                   , _cdDMUserId               = if chan^.channelTypeL == Direct-                                                 then userIdForDMChannel myId $-                                                      sanitizeUserText $ channelName chan-                                                 else Nothing-                   , _cdSidebarShowOverride    = Nothing-                   }--channelInfoFromChannelWithData :: Channel -> ChannelMember -> ChannelInfo -> ChannelInfo-channelInfoFromChannelWithData chan chanMember ci =-    let viewed   = chanMember ^. to channelMemberLastViewedAt-        updated  = chan ^. channelLastPostAtL-    in ci { _cdViewed           = Just viewed-          , _cdNewMessageIndicator = case _cdNewMessageIndicator ci of-              Hide -> if updated > viewed then NewPostsAfterServerTime viewed else Hide-              v -> v-          , _cdUpdated          = updated-          , _cdName             = preferredChannelName chan-          , _cdDisplayName      = sanitizeUserText $ channelDisplayName chan-          , _cdHeader           = (sanitizeUserText $ chan^.channelHeaderL)-          , _cdPurpose          = (sanitizeUserText $ chan^.channelPurposeL)-          , _cdType             = (chan^.channelTypeL)-          , _cdMentionCount     = chanMember^.to channelMemberMentionCount-          , _cdNotifyProps      = chanMember^.to channelMemberNotifyProps-          }---- | The 'ChannelContents' is a wrapper for a list of---   'Message' values-data ChannelContents = ChannelContents-  { _cdMessages :: Messages-  , _cdFetchPending :: Bool-  }---- | An initial empty 'ChannelContents' value.  This also contains an--- UnknownGapBefore, which is a signal that causes actual content fetching.--- The initial Gap's timestamp is the local client time, but--- subsequent fetches will synchronize with the server (and eventually--- eliminate this Gap as well).-emptyChannelContents :: MonadIO m => m ChannelContents-emptyChannelContents = do-  gapMsg <- clientMessageToMessage <$> newClientMessage UnknownGapBefore "--Fetching messages--"-  return $ ChannelContents { _cdMessages = addMessage gapMsg noMessages-                           , _cdFetchPending = False-                           }------------------------------------------------------------------------------- | The 'ChannelInfo' record represents metadata---   about a channel-data ChannelInfo = ChannelInfo-  { _cdChannelId        :: ChannelId-    -- ^ The channel's ID-  , _cdViewed           :: Maybe ServerTime-    -- ^ The last time we looked at a channel-  , _cdNewMessageIndicator :: NewMessageIndicator-    -- ^ The state of the channel's new message indicator.-  , _cdEditedMessageThreshold :: Maybe ServerTime-    -- ^ The channel's edited message threshold.-  , _cdMentionCount     :: Int-    -- ^ The current number of unread mentions-  , _cdUpdated          :: ServerTime-    -- ^ The last time a message showed up in the channel-  , _cdName             :: Text-    -- ^ The name of the channel-  , _cdDisplayName      :: Text-    -- ^ The display name of the channel-  , _cdHeader           :: Text-    -- ^ The header text of a channel-  , _cdPurpose          :: Text-    -- ^ The stated purpose of the channel-  , _cdType             :: Type-    -- ^ The type of a channel: public, private, or DM-  , _cdNotifyProps      :: ChannelNotifyProps-    -- ^ The user's notification settings for this channel-  , _cdTypingUsers      :: TypingUsers-    -- ^ The users who are currently typing in this channel-  , _cdDMUserId         :: Maybe UserId-    -- ^ The user associated with this channel, if it is a DM channel-  , _cdSidebarShowOverride :: Maybe UTCTime-    -- ^ If set, show this channel in the sidebar regardless of other-    -- considerations as long as the specified timestamp meets a cutoff.-    -- Otherwise fall back to other application policy to determine-    -- whether to show the channel.-  }---- ** Channel-related Lenses--makeLenses ''ChannelContents-makeLenses ''ChannelInfo-makeLenses ''ClientChannel-makeLenses ''EphemeralEditState--isMuted :: ClientChannel -> Bool-isMuted cc = cc^.ccInfo.cdNotifyProps.channelNotifyPropsMarkUnreadL ==-             IsValue NotifyOptionMention--notifyPreference :: User -> ClientChannel -> NotifyOption-notifyPreference u cc =-    if isMuted cc then NotifyOptionNone-    else case cc^.ccInfo.cdNotifyProps.channelNotifyPropsDesktopL of-             IsValue v -> v-             Default   -> (userNotifyProps u)^.userNotifyPropsDesktopL---- ** Miscellaneous channel operations--makeClientChannel :: (MonadIO m) => UserId -> Channel -> m ClientChannel-makeClientChannel myId nc = emptyChannelContents >>= \contents ->-  return ClientChannel-  { _ccContents = contents-  , _ccInfo = initialChannelInfo myId nc-  , _ccEditState = defaultEphemeralEditState-  }--defaultEphemeralEditState :: EphemeralEditState-defaultEphemeralEditState =-    EphemeralEditState { _eesMultiline = False-                       , _eesInputHistoryPosition = Nothing-                       , _eesLastInput = ("", NewPost)-                       }--canLeaveChannel :: ChannelInfo -> Bool-canLeaveChannel cInfo = not $ cInfo^.cdType `elem` [Direct]---- ** Manage the collection of all Channels---- | Define a binary kinded type to allow derivation of functor.-data AllMyChannels a =-    AllChannels { _chanMap :: HashMap ChannelId a-                , _userChannelMap :: HashMap UserId ChannelId-                , _channelNameSet :: S.Set Text-                }-                deriving (Functor, Foldable, Traversable)---- | Define the exported typename which universally binds the--- collection to the ChannelInfo type.-type ClientChannels = AllMyChannels ClientChannel--makeLenses ''AllMyChannels--getChannelNameSet :: ClientChannels -> S.Set Text-getChannelNameSet = _channelNameSet---- | Initial collection of Channels with no members-noChannels :: ClientChannels-noChannels = AllChannels HM.empty HM.empty mempty---- | Add a channel to the existing collection.-addChannel :: ChannelId -> ClientChannel -> ClientChannels -> ClientChannels-addChannel cId cinfo =-    (chanMap %~ HM.insert cId cinfo) .-    (if cinfo^.ccInfo.cdType `notElem` [Direct, Group]-     then channelNameSet %~ S.insert (cinfo^.ccInfo.cdName)-     else id) .-    (case cinfo^.ccInfo.cdDMUserId of-         Nothing -> id-         Just uId -> userChannelMap %~ HM.insert uId cId-    )---- | Remove a channel from the collection.-removeChannel :: ChannelId -> ClientChannels -> ClientChannels-removeChannel cId cs =-    let mChan = findChannelById cId cs-        removeChannelName = case mChan of-            Nothing -> id-            Just ch -> channelNameSet %~ S.delete (ch^.ccInfo.cdName)-    in cs & chanMap %~ HM.delete cId-          & removeChannelName-          & userChannelMap %~ HM.filter (/= cId)--getDmChannelFor :: UserId -> ClientChannels -> Maybe ChannelId-getDmChannelFor uId cs = cs^.userChannelMap.at uId--allDmChannelMappings :: ClientChannels -> [(UserId, ChannelId)]-allDmChannelMappings = HM.toList . _userChannelMap---- | Get the ChannelInfo information given the ChannelId-findChannelById :: ChannelId -> ClientChannels -> Maybe ClientChannel-findChannelById cId = HM.lookup cId . _chanMap---- | Transform the specified channel in place with provided function.-modifyChannelById :: ChannelId -> (ClientChannel -> ClientChannel)-                  -> ClientChannels -> ClientChannels-modifyChannelById cId f = chanMap.ix(cId) %~ f---- | A 'Traversal' that will give us the 'ClientChannel' in a--- 'ClientChannels' structure if it exists-channelByIdL :: ChannelId -> Traversal' ClientChannels ClientChannel-channelByIdL cId = chanMap . ix cId---- | A 'Lens' that will give us the 'ClientChannel' in a--- 'ClientChannels' wrapped in a 'Maybe'-maybeChannelByIdL :: ChannelId -> Lens' ClientChannels (Maybe ClientChannel)-maybeChannelByIdL cId = chanMap . at cId---- | Apply a filter to each ClientChannel and return a list of the--- ChannelId values for which the filter matched.-filteredChannelIds :: (ClientChannel -> Bool) -> ClientChannels -> [ChannelId]-filteredChannelIds f cc = fst <$> filter (f . snd) (HM.toList (cc^.chanMap))---- | Filter the ClientChannel collection, keeping only those for which--- the provided filter test function returns True.-filteredChannels :: ((ChannelId, ClientChannel) -> Bool)-                 -> ClientChannels -> [(ChannelId, ClientChannel)]-filteredChannels f cc = filter f $ cc^.chanMap.to HM.toList------------------------------------------------------------------------------ * Channel State management----- | Add user to the list of users in this channel who are currently typing.-addChannelTypingUser :: UserId -> UTCTime -> ClientChannel -> ClientChannel-addChannelTypingUser uId ts = ccInfo.cdTypingUsers %~ (addTypingUser uId ts)---- | Clear the new message indicator for the specified channel-clearNewMessageIndicator :: ClientChannel -> ClientChannel-clearNewMessageIndicator c = c & ccInfo.cdNewMessageIndicator .~ Hide---- | Clear the edit threshold for the specified channel-clearEditedThreshold :: ClientChannel -> ClientChannel-clearEditedThreshold c = c & ccInfo.cdEditedMessageThreshold .~ Nothing---- | Adjust updated time based on a message, ensuring that the updated--- time does not move backward.-adjustUpdated :: Post -> ClientChannel -> ClientChannel-adjustUpdated m =-    ccInfo.cdUpdated %~ max (maxPostTimestamp m)--adjustEditedThreshold :: Post -> ClientChannel -> ClientChannel-adjustEditedThreshold m c =-    if m^.postUpdateAtL <= m^.postCreateAtL-    then c-    else c & ccInfo.cdEditedMessageThreshold %~ (\mt -> case mt of-        Just t -> Just $ min (m^.postUpdateAtL) t-        Nothing -> Just $ m^.postUpdateAtL-        )--maxPostTimestamp :: Post -> ServerTime-maxPostTimestamp m = max (m^.postDeleteAtL . non (m^.postUpdateAtL)) (m^.postCreateAtL)--updateNewMessageIndicator :: Post -> ClientChannel -> ClientChannel-updateNewMessageIndicator m =-    ccInfo.cdNewMessageIndicator %~-        (\old ->-          case old of-              Hide ->-                  NewPostsStartingAt $ m^.postCreateAtL-              NewPostsStartingAt ts ->-                  NewPostsStartingAt $ min (m^.postCreateAtL) ts-              NewPostsAfterServerTime ts ->-                  if m^.postCreateAtL <= ts-                  then NewPostsStartingAt $ m^.postCreateAtL-                  else NewPostsAfterServerTime ts-              )---- | Town Square is special in that its non-display name cannot be--- changed and is a hard-coded constant server-side according to the--- developers (as of 8/2/17). So this is a reliable way to check for--- whether a channel is in fact that channel, even if the user has--- changed its display name.-isTownSquare :: Channel -> Bool-isTownSquare c = (sanitizeUserText $ c^.channelNameL) == "town-square"--channelDeleted :: Channel -> Bool-channelDeleted c = c^.channelDeleteAtL > c^.channelCreateAtL
− src/Types/Common.hs 
@@ -1,41 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-module Types.Common-  ( sanitizeUserText-  , sanitizeUserText'-  , userIdForDMChannel-  )-where--import Prelude ()-import Prelude.MH--import qualified Data.Text as T--import Network.Mattermost.Types ( UserText, unsafeUserText, UserId(..), Id(..) )--sanitizeUserText :: UserText -> T.Text-sanitizeUserText = sanitizeUserText' . unsafeUserText--sanitizeUserText' :: T.Text -> T.Text-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--- is but neither user ID in the name matches the current user's ID.-userIdForDMChannel :: UserId-                   -- ^ My user ID-                   -> Text-                   -- ^ The channel name-                   -> Maybe UserId-userIdForDMChannel me chanName =-    -- Direct channel names are of the form "UID__UID" where one of the-    -- UIDs is mine and the other is the other channel participant.-    let vals = T.splitOn "__" chanName-    in case vals of-        [u1, u2] -> if | (UI $ Id u1) == me  -> Just $ UI $ Id u2-                       | (UI $ Id u2) == me  -> Just $ UI $ Id u1-                       | otherwise        -> Nothing-        _ -> Nothing
− src/Types/DirectionalSeq.hs 
@@ -1,97 +0,0 @@-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE TypeFamilies #-}--{- | These declarations allow the use of a DirectionalSeq, which is a-   Seq that uses a phantom type to identify the ordering of the-   elements in the sequence (Forward or Reverse).  The constructors-   are not exported from this module so that a DirectionalSeq can only-   be constructed by the functions in this module.--}--module Types.DirectionalSeq where--import           Prelude ()-import           Prelude.MH--import qualified Data.Sequence as Seq---data Chronological-data Retrograde-class SeqDirection a where-  type ReverseDirection a-instance SeqDirection Chronological-  where type ReverseDirection Chronological = Retrograde-instance SeqDirection Retrograde-  where type ReverseDirection Retrograde = Chronological--data SeqDirection dir => DirectionalSeq dir a =-    DSeq { dseq :: Seq a }-         deriving (Show, Functor, Foldable, Traversable)--emptyDirSeq :: DirectionalSeq dir a-emptyDirSeq = DSeq mempty--appendDirSeq :: DirectionalSeq dir a -> DirectionalSeq dir a -> DirectionalSeq dir a-appendDirSeq a b = DSeq $ mappend (dseq a) (dseq b)--onDirectedSeq :: SeqDirection dir => (Seq a -> Seq b)-              -> DirectionalSeq dir a -> DirectionalSeq dir b-onDirectedSeq f = DSeq . f . dseq---- | Uses a start-predicate and and end-predicate to--- identify (the first matching) subset that is delineated by--- start-predicate and end-predicate (inclusive).  It will then call--- the passed operation function on the subset messages to get back a--- (possibly modified) set of messages, along with an extracted value.--- The 'onDirSeqSubset' function will replace the original subset of--- messages with the set returned by the operation function and return--- the resulting message list along with the extracted value.--onDirSeqSubset :: SeqDirection dir =>-                 (e -> Bool) -> (e -> Bool)-               -> (DirectionalSeq dir e -> (DirectionalSeq dir e, a))-               -> DirectionalSeq dir e-               -> (DirectionalSeq dir e, a)-onDirSeqSubset startPred endPred op entries =-    let ml = dseq entries-        (bl, ml1) = Seq.breakl startPred ml-        (ml2, el) = Seq.breakl endPred ml1-        -- move match from start of el to end of ml2-        (ml2', el') = if not (Seq.null el)-                      then (ml2 <> Seq.take 1 el, Seq.drop 1 el)-                      else (ml2, el)-        (ml3, rval) = op $ DSeq ml2'-    in (DSeq bl `appendDirSeq` ml3 `appendDirSeq` DSeq el', rval)---- | dirSeqBreakl splits the DirectionalSeq into a tuple where the--- first element is the (possibly empty) DirectionalSeq of all--- elements from the start for which the predicate returns false; the--- second tuple element is the remainder of the list, starting with--- the first element for which the predicate matched.-dirSeqBreakl :: SeqDirection dir =>-               (e -> Bool) -> DirectionalSeq dir e-             -> (DirectionalSeq dir e, DirectionalSeq dir e)-dirSeqBreakl isMatch entries =-    let (removed, remaining) = Seq.breakl isMatch $ dseq entries-    in (DSeq removed, DSeq remaining)---- | dirSeqPartition splits the DirectionalSeq into a tuple of two--- DirectionalSeq elements: the first contains all elements for which--- the predicate is true and the second contains all elements for--- which the predicate is false.-dirSeqPartition :: SeqDirection dir =>-                  (e -> Bool) -> DirectionalSeq dir e-                -> (DirectionalSeq dir e, DirectionalSeq dir e)-dirSeqPartition isMatch entries =-    let (match, nomatch) = Seq.partition isMatch $ dseq entries-    in (DSeq match, DSeq nomatch)---withDirSeqHead :: SeqDirection dir => (e -> r) -> DirectionalSeq dir e -> Maybe r-withDirSeqHead op entries =-    case Seq.viewl (dseq entries) of-      Seq.EmptyL -> Nothing-      e Seq.:< _ -> Just $ op e
− src/Types/KeyEvents.hs 
@@ -1,434 +0,0 @@-module Types.KeyEvents-  (-  -- * Types-    KeyEvent(..)-  , KeyConfig-  , Binding(..)-  , BindingState(..)--  -- * Data-  , allEvents--  -- * Parsing and pretty-printing-  , parseBinding-  , parseBindingList-  , ppBinding-  , nonCharKeys-  , eventToBinding--  -- * Key event name resolution-  , keyEventFromName-  , keyEventName-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.Map.Strict as M-import qualified Data.Text as T-import qualified Graphics.Vty as Vty----- | This enum represents all the possible key events a user might---   want to use.-data KeyEvent-  = VtyRefreshEvent-  | ShowHelpEvent-  | EnterSelectModeEvent-  | ReplyRecentEvent-  | ToggleMessagePreviewEvent-  | InvokeEditorEvent-  | EnterFastSelectModeEvent-  | QuitEvent-  | NextChannelEvent-  | PrevChannelEvent-  | NextChannelEventAlternate-  | PrevChannelEventAlternate-  | NextUnreadChannelEvent-  | NextUnreadUserOrChannelEvent-  | LastChannelEvent-  | EnterOpenURLModeEvent-  | ClearUnreadEvent-  | ToggleMultiLineEvent-  | EnterFlaggedPostsEvent-  | ToggleChannelListVisibleEvent-  | ShowAttachmentListEvent--  | EditorKillToBolEvent-  | EditorKillToEolEvent-  | EditorBolEvent-  | EditorEolEvent-  | EditorTransposeCharsEvent-  | EditorDeleteCharacter-  | EditorPrevCharEvent-  | EditorNextCharEvent-  | EditorPrevWordEvent-  | EditorNextWordEvent-  | EditorDeleteNextWordEvent-  | EditorDeletePrevWordEvent-  | EditorHomeEvent-  | EditorEndEvent-  | EditorYankEvent--  | SelectNextTabEvent-  | SelectPreviousTabEvent--  -- generic cancel-  | CancelEvent--  -- channel-scroll-specific-  | LoadMoreEvent-  | OpenMessageURLEvent--  -- scrolling events---maybe rebindable?-  | ScrollUpEvent-  | ScrollDownEvent-  | ScrollLeftEvent-  | ScrollRightEvent-  | PageUpEvent-  | PageDownEvent-  | PageRightEvent-  | PageLeftEvent-  | ScrollTopEvent-  | ScrollBottomEvent-  | SelectOldestMessageEvent--  -- select events---not the same as scrolling sometimes!-  | SelectUpEvent-  | SelectDownEvent--  -- search select events---these need to not be valid editor inputs-  -- (such as 'j' and 'k')-  | SearchSelectUpEvent-  | SearchSelectDownEvent--  -- E.g. Pressing enter on an item in a list to do something with it-  | ActivateListItemEvent--  | ViewMessageEvent-  | FillGapEvent-  | FlagMessageEvent-  | PinMessageEvent-  | YankMessageEvent-  | YankWholeMessageEvent-  | DeleteMessageEvent-  | EditMessageEvent-  | ReplyMessageEvent-  | ReactToMessageEvent--  -- Attachments-  | AttachmentListAddEvent-  | AttachmentListDeleteEvent-  | AttachmentOpenEvent--  -- Form submission-  | FormSubmitEvent-    deriving (Eq, Show, Ord, Enum)--allEvents :: [KeyEvent]-allEvents =-  [ QuitEvent-  , VtyRefreshEvent-  , ClearUnreadEvent--  , ToggleMessagePreviewEvent-  , InvokeEditorEvent-  , ToggleMultiLineEvent-  , CancelEvent-  , ReplyRecentEvent-  , SelectNextTabEvent-  , SelectPreviousTabEvent--  , 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-  , EnterSelectModeEvent-  , EnterOpenURLModeEvent--  , LoadMoreEvent-  , OpenMessageURLEvent--  , ScrollUpEvent-  , ScrollDownEvent-  , ScrollLeftEvent-  , ScrollRightEvent-  , PageUpEvent-  , PageDownEvent-  , PageLeftEvent-  , PageRightEvent-  , ScrollTopEvent-  , ScrollBottomEvent-  , SelectOldestMessageEvent--  , SelectUpEvent-  , SelectDownEvent--  , ActivateListItemEvent--  , SearchSelectUpEvent-  , SearchSelectDownEvent--  , FlagMessageEvent-  , PinMessageEvent-  , ViewMessageEvent-  , FillGapEvent-  , YankMessageEvent-  , YankWholeMessageEvent-  , DeleteMessageEvent-  , EditMessageEvent-  , ReplyMessageEvent-  , ReactToMessageEvent-  , AttachmentListAddEvent-  , AttachmentListDeleteEvent-  , AttachmentOpenEvent-  , FormSubmitEvent-  ]--eventToBinding :: Vty.Event -> Binding-eventToBinding (Vty.EvKey k mods) = Binding mods k-eventToBinding k = error $ "BUG: invalid keybinding " <> show k--data Binding = Binding-  { kbMods :: [Vty.Modifier]-  , kbKey  :: Vty.Key-  } deriving (Eq, Show, Ord)--data BindingState =-    BindingList [Binding]-    | Unbound-    deriving (Show, Eq, Ord)--type KeyConfig = M.Map KeyEvent BindingState--parseBinding :: Text -> Either String Binding-parseBinding kb = go (T.splitOn "-" $ T.toLower kb) []-  where go [k] mods = do-          key <- pKey k-          return Binding { kbMods = mods, kbKey = key }-        go (k:ks) mods = do-          m <- case k of-            "s"       -> return Vty.MShift-            "shift"   -> return Vty.MShift-            "m"       -> return Vty.MMeta-            "meta"    -> return Vty.MMeta-            "a"       -> return Vty.MAlt-            "alt"     -> return Vty.MAlt-            "c"       -> return Vty.MCtrl-            "ctrl"    -> return Vty.MCtrl-            "control" -> return Vty.MCtrl-            _         -> Left ("Unknown modifier prefix: " ++ show k)-          go ks (m:mods)-        go [] _ = Left "Empty keybinding not allowed"-        pKey "esc"       = return Vty.KEsc-        pKey "backspace" = return Vty.KBS-        pKey "enter"     = return Vty.KEnter-        pKey "left"      = return Vty.KLeft-        pKey "right"     = return Vty.KRight-        pKey "up"        = return Vty.KUp-        pKey "down"      = return Vty.KDown-        pKey "upleft"    = return Vty.KUpLeft-        pKey "upright"   = return Vty.KUpRight-        pKey "downleft"  = return Vty.KDownLeft-        pKey "downright" = return Vty.KDownRight-        pKey "center"    = return Vty.KCenter-        pKey "backtab"   = return Vty.KBackTab-        pKey "printscreen" = return Vty.KPrtScr-        pKey "pause"     = return Vty.KPause-        pKey "insert"    = return Vty.KIns-        pKey "home"      = return Vty.KHome-        pKey "pgup"      = return Vty.KPageUp-        pKey "del"       = return Vty.KDel-        pKey "end"       = return Vty.KEnd-        pKey "pgdown"    = return Vty.KPageDown-        pKey "begin"     = return Vty.KBegin-        pKey "menu"      = return Vty.KMenu-        pKey "space"     = return (Vty.KChar ' ')-        pKey "tab"       = return (Vty.KChar '\t')-        pKey t-          | Just (c, "") <- T.uncons t =-              return (Vty.KChar c)-          | Just n <- T.stripPrefix "f" t =-              case readMaybe (T.unpack n) of-                  Nothing -> Left ("Unknown keybinding: " ++ show t)-                  Just i -> return (Vty.KFun i)-          | otherwise = Left ("Unknown keybinding: " ++ show t)--ppBinding :: Binding -> Text-ppBinding (Binding mods k) =-    T.intercalate "-" $ (ppMod <$> mods) <> [ppKey k]--ppKey :: Vty.Key -> Text-ppKey (Vty.KChar c)   = ppChar c-ppKey (Vty.KFun n)    = "F" <> (T.pack $ show n)-ppKey Vty.KBackTab    = "BackTab"-ppKey Vty.KEsc        = "Esc"-ppKey Vty.KBS         = "Backspace"-ppKey Vty.KEnter      = "Enter"-ppKey Vty.KUp         = "Up"-ppKey Vty.KDown       = "Down"-ppKey Vty.KLeft       = "Left"-ppKey Vty.KRight      = "Right"-ppKey Vty.KHome       = "Home"-ppKey Vty.KEnd        = "End"-ppKey Vty.KPageUp     = "PgUp"-ppKey Vty.KPageDown   = "PgDown"-ppKey Vty.KDel        = "Del"-ppKey Vty.KUpLeft     = "UpLeft"-ppKey Vty.KUpRight    = "UpRight"-ppKey Vty.KDownLeft   = "DownLeft"-ppKey Vty.KDownRight  = "DownRight"-ppKey Vty.KCenter     = "Center"-ppKey Vty.KPrtScr     = "PrintScreen"-ppKey Vty.KPause      = "Pause"-ppKey Vty.KIns        = "Insert"-ppKey Vty.KBegin      = "Begin"-ppKey Vty.KMenu       = "Menu"--nonCharKeys :: [Text]-nonCharKeys = map ppKey-  [ Vty.KBackTab, Vty.KEsc, Vty.KBS, Vty.KEnter, Vty.KUp, Vty.KDown-  , Vty.KLeft, Vty.KRight, Vty.KHome, Vty.KEnd, Vty.KPageDown-  , Vty.KPageUp, Vty.KDel, Vty.KUpLeft, Vty.KUpRight, Vty.KDownLeft-  , Vty.KDownRight, Vty.KCenter, Vty.KPrtScr, Vty.KPause, Vty.KIns-  , Vty.KBegin, Vty.KMenu-  ]--ppChar :: Char -> Text-ppChar '\t' = "Tab"-ppChar ' '  = "Space"-ppChar c    = T.singleton c--ppMod :: Vty.Modifier -> Text-ppMod Vty.MMeta  = "M"-ppMod Vty.MAlt   = "A"-ppMod Vty.MCtrl  = "C"-ppMod Vty.MShift = "S"--parseBindingList :: Text -> Either String BindingState-parseBindingList t =-    if T.toLower t == "unbound"-    then return Unbound-    else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," t)--keyEventFromName :: Text -> Either String KeyEvent-keyEventFromName t =-    let mapping = M.fromList [ (keyEventName e, e) | e <- allEvents ]-    in case M.lookup t mapping of-        Just e -> return e-        Nothing -> Left ("Unknown event: " ++ show t)--keyEventName :: KeyEvent -> Text-keyEventName ev = case ev of-  QuitEvent                 -> "quit"-  VtyRefreshEvent           -> "vty-refresh"-  ClearUnreadEvent          -> "clear-unread"-  CancelEvent               -> "cancel"--  ToggleMessagePreviewEvent -> "toggle-message-preview"-  InvokeEditorEvent         -> "invoke-editor"-  ToggleMultiLineEvent      -> "toggle-multiline"-  ReplyRecentEvent          -> "reply-recent"--  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"--  SelectNextTabEvent        -> "select-next-tab"-  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"-  ShowHelpEvent             -> "show-help"-  EnterSelectModeEvent      -> "select-mode"-  EnterOpenURLModeEvent     -> "enter-url-open"--  LoadMoreEvent             -> "load-more"-  OpenMessageURLEvent       -> "open-message-url"--  ScrollUpEvent     -> "scroll-up"-  ScrollDownEvent   -> "scroll-down"-  ScrollLeftEvent   -> "scroll-left"-  ScrollRightEvent  -> "scroll-right"-  PageUpEvent       -> "page-up"-  PageDownEvent     -> "page-down"-  PageLeftEvent     -> "page-left"-  PageRightEvent    -> "page-right"-  ScrollTopEvent    -> "scroll-top"-  ScrollBottomEvent -> "scroll-bottom"-  SelectOldestMessageEvent -> "select-oldest-message"--  SelectUpEvent   -> "select-up"-  SelectDownEvent -> "select-down"--  SearchSelectUpEvent   -> "search-select-up"-  SearchSelectDownEvent -> "search-select-down"--  ActivateListItemEvent -> "activate-list-item"--  FlagMessageEvent   -> "flag-message"-  PinMessageEvent   -> "pin-message"-  ViewMessageEvent   -> "view-message"-  FillGapEvent       -> "fetch-for-gap"-  YankMessageEvent   -> "yank-message"-  YankWholeMessageEvent   -> "yank-whole-message"-  DeleteMessageEvent -> "delete-message"-  EditMessageEvent   -> "edit-message"-  ReplyMessageEvent  -> "reply-message"-  ReactToMessageEvent -> "react-to-message"--  AttachmentListAddEvent    -> "add-to-attachment-list"-  AttachmentListDeleteEvent -> "delete-from-attachment-list"-  AttachmentOpenEvent       -> "open-attachment"--  FormSubmitEvent -> "submit-form"
− src/Types/Messages.hs 
@@ -1,739 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE TemplateHaskell #-}--{-|--The 'Message' is a single displayed event in a Channel.  All Messages-have a date/time, and messages that represent posts to the channel-have a (hash) ID, and displayable text, along with other attributes.--All Messages are sorted chronologically.  There is no assumption that-the server date/time is synchronized with the local date/time, so all-of the Message ordering uses the server's date/time.--The mattermost-api retrieves a 'Post' from the server, briefly encodes-the useful portions of that as a 'ClientPost' object and then converts-it to a 'Message' inserting this result it into the collection of-Messages associated with a Channel.  The PostID of the message-uniquely identifies that message and can be used to interact with the-server for subsequent operations relative to that message's 'Post'.-The date/time associated with these messages is generated by the-server.--There are also "messages" generated directly by the Matterhorn client-which can be used to display additional, client-related information to-the user. Examples of these client messages are: date boundaries, the-"new messages" marker, errors from invoking the browser, etc.  These-client-generated messages will have a date/time although it is locally-generated (usually by relation to an associated Post).--Most other Matterhorn operations primarily are concerned with-user-posted messages (@case mMessageId of Just _@ or @case mType of CP-_@), but others will include client-generated messages (@case mMessageId-of Nothing@ or @case mType of C _@).----}--module Types.Messages-  ( -- * Message and operations on a single Message-    Message(..)-  , isDeletable, isReplyable, isReactable, isEditable, isReplyTo, isGap, isFlaggable-  , isPinnable, isEmote, isJoinLeave, isTransition, isNewMessagesTransition-  , mText, mUser, mDate, mType, mPending, mDeleted, mPinned-  , mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged-  , mOriginalPost, mChannelId, mMarkdownSource-  , isBotMessage-  , MessageType(..)-  , MessageId(..)-  , ThreadState(..)-  , MentionedUser(..)-  , isPostMessage-  , messagePostId-  , messageIdPostId-  , UserRef(..)-  , ReplyState(..)-  , clientMessageToMessage-  , clientPostToMessage-  , clientPostReactionUserIds-  , newMessageOfType-    -- * Message Collections-  , Messages-  , ChronologicalMessages-  , RetrogradeMessages-  , MessageOps (..)-  , noMessages-  , messagesLength-  , filterMessages-  , reverseMessages-  , unreverseMessages-  , splitMessages-  , splitDirSeqOn-  , chronologicalMsgsWithThreadStates-  , retrogradeMsgsWithThreadStates-  , findMessage-  , getRelMessageId-  , messagesHead-  , messagesDrop-  , getNextMessage-  , getPrevMessage-  , getNextMessageId-  , getPrevMessageId-  , getNextPostId-  , getPrevPostId-  , getEarliestPostMsg-  , getLatestPostMsg-  , getEarliestSelectableMessage-  , getLatestSelectableMessage-  , findLatestUserMessage-  -- * Operations on any Message type-  , messagesAfter-  , removeMatchesFromSubset-  , withFirstMessage-  , msgURLs--  , LinkChoice(LinkChoice)-  , linkUser-  , linkURL-  , linkTime-  , linkLabel-  , linkFileId-  )-where--import           Prelude ()-import           Prelude.MH--import           Control.Monad-import qualified Data.Foldable as F-import           Data.Hashable ( Hashable )-import qualified Data.Map.Strict as Map-import           Data.Sequence as Seq-import qualified Data.Set as S-import           Data.Tuple-import           Data.UUID ( UUID )-import           GHC.Generics ( Generic )-import           Lens.Micro.Platform ( makeLenses )--import           Network.Mattermost.Types ( ChannelId, PostId, Post-                                          , ServerTime, UserId, FileId )--import           Types.DirectionalSeq-import           Types.Posts-import           Types.RichText ( RichTextBlock(..), Element(..)-                                , ElementData(..), findUsernames, blockGetURLs-                                , ElementStyle(..), URL(..), parseMarkdown-                                )----- | The state of a message's thread context.-data ThreadState =-    NoThread-    -- ^ The message is not in a thread at all.-    | InThreadShowParent-    -- ^ The message is in a thread, and the thread's root message-    -- (parent) should be displayed above this message.-    | InThread-    -- ^ The message is in a thread but the thread's root message should-    -- not be displayed above this message.-    deriving (Show, Eq)---- ------------------------------------------------------------------------- * Messages--data MessageId = MessagePostId PostId-               | MessageUUID UUID-               deriving (Eq, Read, Show, Generic, Hashable)--messageIdPostId :: MessageId -> Maybe PostId-messageIdPostId (MessagePostId p) = Just p-messageIdPostId _ = Nothing---- | A 'Message' is any message we might want to render, either from---   Mattermost itself or from a client-internal source.-data Message = Message-  { _mText          :: Seq RichTextBlock-  , _mMarkdownSource :: Text-  , _mUser          :: UserRef-  , _mDate          :: ServerTime-  , _mType          :: MessageType-  , _mPending       :: Bool-  , _mDeleted       :: Bool-  , _mAttachments   :: Seq Attachment-  , _mInReplyToMsg  :: ReplyState-  , _mMessageId     :: Maybe MessageId-  , _mReactions     :: Map.Map Text (S.Set UserId)-  , _mOriginalPost  :: Maybe Post-  , _mFlagged       :: Bool-  , _mPinned        :: Bool-  , _mChannelId     :: Maybe ChannelId-  } deriving (Show)--isPostMessage :: Message -> Bool-isPostMessage m =-    isJust (_mMessageId m >>= messageIdPostId)--messagePostId :: Message -> Maybe PostId-messagePostId m = do-    mId <- _mMessageId m-    messageIdPostId mId--isDeletable :: Message -> Bool-isDeletable m =-    isJust (messagePostId m) &&-    case _mType m of-      CP NormalPost -> True-      CP Emote -> True-      _ -> False--isFlaggable :: Message -> Bool-isFlaggable = isJust . messagePostId--isPinnable :: Message -> Bool-isPinnable = isJust . messagePostId--isReplyable :: Message -> Bool-isReplyable m =-    isJust (messagePostId m) &&-    case _mType m of-      CP NormalPost -> True-      CP Emote -> True-      _ -> False--isReactable :: Message -> Bool-isReactable m =-    isJust (messagePostId m) &&-    case _mType m of-      CP NormalPost -> True-      CP Emote -> True-      _ -> False--isEditable :: Message -> Bool-isEditable m =-    isJust (messagePostId m) &&-    case _mType m of-      CP NormalPost -> True-      CP Emote -> True-      _ -> False--isReplyTo :: PostId -> Message -> Bool-isReplyTo expectedParentId m =-    case _mInReplyToMsg m of-        NotAReply                -> False-        InReplyTo actualParentId -> actualParentId == expectedParentId--isGap :: Message -> Bool-isGap m = case _mType m of-            C UnknownGapBefore -> True-            C UnknownGapAfter -> True-            _ -> False--isTransition :: Message -> Bool-isTransition m = case _mType m of-                   C DateTransition -> True-                   C NewMessagesTransition -> True-                   _ -> False--isNewMessagesTransition :: Message -> Bool-isNewMessagesTransition m = case _mType m of-    C NewMessagesTransition -> True-    _ -> False--isEmote :: Message -> Bool-isEmote m = case _mType m of-              CP Emote -> True-              _ -> False--isJoinLeave :: Message -> Bool-isJoinLeave m = case _mType m of-                  CP Join -> True-                  CP Leave -> True-                  _ -> False---- | A 'Message' is the representation we use for storage and---   rendering, so it must be able to represent either a---   post from Mattermost or an internal message. This represents---   the union of both kinds of post types.-data MessageType = C ClientMessageType-                 | CP ClientPostType-                 deriving (Show)---- | There may be no user (usually an internal message), a reference to--- a user (by Id), or the server may have supplied a specific username--- (often associated with bots). The boolean flag indicates whether the--- user reference is for a message from a bot.-data UserRef = NoUser | UserI Bool UserId | UserOverride Bool Text-               deriving (Eq, Show, Ord)--isBotMessage :: Message -> Bool-isBotMessage m =-    case _mUser m of-        UserI bot _        -> bot-        UserOverride bot _ -> bot-        NoUser             -> False---- | The 'ReplyState' of a message represents whether a message---   is a reply, and if so, to what message-data ReplyState =-    NotAReply-    | InReplyTo PostId-    deriving (Show, Eq)---- | This type represents links to things in the 'open links' view.-data LinkChoice =-    LinkChoice { _linkTime   :: ServerTime-               , _linkUser   :: UserRef-               , _linkLabel  :: Maybe (Seq Element)-               , _linkURL    :: URL-               , _linkFileId :: Maybe FileId-               } deriving (Eq, Show)--makeLenses ''LinkChoice---- | Convert a 'ClientMessage' to a 'Message'.  A 'ClientMessage' is--- one that was generated by the Matterhorn client and which the--- server knows nothing about.  For example, an error message--- associated with passing a link to the local browser.-clientMessageToMessage :: ClientMessage -> Message-clientMessageToMessage cm = Message-  { _mText          = parseMarkdown (cm^.cmText)-  , _mMarkdownSource = cm^.cmText-  , _mUser          = NoUser-  , _mDate          = cm^.cmDate-  , _mType          = C $ cm^.cmType-  , _mPending       = False-  , _mDeleted       = False-  , _mAttachments   = Seq.empty-  , _mInReplyToMsg  = NotAReply-  , _mMessageId     = Nothing-  , _mReactions     = Map.empty-  , _mOriginalPost  = Nothing-  , _mFlagged       = False-  , _mPinned        = False-  , _mChannelId     = Nothing-  }---data MentionedUser =-    UsernameMention Text-    | UserIdMention UserId-    deriving (Eq, Show, Ord)--clientPostReactionUserIds :: ClientPost -> S.Set UserId-clientPostReactionUserIds cp =-    S.unions $ F.toList $ cp^.cpReactions---- | Builds a message from a ClientPost and also returns the set of--- usernames mentioned in the text of the message.-clientPostToMessage :: ClientPost -> (Message, S.Set MentionedUser)-clientPostToMessage cp = (m, mentions)-    where-        mentions =-            S.fromList $-                (UsernameMention <$> (F.toList $ findUsernames $ cp^.cpText)) <>-                (UserIdMention <$> (F.toList $ clientPostReactionUserIds cp))-        m = Message { _mText = cp^.cpText-                    , _mMarkdownSource = cp^.cpMarkdownSource-                    , _mUser =-                        case cp^.cpUserOverride of-                            Just n | cp^.cpType == NormalPost -> UserOverride (cp^.cpFromWebhook) n-                            _ -> maybe NoUser (UserI (cp^.cpFromWebhook)) $ cp^.cpUser-                    , _mDate = cp^.cpDate-                    , _mType = CP $ cp^.cpType-                    , _mPending = cp^.cpPending-                    , _mDeleted = cp^.cpDeleted-                    , _mAttachments = cp^.cpAttachments-                    , _mInReplyToMsg =-                        case cp^.cpInReplyToPost of-                            Nothing  -> NotAReply-                            Just pId -> InReplyTo pId-                    , _mMessageId = Just $ MessagePostId $ cp^.cpPostId-                    , _mReactions = cp^.cpReactions-                    , _mOriginalPost = Just $ cp^.cpOriginalPost-                    , _mFlagged = False-                    , _mPinned = cp^.cpPinned-                    , _mChannelId = Just $ cp^.cpChannelId-                    }---newMessageOfType :: Text -> MessageType -> ServerTime -> Message-newMessageOfType text typ d = Message-  { _mText         = parseMarkdown text-  , _mMarkdownSource = text-  , _mUser         = NoUser-  , _mDate         = d-  , _mType         = typ-  , _mPending      = False-  , _mDeleted      = False-  , _mAttachments  = Seq.empty-  , _mInReplyToMsg = NotAReply-  , _mMessageId    = Nothing-  , _mReactions    = Map.empty-  , _mOriginalPost = Nothing-  , _mFlagged      = False-  , _mPinned       = False-  , _mChannelId    = Nothing-  }---- ** 'Message' Lenses--makeLenses ''Message---- -------------------------------------------------------------------------- * Message Collections---- | A wrapper for an ordered, unique list of 'Message' values.------ This type has (and promises) the following instances: Show,--- Functor, Monoid, Foldable, Traversable-type ChronologicalMessages = DirectionalSeq Chronological Message-type Messages = ChronologicalMessages---- | There are also cases where the list of 'Message' values are kept--- in reverse order (most recent -> oldest); these cases are--- represented by the `RetrogradeMessages` type.-type RetrogradeMessages = DirectionalSeq Retrograde Message---- ** Common operations on Messages--filterMessages :: SeqDirection seq-               => (a -> Bool)-               -> DirectionalSeq seq a-               -> DirectionalSeq seq a-filterMessages f = onDirectedSeq (Seq.filter f)--class MessageOps a where-    -- | addMessage inserts a date in proper chronological order, with-    -- the following extra functionality:-    --     * no duplication (by PostId)-    --     * no duplication (adjacent UnknownGap entries)-    addMessage :: Message -> a -> a--instance MessageOps ChronologicalMessages where-    addMessage m ml =-        case viewr (dseq ml) of-            EmptyR -> DSeq $ singleton m-            _ :> l ->-                case compare (m^.mDate) (l^.mDate) of-                  GT -> DSeq $ dseq ml |> m-                  EQ -> if m^.mMessageId == l^.mMessageId && isJust (m^.mMessageId)-                        then ml-                        else dirDateInsert m ml-                  LT -> dirDateInsert m ml--dirDateInsert :: Message -> ChronologicalMessages -> ChronologicalMessages-dirDateInsert m = onDirectedSeq $ finalize . foldr insAfter initial-   where initial = (Just m, mempty)-         insAfter c (Nothing, l) = (Nothing, c <| l)-         insAfter c (Just n, l) =-             case compare (n^.mDate) (c^.mDate) of-               GT -> (Nothing, c <| (n <| l))-               EQ -> if n^.mMessageId == c^.mMessageId && isJust (c^.mMessageId)-                     then (Nothing, c <| l)-                     else (Just n, c <| l)-               LT -> (Just n, c <| l)-         finalize (Just n, l) = n <| l-         finalize (_, l) = l--noMessages :: Messages-noMessages = DSeq mempty--messagesLength :: DirectionalSeq seq a -> Int-messagesLength (DSeq ms) = Seq.length ms---- | Reverse the order of the messages-reverseMessages :: Messages -> RetrogradeMessages-reverseMessages = DSeq . Seq.reverse . dseq---- | Unreverse the order of the messages-unreverseMessages :: RetrogradeMessages -> Messages-unreverseMessages = DSeq . Seq.reverse . dseq--splitDirSeqOn :: SeqDirection d-              => (a -> Bool)-              -> DirectionalSeq d a-              -> (Maybe a, (DirectionalSeq (ReverseDirection d) a,-                            DirectionalSeq d a))-splitDirSeqOn f msgs =-    let (removed, remaining) = dirSeqBreakl f msgs-        devomer = DSeq $ Seq.reverse $ dseq removed-    in (withDirSeqHead id remaining, (devomer, onDirectedSeq (Seq.drop 1) remaining))---- ------------------------------------------------------------------------- * Operations on Posted Messages---- | Searches for the specified MessageId and returns a tuple where the--- first element is the Message associated with the MessageId (if it--- exists), and the second element is another tuple: the first element--- of the second is all the messages from the beginning of the list to--- the message just before the MessageId message (or all messages if not--- found) *in reverse order*, and the second element of the second are--- all the messages that follow the found message (none if the message--- was never found) in *forward* order.-splitMessages :: Maybe MessageId-              -> DirectionalSeq Chronological (Message, ThreadState)-              -> (Maybe (Message, ThreadState),-                   ( DirectionalSeq Retrograde (Message, ThreadState),-                     DirectionalSeq Chronological (Message, ThreadState)))-splitMessages mid msgs = splitDirSeqOn (\(m, _) -> isJust mid && m^.mMessageId == mid) msgs---- | Given a message and its chronological predecessor, return--- the thread state of the specified message with respect to its--- predecessor.-threadStateFor :: Message-               -- ^ The message whose state is to be obtained.-               -> Message-               -- ^ The message's predecessor.-               -> ThreadState-threadStateFor msg prev = case msg^.mInReplyToMsg of-    InReplyTo rootId ->-        if | (prev^.mMessageId) == Just (MessagePostId rootId) ->-               InThread-           | prev^.mInReplyToMsg == msg^.mInReplyToMsg ->-               InThread-           | otherwise ->-               InThreadShowParent-    _ -> NoThread--retrogradeMsgsWithThreadStates :: RetrogradeMessages -> DirectionalSeq Retrograde (Message, ThreadState)-retrogradeMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs)-    where-        getMessagePredecessor ms =-                let visiblePredMsg m = not (isTransition m || m^.mDeleted) in-                case Seq.viewl ms of-                    prev Seq.:< rest ->-                        if visiblePredMsg prev-                        then Just prev-                        else getMessagePredecessor rest-                    Seq.EmptyL -> Nothing--        checkAdjacentMessages s = case Seq.viewl s of-            Seq.EmptyL -> mempty-            m Seq.:< t ->-                let new_m = case getMessagePredecessor t of-                        Just prev -> (m, threadStateFor m prev)-                        Nothing -> case m^.mInReplyToMsg of-                            InReplyTo _ -> (m, InThreadShowParent)-                            _           -> (m, NoThread)-                in new_m Seq.<| checkAdjacentMessages t--chronologicalMsgsWithThreadStates :: Messages -> DirectionalSeq Chronological (Message, ThreadState)-chronologicalMsgsWithThreadStates msgs = DSeq $ checkAdjacentMessages (dseq msgs)-    where-        getMessagePredecessor ms =-                let visiblePredMsg m = not (isTransition m || m^.mDeleted) in-                case Seq.viewr ms of-                    rest Seq.:> prev ->-                        if visiblePredMsg prev-                        then Just prev-                        else getMessagePredecessor rest-                    Seq.EmptyR -> Nothing--        checkAdjacentMessages s = case Seq.viewr s of-            Seq.EmptyR -> mempty-            t Seq.:> m ->-                let new_m = case getMessagePredecessor t of-                        Just prev -> (m, threadStateFor m prev)-                        Nothing -> case m^.mInReplyToMsg of-                            InReplyTo _ -> (m, InThreadShowParent)-                            _           -> (m, NoThread)-                in checkAdjacentMessages t Seq.|> new_m---- | findMessage searches for a specific message as identified by the--- PostId.  The search starts from the most recent messages because--- that is the most likely place the message will occur.-findMessage :: MessageId -> Messages -> Maybe Message-findMessage mid msgs =-    findIndexR (\m -> m^.mMessageId == Just mid) (dseq msgs)-    >>= Just . Seq.index (dseq msgs)---- | Look forward for the first Message with an ID that follows the--- specified Id and return it.  If no input Id supplied, get the--- latest (most recent chronologically) Message in the input set.-getNextMessage :: Maybe MessageId -> Messages -> Maybe Message-getNextMessage = getRelMessageId---- | Look backward for the first Message with an ID that follows the--- specified MessageId and return it.  If no input MessageId supplied,--- get the latest (most recent chronologically) Message in the input--- set.-getPrevMessage :: Maybe MessageId -> Messages -> Maybe Message-getPrevMessage mId = getRelMessageId mId . reverseMessages--messagesHead :: (SeqDirection seq) => DirectionalSeq seq a -> Maybe a-messagesHead = withDirSeqHead id--messagesDrop :: (SeqDirection seq) => Int -> DirectionalSeq seq a -> DirectionalSeq seq a-messagesDrop i = onDirectedSeq (Seq.drop i)---- | Look forward for the first Message with an ID that follows the--- specified MessageId and return that found Message's ID; if no input--- MessageId is specified, return the latest (most recent--- chronologically) MessageId (if any) in the input set.-getNextMessageId :: Maybe MessageId -> Messages -> Maybe MessageId-getNextMessageId mId = _mMessageId <=< getNextMessage mId---- | Look backwards for the first Message with an ID that comes before--- the specified MessageId and return that found Message's ID; if no--- input MessageId is specified, return the latest (most recent--- chronologically) MessageId (if any) in the input set.-getPrevMessageId :: Maybe MessageId -> Messages -> Maybe MessageId-getPrevMessageId mId = _mMessageId <=< getPrevMessage mId---- | Look forward for the first Message with an ID that follows the--- specified PostId and return that found Message's PostID; if no--- input PostId is specified, return the latest (most recent--- chronologically) PostId (if any) in the input set.-getNextPostId :: Maybe PostId -> Messages -> Maybe PostId-getNextPostId pid = messagePostId <=< getNextMessage (MessagePostId <$> pid)---- | Look backwards for the first Post with an ID that comes before--- the specified PostId.-getPrevPostId :: Maybe PostId -> Messages -> Maybe PostId-getPrevPostId pid = messagePostId <=< getPrevMessage (MessagePostId <$> pid)---getRelMessageId :: SeqDirection dir =>-                   Maybe MessageId-                -> DirectionalSeq dir Message-                -> Maybe Message-getRelMessageId mId =-  let isMId = const ((==) mId . _mMessageId) <$> mId-  in getRelMessage isMId---- | Internal worker function to return a different user message in--- relation to either the latest point or a specific message.-getRelMessage :: SeqDirection dir =>-                 Maybe (Message -> Bool)-              -> DirectionalSeq dir Message-              -> Maybe Message-getRelMessage matcher msgs =-  let after = case matcher of-                Just matchFun -> case splitDirSeqOn matchFun msgs of-                                   (_, (_, ms)) -> ms-                Nothing -> msgs-  in withDirSeqHead id $ filterMessages validSelectableMessage after---- | Find the most recent message that is a Post (as opposed to a--- local message) (if any).-getLatestPostMsg :: Messages -> Maybe Message-getLatestPostMsg msgs =-    case viewr $ dropWhileR (not . validUserMessage) (dseq msgs) of-      EmptyR -> Nothing-      _ :> m -> Just m---- | Find the oldest message that is a message with an ID.-getEarliestSelectableMessage :: Messages -> Maybe Message-getEarliestSelectableMessage msgs =-    case viewl $ dropWhileL (not . validSelectableMessage) (dseq msgs) of-      EmptyL -> Nothing-      m :< _ -> Just m---- | Find the most recent message that is a message with an ID.-getLatestSelectableMessage :: Messages -> Maybe Message-getLatestSelectableMessage msgs =-    case viewr $ dropWhileR (not . validSelectableMessage) (dseq msgs) of-      EmptyR -> Nothing-      _ :> m -> Just m---- | Find the earliest message that is a Post (as opposed to a--- local message) (if any).-getEarliestPostMsg :: Messages -> Maybe Message-getEarliestPostMsg msgs =-    case viewl $ dropWhileL (not . validUserMessage) (dseq msgs) of-      EmptyL -> Nothing-      m :< _ -> Just m---- | Find the most recent message that is a message posted by a user--- that matches the test (if any), skipping local client messages and--- any user event that is not a message (i.e. find a normal message or--- an emote).-findLatestUserMessage :: (Message -> Bool) -> Messages -> Maybe Message-findLatestUserMessage f ml =-    case viewr $ dropWhileR (\m -> not (validUserMessage m && f m)) $ dseq ml of-      EmptyR -> Nothing-      _ :> m -> Just m--validUserMessage :: Message -> Bool-validUserMessage m =-    not (m^.mDeleted) && case m^.mMessageId of-        Just (MessagePostId _) -> True-        _ -> False--validSelectableMessage :: Message -> Bool-validSelectableMessage m = (not $ m^.mDeleted) && (isJust $ m^.mMessageId)---- ------------------------------------------------------------------------- * Operations on any Message type---- | Return all messages that were posted after the specified date/time.-messagesAfter :: ServerTime -> Messages -> Messages-messagesAfter viewTime = onDirectedSeq $ takeWhileR (\m -> m^.mDate > viewTime)---- | Removes any Messages (all types) for which the predicate is true--- from the specified subset of messages (identified by a starting and--- ending MessageId, inclusive) and returns the resulting list (from--- start to finish, irrespective of 'firstId' and 'lastId') and the--- list of removed items.------    start       | end          |  operates-on              | (test) case---   --------------------------------------------------------|----------------   Nothing      | Nothing      | entire list               |  C1---   Nothing      | Just found   | start --> found]          |  C2---   Nothing      | Just missing | nothing [suggest invalid] |  C3---   Just found   | Nothing      | [found --> end            |  C4---   Just found   | Just found   | [found --> found]         |  C5---   Just found   | Just missing | [found --> end            |  C6---   Just missing | Nothing      | nothing [suggest invalid] |  C7---   Just missing | Just found   | start --> found]          |  C8---   Just missing | Just missing | nothing [suggest invalid] |  C9------  @removeMatchesFromSubset matchPred fromId toId msgs = (remaining, removed)@----removeMatchesFromSubset :: (Message -> Bool) -> Maybe MessageId -> Maybe MessageId-                        -> Messages -> (Messages, Messages)-removeMatchesFromSubset matching firstId lastId msgs =-    let knownIds = fmap (^.mMessageId) msgs-    in if isNothing firstId && isNothing lastId-       then swap $ dirSeqPartition matching msgs-       else if isJust firstId && firstId `elem` knownIds-            then onDirSeqSubset-                (\m -> m^.mMessageId == firstId)-                (if isJust lastId then \m -> m^.mMessageId == lastId else const False)-                (swap . dirSeqPartition matching) msgs-            else if isJust lastId && lastId `elem` knownIds-                 then onDirSeqSubset-                     (const True)-                     (\m -> m^.mMessageId == lastId)-                     (swap . dirSeqPartition matching) msgs-                 else (msgs, noMessages)---- | Performs an operation on the first Message, returning just the--- result of that operation, or Nothing if there were no messages.--- Note that the message is not necessarily a posted user message.-withFirstMessage :: SeqDirection dir => (Message -> r) -> DirectionalSeq dir Message -> Maybe r-withFirstMessage = withDirSeqHead--msgURLs :: Message -> Seq LinkChoice-msgURLs msg =-  let uRef = msg^.mUser-      msgUrls = (\ (url, text) -> LinkChoice (msg^.mDate) uRef text url Nothing) <$>-                  (Seq.fromList $ mconcat $ blockGetURLs <$> (toList $ msg^.mText))-      attachmentURLs = (\ a ->-                          LinkChoice-                            (msg^.mDate)-                            uRef-                            (Just $ attachmentLabel a)-                            (URL $ a^.attachmentURL)-                            (Just (a^.attachmentFileId)))-                       <$> (msg^.mAttachments)-      attachmentLabel a =-          Seq.fromList [ Element Normal $ EText "attachment"-                       , Element Normal ESpace-                       , Element Code $ EText $ a^.attachmentName-                       ]-  in msgUrls <> attachmentURLs
− src/Types/Posts.hs 
@@ -1,228 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TemplateHaskell #-}-module Types.Posts-  ( ClientMessage-  , newClientMessage-  , cmDate-  , cmType-  , cmText--  , ClientMessageType(..)--  , Attachment-  , mkAttachment-  , attachmentName-  , attachmentFileId-  , attachmentURL--  , ClientPostType(..)--  , ClientPost-  , toClientPost-  , cpUserOverride-  , cpMarkdownSource-  , cpUser-  , cpText-  , cpType-  , cpReactions-  , cpPending-  , cpOriginalPost-  , cpFromWebhook-  , cpInReplyToPost-  , cpDate-  , cpChannelId-  , cpAttachments-  , cpDeleted-  , cpPostId-  , cpPinned--  , unEmote--  , postIsLeave-  , postIsJoin-  , postIsTopicChange-  , postIsEmote-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.Map.Strict as Map-import qualified Data.Sequence as Seq-import qualified Data.Text as T-import qualified Data.Set as S-import           Data.Time.Clock ( getCurrentTime )-import           Lens.Micro.Platform ( makeLenses )--import           Network.Mattermost.Lenses-import           Network.Mattermost.Types--import           Types.Common-import           Types.RichText ( RichTextBlock(Blockquote), parseMarkdown )----- * Client Messages---- | A 'ClientMessage' is a message given to us by our client,---   like help text or an error message.-data ClientMessage = ClientMessage-  { _cmText :: Text-  , _cmDate :: ServerTime-  , _cmType :: ClientMessageType-  } deriving (Show)---- | Create a new 'ClientMessage' value.  This is a message generated--- by this Matterhorn client and not by (or visible to) the Server.--- These should be visible, but not necessarily integrated into any--- special position in the output stream (i.e., they should generally--- appear at the bottom of the messages display, but subsequent--- messages should follow them), so this is a special place where--- there is an assumed approximation of equality between local time--- and server time.-newClientMessage :: (MonadIO m) => ClientMessageType -> Text -> m ClientMessage-newClientMessage ty msg = do-  now <- liftIO getCurrentTime-  return (ClientMessage msg (ServerTime now) ty)---- | We format 'ClientMessage' values differently depending on---   their 'ClientMessageType'-data ClientMessageType =-    Informative-    | Error-    | DateTransition-    | NewMessagesTransition-    | UnknownGapBefore -- ^ a region where the server may have-                       -- messages before the given timestamp that are-                       -- not known locally by this client-    | UnknownGapAfter  -- ^ a region where server may have messages-                       -- after the given timestamp that are not known-                       -- locally by this client-    deriving (Show)---- ** 'ClientMessage' Lenses--makeLenses ''ClientMessage---- * Mattermost Posts---- | A 'ClientPost' is a temporary internal representation of---   the Mattermost 'Post' type, with unnecessary information---   removed and some preprocessing done.-data ClientPost = ClientPost-  { _cpText          :: Seq RichTextBlock-  , _cpMarkdownSource :: Text-  , _cpUser          :: Maybe UserId-  , _cpUserOverride  :: Maybe Text-  , _cpDate          :: ServerTime-  , _cpType          :: ClientPostType-  , _cpPending       :: Bool-  , _cpDeleted       :: Bool-  , _cpAttachments   :: Seq Attachment-  , _cpInReplyToPost :: Maybe PostId-  , _cpPostId        :: PostId-  , _cpChannelId     :: ChannelId-  , _cpReactions     :: Map.Map Text (S.Set UserId)-  , _cpOriginalPost  :: Post-  , _cpFromWebhook   :: Bool-  , _cpPinned        :: Bool-  } deriving (Show)---- | An attachment has a very long URL associated, as well as---   an actual file URL-data Attachment = Attachment-  { _attachmentName   :: Text-  , _attachmentURL    :: Text-  , _attachmentFileId :: FileId-  } deriving (Eq, Show)--mkAttachment :: Text -> Text -> FileId -> Attachment-mkAttachment = Attachment---- | A Mattermost 'Post' value can represent either a normal---   chat message or one of several special events.-data ClientPostType =-    NormalPost-    | Emote-    | Join-    | Leave-    | TopicChange-    deriving (Eq, Show)---- ** Creating 'ClientPost' Values---- | Determine the internal 'PostType' based on a 'Post'-postClientPostType :: Post -> ClientPostType-postClientPostType cp =-    if | postIsEmote cp       -> Emote-       | postIsJoin  cp       -> Join-       | postIsLeave cp       -> Leave-       | postIsTopicChange cp -> TopicChange-       | otherwise            -> NormalPost---- | Find out whether a 'Post' represents a topic change-postIsTopicChange :: Post -> Bool-postIsTopicChange p = postType p == PostTypeHeaderChange---- | Find out whether a 'Post' is from a @/me@ command-postIsEmote :: Post -> Bool-postIsEmote p =-    and [ p^.postPropsL.postPropsOverrideIconUrlL == Just (""::Text)-        , ("*" `T.isPrefixOf` (sanitizeUserText $ postMessage p))-        , ("*" `T.isSuffixOf` (sanitizeUserText $ postMessage p))-        ]---- | Find out whether a 'Post' is a user joining a channel-postIsJoin :: Post -> Bool-postIsJoin p =-  p^.postTypeL == PostTypeJoinChannel---- | Find out whether a 'Post' is a user leaving a channel-postIsLeave :: Post -> Bool-postIsLeave p =-  p^.postTypeL == PostTypeLeaveChannel---- | Undo the automatic formatting of posts generated by @/me@-commands-unEmote :: ClientPostType -> Text -> Text-unEmote Emote t = if "*" `T.isPrefixOf` t && "*" `T.isSuffixOf` t-                  then T.init $ T.tail t-                  else t-unEmote _ t = t---- | Convert a Mattermost 'Post' to a 'ClientPost', passing in a---   'ParentId' if it has a known one.-toClientPost :: Post -> Maybe PostId -> ClientPost-toClientPost p parentId =-  let src = unEmote (postClientPostType p) $ sanitizeUserText $ postMessage p-  in ClientPost { _cpText          = parseMarkdown src <> getAttachmentText p-                , _cpMarkdownSource = src-                , _cpUser          = postUserId p-                , _cpUserOverride  = p^.postPropsL.postPropsOverrideUsernameL-                , _cpDate          = postCreateAt p-                , _cpType          = postClientPostType p-                , _cpPending       = False-                , _cpDeleted       = False-                , _cpPinned        = fromMaybe False $ postPinned p-                , _cpAttachments   = Seq.empty-                , _cpInReplyToPost = parentId-                , _cpPostId        = p^.postIdL-                , _cpChannelId     = p^.postChannelIdL-                , _cpReactions     = Map.empty-                , _cpOriginalPost  = p-                , _cpFromWebhook   = fromMaybe False $ p^.postPropsL.postPropsFromWebhookL-                }---- | Right now, instead of treating 'attachment' properties specially, we're---   just going to roll them directly into the message text-getAttachmentText :: Post -> Seq RichTextBlock-getAttachmentText p =-  case p^.postPropsL.postPropsAttachmentsL of-    Nothing -> Seq.empty-    Just attachments ->-      fmap (Blockquote . render) attachments-  where render att = parseMarkdown (att^.ppaTextL) <> parseMarkdown (att^.ppaFallbackL)---- ** 'ClientPost' Lenses--makeLenses ''Attachment-makeLenses ''ClientPost
− src/Types/RichText.hs 
@@ -1,409 +0,0 @@--- | This module provides a set of data types to represent message text.--- The types here are based loosely on the @cheapskate@ package's types--- but provide higher-level support for the kinds of things we find in--- Mattermost messages such as user and channel references.------ To parse a Markdown document, use 'parseMarkdown'. To actually render--- text in this representation, see the module 'Draw.RichText'.-module Types.RichText-  ( RichTextBlock(..)-  , ListType(..)-  , CodeBlockInfo(..)-  , NumDecoration(..)-  , Element(..)-  , ElementData(..)-  , ElementStyle(..)--  , URL(..)-  , unURL--  , parseMarkdown-  , setElementStyle--  , findUsernames-  , blockGetURLs-  , findVerbatimChunk--  -- Exposed for testing only:-  , fromMarkdownBlocks-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Cheapskate as C-import           Data.Char ( isAlphaNum, isAlpha )-import qualified Data.Foldable as F-import           Data.Monoid (First(..))-import qualified Data.Set as S-import qualified Data.Sequence as Seq-import           Data.Sequence ( (<|), ViewL((:<)) )-import qualified Data.Text as T--import           Constants ( userSigil, normalChannelSigil )---- | A block in a rich text document.-data RichTextBlock =-    Para (Seq Element)-    -- ^ A paragraph.-    | Header Int (Seq Element)-    -- ^ A section header with specified depth and contents.-    | Blockquote (Seq RichTextBlock)-    -- ^ A blockquote.-    | List Bool ListType (Seq (Seq RichTextBlock))-    -- ^ An itemized list.-    | CodeBlock CodeBlockInfo Text-    -- ^ A code block.-    | HTMLBlock Text-    -- ^ A fragment of raw HTML.-    | HRule-    -- ^ A horizontal rule.-    deriving (Show)---- | The type of itemized list items.-data ListType =-    Bullet Char-    -- ^ Decorate the items with bullet using the specified character.-    | Numbered NumDecoration Int-    -- ^ Number the items starting at the specified number; use the-    -- indicated decoration following the number.-    deriving (Eq, Show)---- | Information about a code block.-data CodeBlockInfo =-    CodeBlockInfo { codeBlockLanguage :: Maybe Text-                  -- ^ The language of the source code in the code-                  -- block, if any. This is encoded in Markdown as a-                  -- sequence of non-whitespace characters following the-                  -- fenced code block opening backticks.-                  , codeBlockInfo :: Maybe Text-                  -- ^ Any text that comes after the language token.-                  -- This text is separated from the language token by-                  -- whitespace.-                  }-                  deriving (Eq, Show)---- | Ways to decorate numbered itemized list items. The decoration--- follows the list item number.-data NumDecoration =-    Paren-    | Period-    deriving (Eq, Show)---- | A single logical inline element in a rich text block.-data Element =-    Element { eStyle :: ElementStyle-            -- ^ The element's visual style.-            , eData :: ElementData-            -- ^ The element's data.-            }-            deriving (Show, Eq)--setElementStyle :: ElementStyle -> Element -> Element-setElementStyle s e = e { eStyle = s }---- | A URL.-newtype URL = URL Text-            deriving (Eq, Show, Ord)--unURL :: URL -> Text-unURL (URL url) = url---- | The kinds of data that can appear in rich text elements.-data ElementData =-    EText Text-    -- ^ A sequence of non-whitespace characters.-    | ESpace-    -- ^ A single space.-    | ESoftBreak-    -- ^ A soft line break.-    | ELineBreak-    -- ^ A hard line break.-    | ERawHtml Text-    -- ^ Raw HTML.-    | EEditSentinel Bool-    -- ^ A sentinel indicating that some text has been edited (used-    -- to indicate that mattermost messages have been edited by their-    -- authors). This has no parsable representation; it is only used-    -- to annotate a message prior to rendering to add a visual editing-    -- indicator. The boolean indicates whether the edit was "recent"-    -- (True) or not (False).-    | EUser Text-    -- ^ A user reference. The text here includes only the username, not-    -- the sigil.-    | EChannel Text-    -- ^ A channel reference. The text here includes only the channel-    -- name, not the sigil.-    | EHyperlink URL (Maybe (Seq Element))-    -- ^ A hyperlink to the specified URL. Optionally provides an-    -- element sequence indicating the URL's text label; if absent, the-    -- label is understood to be the URL itself.-    | EImage URL (Maybe (Seq Element))-    -- ^ An image at the specified URL. Optionally provides an element-    -- sequence indicating the image's "alt" text label; if absent, the-    -- label is understood to be the URL itself.-    | EEmoji Text-    -- ^ An emoji reference. The text here includes only the text-    -- portion, not the colons, e.g. "foo" instead of ":foo:".-    deriving (Show, Eq)---- | Element visual styles.-data ElementStyle =-    Normal-    -- ^ Normal text-    | Emph-    -- ^ Emphasized text-    | Strong-    -- ^ Bold text-    | Code-    -- ^ Inline code segment or code block-    | Hyperlink URL ElementStyle-    -- ^ A terminal hyperlink to the specified URL, composed with-    -- another element style-    deriving (Eq, Show)--parseMarkdown :: T.Text -> Seq RichTextBlock-parseMarkdown t = fromMarkdownBlocks bs where C.Doc _ bs = C.markdown C.def t---- | Convert a sequence of markdown (Cheapskate) blocks into rich text--- blocks.-fromMarkdownBlocks :: C.Blocks -> Seq RichTextBlock-fromMarkdownBlocks = fmap fromMarkdownBlock---- | Convert a single markdown block into a single rich text block.-fromMarkdownBlock :: C.Block -> RichTextBlock-fromMarkdownBlock (C.Para is) =-    Para $ fromMarkdownInlines is-fromMarkdownBlock (C.Header level is) =-    Header level $ fromMarkdownInlines is-fromMarkdownBlock (C.Blockquote bs) =-    Blockquote $ fromMarkdownBlock <$> bs-fromMarkdownBlock (C.List f ty bss) =-    List f (fromMarkdownListType ty) $ fmap fromMarkdownBlock <$> Seq.fromList bss-fromMarkdownBlock (C.CodeBlock attr body) =-    CodeBlock (fromMarkdownCodeAttr attr) body-fromMarkdownBlock (C.HtmlBlock body) =-    HTMLBlock body-fromMarkdownBlock C.HRule =-    HRule--fromMarkdownCodeAttr :: C.CodeAttr -> CodeBlockInfo-fromMarkdownCodeAttr (C.CodeAttr lang info) =-    let strippedLang = T.strip lang-        strippedInfo = T.strip info-        maybeText t = if T.null t then Nothing else Just t-    in CodeBlockInfo (maybeText strippedLang)-                     (maybeText strippedInfo)--fromMarkdownListType :: C.ListType -> ListType-fromMarkdownListType (C.Bullet c) =-    Bullet c-fromMarkdownListType (C.Numbered wrap i) =-    let dec = case wrap of-                  C.PeriodFollowing -> Period-                  C.ParenFollowing -> Paren-    in Numbered dec i---- | Remove hyperlinks from an inline sequence. This should only be used--- for sequences that are themselves used as labels for hyperlinks; this--- prevents them from embedding their own hyperlinks, which is nonsense.------ Any hyperlinks found in the sequence will be replaced with a text--- represent of their URL (if they have no label) or the label itself--- otherwise.-removeHyperlinks :: Seq C.Inline -> Seq C.Inline-removeHyperlinks is =-    case Seq.viewl is of-        h :< t ->-            case h of-                C.Link label theUrl _ ->-                    if Seq.null label-                    then C.Str theUrl <| removeHyperlinks t-                    else removeHyperlinks label <> removeHyperlinks t-                _ -> h <| removeHyperlinks t-        Seq.EmptyL -> mempty---- | Convert a sequence of Markdown inline values to a sequence of--- Elements.------ This conversion converts sequences of Markdown AST fragments into--- RichText elements. In particular, this function may determine that--- some sequences of Markdown text fragments belong together, such as--- the sequence @["@", "joe", "-", "user"]@, which should be treated as--- a single "@joe-user" token due to username character validation. When--- appropriate, this function does such consolidation when converting to--- RichText elements.------ This function is also partially responsible for paving the way for--- line-wrapping later on when RichText is rendered. This means that,--- when possible, the elements produced by this function need to be as--- small as possible, without losing structure information. An example--- of this is Markdown inline code fragments, such as "`this is code`".--- This function will convert that one Markdown inline code fragment--- into a sequence of five RichText elements, each with a "Code" style--- assigned: @[EText "this", ESpace, EText "is", ESpace, EText "code"]@.--- This "flattening" of the original Markdown structure makes it much--- easier to do line-wrapping without losing style information because--- it is possible to gather up tokens that do not exceed line widths--- without losing style information. This is key to rendering the text--- with the right terminal attributes.------ However, there are a couple of cases where such flattening does *not*--- happen: hyperlinks and images. In these cases we do not flatten the--- (arbitrary) text label structure of links and images because we need--- to be able to recover those labels to gather up URLs to show to the--- user in the URL list. So we leave the complete text structure of--- those labels behind in the 'EHyperlink' and 'EImage' constructors as--- sequences of Elements. This means that logic in 'Draw.RichText' that--- does line-wrapping will have to explicitly break up link and image--- labels across line breaks.-fromMarkdownInlines :: Seq C.Inline -> Seq Element-fromMarkdownInlines inlines =-    let go sty is = case Seq.viewl is of-          C.Str ":" :< xs ->-              let validEmojiFragment (C.Str f) =-                      f `elem` ["_", "-"] || T.all isAlphaNum f-                  validEmojiFragment _ = False-                  (emojiFrags, rest) = Seq.spanl validEmojiFragment xs-                  em = T.concat $ unsafeGetStr <$> F.toList emojiFrags-              in case Seq.viewl rest of-                  C.Str ":" :< rest2 ->-                      Element Normal (EEmoji em) <| go sty rest2-                  _ ->-                      Element sty (EText ":") <| go sty xs-          C.Str t :< xs | userSigil `T.isPrefixOf` t ->-              let (uFrags, rest) = Seq.spanl isNameFragment xs-                  t' = T.concat $ t : (unsafeGetStr <$> F.toList uFrags)-                  u = T.drop 1 t'-              in Element sty (EUser u) <| go sty rest-          C.Str t :< xs | normalChannelSigil `T.isPrefixOf` t ->-              let (cFrags, rest) = Seq.spanl isNameFragment xs-                  cn = T.drop 1 $ T.concat $ t : (unsafeGetStr <$> F.toList cFrags)-              in Element sty (EChannel cn) <| go sty rest-          C.Str t :< xs ->-              -- When we encounter a string node, we go ahead and-              -- process the rest of the nodes in the sequence. If the-              -- new sequence starts with *another* string node with-              -- the same style, we merge them. We do this because-              -- Cheapskate will parse things like punctuation as-              -- individual string nodes, but we want to keep those-              -- together with any text is adjacent to them to avoid-              -- e.g. breaking up quotes from quoted text when doing-              -- line-wrapping. It's important to make sure we only do-              -- this for adjacent string (i.e. not whitespace) nodes-              -- and that we make sure we only merge when they have the-              -- same style.-              let rest = go sty xs-                  e = Element sty (EText t)-              in case Seq.viewl rest of-                  Element sty2 (EText t2) :< tail_ | sty2 == sty ->-                      (Element sty (EText (t <> t2))) <| tail_-                  _ ->-                      e <| rest-          C.Space :< xs ->-              Element sty ESpace <| go sty xs-          C.SoftBreak :< xs ->-              Element sty ESoftBreak <| go sty xs-          C.LineBreak :< xs ->-              Element sty ELineBreak <| go sty xs-          C.Link label theUrl _ :< xs ->-              let mLabel = if Seq.null label-                           then Nothing-                           else Just $ fromMarkdownInlines $ removeHyperlinks label-                  url = URL theUrl-              in (Element (Hyperlink url sty) $ EHyperlink url mLabel) <| go sty xs-          C.Image altIs theUrl _ :< xs ->-              let mLabel = if Seq.null altIs-                           then Nothing-                           else Just $ fromMarkdownInlines altIs-                  url = URL theUrl-              in (Element (Hyperlink url sty) $ EImage url mLabel) <| go sty xs-          C.RawHtml t :< xs ->-              Element sty (ERawHtml t) <| go sty xs-          C.Code t :< xs ->-              -- We turn a single code string into individual Elements-              -- so we can perform line-wrapping on the inline code-              -- text.-              let ts = [ Element Code frag-                       | wd <- T.split (== ' ') t-                       , frag <- case wd of-                           "" -> [ESpace]-                           _  -> [ESpace, EText wd]-                       ]-                  ts' = case ts of-                    (Element _ ESpace:rs) -> rs-                    _                     -> ts-              in Seq.fromList ts' <> go sty xs-          C.Emph as :< xs ->-              go Emph as <> go sty xs-          C.Strong as :< xs ->-              go Strong as <> go sty xs-          C.Entity t :< xs ->-              Element sty (EText t) <| go sty xs-          Seq.EmptyL -> mempty--    in go Normal inlines--unsafeGetStr :: C.Inline -> Text-unsafeGetStr (C.Str t) = t-unsafeGetStr _ = error "BUG: unsafeGetStr called on non-Str Inline"---- | Obtain all username references in a sequence of rich text blocks.-findUsernames :: Seq RichTextBlock -> S.Set T.Text-findUsernames = S.unions . F.toList . fmap blockFindUsernames--blockFindUsernames :: RichTextBlock -> S.Set T.Text-blockFindUsernames (Para is) =-    elementFindUsernames $ F.toList is-blockFindUsernames (Header _ is) =-    elementFindUsernames $ F.toList is-blockFindUsernames (Blockquote bs) =-    findUsernames bs-blockFindUsernames (List _ _ bs) =-    S.unions $ F.toList $ findUsernames <$> bs-blockFindUsernames _ =-    mempty--elementFindUsernames :: [Element] -> S.Set T.Text-elementFindUsernames [] = mempty-elementFindUsernames (e : es) =-    case eData e of-        EUser u -> S.insert u $ elementFindUsernames es-        _ -> elementFindUsernames es---- | Obtain all URLs (and optional labels) in a rich text block.-blockGetURLs :: RichTextBlock -> [(URL, Maybe (Seq Element))]-blockGetURLs (Para is) =-    catMaybes $ elementGetURL <$> toList is-blockGetURLs (Header _ is) =-    catMaybes $ elementGetURL <$> toList is-blockGetURLs (Blockquote bs) =-    mconcat $ blockGetURLs <$> toList bs-blockGetURLs (List _ _ bss) =-    mconcat $ mconcat $-    (fmap blockGetURLs . F.toList) <$> F.toList bss-blockGetURLs _ =-    mempty--elementGetURL :: Element -> Maybe (URL, Maybe (Seq Element))-elementGetURL (Element _ (EHyperlink url label)) =-    Just (url, label)-elementGetURL (Element _ (EImage url label)) =-    Just (url, label)-elementGetURL _ =-    Nothing---- | Find the first code block in a sequence of rich text blocks.-findVerbatimChunk :: Seq RichTextBlock -> Maybe Text-findVerbatimChunk = getFirst . F.foldMap go-  where go (CodeBlock _ t) = First (Just t)-        go _               = First Nothing--isValidNameChar :: Char -> Bool-isValidNameChar c = isAlpha c || c == '_' || c == '.' || c == '-'--isNameFragment :: C.Inline -> Bool-isNameFragment (C.Str t) =-    not (T.null t) && isValidNameChar (T.head t)-isNameFragment _ = False
− src/Types/Users.hs 
@@ -1,196 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveFunctor #-}--module Types.Users-  ( UserInfo(..)-  , UserStatus(..)-  , Users   -- constructor remains internal-  -- * Lenses created for accessing UserInfo fields-  , uiName, uiId, uiStatus, uiInTeam, uiNickName, uiFirstName, uiLastName, uiEmail-  , uiDeleted-  -- * Various operations on UserInfo-  -- * Creating UserInfo objects-  , userInfoFromUser-  -- * Miscellaneous-  , getUsernameSet-  , trimUserSigil-  , statusFromText-  , findUserById-  , findUserByUsername-  , findUserByNickname-  , noUsers, addUser, allUsers-  , modifyUserById-  , userDeleted-  , TypingUsers-  , noTypingUsers-  , addTypingUser-  , allTypingUsers-  , expireTypingUsers-  , getAllUserIds-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.HashMap.Strict as HM-import qualified Data.Set as S-import           Data.Semigroup ( Max(..) )-import qualified Data.Text as T-import           Lens.Micro.Platform ( (%~), makeLenses, ix )--import           Network.Mattermost.Types ( UserId(..), User(..) )--import           Types.Common-import           Constants ( userSigil )---- * 'UserInfo' Values---- | A 'UserInfo' value represents everything we need to know at---   runtime about a user-data UserInfo = UserInfo-  { _uiName      :: Text-  , _uiId        :: UserId-  , _uiStatus    :: UserStatus-  , _uiInTeam    :: Bool-  , _uiNickName  :: Maybe Text-  , _uiFirstName :: Text-  , _uiLastName  :: Text-  , _uiEmail     :: Text-  , _uiDeleted   :: Bool-  } deriving (Eq, Show)---- | Is this user deleted?-userDeleted :: User -> Bool-userDeleted u =-    case userCreateAt u of-        Nothing -> False-        Just c -> userDeleteAt u > c---- | Create a 'UserInfo' value from a Mattermost 'User' value-userInfoFromUser :: User -> Bool -> UserInfo-userInfoFromUser up inTeam = UserInfo-  { _uiName      = userUsername up-  , _uiId        = userId up-  , _uiStatus    = Offline-  , _uiInTeam    = inTeam-  , _uiNickName  =-      let nick = sanitizeUserText $ userNickname up-      in if T.null nick then Nothing else Just nick-  , _uiFirstName = sanitizeUserText $ userFirstName up-  , _uiLastName  = sanitizeUserText $ userLastName up-  , _uiEmail     = sanitizeUserText $ userEmail up-  , _uiDeleted   = userDeleted up-  }---- | The 'UserStatus' value represents possible current status for---   a user-data UserStatus-  = Online-  | Away-  | Offline-  | DoNotDisturb-  | Other Text-    deriving (Eq, Show)--statusFromText :: Text -> UserStatus-statusFromText t = case t of-  "online"  -> Online-  "offline" -> Offline-  "away"    -> Away-  "dnd"     -> DoNotDisturb-  _         -> Other t---- ** 'UserInfo' lenses--makeLenses ''UserInfo---- ** Manage the collection of all Users---- | Define a binary kinded type to allow derivation of functor.-data AllMyUsers a =-    AllUsers { _ofUsers :: HashMap UserId a-             , _usernameSet :: S.Set Text-             }-             deriving Functor--makeLenses ''AllMyUsers---- | Define the exported typename which universally binds the--- collection to the UserInfo type.-type Users = AllMyUsers UserInfo--getUsernameSet :: Users -> S.Set Text-getUsernameSet = _usernameSet---- | Initial collection of Users with no members-noUsers :: Users-noUsers = AllUsers HM.empty mempty--getAllUserIds :: Users -> [UserId]-getAllUserIds = HM.keys . _ofUsers---- | Add a member to the existing collection of Users-addUser :: UserInfo -> Users -> Users-addUser userinfo u =-    u & ofUsers %~ HM.insert (userinfo^.uiId) userinfo-      & usernameSet %~ S.insert (userinfo^.uiName)---- | Get a list of all known users-allUsers :: Users -> [UserInfo]-allUsers = HM.elems . _ofUsers---- | Define the exported typename to represent the collection of users--- | who are currently typing. The values kept against the user id keys are the--- | latest timestamps of typing events from the server.-type TypingUsers = AllMyUsers (Max UTCTime)---- | Initial collection of TypingUsers with no members-noTypingUsers :: TypingUsers-noTypingUsers = AllUsers HM.empty mempty---- | Add a member to the existing collection of TypingUsers-addTypingUser :: UserId -> UTCTime -> TypingUsers -> TypingUsers-addTypingUser uId ts = ofUsers %~ HM.insertWith (<>) uId (Max ts)---- | Get a list of all typing users-allTypingUsers :: TypingUsers -> [UserId]-allTypingUsers = HM.keys . _ofUsers---- | Remove all the expired users from the collection of TypingUsers.--- | Expiry is decided by the given timestamp.-expireTypingUsers :: UTCTime -> TypingUsers -> TypingUsers-expireTypingUsers expiryTimestamp =-    ofUsers %~ HM.filter (\(Max ts') -> ts' >= expiryTimestamp)---- | Get the User information given the UserId-findUserById :: UserId -> Users -> Maybe UserInfo-findUserById uId = HM.lookup uId . _ofUsers---- | Get the User information given the user's name. This is an exact--- match on the username field. It will automatically trim a user sigil--- from the input.-findUserByUsername :: Text -> Users -> Maybe (UserId, UserInfo)-findUserByUsername name allusers =-  case filter ((== trimUserSigil name) . _uiName . snd) $ HM.toList $ _ofUsers allusers of-    (usr : []) -> Just usr-    _ -> Nothing---- | Get the User information given the user's name. This is an exact--- match on the nickname field, not necessarily the presented name. It--- will automatically trim a user sigil from the input.-findUserByNickname:: Text -> Users -> Maybe (UserId, UserInfo)-findUserByNickname nick us =-  case filter ((== (Just $ trimUserSigil nick)) . _uiNickName . snd) $ HM.toList $ _ofUsers us of-    (pair : []) -> Just pair-    _ -> Nothing--trimUserSigil :: Text -> Text-trimUserSigil n-    | userSigil `T.isPrefixOf` n = T.tail n-    | otherwise                  = n---- | Extract a specific user from the collection and perform an--- endomorphism operation on it, then put it back into the collection.-modifyUserById :: UserId -> (UserInfo -> UserInfo) -> Users -> Users-modifyUserById uId f = ofUsers.ix(uId) %~ f
− src/Util.hs 
@@ -1,25 +0,0 @@-module Util-  ( nubOn-  )-where--import           Prelude ()-import           Prelude.MH--import qualified Data.Set as Set----- | The 'nubOn' function removes duplicate elements from a list. In--- particular, it keeps only the /last/ occurrence of each--- element. The equality of two elements in a call to @nub f@ is--- determined using @f x == f y@, and the resulting elements must have--- an 'Ord' instance in order to make this function more efficient.-nubOn :: (Ord b) => (a -> b) -> [a] -> [a]-nubOn f = snd . go Set.empty-  where go before [] = (before, [])-        go before (x:xs) =-          let (before', xs') = go before xs-              key = f x in-          if key `Set.member` before'-            then (before', xs')-            else (Set.insert key before', x : xs')
− src/Windows/ViewMessage.hs 
@@ -1,217 +0,0 @@-module Windows.ViewMessage-  ( viewMessageWindowTemplate-  , viewMessageKeybindings-  , viewMessageKeyHandlers-  , viewMessageReactionsKeybindings-  , viewMessageReactionsKeyHandlers-  )-where--import           Prelude ()-import           Prelude.MH--import           Brick-import           Brick.Widgets.Border--import qualified Data.Set as S-import qualified Data.Map as M-import           Data.Maybe ( fromJust )-import qualified Data.Text as T-import qualified Data.Foldable as F-import qualified Graphics.Vty as Vty-import           Lens.Micro.Platform ( to )--import           Constants-import           Events.Keybindings-import           Themes-import           Types-import           Draw.RichText-import           Draw.Messages ( nameForUserRef )---- | The template for "View Message" windows triggered by message--- selection mode.-viewMessageWindowTemplate :: TabbedWindowTemplate ViewMessageWindowTab-viewMessageWindowTemplate =-    TabbedWindowTemplate { twtEntries = [ messageEntry-                                        , reactionsEntry-                                        ]-                         , twtTitle = const $ txt "View Message"-                         }--messageEntry :: TabbedWindowEntry ViewMessageWindowTab-messageEntry =-    TabbedWindowEntry { tweValue = VMTabMessage-                      , tweRender = renderTab-                      , tweHandleEvent = handleEvent-                      , tweTitle = tabTitle-                      , tweShowHandler = onShow-                      }--reactionsEntry :: TabbedWindowEntry ViewMessageWindowTab-reactionsEntry =-    TabbedWindowEntry { tweValue = VMTabReactions-                      , tweRender = renderTab-                      , tweHandleEvent = handleEvent-                      , tweTitle = tabTitle-                      , tweShowHandler = onShow-                      }--tabTitle :: ViewMessageWindowTab -> Bool -> T.Text-tabTitle VMTabMessage _ = "Message"-tabTitle VMTabReactions _ = "Reactions"---- When we show the tabs, we need to reset the viewport scroll position--- for viewports in that tab. This is because an older View Message--- window used the same handle for the viewport and we don't want that--- old state affecting this window. This also means that switching tabs--- in an existing window resets this state, too.-onShow :: ViewMessageWindowTab -> MH ()-onShow VMTabMessage = resetVp ViewMessageArea-onShow VMTabReactions = resetVp ViewMessageArea--resetVp :: Name -> MH ()-resetVp n = do-    let vs = viewportScroll n-    mh $ do-        vScrollToBeginning vs-        hScrollToBeginning vs--renderTab :: ViewMessageWindowTab -> ChatState -> Widget Name-renderTab tab cs =-    let latestMessage = case cs^.csViewedMessage of-          Nothing -> error "BUG: no message to show, please report!"-          Just (m, _) -> getLatestMessage cs m-    in case tab of-        VMTabMessage -> viewMessageBox cs latestMessage-        VMTabReactions -> reactionsText cs latestMessage--getLatestMessage :: ChatState -> Message -> Message-getLatestMessage cs m =-    case m^.mMessageId of-        Nothing -> m-        Just mId -> fromJust $ findMessage mId $ cs^.csCurrentChannel.ccContents.cdMessages--handleEvent :: ViewMessageWindowTab -> Vty.Event -> MH ()-handleEvent VMTabMessage =-    void . handleKeyboardEvent viewMessageKeybindings (const $ return ())-handleEvent VMTabReactions =-    void . handleKeyboardEvent viewMessageReactionsKeybindings (const $ return ())--reactionsText :: ChatState -> Message -> Widget Name-reactionsText st m = viewport ViewMessageReactionsArea Vertical body-    where-        body = case null reacList of-            True -> txt "This message has no reactions."-            False -> vBox $ mkEntry <$> reacList-        reacList = M.toList (m^.mReactions)-        mkEntry (reactionName, userIdSet) =-            let count = str $ "(" <> show (S.size userIdSet) <> ")"-                name = withDefAttr emojiAttr $ txt $ ":" <> reactionName <> ":"-                usernameList = usernameText userIdSet-            in (name <+> (padLeft (Pad 1) count)) <=>-               (padLeft (Pad 2) usernameList)--        hs = getHighlightSet st--        usernameText uids =-            renderText' (myUsername st) hs $-            T.intercalate ", " $-            fmap (userSigil <>) $-            catMaybes (lookupUsername <$> F.toList uids)--        lookupUsername uid = usernameForUserId uid st--viewMessageBox :: ChatState -> Message -> Widget Name-viewMessageBox st msg =-    let maybeWarn = if not (msg^.mDeleted) then id else warn-        warn w = vBox [w, hBorder, deleteWarning]-        deleteWarning = withDefAttr errorMessageAttr $-                        txtWrap $ "Alert: this message has been deleted and " <>-                                  "will no longer be accessible once this window " <>-                                  "is closed."-        mkBody vpWidth =-            let hs = getHighlightSet st-                parent = case msg^.mInReplyToMsg of-                     NotAReply -> Nothing-                     InReplyTo pId -> getMessageForPostId st pId-                md = MessageData { mdEditThreshold     = Nothing-                                 , mdShowOlderEdits    = False-                                 , mdMessage           = msg-                                 , mdUserName          = msg^.mUser.to (nameForUserRef st)-                                 , mdParentMessage     = parent-                                 , mdParentUserName    = parent >>= (^.mUser.to (nameForUserRef st))-                                 , mdRenderReplyParent = True-                                 , mdHighlightSet      = hs-                                 , mdIndentBlocks      = True-                                 , mdThreadState       = NoThread-                                 , mdShowReactions     = False-                                 , mdMessageWidthLimit = Just vpWidth-                                 , mdMyUsername        = myUsername st-                                 }-            in renderMessage md--    in Widget Greedy Greedy $ do-        ctx <- getContext-        render $ maybeWarn $ viewport ViewMessageArea Both $ mkBody (ctx^.availWidthL)--viewMessageKeybindings :: KeyConfig -> KeyHandlerMap-viewMessageKeybindings = mkKeybindings viewMessageKeyHandlers--viewMessageKeyHandlers :: [KeyEventHandler]-viewMessageKeyHandlers =-    let vs = viewportScroll ViewMessageArea-    in [ mkKb PageUpEvent "Page up" $-           mh $ vScrollBy vs (-1 * pageAmount)--       , mkKb PageDownEvent "Page down" $-           mh $ vScrollBy vs pageAmount--       , mkKb PageLeftEvent "Page left" $-           mh $ hScrollBy vs (-2 * pageAmount)--       , mkKb PageRightEvent "Page right" $-           mh $ hScrollBy vs (2 * pageAmount)--       , mkKb ScrollUpEvent "Scroll up" $-           mh $ vScrollBy vs (-1)--       , mkKb ScrollDownEvent "Scroll down" $-           mh $ vScrollBy vs 1--       , mkKb ScrollLeftEvent "Scroll left" $-           mh $ hScrollBy vs (-1)--       , mkKb ScrollRightEvent "Scroll right" $-           mh $ hScrollBy vs 1--       , mkKb ScrollBottomEvent "Scroll to the end of the message" $-           mh $ vScrollToEnd vs--       , mkKb ScrollTopEvent "Scroll to the beginning of the message" $-           mh $ vScrollToBeginning vs-       ]--viewMessageReactionsKeybindings :: KeyConfig -> KeyHandlerMap-viewMessageReactionsKeybindings = mkKeybindings viewMessageReactionsKeyHandlers--viewMessageReactionsKeyHandlers :: [KeyEventHandler]-viewMessageReactionsKeyHandlers =-    let vs = viewportScroll ViewMessageReactionsArea-    in [ mkKb PageUpEvent "Page up" $-           mh $ vScrollBy vs (-1 * pageAmount)--       , mkKb PageDownEvent "Page down" $-           mh $ vScrollBy vs pageAmount--       , mkKb ScrollUpEvent "Scroll up" $-           mh $ vScrollBy vs (-1)--       , mkKb ScrollDownEvent "Scroll down" $-           mh $ vScrollBy vs 1--       , mkKb ScrollBottomEvent "Scroll to the end of the reactions list" $-           mh $ vScrollToEnd vs--       , mkKb ScrollTopEvent "Scroll to the beginning of the reactions list" $-           mh $ vScrollToBeginning vs-       ]
− src/Zipper.hs 
@@ -1,119 +0,0 @@-module Zipper-  ( Zipper-  , fromList-  , toList-  , focus-  , unsafeFocus-  , left-  , leftL-  , right-  , rightL-  , findRight-  , maybeFindRight-  , updateList-  , updateListBy-  , filterZipper-  , maybeMapZipper-  , isEmpty-  )-where--import           Prelude ()-import           Prelude.MH hiding (toList)--import           Data.Maybe ( fromJust )-import qualified Data.Foldable as F-import qualified Data.Sequence as Seq-import qualified Data.CircularList as C-import           Lens.Micro.Platform--data Zipper a b =-    Zipper { zRing :: C.CList b-           , zTrees :: Seq.Seq (a, Seq.Seq b)-           }--instance F.Foldable (Zipper a) where-    foldMap f = foldMap f .-                F.toList .-                mconcat .-                F.toList .-                fmap snd .-                zTrees--instance Functor (Zipper a) where-    fmap f z =-        Zipper { zRing = f <$> zRing z-               , zTrees = zTrees z & mapped._2.mapped %~ f-               }--isEmpty :: Zipper a b -> Bool-isEmpty = C.isEmpty . zRing---- Move the focus one element to the left-left :: Zipper a b -> Zipper a b-left z = z { zRing = C.rotL (zRing z) }---- A lens on the zipper moved to the left-leftL :: Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)-leftL = lens left (\ _ b -> right b)---- Move the focus one element to the right-right :: Zipper a b -> Zipper a b-right z = z { zRing = C.rotR (zRing z) }---- A lens on the zipper moved to the right-rightL :: Lens (Zipper a b) (Zipper a b) (Zipper a b) (Zipper a b)-rightL = lens right (\ _ b -> left b)---- Return the focus element-focus :: Zipper a b -> Maybe b-focus = C.focus . zRing--unsafeFocus :: Zipper a b -> b-unsafeFocus = fromJust . focus---- Turn a list into a wraparound zipper, focusing on the head-fromList :: (Eq b) => [(a, [b])] -> Zipper a b-fromList xs =-    let ts = Seq.fromList $ xs & mapped._2 %~ Seq.fromList-        tsList = F.toList $ mconcat $ F.toList $ snd <$> ts-        maybeFocus = if null tsList-                     then id-                     else fromJust . C.rotateTo (tsList !! 0)-    in Zipper { zRing = maybeFocus $ C.fromList tsList-              , zTrees = ts-              }--toList :: Zipper a b -> [(a, [b])]-toList z = F.toList $ zTrees z & mapped._2 %~ F.toList---- Shift the focus until a given element is found, or return the--- same zipper if none applies-findRight :: (b -> Bool) -> Zipper a b -> Zipper a b-findRight f z = fromMaybe z $ maybeFindRight f z---- Shift the focus until a given element is found, or return--- Nothing if none applies-maybeFindRight :: (b -> Bool) -> Zipper a b -> Maybe (Zipper a b)-maybeFindRight f z = do-    newRing <- C.findRotateTo f (zRing z)-    return z { zRing = newRing }--updateList :: (Eq b) => [(a, [b])] -> Zipper a b -> Zipper a b-updateList newList oldZip = updateListBy (\old b -> old == Just b) newList oldZip--updateListBy :: (Eq b) => (Maybe b -> b -> Bool) -> [(a, [b])] -> Zipper a b -> Zipper a b-updateListBy f newList oldZip = findRight (f (focus oldZip)) $ fromList newList--maybeMapZipper :: (Eq c) => (b -> Maybe c) -> Zipper a b -> Zipper a c-maybeMapZipper f z =-    let oldTrees = zTrees z-        newTrees = F.toList $ oldTrees & mapped._2 %~ (catMaybes . F.toList . fmap f)-    in fromList newTrees--filterZipper :: (Eq b) => (b -> Bool) -> Zipper a b -> Zipper a b-filterZipper f oldZip = maintainFocus newZip-  where maintainFocus = findRight ((== focus oldZip) . Just)-        newZip = Zipper { zTrees = zTrees oldZip & mapped._2 %~ Seq.filter f-                        , zRing = C.filterR f (zRing oldZip)-                        }
test/Message_QCA.hs view
@@ -13,10 +13,11 @@ import Network.Mattermost.QuickCheck import Network.Mattermost.Types import Test.Tasty.QuickCheck-import Types.Messages-import Types.Posts-import Types.RichText +import Matterhorn.Types.Messages+import Matterhorn.Types.Posts+import Matterhorn.Types.RichText+ genMap :: Ord key => Gen key -> Gen value -> Gen (Map key value) genMap gk gv = let kv = (,) <$> gk <*> gv in fromList <$> listOf kv @@ -31,7 +32,7 @@  genMessage :: Gen Message genMessage = Message-             <$> (fromMarkdownBlocks <$> genBlocks)+             <$> (fromMarkdownBlocks Nothing <$> genBlocks)              <*> genText              <*> genUserRef              <*> genTime@@ -59,7 +60,7 @@ genMessage__DeletedPost :: Gen Message__DeletedPost genMessage__DeletedPost = Message__DeletedPost                           <$> (Message-                              <$> (fromMarkdownBlocks <$> genBlocks)+                              <$> (fromMarkdownBlocks Nothing <$> genBlocks)                               <*> genText                               <*> genUserRef                               <*> genTime@@ -81,7 +82,7 @@ genMessage__Posted :: Gen Message__Posted genMessage__Posted = Message__Posted                      <$> (Message-                         <$> (fromMarkdownBlocks <$> genBlocks)+                         <$> (fromMarkdownBlocks Nothing <$> genBlocks)                          <*> genText                          <*> genUserRef                          <*> genTime
test/test_messages.hs view
@@ -14,18 +14,22 @@ import           Data.Time.Calendar (Day(..)) import           Data.Time.Clock (UTCTime(..), getCurrentTime                                  , secondsToDiffTime)-import           Message_QCA-import           Network.Mattermost.Types import           System.Exit-import           Test.QuickCheck.Checkers+ import           Test.Tasty import           Test.Tasty.HUnit import           Test.Tasty.QuickCheck-import           TimeUtils-import           Types.DirectionalSeq-import           Types.Messages-import           Types.Posts-import           Prelude.MH+import           Test.QuickCheck.Checkers++import           Network.Mattermost.Types++import           Message_QCA++import           Matterhorn.Types.DirectionalSeq+import           Matterhorn.Types.Messages+import           Matterhorn.Types.Posts+import           Matterhorn.Prelude+import           Matterhorn.TimeUtils  main :: IO () main = defaultMain tests `catch` (\e -> do