matterhorn 50200.6.0 → 50200.7.0
raw patch · 43 files changed
+709/−251 lines, 43 filesdep ~brickdep ~hashabledep ~mattermost-api
Dependency ranges changed: brick, hashable, mattermost-api, mattermost-api-qc, microlens-platform, time, vty
Files
- CHANGELOG.md +50/−0
- README.md +9/−7
- docs/commands.md +46/−0
- docs/keybindings.md +157/−0
- docs/notification-scripts.md +34/−0
- matterhorn.cabal +17/−14
- notification-scripts/notify +3/−0
- src/App.hs +8/−2
- src/Command.hs +15/−4
- src/Config.hs +16/−1
- src/Connection.hs +2/−1
- src/Draw.hs +1/−1
- src/Draw/Autocomplete.hs +7/−3
- src/Draw/ChannelList.hs +3/−6
- src/Draw/ListOverlay.hs +1/−1
- src/Draw/Main.hs +13/−3
- src/Draw/ManageAttachments.hs +2/−2
- src/Draw/PostListOverlay.hs +14/−2
- src/Draw/ShowHelp.hs +41/−11
- src/Events.hs +22/−1
- src/Events/Keybindings.hs +75/−92
- src/Events/Main.hs +1/−7
- src/Events/MessageSelect.hs +3/−0
- src/Events/ShowHelp.hs +7/−22
- src/Login.hs +11/−16
- src/Main.hs +15/−4
- src/Markdown.hs +6/−8
- src/Options.hs +10/−2
- src/State/ChannelSelect.hs +2/−2
- src/State/Channels.hs +9/−0
- src/State/Help.hs +6/−2
- src/State/MessageSelect.hs +21/−0
- src/State/PostListOverlay.hs +7/−0
- src/State/Setup.hs +4/−2
- src/State/Themes.hs +3/−3
- src/Themes.hs +13/−4
- src/Types.hs +19/−8
- src/Types/Channels.hs +5/−1
- src/Types/KeyEvents.hs +3/−0
- src/Types/Messages.hs +21/−18
- src/Types/Posts.hs +3/−0
- test/Message_QCA.hs +3/−0
- test/test_messages.hs +1/−1
CHANGELOG.md view
@@ -1,4 +1,54 @@ +50200.7.0+=========++New features:+ * The channel sidebar now displays channels by display name, not URL name (#522).+ * The channel autocompletion list now includes channel display names.+ * Matterhorn now adds the character set with "stty erase" to the Vty+ input map so that the erase character translates to a backspace key+ event.+ * Matterhorn now supports viewing pinned posts and changing pinning status (#213)+ * This change adds a new command, `/pinned-posts`, that will show a+ post list of pinned posts in the current channel.+ * This change adds a new message select key event, `pin-message`+ (default: `p`) to toggle the pinning state of the selected post.+ * A new `[PIN]` indicator is now displayed to the left of pinned posts.+ * A new theme attribute, `pinnedMessageIndicator`, was added to+ render the pinning indicator.+ * A new configuration option now controls certificate validation (#263).+ This change adds a new config setting, `validateServerCertificate`.+ Its default is `True`. The sample config also includes documentation+ about the setting.+ * A new `/purpose` command was added to set channel purpose strings+ (#524).+ * A new example notification script for Mac OS systems was added at+ `notification-scripts/notify-macos`.+ * The help screen (default binding: `F1`) is now reachable from any+ Matterhorn screen (#525).+ * Private channels are now displayed as their own sidebar group (#510).++Other changes:+ * The `markdownEmph` attribute is now being used to render user list+ window and attachment window titles.+ * The output of the `/theme` command was improved.+ * The help UI's default colors were changed to improve contrast (#564)+ * Matterhorn now shows channel purpose strings, not headers, in channel+ autocompletion matches to match the official client's behavior (#524).+ * The notification script API is now documented in+ `docs/notification-scripts.md`.+ * Configuration files without trailing newlines are now supported+ (#540).+ * Websocket action responses are now supported, which fixed a bug where+ typing notifications would cause websockets to get disconnected (#529).+ * Emote messages that get flagged now properly display a flagging+ indicator (#530).+ * Matterhorn now supports generation of a command table similar to its+ support for generating keybinding tables. This is done with the new+ `-m`/`-M` command-line options.+ * Date transition lines at the beginning of channels are now preserved+ (#534).+ 50200.6.0 =========
README.md view
@@ -74,16 +74,17 @@ * Right: messages in the current channel * Bottom: editing area for writing, editing, and replying to messages -You can use built-in keybindings or `/cmd`-style commands to operate-the client. Keybinding information may be obtained in a number of ways:+You can use built-in keybindings or `/cmd`-style commands to operate the+client. Keybinding and command help may be obtained in a number of ways: * The `/help` command within Matterhorn. * The `F1` key within Matterhorn.-* Running matterhorn with the `-k` argument to get a text table of available keybindings-* Running matterhorn with the `-K` argument to get a [Markdown table of available keybindings](docs/keybindings.md)+* Running matterhorn with the `-k` argument to get a text table of available keybindings.+* Running matterhorn with the `-K` argument to get a [Markdown table of available keybindings](docs/keybindings.md).+* Running matterhorn with the `-M` argument to get a [Markdown table of available commands](docs/commands.md). - Note: The latter two commands do not start the client but simply- print to stdout and exit. The bindings shown include any user+ Note: The latter three commands do not start the client but simply+ print to stdout and exit. The keybindings shown include any user overrides from the config files; use the `-i` flag to skip loading the local config files and see the Matterhorn default keybindings. @@ -186,7 +187,8 @@ supported.) Also supports `NO_PROXY`. * Multiple color themes with color theme customization support * Custom notifications via notification scripts (see the- `activityNotifyCommand` configuration setting).+ `activityNotifyCommand` configuration setting and+ `docs/notification-scripts.md` for details). # Spell Checking Support
+ docs/commands.md view
@@ -0,0 +1,46 @@+# Commands++| Command | Description |+| ------- | ----------- |+| `/add-user` | Search for a user to add to the current channel |+| `/add-user <@user>` | Add a user to the current channel |+| `/create-channel <channel name>` | Create a new public channel |+| `/create-private-channel <channel name>` | Create a new private channel |+| `/delete-channel` | Delete the current channel |+| `/flags` | Open a window of your flagged posts |+| `/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 <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 |+| `/join <~channel>` | Join the specified channel |+| `/leave` | Leave the current channel |+| `/left` | Focus on the previous channel |+| `/log-mark <log marking message>` | Add marker message to the current log |+| `/log-snapshot <path>` | Dump the current log buffer to the specified path |+| `/log-start <path>` | Begin logging to the specified path |+| `/log-status` | Show current logging status |+| `/log-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 |+| `/msg <@user>` | Chat with the specified user |+| `/msg <@user> <message or command>` | Go to a user's channel and send the specified message or command |+| `/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 |+| `/right` | Focus on the next channel |+| `/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 |+| `/theme` | List the available themes |+| `/theme <theme>` | Set the color theme |+| `/toggle-channel-list` | Toggle channel list visibility |+| `/topic <topic>` | Set the current channel's topic (header) |+| `/user` | Show users to initiate a private DM chat channel |
+ docs/keybindings.md view
@@ -0,0 +1,157 @@+# Keybindings++# Global Keybindings+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `F1` | `show-help` | Show this help screen |++# Help Page+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Return to the previous interface |+| `PgDown` | `page-down` | Page down |+| `PgUp` | `page-up` | Page up |+| `End` | `scroll-bottom` | Scroll to the end of the help |+| `Down` | `scroll-down` | Scroll down |+| `Home` | `scroll-top` | Scroll to the beginning of the help |+| `Up` | `scroll-up` | Scroll up |++# Main Interface+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Cancel autocomplete, message reply, or edit, in that order |+| `M-l` | `clear-unread` | Clear the current channel's unread / edited indicators |+| `C-g` | `enter-fast-select` | Enter fast channel selection mode |+| `C-o` | `enter-url-open` | Select and open a URL posted to the current channel |+| `M-s` | `focus-last-channel` | Change to the most recently-focused channel |+| `C-n` | `focus-next-channel` | Change to the next channel in the channel list |+| `M-a` | `focus-next-unread` | Change to the next channel with unread messages |+| `C-p` | `focus-prev-channel` | Change to the previous channel in the channel list |+| `M-k` | `invoke-editor` | Invoke *$EDITOR* to edit the current message |+| `PgUp` | `page-up` | Page up in the channel message list (enters message select mode) |+| `C-q` | `quit` | Quit |+| `C-r` | `reply-recent` | Reply to the most recent message |+| `Down` | `scroll-down` | Scroll down in the channel input history |+| `Home` | `scroll-top` | Scroll to top of channel message list |+| `Up` | `scroll-up` | Scroll up in the channel input history |+| `C-s` | `select-mode` | Select a message to edit/reply/delete |+| `C-x` | `show-attachment-list` | Show the attachment list |+| `M-8` | `show-flagged-posts` | View currently flagged posts |+| `F2` | `toggle-channel-list-visibility` | Toggle channel list visibility |+| `M-p` | `toggle-message-preview` | Toggle message preview |+| `M-e` | `toggle-multiline` | Toggle multi-line message compose mode |++# Channel Select Mode+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Cancel channel selection |+| `C-n` | `focus-next-channel` | Select next match |+| `C-p` | `focus-prev-channel` | Select previous match |++# URL Select Mode+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Cancel URL selection |+| `j`, `Down` | `select-down` | Move cursor down |+| `k`, `Up` | `select-up` | Move cursor up |++# Message Select Mode+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Cancel message selection |+| `d` | `delete-message` | Delete the selected message (with confirmation) |+| `e` | `edit-message` | Begin editing the selected message |+| `Enter` | `fetch-for-gap` | Fetch messages for the selected gap |+| `f` | `flag-message` | Flag the selected message |+| `o` | `open-message-url` | Open all URLs in the selected message |+| `PgDown` | `page-down` | Move the cursor down by 10 messages |+| `PgUp` | `page-up` | Move the cursor up by 10 messages |+| `p` | `pin-message` | Toggle whether the selected message is pinned |+| `a` | `react-to-message` | Post a reaction to the selected message |+| `r` | `reply-message` | Begin composing a reply to the selected message |+| `End` | `scroll-bottom` | Scroll to bottom and select the latest message |+| `Home` | `scroll-top` | Scroll to top and select the oldest message |+| `j`, `Down` | `select-down` | Select the next message |+| `k`, `Up` | `select-up` | Select the previous message |+| `v` | `view-message` | View the selected message |+| `y` | `yank-message` | Copy a verbatim section or message to the clipboard |+| `Y` | `yank-whole-message` | Copy an entire message to the clipboard |++# Flagged Messages+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Enter` | `activate-list-item` | Jump to and select current message |+| `Esc`, `C-c` | `cancel` | Exit post browsing |+| `f` | `flag-message` | Toggle the selected message flag |+| `j`, `Down` | `select-down` | Select the next message |+| `k`, `Up` | `select-up` | Select the previous message |++# User Listings+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Enter` | `activate-list-item` | Interact with the selected user |+| `Esc`, `C-c` | `cancel` | Close the user search list |+| `PgDown` | `page-down` | Page down in the user list |+| `PgUp` | `page-up` | Page up in the user list |+| `C-n`, `Down` | `search-select-down` | Select the next user |+| `C-p`, `Up` | `search-select-up` | Select the previous user |++# Channel Search Window+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Enter` | `activate-list-item` | Join the selected channel |+| `Esc`, `C-c` | `cancel` | Close the channel search list |+| `PgDown` | `page-down` | Page down in the channel list |+| `PgUp` | `page-up` | Page up in the channel list |+| `C-n`, `Down` | `search-select-down` | Select the next channel |+| `C-p`, `Up` | `search-select-up` | Select the previous channel |++# Reaction Emoji Search Window+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Enter` | `activate-list-item` | Post the selected emoji reaction |+| `Esc`, `C-c` | `cancel` | Close the emoji search window |+| `PgDown` | `page-down` | Page down in the emoji list |+| `PgUp` | `page-up` | Page up in the emoji list |+| `C-n`, `Down` | `search-select-down` | Select the next emoji |+| `C-p`, `Up` | `search-select-up` | Select the previous emoji |++# Message Viewer: Common+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `Esc`, `C-c` | `cancel` | Close window |+| `Tab` | `select-next-tab` | Select next tab |+| `BackTab` | `select-previous-tab` | Select previous tab |++# Message Viewer: Message tab+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `PgDown` | `page-down` | Page down |+| `PgUp` | `page-up` | Page up |+| `End` | `scroll-bottom` | Scroll to the end of the message |+| `Down` | `scroll-down` | Scroll down |+| `Left` | `scroll-left` | Scroll left |+| `Right` | `scroll-right` | Scroll right |+| `Home` | `scroll-top` | Scroll to the beginning of the message |+| `Up` | `scroll-up` | Scroll up |++# Message Viewer: Reactions tab+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `PgDown` | `page-down` | Page down |+| `PgUp` | `page-up` | Page up |+| `End` | `scroll-bottom` | Scroll to the end of the reactions list |+| `Down` | `scroll-down` | Scroll down |+| `Home` | `scroll-top` | Scroll to the beginning of the reactions list |+| `Up` | `scroll-up` | Scroll up |++# Attachment List+| Keybinding | Event Name | Description |+| ---------- | ---------- | ----------- |+| `a` | `add-to-attachment-list` | Add a new attachment to the attachment list |+| `Esc`, `C-c` | `cancel` | Close attachment list |+| `d` | `delete-from-attachment-list` | Delete the selected attachment from the attachment list |+| `o` | `open-attachment` | Open the selected attachment using the URL open command |+| `j`, `Down` | `select-down` | Move cursor down |+| `k`, `Up` | `select-up` | Move cursor up |+
+ docs/notification-scripts.md view
@@ -0,0 +1,34 @@++Notification Scripts+====================++When new post notifications are enabled in user or server preferences,+Matterhorn supports invoking an external program to deliver system+notifications. Example notification scripts are provided in the+`notification-scripts` directory.++The interface for notification scripts is as follows:++* Notification scripts are expected to return immediately. The longer+ the script takes to run, the longer Matterhorn will wait on the script+ to finish, which will cause Matterhorn to delay looking at incoming+ network messages, etc.++* Matterhorn will invoke the command with three arguments:+ * The mention argument, whose values are:+ * "1" - this value indicates that the user running Matterhorn was+ mentioned in the message body.+ * "2" - this value indicates that the user running Matterhorn was+ not mentioned in the message body.+ * The sender username argument: the username of the user that sent the+ message.+ * The message body, sanitized of tabs (converted to spaces) and escape+ characters (converted to "<ESC>").++* Matterhorn will wait for the process to terminate. If the process+ emits any output to standard out OR if the command exits with a+ non-zero xit status, Matterhorn will consider that evidence that+ the command has failed and will display an error to the user in the+ current channel. The standard out and standard error output will be+ logged to a temporary subprocess log file and the log file's path will+ be included in the error message.
matterhorn.cabal view
@@ -1,5 +1,5 @@ name: matterhorn-version: 50200.6.0+version: 50200.7.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@@ -20,6 +20,9 @@ extra-doc-files: CHANGELOG.md README.md+ docs/keybindings.md+ docs/notification-scripts.md+ docs/commands.md docs/AUTHORS.txt docs/PRACTICES.md scripts/cowsay@@ -132,7 +135,7 @@ NoImplicitPrelude ghc-options: -Wall -threaded -with-rtsopts=-I0 -Wcompat build-depends: base >=4.8 && <5- , mattermost-api == 50200.3.0+ , mattermost-api == 50200.4.0 , base-compat >= 0.9 && < 0.11 , unordered-containers >= 0.2 && < 0.3 , containers >= 0.5.7 && < 0.7@@ -144,20 +147,20 @@ , stm >= 2.4 && < 2.6 , config-ini >= 0.2.2.0 && < 0.3 , process >= 1.4 && < 1.7- , microlens-platform >= 0.3 && < 0.4- , brick >= 0.50 && < 0.51+ , microlens-platform >= 0.3 && < 0.5+ , brick >= 0.52 && < 0.53 , brick-skylighting >= 0.2 && < 0.4- , vty >= 5.26 && < 5.27+ , vty >= 5.28 && < 5.29 , word-wrap >= 0.4.0 && < 0.5 , transformers >= 0.4 && < 0.6 , text-zipper >= 0.10 && < 0.11- , time >= 1.6 && < 1.9+ , time >= 1.6 && < 2.0 , xdg-basedir >= 0.2 && < 0.3 , filepath >= 1.4 && < 1.5 , directory >= 1.3 && < 1.4 , vector < 0.13 , strict >= 0.3 && < 0.4- , hashable >= 1.2 && < 1.3+ , hashable >= 1.2 && < 1.4 , cheapskate >= 0.1 && < 0.2 , utf8-string >= 1.0 && < 1.1 , temporary >= 1.2 && < 1.4@@ -195,7 +198,7 @@ hs-source-dirs: src, test build-depends: base >=4.7 && <5 , base-compat >= 0.9 && < 0.11- , brick >= 0.50 && < 0.51+ , brick >= 0.52 && < 0.53 , bytestring >= 0.10 && < 0.11 , cheapskate >= 0.1 && < 0.2 , checkers >= 0.4 && < 0.6@@ -204,11 +207,11 @@ , containers >= 0.5.7 && < 0.7 , directory >= 1.3 && < 1.4 , filepath >= 1.4 && < 1.5- , hashable >= 1.2 && < 1.3+ , hashable >= 1.2 && < 1.4 , Hclip >= 3.0 && < 3.1- , mattermost-api == 50200.3.0- , mattermost-api-qc == 50200.3.0- , microlens-platform >= 0.3 && < 0.4+ , mattermost-api == 50200.4.0+ , mattermost-api-qc == 50200.4.0+ , microlens-platform >= 0.3 && < 0.5 , mtl >= 2.2 && < 2.3 , process >= 1.4 && < 1.7 , quickcheck-text >= 0.1 && < 0.2@@ -220,14 +223,14 @@ , tasty-quickcheck >= 0.8 && < 0.12 , text >= 1.2 && < 1.3 , text-zipper >= 0.10 && < 0.11- , time >= 1.6 && < 1.9+ , time >= 1.6 && < 2.0 , timezone-olson >= 0.1.7 && < 0.2 , 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.26 && < 5.27+ , vty >= 5.28 && < 5.29 , xdg-basedir >= 0.2 && < 0.3 , semigroups >= 0.18 && < 0.19 , uuid >= 1.3 && < 1.4
notification-scripts/notify view
@@ -2,6 +2,9 @@ # Sample shell script for using notify-send with matterhorn This script # works on Linux only. It depends on the 'notify-send' command.+#+# See docs/notification-scripts.md for details on the notification+# script API used with this script. # Positional parameters passed to this script by Matterhorn: mentioned="${1?}"
src/App.hs view
@@ -12,6 +12,7 @@ import qualified Graphics.Vty as Vty import Text.Aspell ( stopAspell ) import GHC.Conc (getNumProcessors, setNumCapabilities)+import System.Posix.IO ( stdInput ) import Network.Mattermost @@ -44,7 +45,7 @@ PostListOverlay _ -> Nothing ManageAttachments -> Nothing ViewMessage -> Nothing- ShowHelp _ -> Nothing+ ShowHelp _ _ -> Nothing UrlSelect -> Nothing , appHandleEvent = Events.onEvent , appStartEvent = return@@ -69,7 +70,12 @@ setupCpuUsage config let mkVty = do- vty <- Vty.mkVty Vty.defaultConfig+ 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
src/Command.hs view
@@ -55,10 +55,14 @@ printArgSpec NoArg = "" printArgSpec (LineArg ts) = "<" <> ts <> ">" printArgSpec (TokenArg t NoArg) = "<" <> t <> ">"-printArgSpec (UserArg rs) = "<" <> userSigil <> "user> " <> printArgSpec rs-printArgSpec (ChannelArg rs) = "<" <> normalChannelSigil <> "channel> " <> printArgSpec rs-printArgSpec (TokenArg t rs) = "<" <> t <> "> " <> printArgSpec rs+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 ()@@ -132,10 +136,14 @@ (TokenArg "theme" NoArg) $ \ (themeName, ()) -> setTheme themeName - , Cmd "topic" "Set the current channel's topic"+ , 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@@ -233,6 +241,9 @@ , 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
src/Config.hs view
@@ -109,6 +109,8 @@ pure Nothing configUnsafeUseHTTP <- fieldFlagDef "unsafeUseUnauthenticatedConnection" False+ configValidateServerCertificate <-+ fieldFlagDef "validateServerCertificate" True configDirectChannelExpirationDays <- fieldDefOf "directChannelExpirationDays" number (configDirectChannelExpirationDays defaultConfig) configDefaultAttachmentPath <- fieldMbOf "defaultAttachmentPath" filePathField@@ -196,6 +198,7 @@ , configEnableAspell = False , configAspellDictionary = Nothing , configUnsafeUseHTTP = False+ , configValidateServerCertificate = True , configChannelListWidth = 20 , configLogMaxBufferSize = 200 , configShowOlderEdits = True@@ -257,7 +260,19 @@ absPath <- convertIOException $ makeAbsolute fp t <- (convertIOException $ T.readFile absPath) `catchE` (\e -> throwE $ "Could not read " <> show absPath <> ": " <> e)- case parseIniFile t fromIni of++ -- 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 ++ ":" ++ err Right conf -> do
src/Connection.hs view
@@ -39,7 +39,8 @@ tid <- liftIO $ do let shunt (Left msg) = writeBChan (st^.csResources.crEventQueue) (WebsocketParseError msg)- shunt (Right e) = writeBChan (st^.csResources.crEventQueue) (WSEvent e)+ 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
src/Draw.hs view
@@ -27,7 +27,7 @@ case appMode st of Main -> drawMain True st UrlSelect -> drawMain True st- ShowHelp topic -> drawShowHelp topic st+ ShowHelp topic _ -> drawShowHelp topic st ChannelSelect -> drawMain True st LeaveChannelConfirm -> drawLeaveChannelConfirm st MessageSelect -> drawMain True st
src/Draw/Autocomplete.hs view
@@ -150,7 +150,8 @@ renderChannelCompletion :: Channel -> Bool -> Bool -> Widget Name renderChannelCompletion c inChan selected =- let nameWidth = 30+ let urlNameWidth = 30+ displayNameWidth = 30 padTo n a = hLimit n $ vLimit 1 (a <+> fill ' ') maybeForce = if selected then forceAttr listSelectedFocusedAttr@@ -161,10 +162,13 @@ txt $ userNotInChannelMarker <> " " in maybeForce $ hBox [ memberDisplay- , padTo nameWidth $+ , padTo urlNameWidth $ withDefAttr channelNameAttr $ txt $ normalChannelSigil <> (sanitizeUserText $ channelName c)- , txt $ sanitizeUserText $ channelHeader c+ , padTo displayNameWidth $+ withDefAttr channelNameAttr $+ txt $ sanitizeUserText $ channelDisplayName c+ , txt $ sanitizeUserText $ channelPurpose c ] renderCommandCompletion :: Text -> Text -> Text -> Widget Name
src/Draw/ChannelList.hs view
@@ -83,6 +83,7 @@ renderChannelListGroupHeading g anyUnread = let label = case g of ChannelGroupPublicChannels -> "Public Channels"+ ChannelGroupPrivateChannels -> "Private Channels" ChannelGroupDirectMessages -> "Direct Messages" addUnread = if anyUnread then (<+> (withDefAttr unreadGroupMarkerAttr $ txt "*"))@@ -116,13 +117,9 @@ current = isCurrentChannel st cId (name, normalSigil, addSpace, status) = case e of CLChannel _ ->- let (useSigil, space) = case chan^.ccInfo.cdType of- MM.Ordinary -> (Just normalChannelSigil, False)- MM.Private -> (Just normalChannelSigil, False)- _ -> (Nothing, False)- in (chan^.ccInfo.cdName, useSigil, space, Nothing)+ (chan^.ccInfo.cdDisplayName, Nothing, False, Nothing) CLGroupDM _ ->- (chan^.ccInfo.cdName, Just " ", True, Nothing)+ (chan^.ccInfo.cdDisplayName, Just " ", True, Nothing) CLUserDM _ uId -> let Just u = userById uId st uname = if useNickname st
src/Draw/ListOverlay.hs view
@@ -51,7 +51,7 @@ -> Widget Name drawListOverlay st scopeHeader scopeNoResults scopePrompt renderItem = centerLayer $ hLimitWithPadding 10 $ vLimit 25 $- borderWithLabel (scopeHeader scope) body+ borderWithLabel (withDefAttr clientEmphAttr $ scopeHeader scope) body where body = vBox [ (padRight (Pad 1) promptMsg) <+> renderEditor (txt . T.unlines) True (st^.listOverlaySearchInput)
src/Draw/Main.hs view
@@ -73,6 +73,7 @@ , _mReactions = mempty , _mOriginalPost = Nothing , _mFlagged = False+ , _mPinned = False , _mChannelId = Nothing } @@ -304,13 +305,14 @@ Nothing -> mkChannelName (chan^.ccInfo) Just u -> userHeader u Private ->- mkChannelName (chan^.ccInfo) <> " (Private)"+ channelNamePair <> " (Private)" Group ->- mkChannelName (chan^.ccInfo) <> " (Private group)"+ channelNamePair <> " (Private group)" _ ->- mkChannelName (chan^.ccInfo)+ channelNamePair newlineToSpace '\n' = ' ' newlineToSpace c = c+ channelNamePair = mkChannelName (chan^.ccInfo) <> " - " <> (chan^.ccInfo.cdDisplayName) in renderText' hs@@ -459,6 +461,14 @@ , ( \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
src/Draw/ManageAttachments.hs view
@@ -39,7 +39,7 @@ hLimit 60 $ vLimit 15 $ joinBorders $- borderWithLabel (txt "Attachments") $+ borderWithLabel (withDefAttr clientEmphAttr $ txt "Attachments") $ vBox [ renderList renderAttachmentItem True (st^.csEditState.cedAttachmentList) , hBorder , hCenter $ withDefAttr clientMessageAttr $@@ -58,7 +58,7 @@ centerLayer $ hLimit 60 $ vLimit 20 $- borderWithLabel (txt "Attach File") $+ 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.
src/Draw/PostListOverlay.hs view
@@ -44,7 +44,18 @@ where -- The 'window title' of the overlay hs = getHighlightSet st contentHeader = withAttr channelListHeaderAttr $ txt $ case contents of- PostListFlagged -> "Flagged posts"+ 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@@ -67,7 +78,8 @@ hCenter $ withDefAttr clientEmphAttr $ str $ case contents of- PostListFlagged -> "You have no flagged messages."+ PostListFlagged -> "You have no flagged messages."+ PostListPinned _ -> "This channel has no pinned messages." PostListSearch _ searching -> if searching then "Searching ..."
src/Draw/ShowHelp.hs view
@@ -2,6 +2,8 @@ ( drawShowHelp , keybindingMarkdownTable , keybindingTextTable+ , commandTextTable+ , commandMarkdownTable ) where @@ -21,6 +23,7 @@ import Network.Mattermost.Version ( mmApiVersion ) import Command+import Events import Events.ChannelSelect import Events.Keybindings import Events.Main@@ -64,24 +67,50 @@ , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Help Topics" , drawHelpTopics , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Commands"- , mkCommandHelpText $ sortWith commandName commandList+ , mkCommandHelpText , padTop (Pad 1) $ hCenter $ withDefAttr helpEmphAttr $ txt "Keybindings" ] <> (mkKeybindingHelp <$> keybindSections kc) - mkCommandHelpText :: [Cmd] -> Widget Name- mkCommandHelpText cs =- let helpInfo = [ (info, desc)- | Cmd cmd desc args _ <- cs- , let argSpec = printArgSpec args- info = T.cons '/' cmd <> " " <> argSpec- ]- commandNameWidth = 4 + (maximum $ T.length <$> fst <$> helpInfo)+ mkCommandHelpText :: Widget Name+ mkCommandHelpText =+ let commandNameWidth = 4 + (maximum $ T.length <$> fst <$> commandHelpInfo) in hCenter $ vBox [ (withDefAttr helpEmphAttr $ txt $ padTo commandNameWidth info) <+> renderText desc- | (info, desc) <- helpInfo+ | (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@@ -375,7 +404,8 @@ keybindSections :: KeyConfig -> [(Text, [Keybinding])] keybindSections kc =- [ ("Help Page", helpKeybindings kc)+ [ ("Global Keybindings", globalKeybindings kc)+ , ("Help Page", helpKeybindings kc) , ("Main Interface", mainKeybindings kc) , ("Channel Select Mode", channelSelectKeybindings kc) , ("URL Select Mode", urlSelectKeybindings kc)
src/Events.hs view
@@ -1,5 +1,6 @@ module Events ( onEvent+ , globalKeybindings ) where @@ -24,6 +25,7 @@ import State.Channels import State.Common import State.Flagging+import State.Help import State.Messages import State.Reactions import State.Users@@ -32,6 +34,7 @@ import Events.ChannelSelect import Events.DeleteChannelConfirm+import Events.Keybindings import Events.LeaveChannelConfirm import Events.Main import Events.MessageSelect@@ -79,6 +82,8 @@ 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 " <>@@ -155,10 +160,14 @@ mh invalidateCache _ -> return () + handleKeyboardEvent globalKeybindings handleGlobalEvent e++handleGlobalEvent :: Vty.Event -> MH ()+handleGlobalEvent e = do mode <- gets appMode case mode of Main -> onEventMain e- ShowHelp _ -> onEventShowHelp e+ ShowHelp _ _ -> onEventShowHelp e ChannelSelect -> onEventChannelSelect e UrlSelect -> onEventUrlSelect e LeaveChannelConfirm -> onEventLeaveChannelConfirm e@@ -172,6 +181,18 @@ ViewMessage -> handleTabbedWindowEvent (csViewedMessage.singular _Just._2) e ManageAttachments -> onEventManageAttachments e ManageAttachmentsBrowseFiles -> onEventManageAttachments e++globalKeybindings :: KeyConfig -> [Keybinding]+globalKeybindings = mkKeybindings+ [ 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
src/Events/Keybindings.hs view
@@ -93,84 +93,69 @@ 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') ]- 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') ]+ 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') ]+ 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 ]-- CancelEvent -> [ kb Vty.KEsc- , ctrl (key 'c')- ]-- SelectNextTabEvent -> [ key '\t' ]- SelectPreviousTabEvent -> [ kb Vty.KBackTab ]-- -- channel-scroll-specific- LoadMoreEvent -> [ ctrl (key 'b') ]-- -- scrolling events- ScrollUpEvent -> [ kb Vty.KUp ]- ScrollDownEvent -> [ kb Vty.KDown ]- ScrollLeftEvent -> [ kb Vty.KLeft ]- ScrollRightEvent -> [ kb Vty.KRight ]- PageUpEvent -> [ kb Vty.KPageUp ]- PageDownEvent -> [ kb Vty.KPageDown ]- ScrollTopEvent -> [ kb Vty.KHome ]- ScrollBottomEvent -> [ kb Vty.KEnd ]-- SelectUpEvent -> [ key 'k', kb Vty.KUp ]- SelectDownEvent -> [ key 'j', kb Vty.KDown ]-- ActivateListItemEvent -> [ kb Vty.KEnter ]-- -- search selection - like SelectUp/Down above but need to not- -- conflict with editor inputs- SearchSelectUpEvent -> [ ctrl (key 'p'), kb Vty.KUp ]- SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ]-- ViewMessageEvent -> [ key 'v' ]- FillGapEvent -> [ kb Vty.KEnter ]- FlagMessageEvent -> [ key 'f' ]- 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' ]+ 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 ]+ ScrollTopEvent -> [ kb Vty.KHome ]+ ScrollBottomEvent -> [ kb Vty.KEnd ]+ 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') ] --- | 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!+-- | 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 -> [Keybinding])] -> 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.+ -- 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))@@ -179,29 +164,28 @@ | 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.+ -- 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.+ -- 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.+ -- 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 $@@ -219,9 +203,9 @@ | (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.)+ -- 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 `"@@ -232,16 +216,15 @@ [e] -> "event " ++ e es -> "events " ++ intercalate " and " es , "\n"- , "This is probably not what you want, as it will interfere\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.+ -- 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
src/Events/Main.hs view
@@ -9,12 +9,10 @@ import Command import Events.Keybindings-import HelpTopics ( mainHelpTopic ) import State.Attachments import State.ChannelSelect import State.Channels import State.Editing-import State.Help import State.MessageSelect import State.PostListOverlay ( enterFlaggedPostListMode ) import State.UrlSelect@@ -29,11 +27,7 @@ mainKeybindings :: KeyConfig -> [Keybinding] mainKeybindings = mkKeybindings- [ mkKb ShowHelpEvent- "Show this help screen"- (showHelpScreen mainHelpTopic)-- , mkKb EnterSelectModeEvent+ [ mkKb EnterSelectModeEvent "Select a message to edit/reply/delete" beginMessageSelect
src/Events/MessageSelect.hs view
@@ -64,6 +64,9 @@ , 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
src/Events/ShowHelp.hs view
@@ -14,7 +14,7 @@ onEventShowHelp :: Vty.Event -> MH () onEventShowHelp = handleKeyboardEvent helpKeybindings $ \ e -> case e of- Vty.EvKey _ _ -> setMode Main+ Vty.EvKey _ _ -> popMode _ -> return () helpKeybindings :: KeyConfig -> [Keybinding]@@ -27,30 +27,15 @@ mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount) , mkKb PageDownEvent "Page down" $ mh $ vScrollBy (viewportScroll HelpViewport) (1 * pageAmount)- , mkKb CancelEvent "Return to the main interface" $- setMode Main+ , 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) ] --- KB "Scroll up"--- (Vty.EvKey Vty.KUp []) $ do--- mh $ vScrollBy (viewportScroll HelpViewport) (-1)--- , KB "Scroll down"--- (Vty.EvKey Vty.KDown []) $ do--- mh $ vScrollBy (viewportScroll HelpViewport) 1--- , KB "Page up"--- (Vty.EvKey Vty.KPageUp []) $ do--- mh $ vScrollBy (viewportScroll HelpViewport) (-1 * pageAmount)--- , KB "Page down"--- (Vty.EvKey Vty.KPageDown []) $ do--- mh $ vScrollBy (viewportScroll HelpViewport) pageAmount--- , KB "Page down"--- (Vty.EvKey (Vty.KChar ' ') []) $ do--- mh $ vScrollBy (viewportScroll HelpViewport) pageAmount--- , KB "Return to the main interface"--- (Vty.EvKey Vty.KEsc []) $ do--- csMode .= Main--- ]+popMode :: MH ()+popMode = do+ ShowHelp _ prevMode <- gets appMode+ setMode prevMode
src/Login.hs view
@@ -72,7 +72,7 @@ import Network.Mattermost ( ConnectionData ) import Network.Mattermost.Types ( Session, User, Login(..), ConnectionPoolConfig(..)- , initConnectionData, initConnectionDataInsecure )+ , initConnectionData, ConnectionType(..) ) import Network.Mattermost.Exceptions ( LoginFailureException(..) ) import Network.Mattermost.Endpoints ( mmLogin ) @@ -167,29 +167,25 @@ -- attempt. -> LogManager -- ^ The log manager used to do logging.- -> Bool- -- ^ Whether the login attempts should use HTTP (True) or- -- not (False, HTTPS only)+ -> ConnectionType+ -- ^ The kind of connection to make to the server. -> 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 unsafeUseHTTP requestChan respChan = forever $ do+loginWorker setLogger logMgr connTy requestChan respChan = forever $ do req <- readBChan requestChan case req of DoLogin initial connInfo -> do writeBChan respChan $ StartConnect initial $ connInfo^.ciHostname ioLogWithManager logMgr Nothing LogGeneral $ "Attempting authentication to " <> connInfo^.ciHostname - let connectFunc = if unsafeUseHTTP- then initConnectionDataInsecure- else initConnectionData- login = Login { username = connInfo^.ciUsername+ let login = Login { username = connInfo^.ciUsername , password = connInfo^.ciPassword } - cd <- fmap setLogger $ connectFunc (connInfo^.ciHostname) (fromIntegral (connInfo^.ciPort)) poolCfg+ cd <- fmap setLogger $ initConnectionData (connInfo^.ciHostname) (fromIntegral (connInfo^.ciPort)) connTy poolCfg result <- convertLoginExceptions $ mmLogin cd login case result of@@ -232,10 +228,9 @@ -- never fires since the login app doesn't -- use suspendAndResume, but we need it to -- satisfy the Brick API.)- -> Bool- -- ^ Whether to use HTTP connections to log- -- in (True) or HTTPS only (False). This- -- comes from the Matterhorn configuration.+ -> ConnectionType+ -- ^ The kind of connection to make to the+ -- mattermost server. -> (ConnectionData -> ConnectionData) -- ^ The function to set the logger on -- connection handles.@@ -248,11 +243,11 @@ -- initial connection attempt is made without -- first getting the user to hit Enter. -> IO (Maybe LoginAttempt, Vty)-interactiveGetLoginSession vty mkVty unsafeUseHTTP setLogger logMgr initialConfig = do+interactiveGetLoginSession vty mkVty connTy setLogger logMgr initialConfig = do requestChan <- newBChan 10 respChan <- newBChan 10 - void $ forkIO $ loginWorker setLogger logMgr unsafeUseHTTP requestChan respChan+ void $ forkIO $ loginWorker setLogger logMgr connTy requestChan respChan void $ forkIO $ startupTimer respChan let initialState = mkState initialConfig requestChan
src/Main.hs view
@@ -11,7 +11,8 @@ import App import Events.Keybindings ( ensureKeybindingConsistency ) import KeyMap ( keybindingModeMap )-import Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable )+import Draw.ShowHelp ( keybindingMarkdownTable, keybindingTextTable+ , commandMarkdownTable, commandTextTable ) main :: IO ()@@ -30,13 +31,23 @@ let keyConfig = configUserKeys config - case optPrintKeybindings opts of- Nothing -> return ()+ printedCommands <- case optPrintCommands opts of+ Nothing -> return False Just ty -> do case ty of+ Markdown -> T.putStrLn commandMarkdownTable+ Plain -> T.putStrLn commandTextTable+ return True++ printedKeybindings <- case optPrintKeybindings opts of+ Nothing -> return False+ Just ty -> do+ case ty of Markdown -> T.putStrLn $ keybindingMarkdownTable keyConfig Plain -> T.putStrLn $ keybindingTextTable keyConfig- exitSuccess+ return True++ when (printedKeybindings || printedCommands) exitSuccess case ensureKeybindingConsistency keyConfig keybindingModeMap of Right () -> return ()
src/Markdown.hs view
@@ -154,19 +154,17 @@ nameElems = case msgUsr of Just un | isEmote msg ->- [ B.txt "*", colorUsername un un+ [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN]" else ""+ , B.txt $ (if msg^.mFlagged then "[!] " else "") <> "*"+ , colorUsername un un , botElem , B.txt " " ]- | msg^.mFlagged ->- [ colorUsername un un- , botElem- , B.txt "[!]: "- ] | otherwise ->- [ colorUsername un un+ [ B.withDefAttr pinnedMessageIndicatorAttr $ B.txt $ if msg^.mPinned then "[PIN] " else ""+ , colorUsername un un , botElem- , B.txt ": "+ , B.txt $ (if msg^.mFlagged then "[!]" else "") <> ": " ] Nothing -> []
src/Options.hs view
@@ -20,7 +20,7 @@ | ShowHelp deriving (Eq, Show) -data KeybindingPrintMode =+data PrintMode = Markdown | Plain deriving (Eq, Show) data Options = Options@@ -28,7 +28,8 @@ , optLogLocation :: Maybe FilePath , optBehaviour :: Behaviour , optIgnoreConfig :: Bool- , optPrintKeybindings :: Maybe KeybindingPrintMode+ , optPrintKeybindings :: Maybe PrintMode+ , optPrintCommands :: Maybe PrintMode } deriving (Eq, Show) defaultOptions :: Options@@ -38,6 +39,7 @@ , optBehaviour = Normal , optIgnoreConfig = False , optPrintKeybindings = Nothing+ , optPrintCommands = Nothing } optDescrs :: [OptDescr (Options -> Options)]@@ -63,6 +65,12 @@ , Option ['K'] ["keybindings-markdown"] (NoArg (\ c -> c { optPrintKeybindings = Just Markdown })) "Print keybindings effective for the current configuration in Markdown format"+ , Option ['m'] ["commands-text"]+ (NoArg (\ c -> c { optPrintCommands = Just Plain }))+ "Print available commands in plain text format"+ , Option ['M'] ["commands-markdown"]+ (NoArg (\ c -> c { optPrintCommands = Just Markdown }))+ "Print available commands in Markdown format" ] mhVersion :: String
src/State/ChannelSelect.hs view
@@ -61,13 +61,13 @@ if patTy == Just PrefixDMOnly then Nothing else if chan^.ccInfo.cdType /= MM.Group- then chanNameMatches e $ chan^.ccInfo.cdName+ 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.cdName+ then chanNameMatches e $ chan^.ccInfo.cdDisplayName else Nothing displayName uInfo = displayNameForUser uInfo cconfig prefs userMatches e uInfo =
src/State/Channels.hs view
@@ -41,6 +41,7 @@ , joinChannelByName , changeChannelByName , setChannelTopic+ , setChannelPurpose , beginCurrentChannelDeleteConfirm , toggleChannelListVisibility , showChannelInSidebar@@ -992,6 +993,14 @@ 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)
src/State/Help.hs view
@@ -13,5 +13,9 @@ showHelpScreen :: HelpTopic -> MH () showHelpScreen topic = do- mh $ vScrollToBeginning (viewportScroll HelpViewport)- setMode $ ShowHelp topic+ curMode <- gets appMode+ case curMode of+ ShowHelp {} -> return ()+ _ -> do+ mh $ vScrollToBeginning (viewportScroll HelpViewport)+ setMode $ ShowHelp topic curMode
src/State/MessageSelect.hs view
@@ -3,6 +3,7 @@ -- * Message selection mode beginMessageSelect , flagSelectedMessage+ , pinSelectedMessage , viewSelectedMessage , fillSelectedGap , yankSelectedMessageVerbatim@@ -85,6 +86,17 @@ 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)@@ -268,4 +280,13 @@ 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/PostListOverlay.hs view
@@ -1,5 +1,6 @@ module State.PostListOverlay ( enterFlaggedPostListMode+ , enterPinnedPostListMode , enterSearchResultPostListMode , postListJumpToCurrent , postListSelectUp@@ -73,6 +74,12 @@ 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.
src/State/Setup.hs view
@@ -73,9 +73,11 @@ let logApiEvent ev = apiLogEventToLogMessage ev >>= sendLogMessage logMgr setLogger cd = cd `withLogger` logApiEvent+ connTy = if configUnsafeUseHTTP config+ then ConnectHTTP+ else ConnectHTTPS $ configValidateServerCertificate config - (mLastAttempt, loginVty) <- interactiveGetLoginSession initialVty mkVty- (configUnsafeUseHTTP config)+ (mLastAttempt, loginVty) <- interactiveGetLoginSession initialVty mkVty connTy setLogger logMgr (incompleteCredentials config)
src/State/Themes.hs view
@@ -20,9 +20,9 @@ listThemes :: MH () listThemes = do- let themeList = T.intercalate "\n\n" $- "Available built-in themes:" :- ((" " <>) <$> internalThemeName <$> internalThemes)+ let themeList = T.intercalate "\n" $+ "Available built-in themes:\n" :+ (("* " <>) <$> internalThemeName <$> internalThemes) postInfoMessage themeList setTheme :: Text -> MH ()
src/Themes.hs view
@@ -25,6 +25,7 @@ , clientEmphAttr , clientStrongAttr , dateTransitionAttr+ , pinnedMessageIndicatorAttr , newMessageTransitionAttr , gapMessageAttr , errorMessageAttr@@ -86,6 +87,9 @@ replyParentAttr :: AttrName replyParentAttr = "replyParentPreview" +pinnedMessageIndicatorAttr :: AttrName+pinnedMessageIndicatorAttr = "pinnedMessageIndicator"+ loadMoreAttr :: AttrName loadMoreAttr = "loadMoreMessages" @@ -251,8 +255,9 @@ , (newMessageTransitionAttr, black `on` yellow) , (errorMessageAttr, fg red) , (gapMessageAttr, fg red)- , (helpAttr, black `on` cyan)- , (helpEmphAttr, fg white)+ , (helpAttr, fg black)+ , (pinnedMessageIndicatorAttr, black `on` cyan)+ , (helpEmphAttr, fg blue `withStyle` bold) , (channelSelectMatchAttr, black `on` magenta) , (channelSelectPromptAttr, fg black) , (completionAlternativeListAttr, white `on` blue)@@ -296,6 +301,7 @@ , (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)@@ -304,8 +310,8 @@ , (newMessageTransitionAttr, fg yellow `withStyle` bold) , (errorMessageAttr, fg red) , (gapMessageAttr, black `on` yellow)- , (helpAttr, black `on` cyan)- , (helpEmphAttr, fg white)+ , (helpAttr, fg white)+ , (helpEmphAttr, fg cyan `withStyle` bold) , (channelSelectMatchAttr, black `on` magenta) , (channelSelectPromptAttr, fg white) , (completionAlternativeListAttr, white `on` blue)@@ -429,6 +435,9 @@ ) , ( 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"
src/Types.hs view
@@ -273,6 +273,7 @@ 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@@ -302,7 +303,7 @@ import Network.Mattermost.Lenses import Network.Mattermost.Types import Network.Mattermost.Types.Config-import Network.Mattermost.WebSocket ( WebsocketEvent )+import Network.Mattermost.WebSocket ( WebsocketEvent, WebsocketActionResponse ) import InputHistory import Emoji@@ -328,6 +329,7 @@ -- | The type of channel list group headings. data ChannelListGroup = ChannelGroupPublicChannels+ | ChannelGroupPrivateChannels | ChannelGroupDirectMessages deriving (Eq) @@ -386,6 +388,8 @@ -- ^ 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@@ -467,15 +471,16 @@ -> Users -> [(ChannelListGroup, [ChannelListEntry])] mkChannelZipperList now config cconfig prefs cs us =- [ (ChannelGroupPublicChannels, getNonDMChannelIdsInOrder cs)+ [ (ChannelGroupPublicChannels, getChannelIdsInOrder cs Ordinary)+ , (ChannelGroupPrivateChannels, getChannelIdsInOrder cs Private) , (ChannelGroupDirectMessages, getDMChannelsInOrder now config cconfig prefs us cs) ] -getNonDMChannelIdsInOrder :: ClientChannels -> [ChannelListEntry]-getNonDMChannelIdsInOrder cs =- let matches (_, info) = info^.ccInfo.cdType `notElem` [Direct, Group]+getChannelIdsInOrder :: ClientChannels -> Type -> [ChannelListEntry]+getChannelIdsInOrder cs ty =+ let matches (_, info) = info^.ccInfo.cdType == ty in fmap (CLChannel . fst) $- sortBy (comparing ((^.ccInfo.cdName) . snd)) $+ sortBy (comparing ((^.ccInfo.cdDisplayName.to T.toLower) . snd)) $ filteredChannels matches cs getDMChannelsInOrder :: UTCTime@@ -523,7 +528,7 @@ getGroupDMChannels now config prefs cs = let matches (_, info) = info^.ccInfo.cdType == Group && groupChannelShouldAppear now config prefs info- in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdName, CLGroupDM cId)) $+ in fmap (\(cId, ch) -> (hasUnread' ch, ch^.ccInfo.cdDisplayName, CLGroupDM cId)) $ filteredChannels matches cs getDMChannels :: UTCTime@@ -996,13 +1001,14 @@ -- | 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+ | ShowHelp HelpTopic Mode | ChannelSelect | UrlSelect | LeaveChannelConfirm@@ -1557,6 +1563,9 @@ 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'))@@ -1576,6 +1585,8 @@ 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
src/Types/Channels.hs view
@@ -18,7 +18,7 @@ , ccContents, ccInfo, ccEditState -- * Lenses created for accessing ChannelInfo fields , cdViewed, cdNewMessageIndicator, cdEditedMessageThreshold, cdUpdated- , cdName, cdHeader, cdPurpose, cdType+ , cdName, cdDisplayName, cdHeader, cdPurpose, cdType , cdMentionCount, cdTypingUsers, cdDMUserId, cdChannelId , cdSidebarShowOverride -- * Lenses created for accessing ChannelContents fields@@ -142,6 +142,7 @@ , _cdMentionCount = 0 , _cdUpdated = updated , _cdName = preferredChannelName chan+ , _cdDisplayName = sanitizeUserText $ channelDisplayName chan , _cdHeader = sanitizeUserText $ chan^.channelHeaderL , _cdPurpose = sanitizeUserText $ chan^.channelPurposeL , _cdType = chan^.channelTypeL@@ -164,6 +165,7 @@ v -> v , _cdUpdated = updated , _cdName = preferredChannelName chan+ , _cdDisplayName = sanitizeUserText $ channelDisplayName chan , _cdHeader = (sanitizeUserText $ chan^.channelHeaderL) , _cdPurpose = (sanitizeUserText $ chan^.channelPurposeL) , _cdType = (chan^.channelTypeL)@@ -210,6 +212,8 @@ -- ^ 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
src/Types/KeyEvents.hs view
@@ -88,6 +88,7 @@ | ViewMessageEvent | FillGapEvent | FlagMessageEvent+ | PinMessageEvent | YankMessageEvent | YankWholeMessageEvent | DeleteMessageEvent@@ -151,6 +152,7 @@ , SearchSelectDownEvent , FlagMessageEvent+ , PinMessageEvent , ViewMessageEvent , FillGapEvent , YankMessageEvent@@ -348,6 +350,7 @@ ActivateListItemEvent -> "activate-list-item" FlagMessageEvent -> "flag-message"+ PinMessageEvent -> "pin-message" ViewMessageEvent -> "view-message" FillGapEvent -> "fetch-for-gap" YankMessageEvent -> "yank-message"
src/Types/Messages.hs view
@@ -42,8 +42,8 @@ ( -- * Message and operations on a single Message Message(..) , isDeletable, isReplyable, isReactable, isEditable, isReplyTo, isGap, isFlaggable- , isEmote, isJoinLeave, isTransition, isNewMessagesTransition- , mText, mUser, mDate, mType, mPending, mDeleted+ , isPinnable, isEmote, isJoinLeave, isTransition, isNewMessagesTransition+ , mText, mUser, mDate, mType, mPending, mDeleted, mPinned , mAttachments, mInReplyToMsg, mMessageId, mReactions, mFlagged , mOriginalPost, mChannelId, mMarkdownSource , isBotMessage@@ -168,6 +168,7 @@ , _mReactions :: Map.Map Text (S.Set UserId) , _mOriginalPost :: Maybe Post , _mFlagged :: Bool+ , _mPinned :: Bool , _mChannelId :: Maybe ChannelId } deriving (Show) @@ -191,6 +192,9 @@ isFlaggable :: Message -> Bool isFlaggable = isJust . messagePostId +isPinnable :: Message -> Bool+isPinnable = isJust . messagePostId+ isReplyable :: Message -> Bool isReplyable m = isJust (messagePostId m) &&@@ -308,6 +312,7 @@ , _mReactions = Map.empty , _mOriginalPost = Nothing , _mFlagged = False+ , _mPinned = False , _mChannelId = Nothing } @@ -349,6 +354,7 @@ , _mReactions = cp^.cpReactions , _mOriginalPost = Just $ cp^.cpOriginalPost , _mFlagged = False+ , _mPinned = cp^.cpPinned , _mChannelId = Just $ cp^.cpChannelId } @@ -368,6 +374,7 @@ , _mReactions = Map.empty , _mOriginalPost = Nothing , _mFlagged = False+ , _mPinned = False , _mChannelId = Nothing } @@ -507,14 +514,12 @@ checkAdjacentMessages s = case Seq.viewl s of Seq.EmptyL -> mempty m Seq.:< t ->- case getMessagePredecessor t of- Just prev ->- (m, threadStateFor m prev) Seq.<| checkAdjacentMessages t- Nothing -> case m^.mInReplyToMsg of- InReplyTo _ ->- Seq.singleton (m, InThreadShowParent)- _ ->- Seq.singleton (m, NoThread)+ 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)@@ -531,14 +536,12 @@ checkAdjacentMessages s = case Seq.viewr s of Seq.EmptyR -> mempty t Seq.:> m ->- case getMessagePredecessor t of- Just prev ->- checkAdjacentMessages t Seq.|> (m, threadStateFor m prev)- Nothing -> case m^.mInReplyToMsg of- InReplyTo _ ->- Seq.singleton (m, InThreadShowParent)- _ ->- Seq.singleton (m, NoThread)+ 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
src/Types/Posts.hs view
@@ -34,6 +34,7 @@ , cpAttachments , cpDeleted , cpPostId+ , cpPinned , unEmote @@ -127,6 +128,7 @@ , _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@@ -207,6 +209,7 @@ , _cpType = postClientPostType p , _cpPending = False , _cpDeleted = False+ , _cpPinned = fromMaybe False $ postPinned p , _cpAttachments = Seq.empty , _cpInReplyToPost = parentId , _cpPostId = p^.postIdL
test/Message_QCA.hs view
@@ -43,6 +43,7 @@ <*> genMap genText (genSet genUserId) <*> genMaybe genPost <*> arbitrary+ <*> arbitrary <*> (Just <$> genChannelId) genUUID :: Gen UUID@@ -70,6 +71,7 @@ <*> genMap genText (genSet genUserId) <*> genMaybe genPost <*> arbitrary+ <*> arbitrary <*> (Just <$> genChannelId)) newtype Message__Posted = Message__Posted { postMsg :: Message }@@ -90,6 +92,7 @@ <*> (Just <$> MessagePostId <$> genPostId) <*> genMap genText (genSet genUserId) <*> genMaybe genPost+ <*> arbitrary <*> arbitrary <*> (Just <$> genChannelId))
test/test_messages.hs view
@@ -67,7 +67,7 @@ makeMsg :: ServerTime -> Maybe MessageId -> Message makeMsg t mId = Message Seq.empty mempty NoUser t (CP NormalPost) False False Seq.empty NotAReply- mId Map.empty Nothing False Nothing+ mId Map.empty Nothing False False Nothing makeMsgs :: [Message] -> Messages makeMsgs = foldr addMessage noMessages